{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Tc.TyCl.Instance
( tcInstDecls1
, tcInstDeclsDeriv
, tcInstDecls2
)
where
import GHC.Prelude
import GHC.Hs
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, badMethodErr,
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.Utils.Zonk
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.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.Session
import GHC.Driver.Ppr
import GHC.Utils.Logger
import GHC.Data.FastString
import GHC.Types.Id
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.Utils.Panic.Plain
import GHC.Types.SrcLoc
import GHC.Utils.Misc
import GHC.Data.BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice )
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 GhcRn]
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv)
tcInstDecls1 [LInstDecl GhcRn]
inst_decls
= do {
; [([InstInfo GhcRn], [FamInst], [DerivInfo])]
stuff <- (GenLocated SrcSpanAnnA (InstDecl GhcRn)
-> TcRn ([InstInfo GhcRn], [FamInst], [DerivInfo]))
-> [GenLocated SrcSpanAnnA (InstDecl GhcRn)]
-> TcRn [([InstInfo GhcRn], [FamInst], [DerivInfo])]
forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndRecoverM LInstDecl GhcRn -> TcRn ([InstInfo GhcRn], [FamInst], [DerivInfo])
GenLocated SrcSpanAnnA (InstDecl GhcRn)
-> TcRn ([InstInfo GhcRn], [FamInst], [DerivInfo])
tcLocalInstDecl [LInstDecl GhcRn]
[GenLocated SrcSpanAnnA (InstDecl GhcRn)]
inst_decls
; let ([[InstInfo GhcRn]]
local_infos_s, [[FamInst]]
fam_insts_s, [[DerivInfo]]
datafam_deriv_infos) = [([InstInfo GhcRn], [FamInst], [DerivInfo])]
-> ([[InstInfo GhcRn]], [[FamInst]], [[DerivInfo]])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [([InstInfo GhcRn], [FamInst], [DerivInfo])]
stuff
fam_insts :: [FamInst]
fam_insts = [[FamInst]] -> [FamInst]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FamInst]]
fam_insts_s
local_infos :: [InstInfo GhcRn]
local_infos = [[InstInfo GhcRn]] -> [InstInfo GhcRn]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[InstInfo GhcRn]]
local_infos_s
; (TcGblEnv
gbl_env, ThBindEnv
th_bndrs) <-
[InstInfo GhcRn]
-> TcM (TcGblEnv, ThBindEnv) -> TcM (TcGblEnv, ThBindEnv)
forall a. [InstInfo GhcRn] -> TcM a -> TcM a
addClsInsts [InstInfo GhcRn]
local_infos (TcM (TcGblEnv, ThBindEnv) -> TcM (TcGblEnv, ThBindEnv))
-> TcM (TcGblEnv, ThBindEnv) -> TcM (TcGblEnv, ThBindEnv)
forall a b. (a -> b) -> a -> b
$
[FamInst] -> TcM (TcGblEnv, ThBindEnv)
addFamInsts [FamInst]
fam_insts
; (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv)
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return ( TcGblEnv
gbl_env
, [InstInfo GhcRn]
local_infos
, [[DerivInfo]] -> [DerivInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[DerivInfo]]
datafam_deriv_infos
, ThBindEnv
th_bndrs ) }
tcInstDeclsDeriv
:: [DerivInfo]
-> [LDerivDecl GhcRn]
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBinds GhcRn)
tcInstDeclsDeriv :: [DerivInfo]
-> [LDerivDecl GhcRn]
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBinds GhcRn)
tcInstDeclsDeriv [DerivInfo]
deriv_infos [LDerivDecl GhcRn]
derivds
= do ThStage
th_stage <- TcM ThStage
getStage
if ThStage -> Bool
isBrackStage ThStage
th_stage
then do { TcGblEnv
gbl_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; (TcGblEnv, [InstInfo GhcRn], HsValBinds GhcRn)
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBinds GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
gbl_env, Bag (InstInfo GhcRn) -> [InstInfo GhcRn]
forall a. Bag a -> [a]
bagToList Bag (InstInfo GhcRn)
forall a. Bag a
emptyBag, HsValBinds GhcRn
forall (a :: Pass) (b :: Pass).
HsValBindsLR (GhcPass a) (GhcPass b)
emptyValBindsOut) }
else do { (TcGblEnv
tcg_env, Bag (InstInfo GhcRn)
info_bag, HsValBinds GhcRn
valbinds) <- [DerivInfo]
-> [LDerivDecl GhcRn]
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
tcDeriving [DerivInfo]
deriv_infos [LDerivDecl GhcRn]
derivds
; (TcGblEnv, [InstInfo GhcRn], HsValBinds GhcRn)
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBinds GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env, Bag (InstInfo GhcRn) -> [InstInfo GhcRn]
forall a. Bag a -> [a]
bagToList Bag (InstInfo GhcRn)
info_bag, HsValBinds GhcRn
valbinds) }
addClsInsts :: [InstInfo GhcRn] -> TcM a -> TcM a
addClsInsts :: [InstInfo GhcRn] -> TcM a -> TcM a
addClsInsts [InstInfo GhcRn]
infos TcM a
thing_inside
= [ClsInst] -> TcM a -> TcM a
forall a. [ClsInst] -> TcM a -> TcM a
tcExtendLocalInstEnv ((InstInfo GhcRn -> ClsInst) -> [InstInfo GhcRn] -> [ClsInst]
forall a b. (a -> b) -> [a] -> [b]
map InstInfo GhcRn -> ClsInst
forall a. InstInfo a -> ClsInst
iSpec [InstInfo GhcRn]
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)
; (TcGblEnv
gbl_env, ThBindEnv
th_bndrs) <- [TyCon] -> TcM (TcGblEnv, ThBindEnv)
addTyConsToGblEnv [TyCon]
data_rep_tycons
; (TcGblEnv, ThBindEnv) -> TcM (TcGblEnv, ThBindEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
gbl_env, ThBindEnv
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 GhcRn -> TcRn ([InstInfo GhcRn], [FamInst], [DerivInfo])
tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl }))
= do { FamInst
fam_inst <- AssocInstInfo -> LTyFamInstDecl GhcRn -> TcM FamInst
tcTyFamInstDecl AssocInstInfo
NotAssociated (SrcSpanAnnA
-> TyFamInstDecl GhcRn
-> GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc TyFamInstDecl GhcRn
decl)
; ([InstInfo GhcRn], [FamInst], [DerivInfo])
-> TcRn ([InstInfo GhcRn], [FamInst], [DerivInfo])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [FamInst
fam_inst], []) }
tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl }))
= do { (FamInst
fam_inst, Maybe DerivInfo
m_deriv_info) <- AssocInstInfo
-> TyVarEnv Name
-> LDataFamInstDecl GhcRn
-> TcM (FamInst, Maybe DerivInfo)
tcDataFamInstDecl AssocInstInfo
NotAssociated TyVarEnv Name
forall a. VarEnv a
emptyVarEnv (SrcSpanAnnA
-> DataFamInstDecl GhcRn
-> GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc DataFamInstDecl GhcRn
decl)
; ([InstInfo GhcRn], [FamInst], [DerivInfo])
-> TcRn ([InstInfo GhcRn], [FamInst], [DerivInfo])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [FamInst
fam_inst], Maybe DerivInfo -> [DerivInfo]
forall a. Maybe a -> [a]
maybeToList Maybe DerivInfo
m_deriv_info) }
tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl }))
= do { ([InstInfo GhcRn]
insts, [FamInst]
fam_insts, [DerivInfo]
deriv_infos) <- LClsInstDecl GhcRn
-> TcRn ([InstInfo GhcRn], [FamInst], [DerivInfo])
tcClsInstDecl (SrcSpanAnnA
-> ClsInstDecl GhcRn -> GenLocated SrcSpanAnnA (ClsInstDecl GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc ClsInstDecl GhcRn
decl)
; ([InstInfo GhcRn], [FamInst], [DerivInfo])
-> TcRn ([InstInfo GhcRn], [FamInst], [DerivInfo])
forall (m :: * -> *) a. Monad m => a -> m a
return ([InstInfo GhcRn]
insts, [FamInst]
fam_insts, [DerivInfo]
deriv_infos) }
tcClsInstDecl :: LClsInstDecl GhcRn
-> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo])
tcClsInstDecl :: LClsInstDecl GhcRn
-> TcRn ([InstInfo GhcRn], [FamInst], [DerivInfo])
tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds
, cid_sigs = uprags, cid_tyfam_insts = ats
, cid_overlap_mode = overlap_mode
, cid_datafam_insts = adts }))
= SrcSpanAnnA
-> TcRn ([InstInfo GhcRn], [FamInst], [DerivInfo])
-> TcRn ([InstInfo GhcRn], [FamInst], [DerivInfo])
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcRn ([InstInfo GhcRn], [FamInst], [DerivInfo])
-> TcRn ([InstInfo GhcRn], [FamInst], [DerivInfo]))
-> TcRn ([InstInfo GhcRn], [FamInst], [DerivInfo])
-> TcRn ([InstInfo GhcRn], [FamInst], [DerivInfo])
forall a b. (a -> b) -> a -> b
$
SDoc
-> TcRn ([InstInfo GhcRn], [FamInst], [DerivInfo])
-> TcRn ([InstInfo GhcRn], [FamInst], [DerivInfo])
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (LHsSigType GhcRn -> SDoc
instDeclCtxt1 LHsSigType GhcRn
hs_ty) (TcRn ([InstInfo GhcRn], [FamInst], [DerivInfo])
-> TcRn ([InstInfo GhcRn], [FamInst], [DerivInfo]))
-> TcRn ([InstInfo GhcRn], [FamInst], [DerivInfo])
-> TcRn ([InstInfo GhcRn], [FamInst], [DerivInfo])
forall a b. (a -> b) -> a -> b
$
do { Type
dfun_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsClsInstType (Bool -> UserTypeCtxt
InstDeclCtxt Bool
False) LHsSigType GhcRn
hs_ty
; let ([TyVar]
tyvars, [Type]
theta, Class
clas, [Type]
inst_tys) = Type -> ([TyVar], [Type], Class, [Type])
tcSplitDFunTy Type
dfun_ty
; SkolemInfo
skol_info <- SkolemInfoAnon -> IOEnv (Env TcGblEnv TcLclEnv) SkolemInfo
forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo SkolemInfoAnon
InstSkol
; (TCvSubst
subst, [TyVar]
skol_tvs) <- SkolemInfo -> [TyVar] -> TcM (TCvSubst, [TyVar])
tcInstSkolTyVars SkolemInfo
skol_info [TyVar]
tyvars
; let tv_skol_prs :: [(Name, TyVar)]
tv_skol_prs = [ (TyVar -> Name
tyVarName TyVar
tv, TyVar
skol_tv)
| (TyVar
tv, TyVar
skol_tv) <- [TyVar]
tyvars [TyVar] -> [TyVar] -> [(TyVar, TyVar)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TyVar]
skol_tvs ]
tv_skol_env :: TyVarEnv Name
tv_skol_env = [(TyVar, Name)] -> TyVarEnv Name
forall a. [(TyVar, a)] -> VarEnv a
mkVarEnv ([(TyVar, Name)] -> TyVarEnv Name)
-> [(TyVar, Name)] -> TyVarEnv Name
forall a b. (a -> b) -> a -> b
$ ((Name, TyVar) -> (TyVar, Name))
-> [(Name, TyVar)] -> [(TyVar, Name)]
forall a b. (a -> b) -> [a] -> [b]
map (Name, TyVar) -> (TyVar, Name)
forall a b. (a, b) -> (b, a)
swap [(Name, TyVar)]
tv_skol_prs
n_inferred :: Int
n_inferred = (VarBndr TyVar ArgFlag -> Bool) -> [VarBndr TyVar ArgFlag] -> Int
forall a. (a -> Bool) -> [a] -> Int
countWhile ((ArgFlag -> ArgFlag -> Bool
forall a. Eq a => a -> a -> Bool
== ArgFlag
Inferred) (ArgFlag -> Bool)
-> (VarBndr TyVar ArgFlag -> ArgFlag)
-> VarBndr TyVar ArgFlag
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarBndr TyVar ArgFlag -> ArgFlag
forall tv argf. VarBndr tv argf -> argf
binderArgFlag) ([VarBndr TyVar ArgFlag] -> Int) -> [VarBndr TyVar ArgFlag] -> Int
forall a b. (a -> b) -> a -> b
$
([VarBndr TyVar ArgFlag], Type) -> [VarBndr TyVar ArgFlag]
forall a b. (a, b) -> a
fst (([VarBndr TyVar ArgFlag], Type) -> [VarBndr TyVar ArgFlag])
-> ([VarBndr TyVar ArgFlag], Type) -> [VarBndr TyVar ArgFlag]
forall a b. (a -> b) -> a -> b
$ Type -> ([VarBndr TyVar ArgFlag], Type)
splitForAllTyCoVarBinders Type
dfun_ty
visible_skol_tvs :: [TyVar]
visible_skol_tvs = Int -> [TyVar] -> [TyVar]
forall a. Int -> [a] -> [a]
drop Int
n_inferred [TyVar]
skol_tvs
; String -> SDoc -> TcRn ()
traceTc String
"tcLocalInstDecl 1" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
dfun_ty SDoc -> SDoc -> SDoc
$$ Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Type -> Int
invisibleTyBndrCount Type
dfun_ty) SDoc -> SDoc -> SDoc
$$ [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
skol_tvs)
; ([(FamInst, Maybe DerivInfo)]
datafam_stuff, [FamInst]
tyfam_insts)
<- [(Name, TyVar)]
-> TcM ([(FamInst, Maybe DerivInfo)], [FamInst])
-> TcM ([(FamInst, Maybe DerivInfo)], [FamInst])
forall r. [(Name, TyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv [(Name, TyVar)]
tv_skol_prs (TcM ([(FamInst, Maybe DerivInfo)], [FamInst])
-> TcM ([(FamInst, Maybe DerivInfo)], [FamInst]))
-> TcM ([(FamInst, Maybe DerivInfo)], [FamInst])
-> TcM ([(FamInst, Maybe DerivInfo)], [FamInst])
forall a b. (a -> b) -> a -> b
$
do { let mini_env :: VarEnv Type
mini_env = [(TyVar, Type)] -> VarEnv Type
forall a. [(TyVar, a)] -> VarEnv a
mkVarEnv (Class -> [TyVar]
classTyVars Class
clas [TyVar] -> [Type] -> [(TyVar, Type)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` HasDebugCallStack => TCvSubst -> [Type] -> [Type]
TCvSubst -> [Type] -> [Type]
substTys TCvSubst
subst [Type]
inst_tys)
mini_subst :: TCvSubst
mini_subst = InScopeSet -> VarEnv Type -> TCvSubst
mkTvSubst (VarSet -> InScopeSet
mkInScopeSet ([TyVar] -> VarSet
mkVarSet [TyVar]
skol_tvs)) VarEnv Type
mini_env
mb_info :: AssocInstInfo
mb_info = InClsInst :: Class -> [TyVar] -> VarEnv Type -> AssocInstInfo
InClsInst { ai_class :: Class
ai_class = Class
clas
, ai_tyvars :: [TyVar]
ai_tyvars = [TyVar]
visible_skol_tvs
, ai_inst_env :: VarEnv Type
ai_inst_env = VarEnv Type
mini_env }
; [(FamInst, Maybe DerivInfo)]
df_stuff <- (GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn)
-> TcM (FamInst, Maybe DerivInfo))
-> [GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn)]
-> TcRn [(FamInst, Maybe DerivInfo)]
forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndRecoverM (AssocInstInfo
-> TyVarEnv Name
-> LDataFamInstDecl GhcRn
-> TcM (FamInst, Maybe DerivInfo)
tcDataFamInstDecl AssocInstInfo
mb_info TyVarEnv Name
tv_skol_env) [LDataFamInstDecl GhcRn]
[GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn)]
adts
; [FamInst]
tf_insts1 <- (GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn) -> TcM FamInst)
-> [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)] -> TcRn [FamInst]
forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndRecoverM (AssocInstInfo -> LTyFamInstDecl GhcRn -> TcM FamInst
tcTyFamInstDecl AssocInstInfo
mb_info) [LTyFamInstDecl GhcRn]
[GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
ats
; Bool
is_boot <- TcRn Bool
tcIsHsBootOrSig
; let atItems :: [ClassATItem]
atItems = Class -> [ClassATItem]
classATItems Class
clas
; [[FamInst]]
tf_insts2 <- (ClassATItem -> TcRn [FamInst])
-> [ClassATItem] -> IOEnv (Env TcGblEnv TcLclEnv) [[FamInst]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SrcSpan -> TCvSubst -> NameSet -> ClassATItem -> TcRn [FamInst]
tcATDefault (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) TCvSubst
mini_subst NameSet
defined_ats)
(if Bool
is_boot then [] else [ClassATItem]
atItems)
; ([(FamInst, Maybe DerivInfo)], [FamInst])
-> TcM ([(FamInst, Maybe DerivInfo)], [FamInst])
forall (m :: * -> *) a. Monad m => a -> m a
return ([(FamInst, Maybe DerivInfo)]
df_stuff, [FamInst]
tf_insts1 [FamInst] -> [FamInst] -> [FamInst]
forall a. [a] -> [a] -> [a]
++ [[FamInst]] -> [FamInst]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FamInst]]
tf_insts2) }
; Name
dfun_name <- Class -> [Type] -> SrcSpan -> TcM Name
newDFunName Class
clas [Type]
inst_tys (GenLocated SrcSpanAnnA (HsSigType GhcRn) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
hs_ty)
; ClsInst
ispec <- Maybe OverlapMode
-> Name -> [TyVar] -> [Type] -> Class -> [Type] -> TcM ClsInst
newClsInst ((GenLocated SrcSpanAnnP OverlapMode -> OverlapMode)
-> Maybe (GenLocated SrcSpanAnnP OverlapMode) -> Maybe OverlapMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpanAnnP OverlapMode -> OverlapMode
forall l e. GenLocated l e -> e
unLoc Maybe (XRec GhcRn OverlapMode)
Maybe (GenLocated SrcSpanAnnP OverlapMode)
overlap_mode) Name
dfun_name
[TyVar]
tyvars [Type]
theta Class
clas [Type]
inst_tys
; let inst_binds :: InstBindings GhcRn
inst_binds = InstBindings :: forall a.
[Name]
-> LHsBinds a -> [LSig a] -> [Extension] -> Bool -> InstBindings a
InstBindings
{ ib_binds :: LHsBinds GhcRn
ib_binds = LHsBinds GhcRn
binds
, ib_tyvars :: [Name]
ib_tyvars = (TyVar -> Name) -> [TyVar] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> Name
Var.varName [TyVar]
tyvars
, ib_pragmas :: [LSig GhcRn]
ib_pragmas = [LSig GhcRn]
uprags
, ib_extensions :: [Extension]
ib_extensions = []
, ib_derived :: Bool
ib_derived = Bool
False }
inst_info :: InstInfo GhcRn
inst_info = InstInfo :: forall a. ClsInst -> InstBindings a -> InstInfo a
InstInfo { iSpec :: ClsInst
iSpec = ClsInst
ispec, iBinds :: InstBindings GhcRn
iBinds = InstBindings GhcRn
inst_binds }
([FamInst]
datafam_insts, [Maybe DerivInfo]
m_deriv_infos) = [(FamInst, Maybe DerivInfo)] -> ([FamInst], [Maybe DerivInfo])
forall a b. [(a, b)] -> ([a], [b])
unzip [(FamInst, Maybe DerivInfo)]
datafam_stuff
deriv_infos :: [DerivInfo]
deriv_infos = [Maybe DerivInfo] -> [DerivInfo]
forall a. [Maybe a] -> [a]
catMaybes [Maybe DerivInfo]
m_deriv_infos
all_insts :: [FamInst]
all_insts = [FamInst]
tyfam_insts [FamInst] -> [FamInst] -> [FamInst]
forall a. [a] -> [a] -> [a]
++ [FamInst]
datafam_insts
; let no_binds :: Bool
no_binds = LHsBinds GhcRn -> Bool
forall (idL :: Pass) idR. LHsBindsLR (GhcPass idL) idR -> Bool
isEmptyLHsBinds LHsBinds GhcRn
binds Bool -> Bool -> Bool
&& [GenLocated SrcSpanAnnA (Sig GhcRn)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
uprags
; Bool
is_boot <- TcRn Bool
tcIsHsBootOrSig
; Bool -> TcRnMessage -> TcRn ()
failIfTc (Bool
is_boot Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
no_binds) TcRnMessage
TcRnIllegalHsBootFileDecl
; ([InstInfo GhcRn], [FamInst], [DerivInfo])
-> TcRn ([InstInfo GhcRn], [FamInst], [DerivInfo])
forall (m :: * -> *) a. Monad m => a -> m a
return ( [InstInfo GhcRn
inst_info], [FamInst]
all_insts, [DerivInfo]
deriv_infos ) }
where
defined_ats :: NameSet
defined_ats = [Name] -> NameSet
mkNameSet ((GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn) -> Name)
-> [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (TyFamInstDecl GhcRn -> Name
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyFamInstDecl (GhcPass p) -> IdP (GhcPass p)
tyFamInstDeclName (TyFamInstDecl GhcRn -> Name)
-> (GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)
-> TyFamInstDecl GhcRn)
-> GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn) -> TyFamInstDecl GhcRn
forall l e. GenLocated l e -> e
unLoc) [LTyFamInstDecl GhcRn]
[GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
ats)
NameSet -> NameSet -> NameSet
`unionNameSet`
[Name] -> NameSet
mkNameSet ((GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn) -> Name)
-> [GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn)] -> [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 GhcRn)
-> GenLocated SrcSpanAnnN Name)
-> GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn)
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FamEqn GhcRn (HsDataDefn GhcRn) -> GenLocated SrcSpanAnnN Name
forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon
(FamEqn GhcRn (HsDataDefn GhcRn) -> GenLocated SrcSpanAnnN Name)
-> (GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn)
-> FamEqn GhcRn (HsDataDefn GhcRn))
-> GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn)
-> GenLocated SrcSpanAnnN Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataFamInstDecl GhcRn -> FamEqn GhcRn (HsDataDefn GhcRn)
forall pass. DataFamInstDecl pass -> FamEqn pass (HsDataDefn pass)
dfid_eqn
(DataFamInstDecl GhcRn -> FamEqn GhcRn (HsDataDefn GhcRn))
-> (GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn)
-> DataFamInstDecl GhcRn)
-> GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn)
-> FamEqn GhcRn (HsDataDefn GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn)
-> DataFamInstDecl GhcRn
forall l e. GenLocated l e -> e
unLoc) [LDataFamInstDecl GhcRn]
[GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn)]
adts)
tcTyFamInstDecl :: AssocInstInfo
-> LTyFamInstDecl GhcRn -> TcM FamInst
tcTyFamInstDecl :: AssocInstInfo -> LTyFamInstDecl GhcRn -> TcM FamInst
tcTyFamInstDecl AssocInstInfo
mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
= SrcSpanAnnA -> TcM FamInst -> TcM FamInst
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM FamInst -> TcM FamInst) -> TcM FamInst -> TcM FamInst
forall a b. (a -> b) -> a -> b
$
TyFamInstDecl GhcRn -> TcM FamInst -> TcM FamInst
forall a. TyFamInstDecl GhcRn -> TcM a -> TcM a
tcAddTyFamInstCtxt TyFamInstDecl GhcRn
decl (TcM FamInst -> TcM FamInst) -> TcM FamInst -> TcM FamInst
forall a b. (a -> b) -> a -> b
$
do { let fam_lname :: LIdP GhcRn
fam_lname = FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)) -> LIdP GhcRn
forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon TyFamInstEqn GhcRn
FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
eqn
; TyCon
fam_tc <- GenLocated SrcSpanAnnN Name -> TcM TyCon
tcLookupLocatedTyCon LIdP GhcRn
GenLocated SrcSpanAnnN Name
fam_lname
; AssocInstInfo -> TyCon -> TcRn ()
tcFamInstDeclChecks AssocInstInfo
mb_clsinfo TyCon
fam_tc
; Bool -> TcRnMessage -> TcRn ()
checkTc (TyCon -> Bool
isTypeFamilyTyCon TyCon
fam_tc) (TyCon -> TcRnMessage
wrongKindOfFamily TyCon
fam_tc)
; Bool -> TcRnMessage -> TcRn ()
checkTc (TyCon -> Bool
isOpenTypeFamilyTyCon TyCon
fam_tc) (TyCon -> TcRnMessage
notOpenFamily TyCon
fam_tc)
; KnotTied CoAxBranch
co_ax_branch <- TyCon
-> AssocInstInfo
-> LTyFamInstEqn GhcRn
-> TcM (KnotTied CoAxBranch)
tcTyFamInstEqn TyCon
fam_tc AssocInstInfo
mb_clsinfo
(SrcSpanAnnA
-> FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
-> GenLocated
SrcSpanAnnA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnN -> SrcSpanAnnA
forall a ann. SrcSpanAnn' a -> SrcAnn ann
na2la (SrcSpanAnnN -> SrcSpanAnnA) -> SrcSpanAnnN -> SrcSpanAnnA
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnN Name -> SrcSpanAnnN
forall l e. GenLocated l e -> l
getLoc LIdP GhcRn
GenLocated SrcSpanAnnN Name
fam_lname) TyFamInstEqn GhcRn
FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
eqn)
; AssocInstInfo -> TyCon -> KnotTied CoAxBranch -> TcRn ()
checkConsistentFamInst AssocInstInfo
mb_clsinfo TyCon
fam_tc KnotTied CoAxBranch
co_ax_branch
; TyCon -> KnotTied CoAxBranch -> TcRn ()
checkValidCoAxBranch TyCon
fam_tc KnotTied CoAxBranch
co_ax_branch
; Name
rep_tc_name <- GenLocated SrcSpanAnnN Name -> [[Type]] -> TcM Name
newFamInstAxiomName LIdP GhcRn
GenLocated SrcSpanAnnN Name
fam_lname [KnotTied CoAxBranch -> [Type]
coAxBranchLHS KnotTied CoAxBranch
co_ax_branch]
; let axiom :: CoAxiom Unbranched
axiom = Name -> TyCon -> KnotTied CoAxBranch -> CoAxiom Unbranched
mkUnbranchedCoAxiom Name
rep_tc_name TyCon
fam_tc KnotTied CoAxBranch
co_ax_branch
; FamFlavor -> CoAxiom Unbranched -> TcM FamInst
newFamInst FamFlavor
SynFamilyInst CoAxiom Unbranched
axiom }
tcFamInstDeclChecks :: AssocInstInfo -> TyCon -> TcM ()
tcFamInstDeclChecks :: AssocInstInfo -> TyCon -> TcRn ()
tcFamInstDeclChecks AssocInstInfo
mb_clsinfo TyCon
fam_tc
= do {
; String -> SDoc -> TcRn ()
traceTc String
"tcFamInstDecl" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc)
; Bool
type_families <- Extension -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TypeFamilies
; Bool
is_boot <- TcRn Bool
tcIsHsBootOrSig
; Bool -> TcRnMessage -> TcRn ()
checkTc Bool
type_families (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ TyCon -> TcRnMessage
badFamInstDecl TyCon
fam_tc
; Bool -> TcRnMessage -> TcRn ()
checkTc (Bool -> Bool
not Bool
is_boot) (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ TcRnMessage
badBootFamInstDeclErr
; Bool -> TcRnMessage -> TcRn ()
checkTc (TyCon -> Bool
isFamilyTyCon TyCon
fam_tc) (TyCon -> TcRnMessage
notFamily TyCon
fam_tc)
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AssocInstInfo -> Bool
isNotAssociated AssocInstInfo
mb_clsinfo Bool -> Bool -> Bool
&&
TyCon -> Bool
isTyConAssoc TyCon
fam_tc)
(TcRnMessage -> TcRn ()
addErr (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ TyCon -> TcRnMessage
assocInClassErr TyCon
fam_tc)
}
tcDataFamInstDecl ::
AssocInstInfo
-> TyVarEnv Name
-> LDataFamInstDecl GhcRn -> TcM (FamInst, Maybe DerivInfo)
tcDataFamInstDecl :: AssocInstInfo
-> TyVarEnv Name
-> LDataFamInstDecl GhcRn
-> TcM (FamInst, Maybe DerivInfo)
tcDataFamInstDecl AssocInstInfo
mb_clsinfo TyVarEnv Name
tv_skol_env
(L loc decl@(DataFamInstDecl { dfid_eqn =
FamEqn { feqn_bndrs = outer_bndrs
, feqn_pats = hs_pats
, feqn_tycon = lfam_name@(L _ fam_name)
, feqn_fixity = fixity
, feqn_rhs = HsDataDefn { dd_ND = new_or_data
, dd_cType = cType
, dd_ctxt = hs_ctxt
, dd_cons = hs_cons
, dd_kindSig = m_ksig
, dd_derivs = derivs } }}))
= SrcSpanAnnA
-> TcM (FamInst, Maybe DerivInfo) -> TcM (FamInst, Maybe DerivInfo)
forall ann a. SrcSpanAnn' 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 GhcRn
-> TcM (FamInst, Maybe DerivInfo) -> TcM (FamInst, Maybe DerivInfo)
forall a. DataFamInstDecl GhcRn -> TcM a -> TcM a
tcAddDataFamInstCtxt DataFamInstDecl GhcRn
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 { TyCon
fam_tc <- GenLocated SrcSpanAnnN Name -> TcM TyCon
tcLookupLocatedTyCon LIdP GhcRn
GenLocated SrcSpanAnnN Name
lfam_name
; AssocInstInfo -> TyCon -> TcRn ()
tcFamInstDeclChecks AssocInstInfo
mb_clsinfo TyCon
fam_tc
; Bool -> TcRnMessage -> TcRn ()
checkTc (TyCon -> Bool
isDataFamilyTyCon TyCon
fam_tc) (TyCon -> TcRnMessage
wrongKindOfFamily TyCon
fam_tc)
; Bool
gadt_syntax <- Name
-> NewOrData
-> Maybe (LHsContext GhcRn)
-> [LConDecl GhcRn]
-> TcRn Bool
dataDeclChecks Name
fam_name NewOrData
new_or_data Maybe (LHsContext GhcRn)
hs_ctxt [LConDecl GhcRn]
hs_cons
; SkolemInfo
skol_info <- SkolemInfoAnon -> IOEnv (Env TcGblEnv TcLclEnv) SkolemInfo
forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo SkolemInfoAnon
FamInstSkol
; ([TyVar]
qtvs, [Type]
pats, Type
tc_res_kind, [Type]
stupid_theta)
<- AssocInstInfo
-> SkolemInfo
-> TyCon
-> HsOuterFamEqnTyVarBndrs GhcRn
-> LexicalFixity
-> Maybe (LHsContext GhcRn)
-> HsTyPats GhcRn
-> Maybe (LHsKind GhcRn)
-> NewOrData
-> TcM ([TyVar], [Type], Type, [Type])
tcDataFamInstHeader AssocInstInfo
mb_clsinfo SkolemInfo
skol_info TyCon
fam_tc HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs LexicalFixity
fixity
Maybe (LHsContext GhcRn)
hs_ctxt HsTyPats GhcRn
hs_pats Maybe (LHsKind GhcRn)
m_ksig NewOrData
new_or_data
; let ([Type]
eta_pats, [TyConBinder]
eta_tcbs) = TyCon -> [Type] -> ([Type], [TyConBinder])
eta_reduce TyCon
fam_tc [Type]
pats
eta_tvs :: [TyVar]
eta_tvs = (TyConBinder -> TyVar) -> [TyConBinder] -> [TyVar]
forall a b. (a -> b) -> [a] -> [b]
map TyConBinder -> TyVar
forall tv argf. VarBndr tv argf -> tv
binderVar [TyConBinder]
eta_tcbs
post_eta_qtvs :: [TyVar]
post_eta_qtvs = (TyVar -> Bool) -> [TyVar] -> [TyVar]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (TyVar -> [TyVar] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TyVar]
eta_tvs) [TyVar]
qtvs
full_tcbs :: [TyConBinder]
full_tcbs = [TyVar] -> VarSet -> [TyConBinder]
mkTyConBindersPreferAnon [TyVar]
post_eta_qtvs
(Type -> VarSet
tyCoVarsOfType ([TyVar] -> Type -> Type
mkSpecForAllTys [TyVar]
eta_tvs Type
tc_res_kind))
[TyConBinder] -> [TyConBinder] -> [TyConBinder]
forall a. [a] -> [a] -> [a]
++ [TyConBinder]
eta_tcbs
; let flav :: TyConFlavour
flav = NewOrData -> TyConFlavour
newOrDataToFlavour NewOrData
new_or_data
; ([TyConBinder]
extra_tcbs, Type
tc_res_kind) <- TyConFlavour
-> SkolemInfo -> [TyConBinder] -> Type -> TcM ([TyConBinder], Type)
etaExpandAlgTyCon TyConFlavour
flav SkolemInfo
skol_info [TyConBinder]
full_tcbs Type
tc_res_kind
; let extra_pats :: [Type]
extra_pats = (TyConBinder -> Type) -> [TyConBinder] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (TyVar -> Type
mkTyVarTy (TyVar -> Type) -> (TyConBinder -> TyVar) -> TyConBinder -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyConBinder -> TyVar
forall tv argf. VarBndr tv argf -> tv
binderVar) [TyConBinder]
extra_tcbs
all_pats :: [Type]
all_pats = [Type]
pats [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
`chkAppend` [Type]
extra_pats
orig_res_ty :: Type
orig_res_ty = TyCon -> [Type] -> Type
mkTyConApp TyCon
fam_tc [Type]
all_pats
tc_ty_binders :: [TyConBinder]
tc_ty_binders = [TyConBinder]
full_tcbs [TyConBinder] -> [TyConBinder] -> [TyConBinder]
forall a. [a] -> [a] -> [a]
`chkAppend` [TyConBinder]
extra_tcbs
; String -> SDoc -> TcRn ()
traceTc String
"tcDataFamInstDecl 1" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Fam tycon:" SDoc -> SDoc -> SDoc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc
, String -> SDoc
text String
"Pats:" SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
pats
, String -> SDoc
text String
"visibilities:" SDoc -> SDoc -> SDoc
<+> [TyConBndrVis] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> [Type] -> [TyConBndrVis]
tcbVisibilities TyCon
fam_tc [Type]
pats)
, String -> SDoc
text String
"all_pats:" SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
all_pats
, String -> SDoc
text String
"tc_ty_binders" SDoc -> SDoc -> SDoc
<+> [TyConBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
tc_ty_binders
, String -> SDoc
text String
"fam_tc_binders:" SDoc -> SDoc -> SDoc
<+> [TyConBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> [TyConBinder]
tyConBinders TyCon
fam_tc)
, String -> SDoc
text String
"tc_res_kind:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
tc_res_kind
, String -> SDoc
text String
"eta_pats" SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
eta_pats
, String -> SDoc
text String
"eta_tcbs" SDoc -> SDoc -> SDoc
<+> [TyConBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
eta_tcbs ]
; ZonkEnv
ze <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
NoFlexi
; (ZonkEnv
ze, [TyConBinder]
ty_binders) <- ZonkEnv -> [TyConBinder] -> TcM (ZonkEnv, [TyConBinder])
forall vis.
ZonkEnv
-> [VarBndr TyVar vis] -> TcM (ZonkEnv, [VarBndr TyVar vis])
zonkTyVarBindersX ZonkEnv
ze [TyConBinder]
tc_ty_binders
; Type
res_kind <- ZonkEnv -> Type -> TcM Type
zonkTcTypeToTypeX ZonkEnv
ze Type
tc_res_kind
; [Type]
all_pats <- ZonkEnv -> [Type] -> TcM [Type]
zonkTcTypesToTypesX ZonkEnv
ze [Type]
all_pats
; [Type]
eta_pats <- ZonkEnv -> [Type] -> TcM [Type]
zonkTcTypesToTypesX ZonkEnv
ze [Type]
eta_pats
; [Type]
stupid_theta <- ZonkEnv -> [Type] -> TcM [Type]
zonkTcTypesToTypesX ZonkEnv
ze [Type]
stupid_theta
; let zonked_post_eta_qtvs :: [TyVar]
zonked_post_eta_qtvs = (TyVar -> TyVar) -> [TyVar] -> [TyVar]
forall a b. (a -> b) -> [a] -> [b]
map (ZonkEnv -> TyVar -> TyVar
lookupTyVarX ZonkEnv
ze) [TyVar]
post_eta_qtvs
zonked_eta_tvs :: [TyVar]
zonked_eta_tvs = (TyVar -> TyVar) -> [TyVar] -> [TyVar]
forall a b. (a -> b) -> [a] -> [b]
map (ZonkEnv -> TyVar -> TyVar
lookupTyVarX ZonkEnv
ze) [TyVar]
eta_tvs
; String -> SDoc -> TcRn ()
traceTc String
"tcDataFamInstDecl" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Fam tycon:" SDoc -> SDoc -> SDoc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc
, String -> SDoc
text String
"Pats:" SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
pats
, String -> SDoc
text String
"visibilities:" SDoc -> SDoc -> SDoc
<+> [TyConBndrVis] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> [Type] -> [TyConBndrVis]
tcbVisibilities TyCon
fam_tc [Type]
pats)
, String -> SDoc
text String
"all_pats:" SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
all_pats
, String -> SDoc
text String
"ty_binders" SDoc -> SDoc -> SDoc
<+> [TyConBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
ty_binders
, String -> SDoc
text String
"fam_tc_binders:" SDoc -> SDoc -> SDoc
<+> [TyConBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> [TyConBinder]
tyConBinders TyCon
fam_tc)
, String -> SDoc
text String
"res_kind:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
res_kind
, String -> SDoc
text String
"eta_pats" SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
eta_pats
, String -> SDoc
text String
"eta_tcbs" SDoc -> SDoc -> SDoc
<+> [TyConBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
eta_tcbs ]
; (TyCon
rep_tc, CoAxiom Unbranched
axiom) <- ((TyCon, CoAxiom Unbranched)
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, CoAxiom Unbranched))
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, CoAxiom Unbranched)
forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM (((TyCon, CoAxiom Unbranched)
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, CoAxiom Unbranched))
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, CoAxiom Unbranched))
-> ((TyCon, CoAxiom Unbranched)
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, CoAxiom Unbranched))
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, CoAxiom Unbranched)
forall a b. (a -> b) -> a -> b
$ \ ~(TyCon
rec_rep_tc, CoAxiom Unbranched
_) ->
do { [DataCon]
data_cons <- [TyVar] -> TcM [DataCon] -> TcM [DataCon]
forall r. [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv ([TyConBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tc_ty_binders) (TcM [DataCon] -> TcM [DataCon]) -> TcM [DataCon] -> TcM [DataCon]
forall a b. (a -> b) -> a -> b
$
NewOrData
-> DataDeclInfo
-> TyCon
-> [TyConBinder]
-> Type
-> [LConDecl GhcRn]
-> TcM [DataCon]
tcConDecls NewOrData
new_or_data (Type -> DataDeclInfo
DDataInstance Type
orig_res_ty)
TyCon
rec_rep_tc [TyConBinder]
tc_ty_binders Type
tc_res_kind
[LConDecl GhcRn]
hs_cons
; Name
rep_tc_name <- GenLocated SrcSpanAnnN Name -> [Type] -> TcM Name
newFamInstTyConName LIdP GhcRn
GenLocated SrcSpanAnnN Name
lfam_name [Type]
pats
; Name
axiom_name <- GenLocated SrcSpanAnnN Name -> [[Type]] -> TcM Name
newFamInstAxiomName LIdP GhcRn
GenLocated SrcSpanAnnN Name
lfam_name [[Type]
pats]
; AlgTyConRhs
tc_rhs <- case NewOrData
new_or_data of
NewOrData
DataType -> AlgTyConRhs -> IOEnv (Env TcGblEnv TcLclEnv) AlgTyConRhs
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 -> [DataCon] -> AlgTyConRhs
mkLevPolyDataTyConRhs
(HasDebugCallStack => Type -> Bool
Type -> Bool
isFixedRuntimeRepKind Type
res_kind)
[DataCon]
data_cons
NewOrData
NewType -> Bool
-> IOEnv (Env TcGblEnv TcLclEnv) AlgTyConRhs
-> IOEnv (Env TcGblEnv TcLclEnv) AlgTyConRhs
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not ([DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
data_cons)) (IOEnv (Env TcGblEnv TcLclEnv) AlgTyConRhs
-> IOEnv (Env TcGblEnv TcLclEnv) AlgTyConRhs)
-> IOEnv (Env TcGblEnv TcLclEnv) AlgTyConRhs
-> IOEnv (Env TcGblEnv TcLclEnv) AlgTyConRhs
forall a b. (a -> b) -> a -> b
$
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] -> DataCon
forall a. [a] -> a
head [DataCon]
data_cons)
; let ax_rhs :: Type
ax_rhs = TyCon -> [Type] -> Type
mkTyConApp TyCon
rep_tc ([TyVar] -> [Type]
mkTyVarTys [TyVar]
zonked_post_eta_qtvs)
axiom :: CoAxiom Unbranched
axiom = Role
-> Name
-> [TyVar]
-> [TyVar]
-> [TyVar]
-> TyCon
-> [Type]
-> Type
-> CoAxiom Unbranched
mkSingleCoAxiom Role
Representational Name
axiom_name
[TyVar]
zonked_post_eta_qtvs [TyVar]
zonked_eta_tvs
[] TyCon
fam_tc [Type]
eta_pats Type
ax_rhs
parent :: AlgTyConFlav
parent = CoAxiom Unbranched -> TyCon -> [Type] -> AlgTyConFlav
DataFamInstTyCon CoAxiom Unbranched
axiom TyCon
fam_tc [Type]
all_pats
rep_tc :: TyCon
rep_tc = Name
-> [TyConBinder]
-> Type
-> [Role]
-> Maybe CType
-> [Type]
-> AlgTyConRhs
-> AlgTyConFlav
-> Bool
-> TyCon
mkAlgTyCon Name
rep_tc_name
[TyConBinder]
ty_binders Type
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 (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 GhcRn CType)
Maybe (GenLocated SrcSpanAnnP CType)
cType) [Type]
stupid_theta
AlgTyConRhs
tc_rhs AlgTyConFlav
parent
Bool
gadt_syntax
; (TyCon, CoAxiom Unbranched)
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, CoAxiom Unbranched)
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon
rep_tc, CoAxiom Unbranched
axiom) }
; let ax_branch :: KnotTied CoAxBranch
ax_branch = CoAxiom Unbranched -> KnotTied CoAxBranch
coAxiomSingleBranch CoAxiom Unbranched
axiom
; AssocInstInfo -> TyCon -> KnotTied CoAxBranch -> TcRn ()
checkConsistentFamInst AssocInstInfo
mb_clsinfo TyCon
fam_tc KnotTied CoAxBranch
ax_branch
; TyCon -> KnotTied CoAxBranch -> TcRn ()
checkValidCoAxBranch TyCon
fam_tc KnotTied CoAxBranch
ax_branch
; TyCon -> TcRn ()
checkValidTyCon TyCon
rep_tc
; let scoped_tvs :: [(Name, TyVar)]
scoped_tvs = (TyVar -> (Name, TyVar)) -> [TyVar] -> [(Name, TyVar)]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> (Name, TyVar)
mk_deriv_info_scoped_tv_pr (TyCon -> [TyVar]
tyConTyVars TyCon
rep_tc)
m_deriv_info :: Maybe DerivInfo
m_deriv_info = case HsDeriving GhcRn
derivs of
[] -> Maybe DerivInfo
forall a. Maybe a
Nothing
HsDeriving GhcRn
preds ->
DerivInfo -> Maybe DerivInfo
forall a. a -> Maybe a
Just (DerivInfo -> Maybe DerivInfo) -> DerivInfo -> Maybe DerivInfo
forall a b. (a -> b) -> a -> b
$ DerivInfo :: TyCon -> [(Name, TyVar)] -> HsDeriving GhcRn -> SDoc -> DerivInfo
DerivInfo { di_rep_tc :: TyCon
di_rep_tc = TyCon
rep_tc
, di_scoped_tvs :: [(Name, TyVar)]
di_scoped_tvs = [(Name, TyVar)]
scoped_tvs
, di_clauses :: HsDeriving GhcRn
di_clauses = HsDeriving GhcRn
preds
, di_ctxt :: SDoc
di_ctxt = DataFamInstDecl GhcRn -> SDoc
tcMkDataFamInstCtxt DataFamInstDecl GhcRn
decl }
; FamInst
fam_inst <- FamFlavor -> CoAxiom Unbranched -> TcM FamInst
newFamInst (TyCon -> FamFlavor
DataFamilyInst TyCon
rep_tc) CoAxiom Unbranched
axiom
; (FamInst, Maybe DerivInfo) -> TcM (FamInst, Maybe DerivInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (FamInst
fam_inst, Maybe DerivInfo
m_deriv_info) }
where
eta_reduce :: TyCon -> [Type] -> ([Type], [TyConBinder])
eta_reduce :: TyCon -> [Type] -> ([Type], [TyConBinder])
eta_reduce TyCon
fam_tc [Type]
pats
= [(Type, VarSet, TyConBndrVis)]
-> [TyConBinder] -> ([Type], [TyConBinder])
forall c.
[(Type, VarSet, c)]
-> [VarBndr TyVar c] -> ([Type], [VarBndr TyVar c])
go ([(Type, VarSet, TyConBndrVis)] -> [(Type, VarSet, TyConBndrVis)]
forall a. [a] -> [a]
reverse ([Type]
-> [VarSet] -> [TyConBndrVis] -> [(Type, VarSet, TyConBndrVis)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Type]
pats [VarSet]
fvs_s [TyConBndrVis]
vis_s)) []
where
vis_s :: [TyConBndrVis]
vis_s :: [TyConBndrVis]
vis_s = TyCon -> [Type] -> [TyConBndrVis]
tcbVisibilities TyCon
fam_tc [Type]
pats
fvs_s :: [TyCoVarSet]
(VarSet
_, [VarSet]
fvs_s) = (VarSet -> Type -> (VarSet, VarSet))
-> VarSet -> [Type] -> (VarSet, [VarSet])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL VarSet -> Type -> (VarSet, VarSet)
add_fvs VarSet
emptyVarSet [Type]
pats
add_fvs :: VarSet -> Type -> (VarSet, VarSet)
add_fvs VarSet
fvs Type
pat = (VarSet
fvs VarSet -> VarSet -> VarSet
`unionVarSet` Type -> VarSet
tyCoVarsOfType Type
pat, VarSet
fvs)
go :: [(Type, VarSet, c)]
-> [VarBndr TyVar c] -> ([Type], [VarBndr TyVar c])
go ((Type
pat, VarSet
fvs_to_the_left, c
tcb_vis):[(Type, VarSet, c)]
pats) [VarBndr TyVar c]
etad_tvs
| Just TyVar
tv <- Type -> Maybe TyVar
getTyVar_maybe Type
pat
, Bool -> Bool
not (TyVar
tv TyVar -> VarSet -> Bool
`elemVarSet` VarSet
fvs_to_the_left)
= [(Type, VarSet, c)]
-> [VarBndr TyVar c] -> ([Type], [VarBndr TyVar c])
go [(Type, VarSet, c)]
pats (TyVar -> c -> VarBndr TyVar c
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv c
tcb_vis VarBndr TyVar c -> [VarBndr TyVar c] -> [VarBndr TyVar c]
forall a. a -> [a] -> [a]
: [VarBndr TyVar c]
etad_tvs)
go [(Type, VarSet, c)]
pats [VarBndr TyVar c]
etad_tvs = ([Type] -> [Type]
forall a. [a] -> [a]
reverse (((Type, VarSet, c) -> Type) -> [(Type, VarSet, c)] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type, VarSet, c) -> Type
forall a b c. (a, b, c) -> a
fstOf3 [(Type, VarSet, c)]
pats), [VarBndr TyVar c]
etad_tvs)
mk_deriv_info_scoped_tv_pr :: TyVar -> (Name, TyVar)
mk_deriv_info_scoped_tv_pr :: TyVar -> (Name, TyVar)
mk_deriv_info_scoped_tv_pr TyVar
tv =
let n :: Name
n = TyVarEnv Name -> Name -> TyVar -> Name
forall a. VarEnv a -> a -> TyVar -> a
lookupWithDefaultVarEnv TyVarEnv Name
tv_skol_env (TyVar -> Name
tyVarName TyVar
tv) TyVar
tv
in (Name
n, TyVar
tv)
tcDataFamInstHeader
:: AssocInstInfo -> SkolemInfo -> TyCon -> HsOuterFamEqnTyVarBndrs GhcRn
-> LexicalFixity -> Maybe (LHsContext GhcRn)
-> HsTyPats GhcRn -> Maybe (LHsKind GhcRn)
-> NewOrData
-> TcM ([TcTyVar], [TcType], TcKind, TcThetaType)
AssocInstInfo
mb_clsinfo SkolemInfo
skol_info TyCon
fam_tc HsOuterFamEqnTyVarBndrs GhcRn
hs_outer_bndrs LexicalFixity
fixity
Maybe (LHsContext GhcRn)
hs_ctxt HsTyPats GhcRn
hs_pats Maybe (LHsKind GhcRn)
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
<+> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> SDoc
forall a. Outputable a => a -> SDoc
ppr HsTyPats GhcRn
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
hs_pats)
; (TcLevel
tclvl, WantedConstraints
wanted, (HsOuterFamEqnTyVarBndrs GhcTc
outer_bndrs, ([Type]
stupid_theta, Type
lhs_ty, Type
master_res_kind, Type
instance_res_kind)))
<- String
-> TcM (HsOuterFamEqnTyVarBndrs GhcTc, ([Type], Type, Type, Type))
-> TcM
(TcLevel, WantedConstraints,
(HsOuterFamEqnTyVarBndrs GhcTc, ([Type], Type, Type, Type)))
forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX String
"tcDataFamInstHeader" (TcM (HsOuterFamEqnTyVarBndrs GhcTc, ([Type], Type, Type, Type))
-> TcM
(TcLevel, WantedConstraints,
(HsOuterFamEqnTyVarBndrs GhcTc, ([Type], Type, Type, Type))))
-> TcM (HsOuterFamEqnTyVarBndrs GhcTc, ([Type], Type, Type, Type))
-> TcM
(TcLevel, WantedConstraints,
(HsOuterFamEqnTyVarBndrs GhcTc, ([Type], Type, Type, Type)))
forall a b. (a -> b) -> a -> b
$
SkolemInfo
-> HsOuterFamEqnTyVarBndrs GhcRn
-> TcM ([Type], Type, Type, Type)
-> TcM (HsOuterFamEqnTyVarBndrs GhcTc, ([Type], Type, Type, Type))
forall a.
SkolemInfo
-> HsOuterFamEqnTyVarBndrs GhcRn
-> TcM a
-> TcM (HsOuterFamEqnTyVarBndrs GhcTc, a)
bindOuterFamEqnTKBndrs SkolemInfo
skol_info HsOuterFamEqnTyVarBndrs GhcRn
hs_outer_bndrs (TcM ([Type], Type, Type, Type)
-> TcM (HsOuterFamEqnTyVarBndrs GhcTc, ([Type], Type, Type, Type)))
-> TcM ([Type], Type, Type, Type)
-> TcM (HsOuterFamEqnTyVarBndrs GhcTc, ([Type], Type, Type, Type))
forall a b. (a -> b) -> a -> b
$
do { [Type]
stupid_theta <- Maybe (LHsContext GhcRn) -> TcM [Type]
tcHsContext Maybe (LHsContext GhcRn)
hs_ctxt
; (Type
lhs_ty, Type
lhs_kind) <- TyCon -> HsTyPats GhcRn -> TcM (Type, Type)
tcFamTyPats TyCon
fam_tc HsTyPats GhcRn
hs_pats
; (Type
lhs_applied_ty, Type
lhs_applied_kind)
<- Type -> Type -> TcM (Type, Type)
tcInstInvisibleTyBinders Type
lhs_ty Type
lhs_kind
; AssocInstInfo -> Type -> TcRn ()
addConsistencyConstraints AssocInstInfo
mb_clsinfo Type
lhs_ty
; Type
res_kind <- Maybe (GenLocated SrcSpanAnnA (HsType GhcRn)) -> TcM Type
tc_kind_sig Maybe (LHsKind GhcRn)
Maybe (GenLocated SrcSpanAnnA (HsType GhcRn))
m_ksig
; let hs_lhs :: LHsKind GhcRn
hs_lhs = LexicalFixity -> IdP GhcRn -> HsTyPats GhcRn -> LHsKind GhcRn
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
LexicalFixity
-> IdP (GhcPass p)
-> [LHsTypeArg (GhcPass p)]
-> LHsType (GhcPass p)
nlHsTyConApp LexicalFixity
fixity (TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
fam_tc) HsTyPats GhcRn
hs_pats
; CoercionN
_ <- Maybe TypedThing -> Type -> Type -> TcM CoercionN
unifyKind (TypedThing -> Maybe TypedThing
forall a. a -> Maybe a
Just (TypedThing -> Maybe TypedThing)
-> (HsType GhcRn -> TypedThing) -> HsType GhcRn -> Maybe TypedThing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsType GhcRn -> TypedThing
HsTypeRnThing (HsType GhcRn -> Maybe TypedThing)
-> HsType GhcRn -> Maybe TypedThing
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsType GhcRn) -> HsType GhcRn
forall l e. GenLocated l e -> e
unLoc LHsKind GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
hs_lhs) Type
lhs_applied_kind Type
res_kind
; String -> SDoc -> TcRn ()
traceTc String
"tcDataFamInstHeader" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc, Maybe (GenLocated SrcSpanAnnA (HsType GhcRn)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (LHsKind GhcRn)
Maybe (GenLocated SrcSpanAnnA (HsType GhcRn))
m_ksig, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
lhs_applied_kind, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
res_kind, Maybe (GenLocated SrcSpanAnnA (HsType GhcRn)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (LHsKind GhcRn)
Maybe (GenLocated SrcSpanAnnA (HsType GhcRn))
m_ksig]
; ([Type], Type, Type, Type) -> TcM ([Type], Type, Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ( [Type]
stupid_theta
, Type
lhs_applied_ty
, Type
lhs_applied_kind
, Type
res_kind ) }
; HsOuterFamEqnTyVarBndrs GhcTc
outer_bndrs <- HsOuterFamEqnTyVarBndrs GhcTc
-> TcM (HsOuterFamEqnTyVarBndrs GhcTc)
forall flag.
HsOuterTyVarBndrs flag GhcTc -> TcM (HsOuterTyVarBndrs flag GhcTc)
scopedSortOuter HsOuterFamEqnTyVarBndrs GhcTc
outer_bndrs
; let outer_tvs :: [TyVar]
outer_tvs = HsOuterFamEqnTyVarBndrs GhcTc -> [TyVar]
forall flag. HsOuterTyVarBndrs flag GhcTc -> [TyVar]
outerTyVars HsOuterFamEqnTyVarBndrs GhcTc
outer_bndrs
; TcLevel -> HsOuterFamEqnTyVarBndrs GhcRn -> [TyVar] -> TcRn ()
checkFamTelescope TcLevel
tclvl HsOuterFamEqnTyVarBndrs GhcRn
hs_outer_bndrs [TyVar]
outer_tvs
; CandidatesQTvs
dvs <- [TyVar] -> Type -> TcM CandidatesQTvs
candidateQTyVarsWithBinders [TyVar]
outer_tvs Type
lhs_ty
; [TyVar]
qtvs <- SkolemInfo
-> NonStandardDefaultingStrategy -> CandidatesQTvs -> TcM [TyVar]
quantifyTyVars SkolemInfo
skol_info NonStandardDefaultingStrategy
TryNotToDefaultNonStandardTyVars CandidatesQTvs
dvs
; let final_tvs :: [TyVar]
final_tvs = [TyVar] -> [TyVar]
scopedSort ([TyVar]
qtvs [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
outer_tvs)
; SkolemInfo -> [TyVar] -> TcLevel -> WantedConstraints -> TcRn ()
reportUnsolvedEqualities SkolemInfo
skol_info [TyVar]
final_tvs TcLevel
tclvl WantedConstraints
wanted
; [TyVar]
final_tvs <- [TyVar] -> TcM [TyVar]
HasDebugCallStack => [TyVar] -> TcM [TyVar]
zonkTcTyVarsToTcTyVars [TyVar]
final_tvs
; Type
lhs_ty <- Type -> TcM Type
zonkTcType Type
lhs_ty
; Type
master_res_kind <- Type -> TcM Type
zonkTcType Type
master_res_kind
; Type
instance_res_kind <- Type -> TcM Type
zonkTcType Type
instance_res_kind
; [Type]
stupid_theta <- [Type] -> TcM [Type]
zonkTcTypes [Type]
stupid_theta
; DataSort -> Type -> TcRn ()
checkDataKindSig (NewOrData -> DataSort
DataInstanceSort NewOrData
new_or_data) Type
master_res_kind
; DataSort -> Type -> TcRn ()
checkDataKindSig (NewOrData -> DataSort
DataInstanceSort NewOrData
new_or_data) Type
instance_res_kind
; let pats :: [Type]
pats = Type -> [Type]
unravelFamInstPats Type
lhs_ty
; ([TyVar], [Type], Type, [Type])
-> TcM ([TyVar], [Type], Type, [Type])
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVar]
final_tvs, [Type]
pats, Type
master_res_kind, [Type]
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 GhcRn)) -> TcM Type
tc_kind_sig Maybe (GenLocated SrcSpanAnnA (HsType GhcRn))
Nothing
= do { Bool
unlifted_newtypes <- Extension -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.UnliftedNewtypes
; Bool
unlifted_datatypes <- Extension -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.UnliftedDatatypes
; case NewOrData
new_or_data of
NewOrData
NewType | Bool
unlifted_newtypes -> TcM Type
newOpenTypeKind
NewOrData
DataType | Bool
unlifted_datatypes -> TcM Type
newOpenTypeKind
NewOrData
_ -> Type -> TcM Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
liftedTypeKind
}
tc_kind_sig (Just GenLocated SrcSpanAnnA (HsType GhcRn)
hs_kind)
= do { Type
sig_kind <- UserTypeCtxt -> LHsKind GhcRn -> TcM Type
tcLHsKindSig UserTypeCtxt
data_ctxt LHsKind GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
hs_kind
; ([TyVar]
_tvs', Type
inner_kind') <- SkolemInfoAnon -> Type -> TcM ([TyVar], Type)
tcSkolemiseInvisibleBndrs (UserTypeCtxt -> SkolemInfoAnon
SigTypeSkol UserTypeCtxt
data_ctxt) Type
sig_kind
; Type -> TcM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
inner_kind' }
tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn]
-> TcM (LHsBinds GhcTc)
tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn] -> TcM (LHsBinds GhcTc)
tcInstDecls2 [LTyClDecl GhcRn]
tycl_decls [InstInfo GhcRn]
inst_decls
= do {
let class_decls :: [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
class_decls = (GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
-> [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
forall a. (a -> Bool) -> [a] -> [a]
filter (TyClDecl GhcRn -> Bool
forall pass. TyClDecl pass -> Bool
isClassDecl (TyClDecl GhcRn -> Bool)
-> (GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TyClDecl GhcRn)
-> GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TyClDecl GhcRn
forall l e. GenLocated l e -> e
unLoc) [LTyClDecl GhcRn]
[GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
tycl_decls
; [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
dm_binds_s <- (GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))))
-> [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LTyClDecl GhcRn -> TcM (LHsBinds GhcTc)
GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
tcClassDecl2 [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
class_decls
; let dm_binds :: Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
dm_binds = [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. [Bag a] -> Bag a
unionManyBags [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
dm_binds_s
; let dm_ids :: [IdP GhcTc]
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
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
dm_binds
; [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
inst_binds_s <- [TyVar]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
forall r. [TyVar] -> TcM r -> TcM r
tcExtendGlobalValEnv [IdP GhcTc]
[TyVar]
dm_ids (IOEnv
(Env TcGblEnv TcLclEnv)
[Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))])
-> IOEnv
(Env TcGblEnv TcLclEnv)
[Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
forall a b. (a -> b) -> a -> b
$
(InstInfo GhcRn
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))))
-> [InstInfo GhcRn]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM InstInfo GhcRn -> TcM (LHsBinds GhcTc)
InstInfo GhcRn
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
tcInstDecl2 [InstInfo GhcRn]
inst_decls
; Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
dm_binds Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. Bag a -> Bag a -> Bag a
`unionBags` [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. [Bag a] -> Bag a
unionManyBags [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
inst_binds_s) }
tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc)
tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc)
tcInstDecl2 (InstInfo { iSpec :: forall a. InstInfo a -> ClsInst
iSpec = ClsInst
ispec, iBinds :: forall a. InstInfo a -> InstBindings a
iBinds = InstBindings GhcRn
ibinds })
= IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall r. TcRn r -> TcRn r -> TcRn r
recoverM (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall (m :: * -> *) a. Monad m => a -> m a
return Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall (idL :: Pass) idR. LHsBindsLR (GhcPass idL) idR
emptyLHsBinds) (IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a b. (a -> b) -> a -> b
$
SrcSpan
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a b. (a -> b) -> a -> b
$
SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (Type -> SDoc
instDeclCtxt2 (TyVar -> Type
idType TyVar
dfun_id)) (IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a b. (a -> b) -> a -> b
$
do {
; SkolemInfo
skol_info <- SkolemInfoAnon -> IOEnv (Env TcGblEnv TcLclEnv) SkolemInfo
forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo SkolemInfoAnon
InstSkol
; ([TyVar]
inst_tyvars, [Type]
dfun_theta, Type
inst_head) <- SkolemInfo -> TyVar -> TcM ([TyVar], [Type], Type)
tcSkolDFunType SkolemInfo
skol_info TyVar
dfun_id
; [TyVar]
dfun_ev_vars <- [Type] -> TcM [TyVar]
newEvVars [Type]
dfun_theta
; let (Class
clas, [Type]
inst_tys) = Type -> (Class, [Type])
tcSplitDFunHead Type
inst_head
([TyVar]
class_tyvars, [Type]
sc_theta, [TyVar]
_, [ClassOpItem]
op_items) = Class -> ([TyVar], [Type], [TyVar], [ClassOpItem])
classBigSig Class
clas
sc_theta' :: [Type]
sc_theta' = HasDebugCallStack => TCvSubst -> [Type] -> [Type]
TCvSubst -> [Type] -> [Type]
substTheta ([TyVar] -> [Type] -> TCvSubst
HasDebugCallStack => [TyVar] -> [Type] -> TCvSubst
zipTvSubst [TyVar]
class_tyvars [Type]
inst_tys) [Type]
sc_theta
; String -> SDoc -> TcRn ()
traceTc String
"tcInstDecl2" ([SDoc] -> SDoc
vcat [[TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
inst_tyvars, [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
inst_tys, [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
dfun_theta, [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
sc_theta'])
; spec_inst_info :: ([LTcSpecPrag], NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)])
spec_inst_info@([LTcSpecPrag]
spec_inst_prags,NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
_) <- TyVar -> InstBindings GhcRn -> TcM ([LTcSpecPrag], TcPragEnv)
tcSpecInstPrags TyVar
dfun_id InstBindings GhcRn
ibinds
; EvBindsVar
dfun_ev_binds_var <- TcM EvBindsVar
newTcEvBinds
; let dfun_ev_binds :: TcEvBinds
dfun_ev_binds = EvBindsVar -> TcEvBinds
TcEvBinds EvBindsVar
dfun_ev_binds_var
; (TcLevel
tclvl, ([TyVar]
sc_meth_ids, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
sc_meth_binds, Bag Implication
sc_meth_implics))
<- TcM
([TyVar], Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
Bag Implication)
-> TcM
(TcLevel,
([TyVar], Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
Bag Implication))
forall a. TcM a -> TcM (TcLevel, a)
pushTcLevelM (TcM
([TyVar], Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
Bag Implication)
-> TcM
(TcLevel,
([TyVar], Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
Bag Implication)))
-> TcM
([TyVar], Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
Bag Implication)
-> TcM
(TcLevel,
([TyVar], Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
Bag Implication))
forall a b. (a -> b) -> a -> b
$
do { ([TyVar]
sc_ids, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
sc_binds, Bag Implication
sc_implics)
<- TyVar
-> Class
-> [TyVar]
-> [TyVar]
-> [Type]
-> TcEvBinds
-> [Type]
-> TcM ([TyVar], LHsBinds GhcTc, Bag Implication)
tcSuperClasses TyVar
dfun_id Class
clas [TyVar]
inst_tyvars [TyVar]
dfun_ev_vars
[Type]
inst_tys TcEvBinds
dfun_ev_binds
[Type]
sc_theta'
; ([TyVar]
meth_ids, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
meth_binds, Bag Implication
meth_implics)
<- TyVar
-> Class
-> [TyVar]
-> [TyVar]
-> [Type]
-> TcEvBinds
-> ([LTcSpecPrag], TcPragEnv)
-> [ClassOpItem]
-> InstBindings GhcRn
-> TcM ([TyVar], LHsBinds GhcTc, Bag Implication)
tcMethods TyVar
dfun_id Class
clas [TyVar]
inst_tyvars [TyVar]
dfun_ev_vars
[Type]
inst_tys TcEvBinds
dfun_ev_binds ([LTcSpecPrag], TcPragEnv)
([LTcSpecPrag], NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)])
spec_inst_info
[ClassOpItem]
op_items InstBindings GhcRn
ibinds
; ([TyVar], Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
Bag Implication)
-> TcM
([TyVar], Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
Bag Implication)
forall (m :: * -> *) a. Monad m => a -> m a
return ( [TyVar]
sc_ids [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
meth_ids
, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
sc_binds Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
meth_binds
, Bag Implication
sc_implics Bag Implication -> Bag Implication -> Bag Implication
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag Implication
meth_implics ) }
; Implication
imp <- TcM Implication
newImplication
; Implication -> TcRn ()
emitImplication (Implication -> TcRn ()) -> Implication -> TcRn ()
forall a b. (a -> b) -> a -> b
$
Implication
imp { ic_tclvl :: TcLevel
ic_tclvl = TcLevel
tclvl
, ic_skols :: [TyVar]
ic_skols = [TyVar]
inst_tyvars
, ic_given :: [TyVar]
ic_given = [TyVar]
dfun_ev_vars
, ic_wanted :: WantedConstraints
ic_wanted = Bag Implication -> WantedConstraints
mkImplicWC Bag Implication
sc_meth_implics
, ic_binds :: EvBindsVar
ic_binds = EvBindsVar
dfun_ev_binds_var
, ic_info :: SkolemInfoAnon
ic_info = SkolemInfoAnon
InstSkol }
; TyVar
self_dict <- Class -> [Type] -> TcM TyVar
newDict Class
clas [Type]
inst_tys
; let class_tc :: TyCon
class_tc = Class -> TyCon
classTyCon Class
clas
loc' :: SrcSpanAnnA
loc' = SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc
[DataCon
dict_constr] = TyCon -> [DataCon]
tyConDataCons TyCon
class_tc
dict_bind :: LHsBind GhcTc
dict_bind = IdP GhcTc -> LHsExpr GhcTc -> LHsBind GhcTc
forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind IdP GhcTc
TyVar
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 :: HsExpr GhcTc
con_app_tys = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap ([Type] -> HsWrapper
mkWpTyApps [Type]
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
con_app_args = (HsExpr GhcTc -> TyVar -> HsExpr GhcTc)
-> HsExpr GhcTc -> [TyVar] -> HsExpr GhcTc
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' HsExpr GhcTc -> TyVar -> HsExpr GhcTc
app_to_meth HsExpr GhcTc
con_app_tys [TyVar]
sc_meth_ids
app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc
app_to_meth :: HsExpr GhcTc -> TyVar -> HsExpr GhcTc
app_to_meth HsExpr GhcTc
fun TyVar
meth_id = XApp GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcTc
EpAnnCO
noComments (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 -> TyVar -> HsExpr GhcTc
wrapId HsWrapper
arg_wrapper TyVar
meth_id))
inst_tv_tys :: [Type]
inst_tv_tys = [TyVar] -> [Type]
mkTyVarTys [TyVar]
inst_tyvars
arg_wrapper :: HsWrapper
arg_wrapper = [TyVar] -> HsWrapper
mkWpEvVarApps [TyVar]
dfun_ev_vars HsWrapper -> HsWrapper -> HsWrapper
<.> [Type] -> HsWrapper
mkWpTyApps [Type]
inst_tv_tys
is_newtype :: Bool
is_newtype = TyCon -> Bool
isNewTyCon TyCon
class_tc
dfun_id_w_prags :: TyVar
dfun_id_w_prags = TyVar -> [TyVar] -> TyVar
addDFunPrags TyVar
dfun_id [TyVar]
sc_meth_ids
dfun_spec_prags :: TcSpecPrags
dfun_spec_prags
| Bool
is_newtype = [LTcSpecPrag] -> TcSpecPrags
SpecPrags []
| Bool
otherwise = [LTcSpecPrag] -> TcSpecPrags
SpecPrags [LTcSpecPrag]
spec_inst_prags
export :: ABExport
export = ABE :: TyVar -> TyVar -> HsWrapper -> TcSpecPrags -> ABExport
ABE { abe_wrap :: HsWrapper
abe_wrap = HsWrapper
idHsWrapper
, abe_poly :: TyVar
abe_poly = TyVar
dfun_id_w_prags
, abe_mono :: TyVar
abe_mono = TyVar
self_dict
, abe_prags :: TcSpecPrags
abe_prags = TcSpecPrags
dfun_spec_prags }
main_bind :: HsBindLR GhcTc GhcTc
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 :: [TyVar]
-> [TyVar]
-> [ABExport]
-> [TcEvBinds]
-> LHsBinds GhcTc
-> Bool
-> AbsBinds
AbsBinds { abs_tvs :: [TyVar]
abs_tvs = [TyVar]
inst_tyvars
, abs_ev_vars :: [TyVar]
abs_ev_vars = [TyVar]
dfun_ev_vars
, abs_exports :: [ABExport]
abs_exports = [ABExport
export]
, abs_ev_binds :: [TcEvBinds]
abs_ev_binds = []
, abs_binds :: LHsBinds GhcTc
abs_binds = GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. a -> Bag a
unitBag LHsBind GhcTc
GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
dict_bind
, abs_sig :: Bool
abs_sig = Bool
True }
; Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. a -> Bag a
unitBag (SrcSpanAnnA
-> HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc' HsBindLR GhcTc GhcTc
main_bind)
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
sc_meth_binds)
}
where
dfun_id :: TyVar
dfun_id = ClsInst -> TyVar
instanceDFunId ClsInst
ispec
loc :: SrcSpan
loc = TyVar -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan TyVar
dfun_id
addDFunPrags :: DFunId -> [Id] -> DFunId
addDFunPrags :: TyVar -> [TyVar] -> TyVar
addDFunPrags TyVar
dfun_id [TyVar]
sc_meth_ids
| Bool
is_newtype
= TyVar
dfun_id TyVar -> Unfolding -> TyVar
`setIdUnfolding` Int -> SimpleOpts -> CoreExpr -> Unfolding
mkInlineUnfoldingWithArity Int
0 SimpleOpts
defaultSimpleOpts CoreExpr
con_app
TyVar -> InlinePragma -> TyVar
`setInlinePragma` InlinePragma
alwaysInlinePragma { inl_sat :: Maybe Int
inl_sat = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0 }
| Bool
otherwise
= TyVar
dfun_id TyVar -> Unfolding -> TyVar
`setIdUnfolding` [TyVar] -> DataCon -> [CoreExpr] -> Unfolding
mkDFunUnfolding [TyVar]
dfun_bndrs DataCon
dict_con [CoreExpr]
dict_args
TyVar -> InlinePragma -> TyVar
`setInlinePragma` InlinePragma
dfunInlinePragma
where
con_app :: CoreExpr
con_app = [TyVar] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [TyVar]
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 (TyVar -> CoreExpr
forall b. TyVar -> Expr b
Var (DataCon -> TyVar
dataConWrapId DataCon
dict_con)) [CoreExpr]
dict_args
dict_args :: [CoreExpr]
dict_args = (Type -> CoreExpr) -> [Type] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Type -> CoreExpr
forall b. Type -> Expr b
Type [Type]
inst_tys [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++
[CoreExpr -> [TyVar] -> CoreExpr
forall b. Expr b -> [TyVar] -> Expr b
mkVarApps (TyVar -> CoreExpr
forall b. TyVar -> Expr b
Var TyVar
id) [TyVar]
dfun_bndrs | TyVar
id <- [TyVar]
sc_meth_ids]
([TyVar]
dfun_tvs, [Type]
dfun_theta, Class
clas, [Type]
inst_tys) = Type -> ([TyVar], [Type], Class, [Type])
tcSplitDFunTy (TyVar -> Type
idType TyVar
dfun_id)
ev_ids :: [TyVar]
ev_ids = Int -> [Type] -> [TyVar]
mkTemplateLocalsNum Int
1 [Type]
dfun_theta
dfun_bndrs :: [TyVar]
dfun_bndrs = [TyVar]
dfun_tvs [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
ev_ids
clas_tc :: TyCon
clas_tc = Class -> TyCon
classTyCon Class
clas
[DataCon
dict_con] = TyCon -> [DataCon]
tyConDataCons TyCon
clas_tc
is_newtype :: Bool
is_newtype = TyCon -> Bool
isNewTyCon TyCon
clas_tc
wrapId :: HsWrapper -> Id -> HsExpr GhcTc
wrapId :: HsWrapper -> TyVar -> HsExpr GhcTc
wrapId HsWrapper
wrapper TyVar
id = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrapper (XVar GhcTc -> LIdP GhcTc -> HsExpr GhcTc
forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
XVar GhcTc
noExtField (TyVar -> LocatedAn NameAnn TyVar
forall a an. a -> LocatedAn an a
noLocA TyVar
id))
tcSuperClasses :: DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType]
-> TcEvBinds
-> TcThetaType
-> TcM ([EvVar], LHsBinds GhcTc, Bag Implication)
tcSuperClasses :: TyVar
-> Class
-> [TyVar]
-> [TyVar]
-> [Type]
-> TcEvBinds
-> [Type]
-> TcM ([TyVar], LHsBinds GhcTc, Bag Implication)
tcSuperClasses TyVar
dfun_id Class
cls [TyVar]
tyvars [TyVar]
dfun_evs [Type]
inst_tys TcEvBinds
dfun_ev_binds [Type]
sc_theta
= do { ([TyVar]
ids, [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
binds, [Implication]
implics) <- ((Type, Int)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TyVar, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Implication))
-> [(Type, Int)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
([TyVar], [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 (Type, Int)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TyVar, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Implication)
tc_super ([Type] -> [Int] -> [(Type, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
sc_theta [Int
fIRST_TAG..])
; ([TyVar], Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
Bag Implication)
-> TcM
([TyVar], Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
Bag Implication)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVar]
ids, [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. [a] -> Bag a
listToBag [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
binds, [Implication] -> Bag Implication
forall a. [a] -> Bag a
listToBag [Implication]
implics) }
where
loc :: SrcSpan
loc = TyVar -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan TyVar
dfun_id
size :: TypeSize
size = [Type] -> TypeSize
sizeTypes [Type]
inst_tys
tc_super :: (Type, Int)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TyVar, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Implication)
tc_super (Type
sc_pred, Int
n)
= do { (Implication
sc_implic, EvBindsVar
ev_binds_var, EvTerm
sc_ev_tm)
<- TcM EvTerm -> TcM (Implication, EvBindsVar, EvTerm)
forall result. TcM result -> TcM (Implication, EvBindsVar, result)
checkInstConstraints (TcM EvTerm -> TcM (Implication, EvBindsVar, EvTerm))
-> TcM EvTerm -> TcM (Implication, EvBindsVar, EvTerm)
forall a b. (a -> b) -> a -> b
$ CtOrigin -> Type -> TcM EvTerm
emitWanted (TypeSize -> CtOrigin
ScOrigin TypeSize
size) Type
sc_pred
; Name
sc_top_name <- OccName -> TcM Name
newName (Int -> OccName -> OccName
mkSuperDictAuxOcc Int
n (Class -> OccName
forall a. NamedThing a => a -> OccName
getOccName Class
cls))
; TyVar
sc_ev_id <- Type -> TcM TyVar
forall gbl lcl. Type -> TcRnIf gbl lcl TyVar
newEvVar Type
sc_pred
; EvBindsVar -> EvBind -> TcRn ()
addTcEvBind EvBindsVar
ev_binds_var (EvBind -> TcRn ()) -> EvBind -> TcRn ()
forall a b. (a -> b) -> a -> b
$ TyVar -> EvTerm -> EvBind
mkWantedEvBind TyVar
sc_ev_id EvTerm
sc_ev_tm
; let sc_top_ty :: Type
sc_top_ty = [TyVar] -> Type -> Type
mkInfForAllTys [TyVar]
tyvars (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
[Type] -> Type -> Type
mkPhiTy ((TyVar -> Type) -> [TyVar] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> Type
idType [TyVar]
dfun_evs) Type
sc_pred
sc_top_id :: TyVar
sc_top_id = HasDebugCallStack => Name -> Type -> Type -> TyVar
Name -> Type -> Type -> TyVar
mkLocalId Name
sc_top_name Type
Many Type
sc_top_ty
export :: ABExport
export = ABE :: TyVar -> TyVar -> HsWrapper -> TcSpecPrags -> ABExport
ABE { abe_wrap :: HsWrapper
abe_wrap = HsWrapper
idHsWrapper
, abe_poly :: TyVar
abe_poly = TyVar
sc_top_id
, abe_mono :: TyVar
abe_mono = TyVar
sc_ev_id
, abe_prags :: TcSpecPrags
abe_prags = TcSpecPrags
noSpecPrags }
local_ev_binds :: TcEvBinds
local_ev_binds = EvBindsVar -> TcEvBinds
TcEvBinds EvBindsVar
ev_binds_var
bind :: HsBindLR GhcTc GhcTc
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 :: [TyVar]
-> [TyVar]
-> [ABExport]
-> [TcEvBinds]
-> LHsBinds GhcTc
-> Bool
-> AbsBinds
AbsBinds { abs_tvs :: [TyVar]
abs_tvs = [TyVar]
tyvars
, abs_ev_vars :: [TyVar]
abs_ev_vars = [TyVar]
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 = LHsBinds GhcTc
forall a. Bag a
emptyBag
, abs_sig :: Bool
abs_sig = Bool
False }
; (TyVar, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Implication)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TyVar, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Implication)
forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar
sc_top_id, SrcSpanAnnA
-> HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) HsBindLR GhcTc GhcTc
bind, Implication
sc_implic) }
checkInstConstraints :: TcM result
-> TcM (Implication, EvBindsVar, result)
checkInstConstraints :: TcM result -> TcM (Implication, EvBindsVar, result)
checkInstConstraints TcM result
thing_inside
= do { (TcLevel
tclvl, WantedConstraints
wanted, result
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
; EvBindsVar
ev_binds_var <- TcM EvBindsVar
newTcEvBinds
; Implication
implic <- TcM Implication
newImplication
; let implic' :: Implication
implic' = Implication
implic { ic_tclvl :: TcLevel
ic_tclvl = TcLevel
tclvl
, ic_wanted :: WantedConstraints
ic_wanted = WantedConstraints
wanted
, ic_binds :: EvBindsVar
ic_binds = EvBindsVar
ev_binds_var
, ic_info :: SkolemInfoAnon
ic_info = SkolemInfoAnon
InstSkol }
; (Implication, EvBindsVar, result)
-> TcM (Implication, EvBindsVar, result)
forall (m :: * -> *) a. Monad m => a -> m a
return (Implication
implic', EvBindsVar
ev_binds_var, result
result) }
tcMethods :: DFunId -> Class
-> [TcTyVar] -> [EvVar]
-> [TcType]
-> TcEvBinds
-> ([LTcSpecPrag], TcPragEnv)
-> [ClassOpItem]
-> InstBindings GhcRn
-> TcM ([Id], LHsBinds GhcTc, Bag Implication)
tcMethods :: TyVar
-> Class
-> [TyVar]
-> [TyVar]
-> [Type]
-> TcEvBinds
-> ([LTcSpecPrag], TcPragEnv)
-> [ClassOpItem]
-> InstBindings GhcRn
-> TcM ([TyVar], LHsBinds GhcTc, Bag Implication)
tcMethods TyVar
dfun_id Class
clas [TyVar]
tyvars [TyVar]
dfun_ev_vars [Type]
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 GhcRn
binds
, ib_tyvars :: forall a. InstBindings a -> [Name]
ib_tyvars = [Name]
lexical_tvs
, ib_pragmas :: forall a. InstBindings a -> [LSig a]
ib_pragmas = [LSig GhcRn]
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, TyVar)]
-> TcM
([TyVar], Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
Bag Implication)
-> TcM
([TyVar], Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
Bag Implication)
forall r. [(Name, TyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv ([Name]
lexical_tvs [Name] -> [TyVar] -> [(Name, TyVar)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TyVar]
tyvars) (TcM
([TyVar], Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
Bag Implication)
-> TcM
([TyVar], Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
Bag Implication))
-> TcM
([TyVar], Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
Bag Implication)
-> TcM
([TyVar], Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
Bag Implication)
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcInstMeth" ([GenLocated SrcSpanAnnA (Sig GhcRn)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
sigs SDoc -> SDoc -> SDoc
$$ Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsBinds GhcRn
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
binds)
; TcRn ()
checkMinimalDefinition
; TcRn ()
checkMethBindMembership
; ([TyVar]
ids, [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
binds, [Maybe Implication]
mb_implics) <- [Extension]
-> TcM
([TyVar], [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[Maybe Implication])
-> TcM
([TyVar], [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[Maybe Implication])
forall a. [Extension] -> TcM a -> TcM a
set_exts [Extension]
exts (TcM
([TyVar], [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[Maybe Implication])
-> TcM
([TyVar], [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[Maybe Implication]))
-> TcM
([TyVar], [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[Maybe Implication])
-> TcM
([TyVar], [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[Maybe Implication])
forall a b. (a -> b) -> a -> b
$
TcM
([TyVar], [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[Maybe Implication])
-> TcM
([TyVar], [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[Maybe Implication])
forall a. TcM a -> TcM a
unset_warnings_deriving (TcM
([TyVar], [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[Maybe Implication])
-> TcM
([TyVar], [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[Maybe Implication]))
-> TcM
([TyVar], [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[Maybe Implication])
-> TcM
([TyVar], [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[Maybe Implication])
forall a b. (a -> b) -> a -> b
$
(ClassOpItem
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TyVar, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication))
-> [ClassOpItem]
-> TcM
([TyVar], [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 (TyVar, LHsBind GhcTc, Maybe Implication)
ClassOpItem
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TyVar, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication)
tc_item [ClassOpItem]
op_items
; ([TyVar], Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
Bag Implication)
-> TcM
([TyVar], Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
Bag Implication)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVar]
ids, [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. [a] -> Bag a
listToBag [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
binds, [Implication] -> Bag Implication
forall a. [a] -> Bag a
listToBag ([Maybe Implication] -> [Implication]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Implication]
mb_implics)) }
where
set_exts :: [LangExt.Extension] -> TcM a -> TcM a
set_exts :: [Extension] -> TcM a -> TcM a
set_exts [Extension]
es TcM a
thing = (Extension -> TcM a -> TcM a) -> TcM a -> [Extension] -> TcM a
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 :: TcM a -> TcM a
unset_warnings_deriving
| Bool
is_derived = WarningFlag -> TcM a -> TcM a
forall gbl lcl a.
WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetWOptM WarningFlag
Opt_WarnInaccessibleCode
| Bool
otherwise = TcM a -> TcM a
forall a. a -> a
id
hs_sig_fn :: HsSigFun
hs_sig_fn = [LSig GhcRn] -> HsSigFun
mkHsSigFun [LSig GhcRn]
sigs
inst_loc :: SrcSpan
inst_loc = TyVar -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan TyVar
dfun_id
tc_item :: ClassOpItem -> TcM (Id, LHsBind GhcTc, Maybe Implication)
tc_item :: ClassOpItem -> TcM (TyVar, LHsBind GhcTc, Maybe Implication)
tc_item (TyVar
sel_id, DefMethInfo
dm_info)
| Just (LHsBind GhcRn
user_bind, SrcSpan
bndr_loc, [LSig GhcRn]
prags) <- Name
-> LHsBinds GhcRn
-> TcPragEnv
-> Maybe (LHsBind GhcRn, SrcSpan, [LSig GhcRn])
findMethodBind (TyVar -> Name
idName TyVar
sel_id) LHsBinds GhcRn
binds TcPragEnv
prag_fn
= Class
-> [TyVar]
-> [TyVar]
-> [Type]
-> TcEvBinds
-> Bool
-> HsSigFun
-> [LTcSpecPrag]
-> [LSig GhcRn]
-> TyVar
-> LHsBind GhcRn
-> SrcSpan
-> TcM (TyVar, LHsBind GhcTc, Maybe Implication)
tcMethodBody Class
clas [TyVar]
tyvars [TyVar]
dfun_ev_vars [Type]
inst_tys
TcEvBinds
dfun_ev_binds Bool
is_derived HsSigFun
hs_sig_fn
[LTcSpecPrag]
spec_inst_prags [LSig GhcRn]
prags
TyVar
sel_id LHsBind GhcRn
user_bind SrcSpan
bndr_loc
| Bool
otherwise
= do { String -> SDoc -> TcRn ()
traceTc String
"tc_def" (TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
sel_id)
; TyVar
-> DefMethInfo -> TcM (TyVar, LHsBind GhcTc, Maybe Implication)
tc_default TyVar
sel_id DefMethInfo
dm_info }
tc_default :: Id -> DefMethInfo
-> TcM (TcId, LHsBind GhcTc, Maybe Implication)
tc_default :: TyVar
-> DefMethInfo -> TcM (TyVar, LHsBind GhcTc, Maybe Implication)
tc_default TyVar
sel_id (Just (Name
dm_name, DefMethSpec Type
_))
= do { (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
meth_bind, [GenLocated SrcSpanAnnA (Sig GhcRn)]
inline_prags) <- TyVar
-> Class -> TyVar -> Name -> TcM (LHsBind GhcRn, [LSig GhcRn])
mkDefMethBind TyVar
dfun_id Class
clas TyVar
sel_id Name
dm_name
; Class
-> [TyVar]
-> [TyVar]
-> [Type]
-> TcEvBinds
-> Bool
-> HsSigFun
-> [LTcSpecPrag]
-> [LSig GhcRn]
-> TyVar
-> LHsBind GhcRn
-> SrcSpan
-> TcM (TyVar, LHsBind GhcTc, Maybe Implication)
tcMethodBody Class
clas [TyVar]
tyvars [TyVar]
dfun_ev_vars [Type]
inst_tys
TcEvBinds
dfun_ev_binds Bool
is_derived HsSigFun
hs_sig_fn
[LTcSpecPrag]
spec_inst_prags [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
inline_prags
TyVar
sel_id LHsBind GhcRn
GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
meth_bind SrcSpan
inst_loc }
tc_default TyVar
sel_id DefMethInfo
Nothing
= do { String -> SDoc -> TcRn ()
traceTc String
"tc_def: warn" (TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
sel_id)
; (TyVar
meth_id, TyVar
_) <- Class
-> [TyVar] -> [TyVar] -> [Type] -> TyVar -> TcM (TyVar, TyVar)
mkMethIds Class
clas [TyVar]
tyvars [TyVar]
dfun_ev_vars
[Type]
inst_tys TyVar
sel_id
; DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let meth_bind :: LHsBind GhcTc
meth_bind = IdP GhcTc -> LHsExpr GhcTc -> LHsBind GhcTc
forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind IdP GhcTc
TyVar
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 (DynFlags -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
error_rhs DynFlags
dflags)
; (TyVar, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TyVar, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication)
forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar
meth_id, LHsBind GhcTc
GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
meth_bind, Maybe Implication
forall a. Maybe a
Nothing) }
where
inst_loc' :: SrcSpanAnnA
inst_loc' = SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
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
EpAnnCO
noComments 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 -> TyVar -> HsExpr GhcTc
wrapId ([Type] -> HsWrapper
mkWpTyApps
[ HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep Type
meth_tau, Type
meth_tau])
TyVar
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
EpAnnCO
noComments (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 :: Type
meth_tau = TyVar -> [Type] -> Type
classMethodInstTy TyVar
sel_id [Type]
inst_tys
error_string :: DynFlags -> String
error_string DynFlags
dflags = DynFlags -> SDoc -> String
showSDoc DynFlags
dflags
([SDoc] -> SDoc
hcat [SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
inst_loc, SDoc
vbar, TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
sel_id ])
lam_wrapper :: HsWrapper
lam_wrapper = [TyVar] -> HsWrapper
mkWpTyLams [TyVar]
tyvars HsWrapper -> HsWrapper -> HsWrapper
<.> [TyVar] -> HsWrapper
mkWpLams [TyVar]
dfun_ev_vars
checkMinimalDefinition :: TcRn ()
checkMinimalDefinition
= Maybe (BooleanFormula Name)
-> (BooleanFormula Name -> TcRn ()) -> TcRn ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust ((Name -> Bool)
-> BooleanFormula Name -> Maybe (BooleanFormula Name)
forall a.
Eq a =>
(a -> Bool) -> BooleanFormula a -> Maybe (BooleanFormula a)
isUnsatisfied Name -> Bool
methodExists (Class -> BooleanFormula Name
classMinimalDef Class
clas)) ((BooleanFormula Name -> TcRn ()) -> TcRn ())
-> (BooleanFormula Name -> TcRn ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$
BooleanFormula Name -> TcRn ()
warnUnsatisfiedMinimalDefinition
methodExists :: Name -> Bool
methodExists Name
meth = Maybe
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
[GenLocated SrcSpanAnnA (Sig GhcRn)])
-> Bool
forall a. Maybe a -> Bool
isJust (Name
-> LHsBinds GhcRn
-> TcPragEnv
-> Maybe (LHsBind GhcRn, SrcSpan, [LSig GhcRn])
findMethodBind Name
meth LHsBinds GhcRn
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
. Class -> Name -> TcRnMessage
forall a. Outputable a => a -> Name -> TcRnMessage
badMethodErr 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 GhcRn -> [LIdP GhcRn]
forall idL idR. UnXRec idL => LHsBindsLR idL idR -> [LIdP idL]
collectMethodBinders LHsBinds GhcRn
binds
cls_meth_nms :: [Name]
cls_meth_nms = (ClassOpItem -> Name) -> [ClassOpItem] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (TyVar -> Name
idName (TyVar -> Name) -> (ClassOpItem -> TyVar) -> ClassOpItem -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClassOpItem -> TyVar
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 :: Class -> [TcTyVar] -> [EvVar] -> [TcType]
-> TcEvBinds -> Bool
-> HsSigFun
-> [LTcSpecPrag] -> [LSig GhcRn]
-> Id -> LHsBind GhcRn -> SrcSpan
-> TcM (TcId, LHsBind GhcTc, Maybe Implication)
tcMethodBody :: Class
-> [TyVar]
-> [TyVar]
-> [Type]
-> TcEvBinds
-> Bool
-> HsSigFun
-> [LTcSpecPrag]
-> [LSig GhcRn]
-> TyVar
-> LHsBind GhcRn
-> SrcSpan
-> TcM (TyVar, LHsBind GhcTc, Maybe Implication)
tcMethodBody Class
clas [TyVar]
tyvars [TyVar]
dfun_ev_vars [Type]
inst_tys
TcEvBinds
dfun_ev_binds Bool
is_derived
HsSigFun
sig_fn [LTcSpecPrag]
spec_inst_prags [LSig GhcRn]
prags
TyVar
sel_id (L bind_loc meth_bind) SrcSpan
bndr_loc
= IOEnv
(Env TcGblEnv TcLclEnv)
(TyVar, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TyVar, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication)
add_meth_ctxt (IOEnv
(Env TcGblEnv TcLclEnv)
(TyVar, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TyVar, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TyVar, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TyVar, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication)
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcMethodBody" (TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
sel_id SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyVar -> Type
idType TyVar
sel_id) SDoc -> SDoc -> SDoc
$$ SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
bndr_loc)
; (TyVar
global_meth_id, TyVar
local_meth_id) <- SrcSpan -> TcM (TyVar, TyVar) -> TcM (TyVar, TyVar)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
bndr_loc (TcM (TyVar, TyVar) -> TcM (TyVar, TyVar))
-> TcM (TyVar, TyVar) -> TcM (TyVar, TyVar)
forall a b. (a -> b) -> a -> b
$
Class
-> [TyVar] -> [TyVar] -> [Type] -> TyVar -> TcM (TyVar, TyVar)
mkMethIds Class
clas [TyVar]
tyvars [TyVar]
dfun_ev_vars
[Type]
inst_tys TyVar
sel_id
; let lm_bind :: HsBindLR GhcRn GhcRn
lm_bind = HsBindLR GhcRn GhcRn
meth_bind { fun_id :: LIdP GhcRn
fun_id = SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
bndr_loc)
(TyVar -> Name
idName TyVar
local_meth_id) }
; (Implication
meth_implic, EvBindsVar
ev_binds_var, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
tc_bind)
<- IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> TcM
(Implication, EvBindsVar,
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall result. TcM result -> TcM (Implication, EvBindsVar, result)
checkInstConstraints (IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> TcM
(Implication, EvBindsVar,
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> TcM
(Implication, EvBindsVar,
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a b. (a -> b) -> a -> b
$
HsSigFun -> TyVar -> TyVar -> LHsBind GhcRn -> TcM (LHsBinds GhcTc)
tcMethodBodyHelp HsSigFun
sig_fn TyVar
sel_id TyVar
local_meth_id (SrcSpanAnnA
-> HsBindLR GhcRn GhcRn
-> GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
bind_loc HsBindLR GhcRn GhcRn
lm_bind)
; TyVar
global_meth_id <- TyVar -> [LSig GhcRn] -> TcM TyVar
addInlinePrags TyVar
global_meth_id [LSig GhcRn]
prags
; [LTcSpecPrag]
spec_prags <- TyVar -> [LSig GhcRn] -> TcM [LTcSpecPrag]
tcSpecPrags TyVar
global_meth_id [LSig GhcRn]
prags
; let specs :: TcSpecPrags
specs = TyVar -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags
mk_meth_spec_prags TyVar
global_meth_id [LTcSpecPrag]
spec_inst_prags [LTcSpecPrag]
spec_prags
export :: ABExport
export = ABE :: TyVar -> TyVar -> HsWrapper -> TcSpecPrags -> ABExport
ABE { abe_poly :: TyVar
abe_poly = TyVar
global_meth_id
, abe_mono :: TyVar
abe_mono = TyVar
local_meth_id
, abe_wrap :: HsWrapper
abe_wrap = HsWrapper
idHsWrapper
, abe_prags :: TcSpecPrags
abe_prags = TcSpecPrags
specs }
local_ev_binds :: TcEvBinds
local_ev_binds = EvBindsVar -> TcEvBinds
TcEvBinds EvBindsVar
ev_binds_var
full_bind :: HsBindLR GhcTc GhcTc
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 :: [TyVar]
-> [TyVar]
-> [ABExport]
-> [TcEvBinds]
-> LHsBinds GhcTc
-> Bool
-> AbsBinds
AbsBinds { abs_tvs :: [TyVar]
abs_tvs = [TyVar]
tyvars
, abs_ev_vars :: [TyVar]
abs_ev_vars = [TyVar]
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
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
tc_bind
, abs_sig :: Bool
abs_sig = Bool
True }
; (TyVar, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TyVar, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication)
forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar
global_meth_id, SrcSpanAnnA
-> HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
bind_loc HsBindLR GhcTc GhcTc
full_bind, Implication -> Maybe Implication
forall a. a -> Maybe a
Just Implication
meth_implic) }
where
add_meth_ctxt :: IOEnv
(Env TcGblEnv TcLclEnv)
(TyVar, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TyVar, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication)
add_meth_ctxt IOEnv
(Env TcGblEnv TcLclEnv)
(TyVar, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication)
thing
| Bool
is_derived = SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TyVar, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TyVar, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication)
forall a. SDoc -> TcM a -> TcM a
addLandmarkErrCtxt (TyVar -> Class -> [Type] -> SDoc
derivBindCtxt TyVar
sel_id Class
clas [Type]
inst_tys) IOEnv
(Env TcGblEnv TcLclEnv)
(TyVar, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication)
thing
| Bool
otherwise = IOEnv
(Env TcGblEnv TcLclEnv)
(TyVar, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication)
thing
tcMethodBodyHelp :: HsSigFun -> Id -> TcId
-> LHsBind GhcRn -> TcM (LHsBinds GhcTc)
tcMethodBodyHelp :: HsSigFun -> TyVar -> TyVar -> LHsBind GhcRn -> TcM (LHsBinds GhcTc)
tcMethodBodyHelp HsSigFun
hs_sig_fn TyVar
sel_id TyVar
local_meth_id LHsBind GhcRn
meth_bind
| Just LHsSigType GhcRn
hs_sig_ty <- HsSigFun
hs_sig_fn Name
sel_name
= do { (Type
sig_ty, HsWrapper
hs_wrap)
<- SrcSpan -> TcRn (Type, HsWrapper) -> TcRn (Type, HsWrapper)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (GenLocated SrcSpanAnnA (HsSigType GhcRn) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
hs_sig_ty) (TcRn (Type, HsWrapper) -> TcRn (Type, HsWrapper))
-> TcRn (Type, HsWrapper) -> TcRn (Type, HsWrapper)
forall a b. (a -> b) -> a -> b
$
do { Bool
inst_sigs <- Extension -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.InstanceSigs
; Bool -> TcRnMessage -> TcRn ()
checkTc Bool
inst_sigs (Name -> LHsSigType GhcRn -> TcRnMessage
misplacedInstSig Name
sel_name LHsSigType GhcRn
hs_sig_ty)
; let ctxt :: UserTypeCtxt
ctxt = Name -> ReportRedundantConstraints -> UserTypeCtxt
FunSigCtxt Name
sel_name ReportRedundantConstraints
NoRRC
; Type
sig_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsSigType UserTypeCtxt
ctxt LHsSigType GhcRn
hs_sig_ty
; let local_meth_ty :: Type
local_meth_ty = TyVar -> Type
idType TyVar
local_meth_id
; let orig :: CtOrigin
orig = Name -> Type -> Type -> CtOrigin
InstanceSigOrigin Name
sel_name Type
sig_ty Type
local_meth_ty
; HsWrapper
hs_wrap <- (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM HsWrapper -> TcM HsWrapper
forall a. (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
addErrCtxtM (Name -> Type -> Type -> TidyEnv -> TcM (TidyEnv, SDoc)
methSigCtxt Name
sel_name Type
sig_ty Type
local_meth_ty) (TcM HsWrapper -> TcM HsWrapper) -> TcM HsWrapper -> TcM HsWrapper
forall a b. (a -> b) -> a -> b
$
CtOrigin -> UserTypeCtxt -> Type -> Type -> TcM HsWrapper
tcSubTypeSigma CtOrigin
orig UserTypeCtxt
ctxt Type
sig_ty Type
local_meth_ty
; (Type, HsWrapper) -> TcRn (Type, HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
sig_ty, HsWrapper
hs_wrap) }
; Name
inner_meth_name <- OccName -> TcM Name
newName (Name -> OccName
nameOccName Name
sel_name)
; let ctxt :: UserTypeCtxt
ctxt = Name -> ReportRedundantConstraints -> UserTypeCtxt
FunSigCtxt Name
sel_name (LHsSigType GhcRn -> ReportRedundantConstraints
lhsSigTypeContextSpan LHsSigType GhcRn
hs_sig_ty)
inner_meth_id :: TyVar
inner_meth_id = HasDebugCallStack => Name -> Type -> Type -> TyVar
Name -> Type -> Type -> TyVar
mkLocalId Name
inner_meth_name Type
Many Type
sig_ty
inner_meth_sig :: TcIdSigInfo
inner_meth_sig = CompleteSig :: TyVar -> UserTypeCtxt -> SrcSpan -> TcIdSigInfo
CompleteSig { sig_bndr :: TyVar
sig_bndr = TyVar
inner_meth_id
, sig_ctxt :: UserTypeCtxt
sig_ctxt = UserTypeCtxt
ctxt
, sig_loc :: SrcSpan
sig_loc = GenLocated SrcSpanAnnA (HsSigType GhcRn) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
hs_sig_ty }
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
tc_bind, [TyVar
inner_id]) <- TcPragEnv
-> TcIdSigInfo -> LHsBind GhcRn -> TcM (LHsBinds GhcTc, [TyVar])
tcPolyCheck TcPragEnv
NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
no_prag_fn TcIdSigInfo
inner_meth_sig LHsBind GhcRn
meth_bind
; let export :: ABExport
export = ABE :: TyVar -> TyVar -> HsWrapper -> TcSpecPrags -> ABExport
ABE { abe_poly :: TyVar
abe_poly = TyVar
local_meth_id
, abe_mono :: TyVar
abe_mono = TyVar
inner_id
, abe_wrap :: HsWrapper
abe_wrap = HsWrapper
hs_wrap
, abe_prags :: TcSpecPrags
abe_prags = TcSpecPrags
noSpecPrags }
; Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. a -> Bag a
unitBag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall l e. l -> e -> GenLocated l e
L (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc LHsBind GhcRn
GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
meth_bind) (HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall a b. (a -> b) -> a -> b
$ 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 :: [TyVar]
-> [TyVar]
-> [ABExport]
-> [TcEvBinds]
-> LHsBinds GhcTc
-> Bool
-> AbsBinds
AbsBinds { abs_tvs :: [TyVar]
abs_tvs = [], abs_ev_vars :: [TyVar]
abs_ev_vars = []
, abs_exports :: [ABExport]
abs_exports = [ABExport
export]
, abs_binds :: LHsBinds GhcTc
abs_binds = LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
tc_bind, abs_ev_binds :: [TcEvBinds]
abs_ev_binds = []
, abs_sig :: Bool
abs_sig = Bool
True }) }
| Bool
otherwise
= do { let ctxt :: UserTypeCtxt
ctxt = Name -> ReportRedundantConstraints -> UserTypeCtxt
FunSigCtxt Name
sel_name ReportRedundantConstraints
NoRRC
tc_sig :: TcIdSigInfo
tc_sig = UserTypeCtxt -> TyVar -> TcIdSigInfo
completeSigFromId UserTypeCtxt
ctxt TyVar
local_meth_id
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
tc_bind, [TyVar]
_) <- TcPragEnv
-> TcIdSigInfo -> LHsBind GhcRn -> TcM (LHsBinds GhcTc, [TyVar])
tcPolyCheck TcPragEnv
NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
no_prag_fn TcIdSigInfo
tc_sig LHsBind GhcRn
meth_bind
; Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall (m :: * -> *) a. Monad m => a -> m a
return Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
tc_bind }
where
sel_name :: Name
sel_name = TyVar -> Name
idName TyVar
sel_id
no_prag_fn :: TcPragEnv
no_prag_fn = TcPragEnv
emptyPragEnv
mkMethIds :: Class -> [TcTyVar] -> [EvVar]
-> [TcType] -> Id -> TcM (TcId, TcId)
mkMethIds :: Class
-> [TyVar] -> [TyVar] -> [Type] -> TyVar -> TcM (TyVar, TyVar)
mkMethIds Class
clas [TyVar]
tyvars [TyVar]
dfun_ev_vars [Type]
inst_tys TyVar
sel_id
= do { Name
poly_meth_name <- OccName -> TcM Name
newName (OccName -> OccName
mkClassOpAuxOcc OccName
sel_occ)
; Name
local_meth_name <- OccName -> TcM Name
newName OccName
sel_occ
; let poly_meth_id :: TyVar
poly_meth_id = HasDebugCallStack => Name -> Type -> Type -> TyVar
Name -> Type -> Type -> TyVar
mkLocalId Name
poly_meth_name Type
Many Type
poly_meth_ty
local_meth_id :: TyVar
local_meth_id = HasDebugCallStack => Name -> Type -> Type -> TyVar
Name -> Type -> Type -> TyVar
mkLocalId Name
local_meth_name Type
Many Type
local_meth_ty
; (TyVar, TyVar) -> TcM (TyVar, TyVar)
forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar
poly_meth_id, TyVar
local_meth_id) }
where
sel_name :: Name
sel_name = TyVar -> Name
idName TyVar
sel_id
!sel_occ :: OccName
sel_occ = Name -> OccName
nameOccName Name
sel_name
local_meth_ty :: Type
local_meth_ty = Class -> TyVar -> [Type] -> Type
instantiateMethod Class
clas TyVar
sel_id [Type]
inst_tys
poly_meth_ty :: Type
poly_meth_ty = [TyVar] -> [Type] -> Type -> Type
mkSpecSigmaTy [TyVar]
tyvars [Type]
theta Type
local_meth_ty
theta :: [Type]
theta = (TyVar -> Type) -> [TyVar] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> Type
idType [TyVar]
dfun_ev_vars
methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
methSigCtxt :: Name -> Type -> Type -> TidyEnv -> TcM (TidyEnv, SDoc)
methSigCtxt Name
sel_name Type
sig_ty Type
meth_ty TidyEnv
env0
= do { (TidyEnv
env1, Type
sig_ty) <- TidyEnv -> Type -> TcM (TidyEnv, Type)
zonkTidyTcType TidyEnv
env0 Type
sig_ty
; (TidyEnv
env2, Type
meth_ty) <- TidyEnv -> Type -> TcM (TidyEnv, Type)
zonkTidyTcType TidyEnv
env1 Type
meth_ty
; let msg :: SDoc
msg = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"When checking that instance signature for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
sel_name))
Int
2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"is more general than its signature in the class"
, String -> SDoc
text String
"Instance sig:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
sig_ty
, String -> SDoc
text String
" Class sig:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
meth_ty ])
; (TidyEnv, SDoc) -> TcM (TidyEnv, SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
env2, SDoc
msg) }
misplacedInstSig :: Name -> LHsSigType GhcRn -> TcRnMessage
misplacedInstSig :: Name -> LHsSigType GhcRn -> TcRnMessage
misplacedInstSig Name
name LHsSigType GhcRn
hs_ty
= DiagnosticMessage -> TcRnMessage
forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Illegal type signature in instance declaration:")
Int
2 (SDoc -> Int -> SDoc -> SDoc
hang (Name -> SDoc
forall a. NamedThing a => a -> SDoc
pprPrefixName Name
name)
Int
2 (SDoc
dcolon SDoc -> SDoc -> SDoc
<+> GenLocated SrcSpanAnnA (HsSigType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
hs_ty))
, String -> SDoc
text String
"(Use InstanceSigs to allow this)" ]
mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags
mk_meth_spec_prags :: TyVar -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags
mk_meth_spec_prags TyVar
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 (TyVar -> InlinePragma
idInlinePragma TyVar
meth_id)
= []
| Bool
otherwise
= [ SrcSpan -> TcSpecPrag -> LTcSpecPrag
forall l e. l -> e -> GenLocated l e
L SrcSpan
inst_loc (TyVar -> HsWrapper -> InlinePragma -> TcSpecPrag
SpecPrag TyVar
meth_id HsWrapper
wrap InlinePragma
inl)
| L SrcSpan
inst_loc (SpecPrag TyVar
_ HsWrapper
wrap InlinePragma
inl) <- [LTcSpecPrag]
spec_inst_prags]
mkDefMethBind :: DFunId -> Class -> Id -> Name
-> TcM (LHsBind GhcRn, [LSig GhcRn])
mkDefMethBind :: TyVar
-> Class -> TyVar -> Name -> TcM (LHsBind GhcRn, [LSig GhcRn])
mkDefMethBind TyVar
dfun_id Class
clas TyVar
sel_id Name
dm_name
= do { Logger
logger <- IOEnv (Env TcGblEnv TcLclEnv) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
; TyVar
dm_id <- Name -> TcM TyVar
tcLookupId Name
dm_name
; let inline_prag :: InlinePragma
inline_prag = TyVar -> InlinePragma
idInlinePragma TyVar
dm_id
inline_prags :: [GenLocated SrcSpanAnnA (Sig GhcRn)]
inline_prags | InlinePragma -> Bool
isAnyInlinePragma InlinePragma
inline_prag
= [Sig GhcRn -> GenLocated SrcSpanAnnA (Sig GhcRn)
forall a an. a -> LocatedAn an a
noLocA (XInlineSig GhcRn -> LIdP GhcRn -> InlinePragma -> Sig GhcRn
forall pass.
XInlineSig pass -> LIdP pass -> InlinePragma -> Sig pass
InlineSig XInlineSig GhcRn
forall a. EpAnn a
noAnn LIdP GhcRn
GenLocated SrcSpanAnnN Name
fn InlinePragma
inline_prag)]
| Bool
otherwise
= []
fn :: GenLocated SrcSpanAnnN Name
fn = Name -> GenLocated SrcSpanAnnN Name
forall a an. a -> LocatedAn an a
noLocA (TyVar -> Name
idName TyVar
sel_id)
visible_inst_tys :: [Type]
visible_inst_tys = [ Type
ty | (TyConBinder
tcb, Type
ty) <- TyCon -> [TyConBinder]
tyConBinders (Class -> TyCon
classTyCon Class
clas) [TyConBinder] -> [Type] -> [(TyConBinder, Type)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Type]
inst_tys
, TyConBinder -> ArgFlag
tyConBinderArgFlag TyConBinder
tcb ArgFlag -> ArgFlag -> Bool
forall a. Eq a => a -> a -> Bool
/= ArgFlag
Inferred ]
rhs :: LocatedA (HsExpr GhcRn)
rhs = (LocatedA (HsExpr GhcRn) -> Type -> LocatedA (HsExpr GhcRn))
-> LocatedA (HsExpr GhcRn) -> [Type] -> LocatedA (HsExpr GhcRn)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' LHsExpr GhcRn -> Type -> LHsExpr GhcRn
LocatedA (HsExpr GhcRn) -> Type -> LocatedA (HsExpr GhcRn)
mk_vta (IdP GhcRn -> LHsExpr GhcRn
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcRn
Name
dm_name) [Type]
visible_inst_tys
bind :: GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
bind = HsBindLR GhcRn GhcRn
-> GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
forall a an. a -> LocatedAn an a
noLocA (HsBindLR GhcRn GhcRn
-> GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
-> HsBindLR GhcRn GhcRn
-> GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
forall a b. (a -> b) -> a -> b
$ Origin
-> GenLocated SrcSpanAnnN Name
-> [LMatch GhcRn (LHsExpr GhcRn)]
-> HsBindLR GhcRn GhcRn
mkTopFunBind Origin
Generated GenLocated SrcSpanAnnN Name
fn ([LMatch GhcRn (LHsExpr GhcRn)] -> HsBindLR GhcRn GhcRn)
-> [LMatch GhcRn (LHsExpr GhcRn)] -> HsBindLR GhcRn GhcRn
forall a b. (a -> b) -> a -> b
$
[HsMatchContext GhcRn
-> [LPat GhcRn]
-> LocatedA (HsExpr GhcRn)
-> LMatch GhcRn (LocatedA (HsExpr GhcRn))
forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA,
Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns) =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch (LIdP GhcRn -> HsMatchContext GhcRn
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs LIdP GhcRn
GenLocated SrcSpanAnnN Name
fn) [] LocatedA (HsExpr GhcRn)
rhs]
; IO () -> TcRn ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_deriv String
"Filling in method body"
DumpFormat
FormatHaskell
([SDoc] -> SDoc
vcat [Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
clas SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
inst_tys,
Int -> SDoc -> SDoc
nest Int
2 (TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
sel_id SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> LocatedA (HsExpr GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LocatedA (HsExpr GhcRn)
rhs)]))
; (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn),
[GenLocated SrcSpanAnnA (Sig GhcRn)])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn),
[GenLocated SrcSpanAnnA (Sig GhcRn)])
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
bind, [GenLocated SrcSpanAnnA (Sig GhcRn)]
inline_prags) }
where
([TyVar]
_, [Type]
_, Class
_, [Type]
inst_tys) = Type -> ([TyVar], [Type], Class, [Type])
tcSplitDFunTy (TyVar -> Type
idType TyVar
dfun_id)
mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn
mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn
mk_vta LHsExpr GhcRn
fun Type
ty = HsExpr GhcRn -> LocatedA (HsExpr GhcRn)
forall a an. a -> LocatedAn an a
noLocA (XAppTypeE GhcRn
-> LHsExpr GhcRn -> LHsWcType (NoGhcTc GhcRn) -> HsExpr GhcRn
forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType NoExtField
XAppTypeE GhcRn
noExtField LHsExpr GhcRn
fun (GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
forall thing. thing -> HsWildCardBndrs GhcRn thing
mkEmptyWildCardBndrs (GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
-> GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
forall a b. (a -> b) -> a -> b
$ LHsKind GhcRn -> LHsKind GhcRn
forall (p :: Pass). LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsParTy
(LHsKind GhcRn -> LHsKind GhcRn) -> LHsKind GhcRn -> LHsKind GhcRn
forall a b. (a -> b) -> a -> b
$ HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a an. a -> LocatedAn an a
noLocA (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a b. (a -> b) -> a -> b
$ XXType GhcRn -> HsType GhcRn
forall pass. XXType pass -> HsType pass
XHsType XXType GhcRn
Type
ty))
derivBindCtxt :: Id -> Class -> [Type ] -> SDoc
derivBindCtxt :: TyVar -> Class -> [Type] -> SDoc
derivBindCtxt TyVar
sel_id Class
clas [Type]
tys
= [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"When typechecking the code for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
sel_id)
, Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
text String
"in a derived instance for"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Class -> [Type] -> SDoc
pprClassPred Class
clas [Type]
tys) SDoc -> SDoc -> SDoc
<> SDoc
colon)
, Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"To see the code I am typechecking, use -ddump-deriv" ]
warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM ()
warnUnsatisfiedMinimalDefinition :: BooleanFormula Name -> TcRn ()
warnUnsatisfiedMinimalDefinition BooleanFormula Name
mindef
= do { Bool
warn <- WarningFlag -> TcRn Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnMissingMethods
; let msg :: TcRnMessage
msg = DiagnosticMessage -> TcRnMessage
forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic (WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnMissingMethods) [GhcHint]
noHints SDoc
message
; Bool -> TcRnMessage -> TcRn ()
diagnosticTc Bool
warn TcRnMessage
msg
}
where
message :: SDoc
message = [SDoc] -> SDoc
vcat [String -> SDoc
text String
"No explicit implementation for"
,Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ BooleanFormula Name -> SDoc
forall a. Outputable a => BooleanFormula a -> SDoc
pprBooleanFormulaNice BooleanFormula Name
mindef
]
tcSpecInstPrags :: DFunId -> InstBindings GhcRn
-> TcM ([LTcSpecPrag], TcPragEnv)
tcSpecInstPrags :: TyVar -> InstBindings GhcRn -> TcM ([LTcSpecPrag], TcPragEnv)
tcSpecInstPrags TyVar
dfun_id (InstBindings { ib_binds :: forall a. InstBindings a -> LHsBinds a
ib_binds = LHsBinds GhcRn
binds, ib_pragmas :: forall a. InstBindings a -> [LSig a]
ib_pragmas = [LSig GhcRn]
uprags })
= do { [LTcSpecPrag]
spec_inst_prags <- (GenLocated SrcSpanAnnA (Sig GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) LTcSpecPrag)
-> [GenLocated SrcSpanAnnA (Sig GhcRn)] -> TcM [LTcSpecPrag]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Sig GhcRn -> TcM TcSpecPrag)
-> GenLocated SrcSpanAnnA (Sig GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) LTcSpecPrag
forall a b an. (a -> TcM b) -> LocatedAn an a -> TcM (Located b)
wrapLocAM (TyVar -> Sig GhcRn -> TcM TcSpecPrag
tcSpecInst TyVar
dfun_id)) ([GenLocated SrcSpanAnnA (Sig GhcRn)] -> TcM [LTcSpecPrag])
-> [GenLocated SrcSpanAnnA (Sig GhcRn)] -> TcM [LTcSpecPrag]
forall a b. (a -> b) -> a -> b
$
(GenLocated SrcSpanAnnA (Sig GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall a. (a -> Bool) -> [a] -> [a]
filter GenLocated SrcSpanAnnA (Sig GhcRn) -> Bool
forall p. UnXRec p => LSig p -> Bool
isSpecInstLSig [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
uprags
; ([LTcSpecPrag], NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)])
-> IOEnv
(Env TcGblEnv TcLclEnv)
([LTcSpecPrag], NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([LTcSpecPrag]
spec_inst_prags, [LSig GhcRn] -> LHsBinds GhcRn -> TcPragEnv
mkPragEnv [LSig GhcRn]
uprags LHsBinds GhcRn
binds) }
tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag
tcSpecInst :: TyVar -> Sig GhcRn -> TcM TcSpecPrag
tcSpecInst TyVar
dfun_id prag :: Sig GhcRn
prag@(SpecInstSig XSpecInstSig GhcRn
_ SourceText
_ LHsSigType GhcRn
hs_ty)
= SDoc -> TcM TcSpecPrag -> TcM TcSpecPrag
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (Sig GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
spec_ctxt Sig GhcRn
prag) (TcM TcSpecPrag -> TcM TcSpecPrag)
-> TcM TcSpecPrag -> TcM TcSpecPrag
forall a b. (a -> b) -> a -> b
$
do { Type
spec_dfun_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsClsInstType UserTypeCtxt
SpecInstCtxt LHsSigType GhcRn
hs_ty
; HsWrapper
co_fn <- UserTypeCtxt -> Type -> Type -> TcM HsWrapper
tcSpecWrapper UserTypeCtxt
SpecInstCtxt (TyVar -> Type
idType TyVar
dfun_id) Type
spec_dfun_ty
; TcSpecPrag -> TcM TcSpecPrag
forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar -> HsWrapper -> InlinePragma -> TcSpecPrag
SpecPrag TyVar
dfun_id HsWrapper
co_fn InlinePragma
defaultInlinePragma) }
where
spec_ctxt :: a -> SDoc
spec_ctxt a
prag = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"In the pragma:") Int
2 (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
prag)
tcSpecInst TyVar
_ Sig GhcRn
_ = String -> TcM TcSpecPrag
forall a. String -> a
panic String
"tcSpecInst"
instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
instDeclCtxt1 LHsSigType GhcRn
hs_inst_ty
= SDoc -> SDoc
inst_decl_ctxt (GenLocated SrcSpanAnnA (HsType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LHsSigType GhcRn -> LHsKind GhcRn
forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
getLHsInstDeclHead LHsSigType GhcRn
hs_inst_ty))
instDeclCtxt2 :: Type -> SDoc
instDeclCtxt2 :: Type -> SDoc
instDeclCtxt2 Type
dfun_ty
= SDoc -> SDoc
inst_decl_ctxt (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Class -> [Type] -> Type
mkClassPred Class
cls [Type]
tys))
where
([TyVar]
_,[Type]
_,Class
cls,[Type]
tys) = Type -> ([TyVar], [Type], Class, [Type])
tcSplitDFunTy Type
dfun_ty
inst_decl_ctxt :: SDoc -> SDoc
inst_decl_ctxt :: SDoc -> SDoc
inst_decl_ctxt SDoc
doc = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"In the instance declaration for")
Int
2 (SDoc -> SDoc
quotes SDoc
doc)
badBootFamInstDeclErr :: TcRnMessage
badBootFamInstDeclErr :: TcRnMessage
badBootFamInstDeclErr
= DiagnosticMessage -> TcRnMessage
forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Illegal family instance in hs-boot file"
notFamily :: TyCon -> TcRnMessage
notFamily :: TyCon -> TcRnMessage
notFamily TyCon
tycon
= DiagnosticMessage -> TcRnMessage
forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Illegal family instance for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tycon)
, Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc
parens (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tycon SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is not an indexed type family")]
assocInClassErr :: TyCon -> TcRnMessage
assocInClassErr :: TyCon -> TcRnMessage
assocInClassErr TyCon
name
= DiagnosticMessage -> TcRnMessage
forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Associated type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
name) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"must be inside a class instance"
badFamInstDecl :: TyCon -> TcRnMessage
badFamInstDecl :: TyCon -> TcRnMessage
badFamInstDecl TyCon
tc_name
= DiagnosticMessage -> TcRnMessage
forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Illegal family instance for" SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc_name)
, Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Use TypeFamilies to allow indexed type families") ]
notOpenFamily :: TyCon -> TcRnMessage
notOpenFamily :: TyCon -> TcRnMessage
notOpenFamily TyCon
tc
= DiagnosticMessage -> TcRnMessage
forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Illegal instance for closed family" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc)