{-# LANGUAGE CPP #-}
{-# 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
#include "GhclibHsVersions.h"
import GHC.Prelude
import GHC.Hs
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.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.Error
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.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])
tcInstDecls1 :: [LInstDecl GhcRn] -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
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 GenLocated SrcSpanAnnA (InstDecl GhcRn)
-> TcRn ([InstInfo GhcRn], [FamInst], [DerivInfo])
LInstDecl GhcRn -> TcRn ([InstInfo GhcRn], [FamInst], [DerivInfo])
tcLocalInstDecl [GenLocated SrcSpanAnnA (InstDecl GhcRn)]
[LInstDecl 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 <- [InstInfo GhcRn] -> TcM TcGblEnv -> TcM TcGblEnv
forall a. [InstInfo GhcRn] -> TcM a -> TcM a
addClsInsts [InstInfo GhcRn]
local_infos (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
[FamInst] -> TcM TcGblEnv -> TcM TcGblEnv
forall a. [FamInst] -> TcM a -> TcM a
addFamInsts [FamInst]
fam_insts (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
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 ) }
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 <- TcM 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 a -> TcM a
addFamInsts :: [FamInst] -> TcM a -> TcM a
addFamInsts [FamInst]
fam_insts TcM a
thing_inside
= [FamInst] -> TcM a -> TcM a
forall a. [FamInst] -> TcM a -> TcM a
tcExtendLocalFamInstEnv [FamInst]
fam_insts (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
[TyThing] -> TcM a -> TcM a
forall r. [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnv [TyThing]
axioms (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"addFamInsts" ([FamInst] -> SDoc
pprFamInsts [FamInst]
fam_insts)
; TcGblEnv
gbl_env <- [TyCon] -> TcM TcGblEnv
addTyConsToGblEnv [TyCon]
data_rep_tycons
; TcGblEnv -> TcM a -> TcM a
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
gbl_env TcM a
thing_inside }
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
; (TCvSubst
subst, [TyVar]
skol_tvs) <- [TyVar] -> TcM (TCvSubst, [TyVar])
tcInstSkolTyVars [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` HasCallStack => 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) [GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn)]
[LDataFamInstDecl 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) [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
[LTyFamInstDecl 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 GenLocated SrcSpanAnnA (HsSigType GhcRn)
LHsSigType 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 (GenLocated SrcSpanAnnP OverlapMode)
Maybe (XRec GhcRn 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 [GenLocated SrcSpanAnnA (Sig GhcRn)]
[LSig GhcRn]
uprags
; Bool
is_boot <- TcRn Bool
tcIsHsBootOrSig
; Bool -> SDoc -> TcRn ()
failIfTc (Bool
is_boot Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
no_binds) SDoc
badBootDeclErr
; ([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) [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
[LTyFamInstDecl 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) [GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn)]
[LDataFamInstDecl 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 FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
TyFamInstEqn GhcRn
eqn
; TyCon
fam_tc <- GenLocated SrcSpanAnnN Name -> TcM TyCon
tcLookupLocatedTyCon GenLocated SrcSpanAnnN Name
LIdP GhcRn
fam_lname
; AssocInstInfo -> TyCon -> TcRn ()
tcFamInstDeclChecks AssocInstInfo
mb_clsinfo TyCon
fam_tc
; Bool -> SDoc -> TcRn ()
checkTc (TyCon -> Bool
isTypeFamilyTyCon TyCon
fam_tc) (TyCon -> SDoc
wrongKindOfFamily TyCon
fam_tc)
; Bool -> SDoc -> TcRn ()
checkTc (TyCon -> Bool
isOpenTypeFamilyTyCon TyCon
fam_tc) (TyCon -> SDoc
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 GenLocated SrcSpanAnnN Name
LIdP GhcRn
fam_lname) FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
TyFamInstEqn 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 GenLocated SrcSpanAnnN Name
LIdP GhcRn
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 -> SDoc -> TcRn ()
checkTc Bool
type_families (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ TyCon -> SDoc
badFamInstDecl TyCon
fam_tc
; Bool -> SDoc -> TcRn ()
checkTc (Bool -> Bool
not Bool
is_boot) (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ SDoc
badBootFamInstDeclErr
; Bool -> SDoc -> TcRn ()
checkTc (TyCon -> Bool
isFamilyTyCon TyCon
fam_tc) (TyCon -> SDoc
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)
(SDoc -> TcRn ()
addErr (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ TyCon -> SDoc
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 GenLocated SrcSpanAnnN Name
LIdP GhcRn
lfam_name
; AssocInstInfo -> TyCon -> TcRn ()
tcFamInstDeclChecks AssocInstInfo
mb_clsinfo TyCon
fam_tc
; Bool -> SDoc -> TcRn ()
checkTc (TyCon -> Bool
isDataFamilyTyCon TyCon
fam_tc) (TyCon -> SDoc
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
; ([TyVar]
qtvs, [Type]
pats, Type
res_kind, [Type]
stupid_theta)
<- AssocInstInfo
-> TyCon
-> HsOuterFamEqnTyVarBndrs GhcRn
-> LexicalFixity
-> Maybe (LHsContext GhcRn)
-> HsTyPats GhcRn
-> Maybe (LHsKind GhcRn)
-> NewOrData
-> TcM ([TyVar], [Type], Type, [Type])
tcDataFamInstHeader AssocInstInfo
mb_clsinfo 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
res_kind))
[TyConBinder] -> [TyConBinder] -> [TyConBinder]
forall a. [a] -> [a] -> [a]
++ [TyConBinder]
eta_tcbs
; ([TyConBinder]
extra_tcbs, Type
final_res_kind) <- [TyConBinder] -> Type -> TcM ([TyConBinder], Type)
etaExpandAlgTyCon [TyConBinder]
full_tcbs Type
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
ty_binders :: [TyConBinder]
ty_binders = [TyConBinder]
full_tcbs [TyConBinder] -> [TyConBinder] -> [TyConBinder]
forall a. [a] -> [a] -> [a]
`chkAppend` [TyConBinder]
extra_tcbs
; 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
"final_res_kind:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
final_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 [TyVar]
qtvs (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]
ty_binders Type
final_res_kind
[LConDecl GhcRn]
hs_cons
; Name
rep_tc_name <- GenLocated SrcSpanAnnN Name -> [Type] -> TcM Name
newFamInstTyConName GenLocated SrcSpanAnnN Name
LIdP GhcRn
lfam_name [Type]
pats
; Name
axiom_name <- GenLocated SrcSpanAnnN Name -> [[Type]] -> TcM Name
newFamInstAxiomName GenLocated SrcSpanAnnN Name
LIdP GhcRn
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 ([DataCon] -> AlgTyConRhs
mkDataTyConRhs [DataCon]
data_cons)
NewOrData
NewType -> ASSERT( not (null data_cons) )
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]
post_eta_qtvs)
axiom :: CoAxiom Unbranched
axiom = Role
-> Name
-> [TyVar]
-> [TyVar]
-> [TyVar]
-> TyCon
-> [Type]
-> Type
-> CoAxiom Unbranched
mkSingleCoAxiom Role
Representational Name
axiom_name
[TyVar]
post_eta_qtvs [TyVar]
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
final_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 (GenLocated SrcSpanAnnP CType)
Maybe (XRec GhcRn 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 -> TyCon -> HsOuterFamEqnTyVarBndrs GhcRn
-> LexicalFixity -> Maybe (LHsContext GhcRn)
-> HsTyPats GhcRn -> Maybe (LHsKind GhcRn)
-> NewOrData
-> TcM ([TyVar], [Type], Kind, ThetaType)
AssocInstInfo
mb_clsinfo 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
= 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 [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
HsTyPats GhcRn
hs_pats)
; (TcLevel
tclvl, WantedConstraints
wanted, ([TyVar]
scoped_tvs, ([Type]
stupid_theta, Type
lhs_ty, Type
master_res_kind, Type
instance_res_kind)))
<- String
-> TcM ([TyVar], ([Type], Type, Type, Type))
-> TcM
(TcLevel, WantedConstraints, ([TyVar], ([Type], Type, Type, Type)))
forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX String
"tcDataFamInstHeader" (TcM ([TyVar], ([Type], Type, Type, Type))
-> TcM
(TcLevel, WantedConstraints,
([TyVar], ([Type], Type, Type, Type))))
-> TcM ([TyVar], ([Type], Type, Type, Type))
-> TcM
(TcLevel, WantedConstraints, ([TyVar], ([Type], Type, Type, Type)))
forall a b. (a -> b) -> a -> b
$
HsOuterFamEqnTyVarBndrs GhcRn
-> TcM ([Type], Type, Type, Type)
-> TcM ([TyVar], ([Type], Type, Type, Type))
forall a.
HsOuterFamEqnTyVarBndrs GhcRn -> TcM a -> TcM ([TyVar], a)
bindOuterFamEqnTKBndrs HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs (TcM ([Type], Type, Type, Type)
-> TcM ([TyVar], ([Type], Type, Type, Type)))
-> TcM ([Type], Type, Type, Type)
-> TcM ([TyVar], ([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 (GenLocated SrcSpanAnnA (HsType GhcRn))
Maybe (LHsKind 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 SDoc -> Type -> Type -> TcM CoercionN
unifyKind (SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (GenLocated SrcSpanAnnA (HsType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsType GhcRn)
LHsKind 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 (GenLocated SrcSpanAnnA (HsType GhcRn))
Maybe (LHsKind 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 ]
; ([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 ) }
; CandidatesQTvs
dvs <- [Type] -> TcM CandidatesQTvs
candidateQTyVarsOfTypes (Type
lhs_ty Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [TyVar] -> [Type]
mkTyVarTys [TyVar]
scoped_tvs)
; [TyVar]
qtvs <- CandidatesQTvs -> TcM [TyVar]
quantifyTyVars CandidatesQTvs
dvs
; SkolemInfo -> [TyVar] -> TcLevel -> WantedConstraints -> TcRn ()
reportUnsolvedEqualities SkolemInfo
FamInstSkol [TyVar]
qtvs TcLevel
tclvl WantedConstraints
wanted
; ZonkEnv
ze <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
NoFlexi
; (ZonkEnv
ze, [TyVar]
qtvs) <- ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar])
zonkTyBndrsX ZonkEnv
ze [TyVar]
qtvs
; Type
lhs_ty <- ZonkEnv -> Type -> TcM Type
zonkTcTypeToTypeX ZonkEnv
ze Type
lhs_ty
; [Type]
stupid_theta <- ZonkEnv -> [Type] -> TcM [Type]
zonkTcTypesToTypesX ZonkEnv
ze [Type]
stupid_theta
; Type
master_res_kind <- ZonkEnv -> Type -> TcM Type
zonkTcTypeToTypeX ZonkEnv
ze Type
master_res_kind
; Type
instance_res_kind <- ZonkEnv -> Type -> TcM Type
zonkTcTypeToTypeX ZonkEnv
ze Type
instance_res_kind
; 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
; [Type]
pats <- case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
lhs_ty of
Just (TyCon
_, [Type]
pats) -> [Type] -> TcM [Type]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
pats
Maybe (TyCon, [Type])
Nothing -> String -> SDoc -> TcM [Type]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcDataFamInstHeader" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
lhs_ty)
; ([TyVar], [Type], Type, [Type])
-> TcM ([TyVar], [Type], Type, [Type])
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVar]
qtvs, [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 GenLocated SrcSpanAnnA (HsType GhcRn)
LHsKind GhcRn
hs_kind
; TcLevel
lvl <- TcM TcLevel
getTcLevel
; let ([TyVar]
tvs, Type
inner_kind) = Type -> ([TyVar], Type)
tcSplitForAllInvisTyVars Type
sig_kind
; (TCvSubst
subst, [TyVar]
_tvs') <- TcLevel -> Bool -> TCvSubst -> [TyVar] -> TcM (TCvSubst, [TyVar])
tcInstSkolTyVarsAt TcLevel
lvl Bool
False TCvSubst
emptyTCvSubst [TyVar]
tvs
; Type -> TcM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst 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) [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
[LTyClDecl 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 GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
LTyClDecl GhcRn -> TcM (LHsBinds 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 Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
LHsBinds 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 [TyVar]
[IdP GhcTc]
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
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
InstInfo GhcRn -> TcM (LHsBinds 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 {
; ([TyVar]
inst_tyvars, [Type]
dfun_theta, Type
inst_head) <- TyVar -> TcM ([TyVar], [Type], Type)
tcSkolDFunType 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' = HasCallStack => 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], NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)])
([LTcSpecPrag], TcPragEnv)
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 :: SkolemInfo
ic_info = SkolemInfo
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 TyVar
IdP GhcTc
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)
(XConLikeOut GhcTc -> ConLike -> HsExpr GhcTc
forall p. XConLikeOut p -> ConLike -> HsExpr p
HsConLikeOut NoExtField
XConLikeOut GhcTc
noExtField (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 EpAnnCO
XApp GhcTc
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 GhcTc
export = ABE :: forall p.
XABE p -> IdP p -> IdP p -> HsWrapper -> TcSpecPrags -> ABExport p
ABE { abe_ext :: XABE GhcTc
abe_ext = NoExtField
XABE GhcTc
noExtField
, abe_wrap :: HsWrapper
abe_wrap = HsWrapper
idHsWrapper
, abe_poly :: IdP GhcTc
abe_poly = TyVar
IdP GhcTc
dfun_id_w_prags
, abe_mono :: IdP GhcTc
abe_mono = TyVar
IdP GhcTc
self_dict
, abe_prags :: TcSpecPrags
abe_prags = TcSpecPrags
dfun_spec_prags }
main_bind :: HsBindLR GhcTc GhcTc
main_bind = AbsBinds :: forall idL idR.
XAbsBinds idL idR
-> [TyVar]
-> [TyVar]
-> [ABExport idL]
-> [TcEvBinds]
-> LHsBinds idL
-> Bool
-> HsBindLR idL idR
AbsBinds { abs_ext :: XAbsBinds GhcTc GhcTc
abs_ext = NoExtField
XAbsBinds GhcTc GhcTc
noExtField
, abs_tvs :: [TyVar]
abs_tvs = [TyVar]
inst_tyvars
, abs_ev_vars :: [TyVar]
abs_ev_vars = [TyVar]
dfun_ev_vars
, abs_exports :: [ABExport GhcTc]
abs_exports = [ABExport GhcTc
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 GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
LHsBind 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 GhcTc
export = ABE :: forall p.
XABE p -> IdP p -> IdP p -> HsWrapper -> TcSpecPrags -> ABExport p
ABE { abe_ext :: XABE GhcTc
abe_ext = NoExtField
XABE GhcTc
noExtField
, abe_wrap :: HsWrapper
abe_wrap = HsWrapper
idHsWrapper
, abe_poly :: IdP GhcTc
abe_poly = TyVar
IdP GhcTc
sc_top_id
, abe_mono :: IdP GhcTc
abe_mono = TyVar
IdP GhcTc
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 = AbsBinds :: forall idL idR.
XAbsBinds idL idR
-> [TyVar]
-> [TyVar]
-> [ABExport idL]
-> [TcEvBinds]
-> LHsBinds idL
-> Bool
-> HsBindLR idL idR
AbsBinds { abs_ext :: XAbsBinds GhcTc GhcTc
abs_ext = NoExtField
XAbsBinds GhcTc GhcTc
noExtField
, abs_tvs :: [TyVar]
abs_tvs = [TyVar]
tyvars
, abs_ev_vars :: [TyVar]
abs_ev_vars = [TyVar]
dfun_evs
, abs_exports :: [ABExport GhcTc]
abs_exports = [ABExport GhcTc
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 :: SkolemInfo
ic_info = SkolemInfo
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 [GenLocated SrcSpanAnnA (Sig GhcRn)]
[LSig GhcRn]
sigs SDoc -> SDoc -> SDoc
$$ Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
LHsBinds 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
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TyVar, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication)
ClassOpItem -> TcM (TyVar, LHsBind 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 [GenLocated SrcSpanAnnA (Sig GhcRn)]
[LSig GhcRn]
inline_prags
TyVar
sel_id GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
LHsBind 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 TyVar
IdP GhcTc
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, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
LHsBind 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 EpAnnCO
XApp GhcTc
noComments GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr 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 EpAnnCO
XLitE GhcTc
noComments (XHsStringPrim GhcTc -> ByteString -> HsLit GhcTc
forall x. XHsStringPrim x -> ByteString -> HsLit x
HsStringPrim SourceText
XHsStringPrim GhcTc
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_ (SDoc -> TcRn ()
addErrTc (SDoc -> TcRn ()) -> (Name -> SDoc) -> Name -> TcRn ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> Name -> SDoc
forall a. Outputable a => a -> Name -> SDoc
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 GhcTc
export = ABE :: forall p.
XABE p -> IdP p -> IdP p -> HsWrapper -> TcSpecPrags -> ABExport p
ABE { abe_ext :: XABE GhcTc
abe_ext = NoExtField
XABE GhcTc
noExtField
, abe_poly :: IdP GhcTc
abe_poly = TyVar
IdP GhcTc
global_meth_id
, abe_mono :: IdP GhcTc
abe_mono = TyVar
IdP GhcTc
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 = AbsBinds :: forall idL idR.
XAbsBinds idL idR
-> [TyVar]
-> [TyVar]
-> [ABExport idL]
-> [TcEvBinds]
-> LHsBinds idL
-> Bool
-> HsBindLR idL idR
AbsBinds { abs_ext :: XAbsBinds GhcTc GhcTc
abs_ext = NoExtField
XAbsBinds GhcTc GhcTc
noExtField
, abs_tvs :: [TyVar]
abs_tvs = [TyVar]
tyvars
, abs_ev_vars :: [TyVar]
abs_ev_vars = [TyVar]
dfun_ev_vars
, abs_exports :: [ABExport GhcTc]
abs_exports = [ABExport GhcTc
export]
, abs_ev_binds :: [TcEvBinds]
abs_ev_binds = [TcEvBinds
dfun_ev_binds, TcEvBinds
local_ev_binds]
, abs_binds :: LHsBinds GhcTc
abs_binds = Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
LHsBinds 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 GenLocated SrcSpanAnnA (HsSigType GhcRn)
LHsSigType 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 -> SDoc -> TcRn ()
checkTc Bool
inst_sigs (Name -> LHsSigType GhcRn -> SDoc
misplacedInstSig Name
sel_name LHsSigType GhcRn
hs_sig_ty)
; Type
sig_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsSigType (Name -> Bool -> UserTypeCtxt
FunSigCtxt Name
sel_name Bool
False) LHsSigType GhcRn
hs_sig_ty
; let local_meth_ty :: Type
local_meth_ty = TyVar -> Type
idType TyVar
local_meth_id
ctxt :: UserTypeCtxt
ctxt = Name -> Bool -> UserTypeCtxt
FunSigCtxt Name
sel_name Bool
False
; 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
$
UserTypeCtxt -> Type -> Type -> TcM HsWrapper
tcSubTypeSigma 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 -> Bool -> UserTypeCtxt
FunSigCtxt Name
sel_name Bool
True
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 GenLocated SrcSpanAnnA (HsSigType GhcRn)
LHsSigType GhcRn
hs_sig_ty }
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
tc_bind, [TyVar
inner_id]) <- TcPragEnv
-> TcIdSigInfo -> LHsBind GhcRn -> TcM (LHsBinds GhcTc, [TyVar])
tcPolyCheck NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
TcPragEnv
no_prag_fn TcIdSigInfo
inner_meth_sig LHsBind GhcRn
meth_bind
; let export :: ABExport GhcTc
export = ABE :: forall p.
XABE p -> IdP p -> IdP p -> HsWrapper -> TcSpecPrags -> ABExport p
ABE { abe_ext :: XABE GhcTc
abe_ext = NoExtField
XABE GhcTc
noExtField
, abe_poly :: IdP GhcTc
abe_poly = TyVar
IdP GhcTc
local_meth_id
, abe_mono :: IdP GhcTc
abe_mono = TyVar
IdP GhcTc
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 GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
LHsBind 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
$
AbsBinds :: forall idL idR.
XAbsBinds idL idR
-> [TyVar]
-> [TyVar]
-> [ABExport idL]
-> [TcEvBinds]
-> LHsBinds idL
-> Bool
-> HsBindLR idL idR
AbsBinds { abs_ext :: XAbsBinds GhcTc GhcTc
abs_ext = NoExtField
XAbsBinds GhcTc GhcTc
noExtField, abs_tvs :: [TyVar]
abs_tvs = [], abs_ev_vars :: [TyVar]
abs_ev_vars = []
, abs_exports :: [ABExport GhcTc]
abs_exports = [ABExport GhcTc
export]
, abs_binds :: LHsBinds GhcTc
abs_binds = Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
LHsBinds 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 -> Bool -> UserTypeCtxt
FunSigCtxt Name
sel_name Bool
False
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 NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
TcPragEnv
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 -> SDoc
misplacedInstSig :: Name -> LHsSigType GhcRn -> SDoc
misplacedInstSig Name
name LHsSigType GhcRn
hs_ty
= [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 GenLocated SrcSpanAnnA (HsSigType GhcRn)
LHsSigType 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 { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; Logger
logger <- IOEnv (Env TcGblEnv TcLclEnv) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
; 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 GenLocated SrcSpanAnnN Name
LIdP GhcRn
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' LocatedA (HsExpr GhcRn) -> Type -> LocatedA (HsExpr GhcRn)
LHsExpr GhcRn -> Type -> LHsExpr GhcRn
mk_vta (IdP GhcRn -> LHsExpr GhcRn
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar Name
IdP GhcRn
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 (NoGhcTc 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)))) ~ SrcSpan) =>
HsMatchContext (NoGhcTc (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 GenLocated SrcSpanAnnN Name
LIdP GhcRn
fn) [] LocatedA (HsExpr GhcRn)
rhs]
; IO () -> TcRn ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags 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 Type
XXType GhcRn
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
; DiagnosticReason -> Bool -> SDoc -> TcRn ()
diagnosticTc (WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnMissingMethods) Bool
warn SDoc
message
}
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 [GenLocated SrcSpanAnnA (Sig GhcRn)]
[LSig 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 :: SDoc
badBootFamInstDeclErr :: SDoc
badBootFamInstDeclErr
= String -> SDoc
text String
"Illegal family instance in hs-boot file"
notFamily :: TyCon -> SDoc
notFamily :: TyCon -> SDoc
notFamily TyCon
tycon
= [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 -> SDoc
assocInClassErr :: TyCon -> SDoc
assocInClassErr TyCon
name
= 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 -> SDoc
badFamInstDecl :: TyCon -> SDoc
badFamInstDecl TyCon
tc_name
= [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 -> SDoc
notOpenFamily :: TyCon -> SDoc
notOpenFamily TyCon
tc
= 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)