{-# 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 "HsVersions.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 (GhcPass 'Renamed)]
-> TcM (TcGblEnv, [InstInfo (GhcPass 'Renamed)], [DerivInfo])
tcInstDecls1 [LInstDecl (GhcPass 'Renamed)]
inst_decls
= do {
; [([InstInfo (GhcPass 'Renamed)], [FamInst], [DerivInfo])]
stuff <- forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndRecoverM LInstDecl (GhcPass 'Renamed)
-> TcM ([InstInfo (GhcPass 'Renamed)], [FamInst], [DerivInfo])
tcLocalInstDecl [LInstDecl (GhcPass 'Renamed)]
inst_decls
; let ([[InstInfo (GhcPass 'Renamed)]]
local_infos_s, [[FamInst]]
fam_insts_s, [[DerivInfo]]
datafam_deriv_infos) = forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [([InstInfo (GhcPass 'Renamed)], [FamInst], [DerivInfo])]
stuff
fam_insts :: [FamInst]
fam_insts = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FamInst]]
fam_insts_s
local_infos :: [InstInfo (GhcPass 'Renamed)]
local_infos = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[InstInfo (GhcPass 'Renamed)]]
local_infos_s
; TcGblEnv
gbl_env <- forall a. [InstInfo (GhcPass 'Renamed)] -> TcM a -> TcM a
addClsInsts [InstInfo (GhcPass 'Renamed)]
local_infos forall a b. (a -> b) -> a -> b
$
forall a. [FamInst] -> TcM a -> TcM a
addFamInsts [FamInst]
fam_insts forall a b. (a -> b) -> a -> b
$
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; forall (m :: * -> *) a. Monad m => a -> m a
return ( TcGblEnv
gbl_env
, [InstInfo (GhcPass 'Renamed)]
local_infos
, 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 (GhcPass 'Renamed)]
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)],
HsValBinds (GhcPass 'Renamed))
tcInstDeclsDeriv [DerivInfo]
deriv_infos [LDerivDecl (GhcPass 'Renamed)]
derivds
= do ThStage
th_stage <- TcM ThStage
getStage
if ThStage -> Bool
isBrackStage ThStage
th_stage
then do { TcGblEnv
gbl_env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
gbl_env, forall a. Bag a -> [a]
bagToList forall a. Bag a
emptyBag, forall (a :: Pass) (b :: Pass).
HsValBindsLR (GhcPass a) (GhcPass b)
emptyValBindsOut) }
else do { (TcGblEnv
tcg_env, Bag (InstInfo (GhcPass 'Renamed))
info_bag, HsValBinds (GhcPass 'Renamed)
valbinds) <- [DerivInfo]
-> [LDerivDecl (GhcPass 'Renamed)]
-> TcM
(TcGblEnv, Bag (InstInfo (GhcPass 'Renamed)),
HsValBinds (GhcPass 'Renamed))
tcDeriving [DerivInfo]
deriv_infos [LDerivDecl (GhcPass 'Renamed)]
derivds
; forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env, forall a. Bag a -> [a]
bagToList Bag (InstInfo (GhcPass 'Renamed))
info_bag, HsValBinds (GhcPass 'Renamed)
valbinds) }
addClsInsts :: [InstInfo GhcRn] -> TcM a -> TcM a
addClsInsts :: forall a. [InstInfo (GhcPass 'Renamed)] -> TcM a -> TcM a
addClsInsts [InstInfo (GhcPass 'Renamed)]
infos TcM a
thing_inside
= forall a. [ClsInst] -> TcM a -> TcM a
tcExtendLocalInstEnv (forall a b. (a -> b) -> [a] -> [b]
map forall a. InstInfo a -> ClsInst
iSpec [InstInfo (GhcPass 'Renamed)]
infos) TcM a
thing_inside
addFamInsts :: [FamInst] -> TcM a -> TcM a
addFamInsts :: forall a. [FamInst] -> TcM a -> TcM a
addFamInsts [FamInst]
fam_insts TcM a
thing_inside
= forall a. [FamInst] -> TcM a -> TcM a
tcExtendLocalFamInstEnv [FamInst]
fam_insts forall a b. (a -> b) -> a -> b
$
forall r. [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnv [TyThing]
axioms 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
; 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 = forall a b. (a -> b) -> [a] -> [b]
map (CoAxiom Branched -> TyThing
ACoAxiom forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (br :: BranchFlag). CoAxiom br -> CoAxiom Branched
toBranchedAxiom forall b c a. (b -> c) -> (a -> b) -> a -> c
. FamInst -> CoAxiom Unbranched
famInstAxiom) [FamInst]
fam_insts
data_rep_tycons :: [TyCon]
data_rep_tycons = [FamInst] -> [TyCon]
famInstsRepTyCons [FamInst]
fam_insts
tcLocalInstDecl :: LInstDecl GhcRn
-> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo])
tcLocalInstDecl :: LInstDecl (GhcPass 'Renamed)
-> TcM ([InstInfo (GhcPass 'Renamed)], [FamInst], [DerivInfo])
tcLocalInstDecl (L SrcSpanAnnA
loc (TyFamInstD { tfid_inst :: forall pass. InstDecl pass -> TyFamInstDecl pass
tfid_inst = TyFamInstDecl (GhcPass 'Renamed)
decl }))
= do { FamInst
fam_inst <- AssocInstInfo -> LTyFamInstDecl (GhcPass 'Renamed) -> TcM FamInst
tcTyFamInstDecl AssocInstInfo
NotAssociated (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc TyFamInstDecl (GhcPass 'Renamed)
decl)
; forall (m :: * -> *) a. Monad m => a -> m a
return ([], [FamInst
fam_inst], []) }
tcLocalInstDecl (L SrcSpanAnnA
loc (DataFamInstD { dfid_inst :: forall pass. InstDecl pass -> DataFamInstDecl pass
dfid_inst = DataFamInstDecl (GhcPass 'Renamed)
decl }))
= do { (FamInst
fam_inst, Maybe DerivInfo
m_deriv_info) <- AssocInstInfo
-> TyVarEnv Name
-> LDataFamInstDecl (GhcPass 'Renamed)
-> TcM (FamInst, Maybe DerivInfo)
tcDataFamInstDecl AssocInstInfo
NotAssociated forall a. VarEnv a
emptyVarEnv (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc DataFamInstDecl (GhcPass 'Renamed)
decl)
; forall (m :: * -> *) a. Monad m => a -> m a
return ([], [FamInst
fam_inst], forall a. Maybe a -> [a]
maybeToList Maybe DerivInfo
m_deriv_info) }
tcLocalInstDecl (L SrcSpanAnnA
loc (ClsInstD { cid_inst :: forall pass. InstDecl pass -> ClsInstDecl pass
cid_inst = ClsInstDecl (GhcPass 'Renamed)
decl }))
= do { ([InstInfo (GhcPass 'Renamed)]
insts, [FamInst]
fam_insts, [DerivInfo]
deriv_infos) <- LClsInstDecl (GhcPass 'Renamed)
-> TcM ([InstInfo (GhcPass 'Renamed)], [FamInst], [DerivInfo])
tcClsInstDecl (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc ClsInstDecl (GhcPass 'Renamed)
decl)
; forall (m :: * -> *) a. Monad m => a -> m a
return ([InstInfo (GhcPass 'Renamed)]
insts, [FamInst]
fam_insts, [DerivInfo]
deriv_infos) }
tcClsInstDecl :: LClsInstDecl GhcRn
-> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo])
tcClsInstDecl :: LClsInstDecl (GhcPass 'Renamed)
-> TcM ([InstInfo (GhcPass 'Renamed)], [FamInst], [DerivInfo])
tcClsInstDecl (L SrcSpanAnnA
loc (ClsInstDecl { cid_poly_ty :: forall pass. ClsInstDecl pass -> LHsSigType pass
cid_poly_ty = LHsSigType (GhcPass 'Renamed)
hs_ty, cid_binds :: forall pass. ClsInstDecl pass -> LHsBinds pass
cid_binds = LHsBinds (GhcPass 'Renamed)
binds
, cid_sigs :: forall pass. ClsInstDecl pass -> [LSig pass]
cid_sigs = [LSig (GhcPass 'Renamed)]
uprags, cid_tyfam_insts :: forall pass. ClsInstDecl pass -> [LTyFamInstDecl pass]
cid_tyfam_insts = [LTyFamInstDecl (GhcPass 'Renamed)]
ats
, cid_overlap_mode :: forall pass. ClsInstDecl pass -> Maybe (XRec pass OverlapMode)
cid_overlap_mode = Maybe (XRec (GhcPass 'Renamed) OverlapMode)
overlap_mode
, cid_datafam_insts :: forall pass. ClsInstDecl pass -> [LDataFamInstDecl pass]
cid_datafam_insts = [LDataFamInstDecl (GhcPass 'Renamed)]
adts }))
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (LHsSigType (GhcPass 'Renamed) -> SDoc
instDeclCtxt1 LHsSigType (GhcPass 'Renamed)
hs_ty) forall a b. (a -> b) -> a -> b
$
do { PredType
dfun_ty <- UserTypeCtxt -> LHsSigType (GhcPass 'Renamed) -> TcM PredType
tcHsClsInstType (Bool -> UserTypeCtxt
InstDeclCtxt Bool
False) LHsSigType (GhcPass 'Renamed)
hs_ty
; let ([Id]
tyvars, [PredType]
theta, Class
clas, [PredType]
inst_tys) = PredType -> ([Id], [PredType], Class, [PredType])
tcSplitDFunTy PredType
dfun_ty
; (TCvSubst
subst, [Id]
skol_tvs) <- [Id] -> TcM (TCvSubst, [Id])
tcInstSkolTyVars [Id]
tyvars
; let tv_skol_prs :: [(Name, Id)]
tv_skol_prs = [ (Id -> Name
tyVarName Id
tv, Id
skol_tv)
| (Id
tv, Id
skol_tv) <- [Id]
tyvars forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
skol_tvs ]
tv_skol_env :: TyVarEnv Name
tv_skol_env = forall a. [(Id, a)] -> VarEnv a
mkVarEnv forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> (b, a)
swap [(Name, Id)]
tv_skol_prs
n_inferred :: Int
n_inferred = forall a. (a -> Bool) -> [a] -> Int
countWhile ((forall a. Eq a => a -> a -> Bool
== ArgFlag
Inferred) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall tv argf. VarBndr tv argf -> argf
binderArgFlag) forall a b. (a -> b) -> a -> b
$
forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ PredType -> ([VarBndr Id ArgFlag], PredType)
splitForAllTyCoVarBinders PredType
dfun_ty
visible_skol_tvs :: [Id]
visible_skol_tvs = forall a. Int -> [a] -> [a]
drop Int
n_inferred [Id]
skol_tvs
; String -> SDoc -> TcRn ()
traceTc String
"tcLocalInstDecl 1" (forall a. Outputable a => a -> SDoc
ppr PredType
dfun_ty SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr (PredType -> Int
invisibleTyBndrCount PredType
dfun_ty) SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr [Id]
skol_tvs)
; ([(FamInst, Maybe DerivInfo)]
datafam_stuff, [FamInst]
tyfam_insts)
<- forall r. [(Name, Id)] -> TcM r -> TcM r
tcExtendNameTyVarEnv [(Name, Id)]
tv_skol_prs forall a b. (a -> b) -> a -> b
$
do { let mini_env :: VarEnv PredType
mini_env = forall a. [(Id, a)] -> VarEnv a
mkVarEnv (Class -> [Id]
classTyVars Class
clas forall a b. [a] -> [b] -> [(a, b)]
`zip` HasCallStack => TCvSubst -> [PredType] -> [PredType]
substTys TCvSubst
subst [PredType]
inst_tys)
mini_subst :: TCvSubst
mini_subst = InScopeSet -> VarEnv PredType -> TCvSubst
mkTvSubst (VarSet -> InScopeSet
mkInScopeSet ([Id] -> VarSet
mkVarSet [Id]
skol_tvs)) VarEnv PredType
mini_env
mb_info :: AssocInstInfo
mb_info = InClsInst { ai_class :: Class
ai_class = Class
clas
, ai_tyvars :: [Id]
ai_tyvars = [Id]
visible_skol_tvs
, ai_inst_env :: VarEnv PredType
ai_inst_env = VarEnv PredType
mini_env }
; [(FamInst, Maybe DerivInfo)]
df_stuff <- forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndRecoverM (AssocInstInfo
-> TyVarEnv Name
-> LDataFamInstDecl (GhcPass 'Renamed)
-> TcM (FamInst, Maybe DerivInfo)
tcDataFamInstDecl AssocInstInfo
mb_info TyVarEnv Name
tv_skol_env) [LDataFamInstDecl (GhcPass 'Renamed)]
adts
; [FamInst]
tf_insts1 <- forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndRecoverM (AssocInstInfo -> LTyFamInstDecl (GhcPass 'Renamed) -> TcM FamInst
tcTyFamInstDecl AssocInstInfo
mb_info) [LTyFamInstDecl (GhcPass 'Renamed)]
ats
; Bool
is_boot <- TcRn Bool
tcIsHsBootOrSig
; let atItems :: [ClassATItem]
atItems = Class -> [ClassATItem]
classATItems Class
clas
; [[FamInst]]
tf_insts2 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SrcSpan -> TCvSubst -> NameSet -> ClassATItem -> TcM [FamInst]
tcATDefault (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) TCvSubst
mini_subst NameSet
defined_ats)
(if Bool
is_boot then [] else [ClassATItem]
atItems)
; forall (m :: * -> *) a. Monad m => a -> m a
return ([(FamInst, Maybe DerivInfo)]
df_stuff, [FamInst]
tf_insts1 forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FamInst]]
tf_insts2) }
; Name
dfun_name <- Class -> [PredType] -> SrcSpan -> TcM Name
newDFunName Class
clas [PredType]
inst_tys (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsSigType (GhcPass 'Renamed)
hs_ty)
; ClsInst
ispec <- Maybe OverlapMode
-> Name -> [Id] -> [PredType] -> Class -> [PredType] -> TcM ClsInst
newClsInst (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall l e. GenLocated l e -> e
unLoc Maybe (XRec (GhcPass 'Renamed) OverlapMode)
overlap_mode) Name
dfun_name
[Id]
tyvars [PredType]
theta Class
clas [PredType]
inst_tys
; let inst_binds :: InstBindings (GhcPass 'Renamed)
inst_binds = InstBindings
{ ib_binds :: LHsBinds (GhcPass 'Renamed)
ib_binds = LHsBinds (GhcPass 'Renamed)
binds
, ib_tyvars :: [Name]
ib_tyvars = forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
Var.varName [Id]
tyvars
, ib_pragmas :: [LSig (GhcPass 'Renamed)]
ib_pragmas = [LSig (GhcPass 'Renamed)]
uprags
, ib_extensions :: [Extension]
ib_extensions = []
, ib_derived :: Bool
ib_derived = Bool
False }
inst_info :: InstInfo (GhcPass 'Renamed)
inst_info = InstInfo { iSpec :: ClsInst
iSpec = ClsInst
ispec, iBinds :: InstBindings (GhcPass 'Renamed)
iBinds = InstBindings (GhcPass 'Renamed)
inst_binds }
([FamInst]
datafam_insts, [Maybe DerivInfo]
m_deriv_infos) = forall a b. [(a, b)] -> ([a], [b])
unzip [(FamInst, Maybe DerivInfo)]
datafam_stuff
deriv_infos :: [DerivInfo]
deriv_infos = forall a. [Maybe a] -> [a]
catMaybes [Maybe DerivInfo]
m_deriv_infos
all_insts :: [FamInst]
all_insts = [FamInst]
tyfam_insts forall a. [a] -> [a] -> [a]
++ [FamInst]
datafam_insts
; let no_binds :: Bool
no_binds = forall (idL :: Pass) idR. LHsBindsLR (GhcPass idL) idR -> Bool
isEmptyLHsBinds LHsBinds (GhcPass 'Renamed)
binds Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LSig (GhcPass 'Renamed)]
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
; forall (m :: * -> *) a. Monad m => a -> m a
return ( [InstInfo (GhcPass 'Renamed)
inst_info], [FamInst]
all_insts, [DerivInfo]
deriv_infos ) }
where
defined_ats :: NameSet
defined_ats = [Name] -> NameSet
mkNameSet (forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyFamInstDecl (GhcPass p) -> IdP (GhcPass p)
tyFamInstDeclName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LTyFamInstDecl (GhcPass 'Renamed)]
ats)
NameSet -> NameSet -> NameSet
`unionNameSet`
[Name] -> NameSet
mkNameSet (forall a b. (a -> b) -> [a] -> [b]
map (forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. DataFamInstDecl pass -> FamEqn pass (HsDataDefn pass)
dfid_eqn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LDataFamInstDecl (GhcPass 'Renamed)]
adts)
tcTyFamInstDecl :: AssocInstInfo
-> LTyFamInstDecl GhcRn -> TcM FamInst
tcTyFamInstDecl :: AssocInstInfo -> LTyFamInstDecl (GhcPass 'Renamed) -> TcM FamInst
tcTyFamInstDecl AssocInstInfo
mb_clsinfo (L SrcSpanAnnA
loc decl :: TyFamInstDecl (GhcPass 'Renamed)
decl@(TyFamInstDecl { tfid_eqn :: forall pass. TyFamInstDecl pass -> TyFamInstEqn pass
tfid_eqn = TyFamInstEqn (GhcPass 'Renamed)
eqn }))
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
forall a. TyFamInstDecl (GhcPass 'Renamed) -> TcM a -> TcM a
tcAddTyFamInstCtxt TyFamInstDecl (GhcPass 'Renamed)
decl forall a b. (a -> b) -> a -> b
$
do { let fam_lname :: LIdP (GhcPass 'Renamed)
fam_lname = forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon TyFamInstEqn (GhcPass 'Renamed)
eqn
; TyCon
fam_tc <- GenLocated SrcSpanAnnN Name -> TcM TyCon
tcLookupLocatedTyCon LIdP (GhcPass 'Renamed)
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 (GhcPass 'Renamed)
-> TcM (KnotTied CoAxBranch)
tcTyFamInstEqn TyCon
fam_tc AssocInstInfo
mb_clsinfo
(forall l e. l -> e -> GenLocated l e
L (forall a ann. SrcSpanAnn' a -> SrcAnn ann
na2la forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> l
getLoc LIdP (GhcPass 'Renamed)
fam_lname) TyFamInstEqn (GhcPass 'Renamed)
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 -> [[PredType]] -> TcM Name
newFamInstAxiomName LIdP (GhcPass 'Renamed)
fam_lname [KnotTied CoAxBranch -> [PredType]
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" (forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc)
; Bool
type_families <- 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 forall a b. (a -> b) -> a -> b
$ TyCon -> SDoc
badFamInstDecl TyCon
fam_tc
; Bool -> SDoc -> TcRn ()
checkTc (Bool -> Bool
not Bool
is_boot) 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)
; 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 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 (GhcPass 'Renamed)
-> TcM (FamInst, Maybe DerivInfo)
tcDataFamInstDecl AssocInstInfo
mb_clsinfo TyVarEnv Name
tv_skol_env
(L SrcSpanAnnA
loc decl :: DataFamInstDecl (GhcPass 'Renamed)
decl@(DataFamInstDecl { dfid_eqn :: forall pass. DataFamInstDecl pass -> FamEqn pass (HsDataDefn pass)
dfid_eqn =
FamEqn { feqn_bndrs :: forall pass rhs. FamEqn pass rhs -> HsOuterFamEqnTyVarBndrs pass
feqn_bndrs = HsOuterFamEqnTyVarBndrs (GhcPass 'Renamed)
outer_bndrs
, feqn_pats :: forall pass rhs. FamEqn pass rhs -> HsTyPats pass
feqn_pats = HsTyPats (GhcPass 'Renamed)
hs_pats
, feqn_tycon :: forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon = lfam_name :: LIdP (GhcPass 'Renamed)
lfam_name@(L SrcSpanAnnN
_ Name
fam_name)
, feqn_fixity :: forall pass rhs. FamEqn pass rhs -> LexicalFixity
feqn_fixity = LexicalFixity
fixity
, feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs = HsDataDefn { dd_ND :: forall pass. HsDataDefn pass -> NewOrData
dd_ND = NewOrData
new_or_data
, dd_cType :: forall pass. HsDataDefn pass -> Maybe (XRec pass CType)
dd_cType = Maybe (XRec (GhcPass 'Renamed) CType)
cType
, dd_ctxt :: forall pass. HsDataDefn pass -> Maybe (LHsContext pass)
dd_ctxt = Maybe (LHsContext (GhcPass 'Renamed))
hs_ctxt
, dd_cons :: forall pass. HsDataDefn pass -> [LConDecl pass]
dd_cons = [LConDecl (GhcPass 'Renamed)]
hs_cons
, dd_kindSig :: forall pass. HsDataDefn pass -> Maybe (LHsKind pass)
dd_kindSig = Maybe (LHsKind (GhcPass 'Renamed))
m_ksig
, dd_derivs :: forall pass. HsDataDefn pass -> HsDeriving pass
dd_derivs = HsDeriving (GhcPass 'Renamed)
derivs } }}))
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
forall a. DataFamInstDecl (GhcPass 'Renamed) -> TcM a -> TcM a
tcAddDataFamInstCtxt DataFamInstDecl (GhcPass 'Renamed)
decl forall a b. (a -> b) -> a -> b
$
do { TyCon
fam_tc <- GenLocated SrcSpanAnnN Name -> TcM TyCon
tcLookupLocatedTyCon LIdP (GhcPass 'Renamed)
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 (GhcPass 'Renamed))
-> [LConDecl (GhcPass 'Renamed)]
-> TcRn Bool
dataDeclChecks Name
fam_name NewOrData
new_or_data Maybe (LHsContext (GhcPass 'Renamed))
hs_ctxt [LConDecl (GhcPass 'Renamed)]
hs_cons
; ([Id]
qtvs, [PredType]
pats, PredType
res_kind, [PredType]
stupid_theta)
<- AssocInstInfo
-> TyCon
-> HsOuterFamEqnTyVarBndrs (GhcPass 'Renamed)
-> LexicalFixity
-> Maybe (LHsContext (GhcPass 'Renamed))
-> HsTyPats (GhcPass 'Renamed)
-> Maybe (LHsKind (GhcPass 'Renamed))
-> NewOrData
-> TcM ([Id], [PredType], PredType, [PredType])
tcDataFamInstHeader AssocInstInfo
mb_clsinfo TyCon
fam_tc HsOuterFamEqnTyVarBndrs (GhcPass 'Renamed)
outer_bndrs LexicalFixity
fixity
Maybe (LHsContext (GhcPass 'Renamed))
hs_ctxt HsTyPats (GhcPass 'Renamed)
hs_pats Maybe (LHsKind (GhcPass 'Renamed))
m_ksig NewOrData
new_or_data
; let ([PredType]
eta_pats, [TyConBinder]
eta_tcbs) = TyCon -> [PredType] -> ([PredType], [TyConBinder])
eta_reduce TyCon
fam_tc [PredType]
pats
eta_tvs :: [Id]
eta_tvs = forall a b. (a -> b) -> [a] -> [b]
map forall tv argf. VarBndr tv argf -> tv
binderVar [TyConBinder]
eta_tcbs
post_eta_qtvs :: [Id]
post_eta_qtvs = forall a. (a -> Bool) -> [a] -> [a]
filterOut (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Id]
eta_tvs) [Id]
qtvs
full_tcbs :: [TyConBinder]
full_tcbs = [Id] -> VarSet -> [TyConBinder]
mkTyConBindersPreferAnon [Id]
post_eta_qtvs
(PredType -> VarSet
tyCoVarsOfType ([Id] -> PredType -> PredType
mkSpecForAllTys [Id]
eta_tvs PredType
res_kind))
forall a. [a] -> [a] -> [a]
++ [TyConBinder]
eta_tcbs
; ([TyConBinder]
extra_tcbs, PredType
final_res_kind) <- [TyConBinder] -> PredType -> TcM ([TyConBinder], PredType)
etaExpandAlgTyCon [TyConBinder]
full_tcbs PredType
res_kind
; let extra_pats :: [PredType]
extra_pats = forall a b. (a -> b) -> [a] -> [b]
map (Id -> PredType
mkTyVarTy forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall tv argf. VarBndr tv argf -> tv
binderVar) [TyConBinder]
extra_tcbs
all_pats :: [PredType]
all_pats = [PredType]
pats forall a. [a] -> [a] -> [a]
`chkAppend` [PredType]
extra_pats
orig_res_ty :: PredType
orig_res_ty = TyCon -> [PredType] -> PredType
mkTyConApp TyCon
fam_tc [PredType]
all_pats
ty_binders :: [TyConBinder]
ty_binders = [TyConBinder]
full_tcbs forall a. [a] -> [a] -> [a]
`chkAppend` [TyConBinder]
extra_tcbs
; String -> SDoc -> TcRn ()
traceTc String
"tcDataFamInstDecl" forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Fam tycon:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc
, String -> SDoc
text String
"Pats:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [PredType]
pats
, String -> SDoc
text String
"visibilities:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (TyCon -> [PredType] -> [TyConBndrVis]
tcbVisibilities TyCon
fam_tc [PredType]
pats)
, String -> SDoc
text String
"all_pats:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [PredType]
all_pats
, String -> SDoc
text String
"ty_binders" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
ty_binders
, String -> SDoc
text String
"fam_tc_binders:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (TyCon -> [TyConBinder]
tyConBinders TyCon
fam_tc)
, String -> SDoc
text String
"res_kind:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr PredType
res_kind
, String -> SDoc
text String
"final_res_kind:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr PredType
final_res_kind
, String -> SDoc
text String
"eta_pats" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [PredType]
eta_pats
, String -> SDoc
text String
"eta_tcbs" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
eta_tcbs ]
; (TyCon
rep_tc, CoAxiom Unbranched
axiom) <- forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM forall a b. (a -> b) -> a -> b
$ \ ~(TyCon
rec_rep_tc, CoAxiom Unbranched
_) ->
do { [DataCon]
data_cons <- forall r. [Id] -> TcM r -> TcM r
tcExtendTyVarEnv [Id]
qtvs forall a b. (a -> b) -> a -> b
$
NewOrData
-> DataDeclInfo
-> TyCon
-> [TyConBinder]
-> PredType
-> [LConDecl (GhcPass 'Renamed)]
-> TcM [DataCon]
tcConDecls NewOrData
new_or_data (PredType -> DataDeclInfo
DDataInstance PredType
orig_res_ty)
TyCon
rec_rep_tc [TyConBinder]
ty_binders PredType
final_res_kind
[LConDecl (GhcPass 'Renamed)]
hs_cons
; Name
rep_tc_name <- GenLocated SrcSpanAnnN Name -> [PredType] -> TcM Name
newFamInstTyConName LIdP (GhcPass 'Renamed)
lfam_name [PredType]
pats
; Name
axiom_name <- GenLocated SrcSpanAnnN Name -> [[PredType]] -> TcM Name
newFamInstAxiomName LIdP (GhcPass 'Renamed)
lfam_name [[PredType]
pats]
; AlgTyConRhs
tc_rhs <- case NewOrData
new_or_data of
NewOrData
DataType -> forall (m :: * -> *) a. Monad m => a -> m a
return ([DataCon] -> AlgTyConRhs
mkDataTyConRhs [DataCon]
data_cons)
NewOrData
NewType -> ASSERT( not (null data_cons) )
forall m n. Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
mkNewTyConRhs Name
rep_tc_name TyCon
rec_rep_tc (forall a. [a] -> a
head [DataCon]
data_cons)
; let ax_rhs :: PredType
ax_rhs = TyCon -> [PredType] -> PredType
mkTyConApp TyCon
rep_tc ([Id] -> [PredType]
mkTyVarTys [Id]
post_eta_qtvs)
axiom :: CoAxiom Unbranched
axiom = Role
-> Name
-> [Id]
-> [Id]
-> [Id]
-> TyCon
-> [PredType]
-> PredType
-> CoAxiom Unbranched
mkSingleCoAxiom Role
Representational Name
axiom_name
[Id]
post_eta_qtvs [Id]
eta_tvs [] TyCon
fam_tc [PredType]
eta_pats PredType
ax_rhs
parent :: AlgTyConFlav
parent = CoAxiom Unbranched -> TyCon -> [PredType] -> AlgTyConFlav
DataFamInstTyCon CoAxiom Unbranched
axiom TyCon
fam_tc [PredType]
all_pats
rep_tc :: TyCon
rep_tc = Name
-> [TyConBinder]
-> PredType
-> [Role]
-> Maybe CType
-> [PredType]
-> AlgTyConRhs
-> AlgTyConFlav
-> Bool
-> TyCon
mkAlgTyCon Name
rep_tc_name
[TyConBinder]
ty_binders PredType
final_res_kind
(forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const Role
Nominal) [TyConBinder]
ty_binders)
(forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall l e. GenLocated l e -> e
unLoc Maybe (XRec (GhcPass 'Renamed) CType)
cType) [PredType]
stupid_theta
AlgTyConRhs
tc_rhs AlgTyConFlav
parent
Bool
gadt_syntax
; 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, Id)]
scoped_tvs = forall a b. (a -> b) -> [a] -> [b]
map Id -> (Name, Id)
mk_deriv_info_scoped_tv_pr (TyCon -> [Id]
tyConTyVars TyCon
rep_tc)
m_deriv_info :: Maybe DerivInfo
m_deriv_info = case HsDeriving (GhcPass 'Renamed)
derivs of
[] -> forall a. Maybe a
Nothing
HsDeriving (GhcPass 'Renamed)
preds ->
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ DerivInfo { di_rep_tc :: TyCon
di_rep_tc = TyCon
rep_tc
, di_scoped_tvs :: [(Name, Id)]
di_scoped_tvs = [(Name, Id)]
scoped_tvs
, di_clauses :: HsDeriving (GhcPass 'Renamed)
di_clauses = HsDeriving (GhcPass 'Renamed)
preds
, di_ctxt :: SDoc
di_ctxt = DataFamInstDecl (GhcPass 'Renamed) -> SDoc
tcMkDataFamInstCtxt DataFamInstDecl (GhcPass 'Renamed)
decl }
; FamInst
fam_inst <- FamFlavor -> CoAxiom Unbranched -> TcM FamInst
newFamInst (TyCon -> FamFlavor
DataFamilyInst TyCon
rep_tc) CoAxiom Unbranched
axiom
; 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 -> [PredType] -> ([PredType], [TyConBinder])
eta_reduce TyCon
fam_tc [PredType]
pats
= forall {c}.
[(PredType, VarSet, c)]
-> [VarBndr Id c] -> ([PredType], [VarBndr Id c])
go (forall a. [a] -> [a]
reverse (forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [PredType]
pats [VarSet]
fvs_s [TyConBndrVis]
vis_s)) []
where
vis_s :: [TyConBndrVis]
vis_s :: [TyConBndrVis]
vis_s = TyCon -> [PredType] -> [TyConBndrVis]
tcbVisibilities TyCon
fam_tc [PredType]
pats
fvs_s :: [TyCoVarSet]
(VarSet
_, [VarSet]
fvs_s) = forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL VarSet -> PredType -> (VarSet, VarSet)
add_fvs VarSet
emptyVarSet [PredType]
pats
add_fvs :: VarSet -> PredType -> (VarSet, VarSet)
add_fvs VarSet
fvs PredType
pat = (VarSet
fvs VarSet -> VarSet -> VarSet
`unionVarSet` PredType -> VarSet
tyCoVarsOfType PredType
pat, VarSet
fvs)
go :: [(PredType, VarSet, c)]
-> [VarBndr Id c] -> ([PredType], [VarBndr Id c])
go ((PredType
pat, VarSet
fvs_to_the_left, c
tcb_vis):[(PredType, VarSet, c)]
pats) [VarBndr Id c]
etad_tvs
| Just Id
tv <- PredType -> Maybe Id
getTyVar_maybe PredType
pat
, Bool -> Bool
not (Id
tv Id -> VarSet -> Bool
`elemVarSet` VarSet
fvs_to_the_left)
= [(PredType, VarSet, c)]
-> [VarBndr Id c] -> ([PredType], [VarBndr Id c])
go [(PredType, VarSet, c)]
pats (forall var argf. var -> argf -> VarBndr var argf
Bndr Id
tv c
tcb_vis forall a. a -> [a] -> [a]
: [VarBndr Id c]
etad_tvs)
go [(PredType, VarSet, c)]
pats [VarBndr Id c]
etad_tvs = (forall a. [a] -> [a]
reverse (forall a b. (a -> b) -> [a] -> [b]
map forall a b c. (a, b, c) -> a
fstOf3 [(PredType, VarSet, c)]
pats), [VarBndr Id c]
etad_tvs)
mk_deriv_info_scoped_tv_pr :: TyVar -> (Name, TyVar)
mk_deriv_info_scoped_tv_pr :: Id -> (Name, Id)
mk_deriv_info_scoped_tv_pr Id
tv =
let n :: Name
n = forall a. VarEnv a -> a -> Id -> a
lookupWithDefaultVarEnv TyVarEnv Name
tv_skol_env (Id -> Name
tyVarName Id
tv) Id
tv
in (Name
n, Id
tv)
tcDataFamInstHeader
:: AssocInstInfo -> 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 (GhcPass 'Renamed)
outer_bndrs LexicalFixity
fixity
Maybe (LHsContext (GhcPass 'Renamed))
hs_ctxt HsTyPats (GhcPass 'Renamed)
hs_pats Maybe (LHsKind (GhcPass 'Renamed))
m_ksig NewOrData
new_or_data
= do { String -> SDoc -> TcRn ()
traceTc String
"tcDataFamInstHeader {" (forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr HsTyPats (GhcPass 'Renamed)
hs_pats)
; (TcLevel
tclvl, WantedConstraints
wanted, ([Id]
scoped_tvs, ([PredType]
stupid_theta, PredType
lhs_ty, PredType
master_res_kind, PredType
instance_res_kind)))
<- forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX String
"tcDataFamInstHeader" forall a b. (a -> b) -> a -> b
$
forall a.
HsOuterFamEqnTyVarBndrs (GhcPass 'Renamed)
-> TcM a -> TcM ([Id], a)
bindOuterFamEqnTKBndrs HsOuterFamEqnTyVarBndrs (GhcPass 'Renamed)
outer_bndrs forall a b. (a -> b) -> a -> b
$
do { [PredType]
stupid_theta <- Maybe (LHsContext (GhcPass 'Renamed)) -> TcM [PredType]
tcHsContext Maybe (LHsContext (GhcPass 'Renamed))
hs_ctxt
; (PredType
lhs_ty, PredType
lhs_kind) <- TyCon -> HsTyPats (GhcPass 'Renamed) -> TcM (PredType, PredType)
tcFamTyPats TyCon
fam_tc HsTyPats (GhcPass 'Renamed)
hs_pats
; (PredType
lhs_applied_ty, PredType
lhs_applied_kind)
<- PredType -> PredType -> TcM (PredType, PredType)
tcInstInvisibleTyBinders PredType
lhs_ty PredType
lhs_kind
; AssocInstInfo -> PredType -> TcRn ()
addConsistencyConstraints AssocInstInfo
mb_clsinfo PredType
lhs_ty
; PredType
res_kind <- Maybe (GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
-> TcM PredType
tc_kind_sig Maybe (LHsKind (GhcPass 'Renamed))
m_ksig
; let hs_lhs :: LHsKind (GhcPass 'Renamed)
hs_lhs = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
LexicalFixity
-> IdP (GhcPass p)
-> [LHsTypeArg (GhcPass p)]
-> LHsType (GhcPass p)
nlHsTyConApp LexicalFixity
fixity (forall a. NamedThing a => a -> Name
getName TyCon
fam_tc) HsTyPats (GhcPass 'Renamed)
hs_pats
; CoercionN
_ <- Maybe SDoc -> PredType -> PredType -> TcM CoercionN
unifyKind (forall a. a -> Maybe a
Just (forall a. Outputable a => a -> SDoc
ppr LHsKind (GhcPass 'Renamed)
hs_lhs)) PredType
lhs_applied_kind PredType
res_kind
; String -> SDoc -> TcRn ()
traceTc String
"tcDataFamInstHeader" forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc, forall a. Outputable a => a -> SDoc
ppr Maybe (LHsKind (GhcPass 'Renamed))
m_ksig, forall a. Outputable a => a -> SDoc
ppr PredType
lhs_applied_kind, forall a. Outputable a => a -> SDoc
ppr PredType
res_kind ]
; forall (m :: * -> *) a. Monad m => a -> m a
return ( [PredType]
stupid_theta
, PredType
lhs_applied_ty
, PredType
lhs_applied_kind
, PredType
res_kind ) }
; CandidatesQTvs
dvs <- [PredType] -> TcM CandidatesQTvs
candidateQTyVarsOfTypes (PredType
lhs_ty forall a. a -> [a] -> [a]
: [Id] -> [PredType]
mkTyVarTys [Id]
scoped_tvs)
; [Id]
qtvs <- CandidatesQTvs -> TcM [Id]
quantifyTyVars CandidatesQTvs
dvs
; SkolemInfo -> [Id] -> TcLevel -> WantedConstraints -> TcRn ()
reportUnsolvedEqualities SkolemInfo
FamInstSkol [Id]
qtvs TcLevel
tclvl WantedConstraints
wanted
; ZonkEnv
ze <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
NoFlexi
; (ZonkEnv
ze, [Id]
qtvs) <- ZonkEnv -> [Id] -> TcM (ZonkEnv, [Id])
zonkTyBndrsX ZonkEnv
ze [Id]
qtvs
; PredType
lhs_ty <- ZonkEnv -> PredType -> TcM PredType
zonkTcTypeToTypeX ZonkEnv
ze PredType
lhs_ty
; [PredType]
stupid_theta <- ZonkEnv -> [PredType] -> TcM [PredType]
zonkTcTypesToTypesX ZonkEnv
ze [PredType]
stupid_theta
; PredType
master_res_kind <- ZonkEnv -> PredType -> TcM PredType
zonkTcTypeToTypeX ZonkEnv
ze PredType
master_res_kind
; PredType
instance_res_kind <- ZonkEnv -> PredType -> TcM PredType
zonkTcTypeToTypeX ZonkEnv
ze PredType
instance_res_kind
; DataSort -> PredType -> TcRn ()
checkDataKindSig (NewOrData -> DataSort
DataInstanceSort NewOrData
new_or_data) PredType
master_res_kind
; DataSort -> PredType -> TcRn ()
checkDataKindSig (NewOrData -> DataSort
DataInstanceSort NewOrData
new_or_data) PredType
instance_res_kind
; [PredType]
pats <- case HasDebugCallStack => PredType -> Maybe (TyCon, [PredType])
splitTyConApp_maybe PredType
lhs_ty of
Just (TyCon
_, [PredType]
pats) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [PredType]
pats
Maybe (TyCon, [PredType])
Nothing -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcDataFamInstHeader" (forall a. Outputable a => a -> SDoc
ppr PredType
lhs_ty)
; forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
qtvs, [PredType]
pats, PredType
master_res_kind, [PredType]
stupid_theta) }
where
fam_name :: Name
fam_name = TyCon -> Name
tyConName TyCon
fam_tc
data_ctxt :: UserTypeCtxt
data_ctxt = Name -> UserTypeCtxt
DataKindCtxt Name
fam_name
tc_kind_sig :: Maybe (GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
-> TcM PredType
tc_kind_sig Maybe (GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
Nothing
= do { Bool
unlifted_newtypes <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.UnliftedNewtypes
; Bool
unlifted_datatypes <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.UnliftedDatatypes
; case NewOrData
new_or_data of
NewOrData
NewType | Bool
unlifted_newtypes -> TcM PredType
newOpenTypeKind
NewOrData
DataType | Bool
unlifted_datatypes -> TcM PredType
newOpenTypeKind
NewOrData
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure PredType
liftedTypeKind
}
tc_kind_sig (Just GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
hs_kind)
= do { PredType
sig_kind <- UserTypeCtxt -> LHsKind (GhcPass 'Renamed) -> TcM PredType
tcLHsKindSig UserTypeCtxt
data_ctxt GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
hs_kind
; TcLevel
lvl <- TcM TcLevel
getTcLevel
; let ([Id]
tvs, PredType
inner_kind) = PredType -> ([Id], PredType)
tcSplitForAllInvisTyVars PredType
sig_kind
; (TCvSubst
subst, [Id]
_tvs') <- TcLevel -> Bool -> TCvSubst -> [Id] -> TcM (TCvSubst, [Id])
tcInstSkolTyVarsAt TcLevel
lvl Bool
False TCvSubst
emptyTCvSubst [Id]
tvs
; forall (m :: * -> *) a. Monad m => a -> m a
return (HasCallStack => TCvSubst -> PredType -> PredType
substTy TCvSubst
subst PredType
inner_kind) }
tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn]
-> TcM (LHsBinds GhcTc)
tcInstDecls2 :: [LTyClDecl (GhcPass 'Renamed)]
-> [InstInfo (GhcPass 'Renamed)] -> TcM (LHsBinds GhcTc)
tcInstDecls2 [LTyClDecl (GhcPass 'Renamed)]
tycl_decls [InstInfo (GhcPass 'Renamed)]
inst_decls
= do {
let class_decls :: [GenLocated SrcSpanAnnA (TyClDecl (GhcPass 'Renamed))]
class_decls = forall a. (a -> Bool) -> [a] -> [a]
filter (forall pass. TyClDecl pass -> Bool
isClassDecl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LTyClDecl (GhcPass 'Renamed)]
tycl_decls
; [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
dm_binds_s <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LTyClDecl (GhcPass 'Renamed) -> TcM (LHsBinds GhcTc)
tcClassDecl2 [GenLocated SrcSpanAnnA (TyClDecl (GhcPass 'Renamed))]
class_decls
; let dm_binds :: Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
dm_binds = forall a. [Bag a] -> Bag a
unionManyBags [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
dm_binds_s
; let dm_ids :: [IdP GhcTc]
dm_ids = forall p idR.
CollectPass p =>
CollectFlag p -> LHsBindsLR p idR -> [IdP p]
collectHsBindsBinders forall p. CollectFlag p
CollNoDictBinders Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
dm_binds
; [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
inst_binds_s <- forall r. [Id] -> TcM r -> TcM r
tcExtendGlobalValEnv [IdP GhcTc]
dm_ids forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM InstInfo (GhcPass 'Renamed) -> TcM (LHsBinds GhcTc)
tcInstDecl2 [InstInfo (GhcPass 'Renamed)]
inst_decls
; forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
dm_binds forall a. Bag a -> Bag a -> Bag a
`unionBags` forall a. [Bag a] -> Bag a
unionManyBags [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
inst_binds_s) }
tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc)
tcInstDecl2 :: InstInfo (GhcPass 'Renamed) -> TcM (LHsBinds GhcTc)
tcInstDecl2 (InstInfo { iSpec :: forall a. InstInfo a -> ClsInst
iSpec = ClsInst
ispec, iBinds :: forall a. InstInfo a -> InstBindings a
iBinds = InstBindings (GhcPass 'Renamed)
ibinds })
= forall r. TcRn r -> TcRn r -> TcRn r
recoverM (forall (m :: * -> *) a. Monad m => a -> m a
return forall (idL :: Pass) idR. LHsBindsLR (GhcPass idL) idR
emptyLHsBinds) forall a b. (a -> b) -> a -> b
$
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc forall a b. (a -> b) -> a -> b
$
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (PredType -> SDoc
instDeclCtxt2 (Id -> PredType
idType Id
dfun_id)) forall a b. (a -> b) -> a -> b
$
do {
; ([Id]
inst_tyvars, [PredType]
dfun_theta, PredType
inst_head) <- Id -> TcM ([Id], [PredType], PredType)
tcSkolDFunType Id
dfun_id
; [Id]
dfun_ev_vars <- [PredType] -> TcM [Id]
newEvVars [PredType]
dfun_theta
; let (Class
clas, [PredType]
inst_tys) = PredType -> (Class, [PredType])
tcSplitDFunHead PredType
inst_head
([Id]
class_tyvars, [PredType]
sc_theta, [Id]
_, [ClassOpItem]
op_items) = Class -> ([Id], [PredType], [Id], [ClassOpItem])
classBigSig Class
clas
sc_theta' :: [PredType]
sc_theta' = HasCallStack => TCvSubst -> [PredType] -> [PredType]
substTheta (HasDebugCallStack => [Id] -> [PredType] -> TCvSubst
zipTvSubst [Id]
class_tyvars [PredType]
inst_tys) [PredType]
sc_theta
; String -> SDoc -> TcRn ()
traceTc String
"tcInstDecl2" ([SDoc] -> SDoc
vcat [forall a. Outputable a => a -> SDoc
ppr [Id]
inst_tyvars, forall a. Outputable a => a -> SDoc
ppr [PredType]
inst_tys, forall a. Outputable a => a -> SDoc
ppr [PredType]
dfun_theta, forall a. Outputable a => a -> SDoc
ppr [PredType]
sc_theta'])
; spec_inst_info :: ([LTcSpecPrag],
NameEnv [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
spec_inst_info@([LTcSpecPrag]
spec_inst_prags,NameEnv [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
_) <- Id
-> InstBindings (GhcPass 'Renamed)
-> TcM ([LTcSpecPrag], TcPragEnv)
tcSpecInstPrags Id
dfun_id InstBindings (GhcPass 'Renamed)
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, ([Id]
sc_meth_ids, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
sc_meth_binds, Bag Implication
sc_meth_implics))
<- forall a. TcM a -> TcM (TcLevel, a)
pushTcLevelM forall a b. (a -> b) -> a -> b
$
do { ([Id]
sc_ids, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
sc_binds, Bag Implication
sc_implics)
<- Id
-> Class
-> [Id]
-> [Id]
-> [PredType]
-> TcEvBinds
-> [PredType]
-> TcM ([Id], LHsBinds GhcTc, Bag Implication)
tcSuperClasses Id
dfun_id Class
clas [Id]
inst_tyvars [Id]
dfun_ev_vars
[PredType]
inst_tys TcEvBinds
dfun_ev_binds
[PredType]
sc_theta'
; ([Id]
meth_ids, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
meth_binds, Bag Implication
meth_implics)
<- Id
-> Class
-> [Id]
-> [Id]
-> [PredType]
-> TcEvBinds
-> ([LTcSpecPrag], TcPragEnv)
-> [ClassOpItem]
-> InstBindings (GhcPass 'Renamed)
-> TcM ([Id], LHsBinds GhcTc, Bag Implication)
tcMethods Id
dfun_id Class
clas [Id]
inst_tyvars [Id]
dfun_ev_vars
[PredType]
inst_tys TcEvBinds
dfun_ev_binds ([LTcSpecPrag],
NameEnv [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
spec_inst_info
[ClassOpItem]
op_items InstBindings (GhcPass 'Renamed)
ibinds
; forall (m :: * -> *) a. Monad m => a -> m a
return ( [Id]
sc_ids forall a. [a] -> [a] -> [a]
++ [Id]
meth_ids
, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
sc_binds forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
meth_binds
, Bag Implication
sc_implics forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag Implication
meth_implics ) }
; Implication
imp <- TcM Implication
newImplication
; Implication -> TcRn ()
emitImplication forall a b. (a -> b) -> a -> b
$
Implication
imp { ic_tclvl :: TcLevel
ic_tclvl = TcLevel
tclvl
, ic_skols :: [Id]
ic_skols = [Id]
inst_tyvars
, ic_given :: [Id]
ic_given = [Id]
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 }
; Id
self_dict <- Class -> [PredType] -> TcM Id
newDict Class
clas [PredType]
inst_tys
; let class_tc :: TyCon
class_tc = Class -> TyCon
classTyCon Class
clas
loc' :: SrcSpanAnnA
loc' = forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc
[DataCon
dict_constr] = TyCon -> [DataCon]
tyConDataCons TyCon
class_tc
dict_bind :: LHsBind GhcTc
dict_bind = forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind Id
self_dict (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 ([PredType] -> HsWrapper
mkWpTyApps [PredType]
inst_tys)
(forall p. XConLikeOut p -> ConLike -> HsExpr p
HsConLikeOut NoExtField
noExtField (DataCon -> ConLike
RealDataCon DataCon
dict_constr))
con_app_args :: HsExpr GhcTc
con_app_args = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' HsExpr GhcTc -> Id -> HsExpr GhcTc
app_to_meth HsExpr GhcTc
con_app_tys [Id]
sc_meth_ids
app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc
app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc
app_to_meth HsExpr GhcTc
fun Id
meth_id = forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp EpAnnCO
noComments (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc' HsExpr GhcTc
fun)
(forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc' (HsWrapper -> Id -> HsExpr GhcTc
wrapId HsWrapper
arg_wrapper Id
meth_id))
inst_tv_tys :: [PredType]
inst_tv_tys = [Id] -> [PredType]
mkTyVarTys [Id]
inst_tyvars
arg_wrapper :: HsWrapper
arg_wrapper = [Id] -> HsWrapper
mkWpEvVarApps [Id]
dfun_ev_vars HsWrapper -> HsWrapper -> HsWrapper
<.> [PredType] -> HsWrapper
mkWpTyApps [PredType]
inst_tv_tys
is_newtype :: Bool
is_newtype = TyCon -> Bool
isNewTyCon TyCon
class_tc
dfun_id_w_prags :: Id
dfun_id_w_prags = Id -> [Id] -> Id
addDFunPrags Id
dfun_id [Id]
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 { abe_ext :: XABE GhcTc
abe_ext = NoExtField
noExtField
, abe_wrap :: HsWrapper
abe_wrap = HsWrapper
idHsWrapper
, abe_poly :: IdP GhcTc
abe_poly = Id
dfun_id_w_prags
, abe_mono :: IdP GhcTc
abe_mono = Id
self_dict
, abe_prags :: TcSpecPrags
abe_prags = TcSpecPrags
dfun_spec_prags }
main_bind :: HsBindLR GhcTc GhcTc
main_bind = AbsBinds { abs_ext :: XAbsBinds GhcTc GhcTc
abs_ext = NoExtField
noExtField
, abs_tvs :: [Id]
abs_tvs = [Id]
inst_tyvars
, abs_ev_vars :: [Id]
abs_ev_vars = [Id]
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 = forall a. a -> Bag a
unitBag LHsBind GhcTc
dict_bind
, abs_sig :: Bool
abs_sig = Bool
True }
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Bag a
unitBag (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc' HsBindLR GhcTc GhcTc
main_bind)
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
sc_meth_binds)
}
where
dfun_id :: Id
dfun_id = ClsInst -> Id
instanceDFunId ClsInst
ispec
loc :: SrcSpan
loc = forall a. NamedThing a => a -> SrcSpan
getSrcSpan Id
dfun_id
addDFunPrags :: DFunId -> [Id] -> DFunId
addDFunPrags :: Id -> [Id] -> Id
addDFunPrags Id
dfun_id [Id]
sc_meth_ids
| Bool
is_newtype
= Id
dfun_id Id -> Unfolding -> Id
`setIdUnfolding` Int -> SimpleOpts -> CoreExpr -> Unfolding
mkInlineUnfoldingWithArity Int
0 SimpleOpts
defaultSimpleOpts CoreExpr
con_app
Id -> InlinePragma -> Id
`setInlinePragma` InlinePragma
alwaysInlinePragma { inl_sat :: Maybe Int
inl_sat = forall a. a -> Maybe a
Just Int
0 }
| Bool
otherwise
= Id
dfun_id Id -> Unfolding -> Id
`setIdUnfolding` [Id] -> DataCon -> [CoreExpr] -> Unfolding
mkDFunUnfolding [Id]
dfun_bndrs DataCon
dict_con [CoreExpr]
dict_args
Id -> InlinePragma -> Id
`setInlinePragma` InlinePragma
dfunInlinePragma
where
con_app :: CoreExpr
con_app = forall b. [b] -> Expr b -> Expr b
mkLams [Id]
dfun_bndrs forall a b. (a -> b) -> a -> b
$
forall b. Expr b -> [Expr b] -> Expr b
mkApps (forall b. Id -> Expr b
Var (DataCon -> Id
dataConWrapId DataCon
dict_con)) [CoreExpr]
dict_args
dict_args :: [CoreExpr]
dict_args = forall a b. (a -> b) -> [a] -> [b]
map forall b. PredType -> Expr b
Type [PredType]
inst_tys forall a. [a] -> [a] -> [a]
++
[forall b. Expr b -> [Id] -> Expr b
mkVarApps (forall b. Id -> Expr b
Var Id
id) [Id]
dfun_bndrs | Id
id <- [Id]
sc_meth_ids]
([Id]
dfun_tvs, [PredType]
dfun_theta, Class
clas, [PredType]
inst_tys) = PredType -> ([Id], [PredType], Class, [PredType])
tcSplitDFunTy (Id -> PredType
idType Id
dfun_id)
ev_ids :: [Id]
ev_ids = Int -> [PredType] -> [Id]
mkTemplateLocalsNum Int
1 [PredType]
dfun_theta
dfun_bndrs :: [Id]
dfun_bndrs = [Id]
dfun_tvs forall a. [a] -> [a] -> [a]
++ [Id]
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 -> Id -> HsExpr GhcTc
wrapId HsWrapper
wrapper Id
id = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrapper (forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField (forall a an. a -> LocatedAn an a
noLocA Id
id))
tcSuperClasses :: DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType]
-> TcEvBinds
-> TcThetaType
-> TcM ([EvVar], LHsBinds GhcTc, Bag Implication)
tcSuperClasses :: Id
-> Class
-> [Id]
-> [Id]
-> [PredType]
-> TcEvBinds
-> [PredType]
-> TcM ([Id], LHsBinds GhcTc, Bag Implication)
tcSuperClasses Id
dfun_id Class
cls [Id]
tyvars [Id]
dfun_evs [PredType]
inst_tys TcEvBinds
dfun_ev_binds [PredType]
sc_theta
= do { ([Id]
ids, [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
binds, [Implication]
implics) <- forall (m :: * -> *) a b c d.
Monad m =>
(a -> m (b, c, d)) -> [a] -> m ([b], [c], [d])
mapAndUnzip3M (PredType, Int)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Id, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Implication)
tc_super (forall a b. [a] -> [b] -> [(a, b)]
zip [PredType]
sc_theta [Int
fIRST_TAG..])
; forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
ids, forall a. [a] -> Bag a
listToBag [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
binds, forall a. [a] -> Bag a
listToBag [Implication]
implics) }
where
loc :: SrcSpan
loc = forall a. NamedThing a => a -> SrcSpan
getSrcSpan Id
dfun_id
size :: TypeSize
size = [PredType] -> TypeSize
sizeTypes [PredType]
inst_tys
tc_super :: (PredType, Int)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Id, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Implication)
tc_super (PredType
sc_pred, Int
n)
= do { (Implication
sc_implic, EvBindsVar
ev_binds_var, EvTerm
sc_ev_tm)
<- forall result. TcM result -> TcM (Implication, EvBindsVar, result)
checkInstConstraints forall a b. (a -> b) -> a -> b
$ CtOrigin -> PredType -> TcM EvTerm
emitWanted (TypeSize -> CtOrigin
ScOrigin TypeSize
size) PredType
sc_pred
; Name
sc_top_name <- OccName -> TcM Name
newName (Int -> OccName -> OccName
mkSuperDictAuxOcc Int
n (forall a. NamedThing a => a -> OccName
getOccName Class
cls))
; Id
sc_ev_id <- forall gbl lcl. PredType -> TcRnIf gbl lcl Id
newEvVar PredType
sc_pred
; EvBindsVar -> EvBind -> TcRn ()
addTcEvBind EvBindsVar
ev_binds_var forall a b. (a -> b) -> a -> b
$ Id -> EvTerm -> EvBind
mkWantedEvBind Id
sc_ev_id EvTerm
sc_ev_tm
; let sc_top_ty :: PredType
sc_top_ty = [Id] -> PredType -> PredType
mkInfForAllTys [Id]
tyvars forall a b. (a -> b) -> a -> b
$
[PredType] -> PredType -> PredType
mkPhiTy (forall a b. (a -> b) -> [a] -> [b]
map Id -> PredType
idType [Id]
dfun_evs) PredType
sc_pred
sc_top_id :: Id
sc_top_id = HasDebugCallStack => Name -> PredType -> PredType -> Id
mkLocalId Name
sc_top_name PredType
Many PredType
sc_top_ty
export :: ABExport GhcTc
export = ABE { abe_ext :: XABE GhcTc
abe_ext = NoExtField
noExtField
, abe_wrap :: HsWrapper
abe_wrap = HsWrapper
idHsWrapper
, abe_poly :: IdP GhcTc
abe_poly = Id
sc_top_id
, abe_mono :: IdP GhcTc
abe_mono = Id
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 { abs_ext :: XAbsBinds GhcTc GhcTc
abs_ext = NoExtField
noExtField
, abs_tvs :: [Id]
abs_tvs = [Id]
tyvars
, abs_ev_vars :: [Id]
abs_ev_vars = [Id]
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 = forall a. Bag a
emptyBag
, abs_sig :: Bool
abs_sig = Bool
False }
; forall (m :: * -> *) a. Monad m => a -> m a
return (Id
sc_top_id, forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) HsBindLR GhcTc GhcTc
bind, Implication
sc_implic) }
checkInstConstraints :: TcM result
-> TcM (Implication, EvBindsVar, result)
checkInstConstraints :: forall result. TcM result -> TcM (Implication, EvBindsVar, result)
checkInstConstraints TcM result
thing_inside
= do { (TcLevel
tclvl, WantedConstraints
wanted, result
result) <- forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints 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 }
; 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 :: Id
-> Class
-> [Id]
-> [Id]
-> [PredType]
-> TcEvBinds
-> ([LTcSpecPrag], TcPragEnv)
-> [ClassOpItem]
-> InstBindings (GhcPass 'Renamed)
-> TcM ([Id], LHsBinds GhcTc, Bag Implication)
tcMethods Id
dfun_id Class
clas [Id]
tyvars [Id]
dfun_ev_vars [PredType]
inst_tys
TcEvBinds
dfun_ev_binds ([LTcSpecPrag]
spec_inst_prags, TcPragEnv
prag_fn) [ClassOpItem]
op_items
(InstBindings { ib_binds :: forall a. InstBindings a -> LHsBinds a
ib_binds = LHsBinds (GhcPass 'Renamed)
binds
, ib_tyvars :: forall a. InstBindings a -> [Name]
ib_tyvars = [Name]
lexical_tvs
, ib_pragmas :: forall a. InstBindings a -> [LSig a]
ib_pragmas = [LSig (GhcPass 'Renamed)]
sigs
, ib_extensions :: forall a. InstBindings a -> [Extension]
ib_extensions = [Extension]
exts
, ib_derived :: forall a. InstBindings a -> Bool
ib_derived = Bool
is_derived })
= forall r. [(Name, Id)] -> TcM r -> TcM r
tcExtendNameTyVarEnv ([Name]
lexical_tvs forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
tyvars) forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcInstMeth" (forall a. Outputable a => a -> SDoc
ppr [LSig (GhcPass 'Renamed)]
sigs SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr LHsBinds (GhcPass 'Renamed)
binds)
; TcRn ()
checkMinimalDefinition
; TcRn ()
checkMethBindMembership
; ([Id]
ids, [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
binds, [Maybe Implication]
mb_implics) <- forall a. [Extension] -> TcM a -> TcM a
set_exts [Extension]
exts forall a b. (a -> b) -> a -> b
$
forall a. TcM a -> TcM a
unset_warnings_deriving forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a b c d.
Monad m =>
(a -> m (b, c, d)) -> [a] -> m ([b], [c], [d])
mapAndUnzip3M ClassOpItem -> TcM (Id, LHsBind GhcTc, Maybe Implication)
tc_item [ClassOpItem]
op_items
; forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
ids, forall a. [a] -> Bag a
listToBag [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
binds, forall a. [a] -> Bag a
listToBag (forall a. [Maybe a] -> [a]
catMaybes [Maybe Implication]
mb_implics)) }
where
set_exts :: [LangExt.Extension] -> TcM a -> TcM a
set_exts :: forall a. [Extension] -> TcM a -> TcM a
set_exts [Extension]
es TcM a
thing = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM TcM a
thing [Extension]
es
unset_warnings_deriving :: TcM a -> TcM a
unset_warnings_deriving :: forall a. TcM a -> TcM a
unset_warnings_deriving
| Bool
is_derived = forall gbl lcl a.
WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetWOptM WarningFlag
Opt_WarnInaccessibleCode
| Bool
otherwise = forall a. a -> a
id
hs_sig_fn :: HsSigFun
hs_sig_fn = [LSig (GhcPass 'Renamed)] -> HsSigFun
mkHsSigFun [LSig (GhcPass 'Renamed)]
sigs
inst_loc :: SrcSpan
inst_loc = forall a. NamedThing a => a -> SrcSpan
getSrcSpan Id
dfun_id
tc_item :: ClassOpItem -> TcM (Id, LHsBind GhcTc, Maybe Implication)
tc_item :: ClassOpItem -> TcM (Id, LHsBind GhcTc, Maybe Implication)
tc_item (Id
sel_id, DefMethInfo
dm_info)
| Just (LHsBind (GhcPass 'Renamed)
user_bind, SrcSpan
bndr_loc, [LSig (GhcPass 'Renamed)]
prags) <- Name
-> LHsBinds (GhcPass 'Renamed)
-> TcPragEnv
-> Maybe
(LHsBind (GhcPass 'Renamed), SrcSpan, [LSig (GhcPass 'Renamed)])
findMethodBind (Id -> Name
idName Id
sel_id) LHsBinds (GhcPass 'Renamed)
binds TcPragEnv
prag_fn
= Class
-> [Id]
-> [Id]
-> [PredType]
-> TcEvBinds
-> Bool
-> HsSigFun
-> [LTcSpecPrag]
-> [LSig (GhcPass 'Renamed)]
-> Id
-> LHsBind (GhcPass 'Renamed)
-> SrcSpan
-> TcM (Id, LHsBind GhcTc, Maybe Implication)
tcMethodBody Class
clas [Id]
tyvars [Id]
dfun_ev_vars [PredType]
inst_tys
TcEvBinds
dfun_ev_binds Bool
is_derived HsSigFun
hs_sig_fn
[LTcSpecPrag]
spec_inst_prags [LSig (GhcPass 'Renamed)]
prags
Id
sel_id LHsBind (GhcPass 'Renamed)
user_bind SrcSpan
bndr_loc
| Bool
otherwise
= do { String -> SDoc -> TcRn ()
traceTc String
"tc_def" (forall a. Outputable a => a -> SDoc
ppr Id
sel_id)
; Id -> DefMethInfo -> TcM (Id, LHsBind GhcTc, Maybe Implication)
tc_default Id
sel_id DefMethInfo
dm_info }
tc_default :: Id -> DefMethInfo
-> TcM (TcId, LHsBind GhcTc, Maybe Implication)
tc_default :: Id -> DefMethInfo -> TcM (Id, LHsBind GhcTc, Maybe Implication)
tc_default Id
sel_id (Just (Name
dm_name, DefMethSpec PredType
_))
= do { (GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
meth_bind, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
inline_prags) <- Id
-> Class
-> Id
-> Name
-> TcM (LHsBind (GhcPass 'Renamed), [LSig (GhcPass 'Renamed)])
mkDefMethBind Id
dfun_id Class
clas Id
sel_id Name
dm_name
; Class
-> [Id]
-> [Id]
-> [PredType]
-> TcEvBinds
-> Bool
-> HsSigFun
-> [LTcSpecPrag]
-> [LSig (GhcPass 'Renamed)]
-> Id
-> LHsBind (GhcPass 'Renamed)
-> SrcSpan
-> TcM (Id, LHsBind GhcTc, Maybe Implication)
tcMethodBody Class
clas [Id]
tyvars [Id]
dfun_ev_vars [PredType]
inst_tys
TcEvBinds
dfun_ev_binds Bool
is_derived HsSigFun
hs_sig_fn
[LTcSpecPrag]
spec_inst_prags [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
inline_prags
Id
sel_id GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
meth_bind SrcSpan
inst_loc }
tc_default Id
sel_id DefMethInfo
Nothing
= do { String -> SDoc -> TcRn ()
traceTc String
"tc_def: warn" (forall a. Outputable a => a -> SDoc
ppr Id
sel_id)
; (Id
meth_id, Id
_) <- Class -> [Id] -> [Id] -> [PredType] -> Id -> TcM (Id, Id)
mkMethIds Class
clas [Id]
tyvars [Id]
dfun_ev_vars
[PredType]
inst_tys Id
sel_id
; DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let meth_bind :: LHsBind GhcTc
meth_bind = forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind Id
meth_id 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)
; forall (m :: * -> *) a. Monad m => a -> m a
return (Id
meth_id, LHsBind GhcTc
meth_bind, forall a. Maybe a
Nothing) }
where
inst_loc' :: SrcSpanAnnA
inst_loc' = forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
inst_loc
error_rhs :: DynFlags -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
error_rhs DynFlags
dflags = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
inst_loc'
forall a b. (a -> b) -> a -> b
$ forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp EpAnnCO
noComments GenLocated SrcSpanAnnA (HsExpr GhcTc)
error_fun (DynFlags -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
error_msg DynFlags
dflags)
error_fun :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
error_fun = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
inst_loc' forall a b. (a -> b) -> a -> b
$
HsWrapper -> Id -> HsExpr GhcTc
wrapId ([PredType] -> HsWrapper
mkWpTyApps
[ HasDebugCallStack => PredType -> PredType
getRuntimeRep PredType
meth_tau, PredType
meth_tau])
Id
nO_METHOD_BINDING_ERROR_ID
error_msg :: DynFlags -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
error_msg DynFlags
dflags = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
inst_loc'
(forall p. XLitE p -> HsLit p -> HsExpr p
HsLit EpAnnCO
noComments (forall x. XHsStringPrim x -> ByteString -> HsLit x
HsStringPrim SourceText
NoSourceText
(String -> ByteString
unsafeMkByteString (DynFlags -> String
error_string DynFlags
dflags))))
meth_tau :: PredType
meth_tau = Id -> [PredType] -> PredType
classMethodInstTy Id
sel_id [PredType]
inst_tys
error_string :: DynFlags -> String
error_string DynFlags
dflags = DynFlags -> SDoc -> String
showSDoc DynFlags
dflags
([SDoc] -> SDoc
hcat [forall a. Outputable a => a -> SDoc
ppr SrcSpan
inst_loc, SDoc
vbar, forall a. Outputable a => a -> SDoc
ppr Id
sel_id ])
lam_wrapper :: HsWrapper
lam_wrapper = [Id] -> HsWrapper
mkWpTyLams [Id]
tyvars HsWrapper -> HsWrapper -> HsWrapper
<.> [Id] -> HsWrapper
mkWpLams [Id]
dfun_ev_vars
checkMinimalDefinition :: TcRn ()
checkMinimalDefinition
= forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust (forall a.
Eq a =>
(a -> Bool) -> BooleanFormula a -> Maybe (BooleanFormula a)
isUnsatisfied Name -> Bool
methodExists (Class -> ClassMinimalDef
classMinimalDef Class
clas)) forall a b. (a -> b) -> a -> b
$
ClassMinimalDef -> TcRn ()
warnUnsatisfiedMinimalDefinition
methodExists :: Name -> Bool
methodExists Name
meth = forall a. Maybe a -> Bool
isJust (Name
-> LHsBinds (GhcPass 'Renamed)
-> TcPragEnv
-> Maybe
(LHsBind (GhcPass 'Renamed), SrcSpan, [LSig (GhcPass 'Renamed)])
findMethodBind Name
meth LHsBinds (GhcPass 'Renamed)
binds TcPragEnv
prag_fn)
checkMethBindMembership :: TcRn ()
checkMethBindMembership
= forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SDoc -> TcRn ()
addErrTc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> Name -> SDoc
badMethodErr Class
clas) [Name]
mismatched_meths
where
bind_nms :: [Name]
bind_nms = forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ forall idL idR. UnXRec idL => LHsBindsLR idL idR -> [LIdP idL]
collectMethodBinders LHsBinds (GhcPass 'Renamed)
binds
cls_meth_nms :: [Name]
cls_meth_nms = forall a b. (a -> b) -> [a] -> [b]
map (Id -> Name
idName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [ClassOpItem]
op_items
mismatched_meths :: [Name]
mismatched_meths = [Name]
bind_nms 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
-> [Id]
-> [Id]
-> [PredType]
-> TcEvBinds
-> Bool
-> HsSigFun
-> [LTcSpecPrag]
-> [LSig (GhcPass 'Renamed)]
-> Id
-> LHsBind (GhcPass 'Renamed)
-> SrcSpan
-> TcM (Id, LHsBind GhcTc, Maybe Implication)
tcMethodBody Class
clas [Id]
tyvars [Id]
dfun_ev_vars [PredType]
inst_tys
TcEvBinds
dfun_ev_binds Bool
is_derived
HsSigFun
sig_fn [LTcSpecPrag]
spec_inst_prags [LSig (GhcPass 'Renamed)]
prags
Id
sel_id (L SrcSpanAnnA
bind_loc HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
meth_bind) SrcSpan
bndr_loc
= TcM
(Id, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication)
-> TcM
(Id, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication)
add_meth_ctxt forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcMethodBody" (forall a. Outputable a => a -> SDoc
ppr Id
sel_id SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (Id -> PredType
idType Id
sel_id) SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr SrcSpan
bndr_loc)
; (Id
global_meth_id, Id
local_meth_id) <- forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
bndr_loc forall a b. (a -> b) -> a -> b
$
Class -> [Id] -> [Id] -> [PredType] -> Id -> TcM (Id, Id)
mkMethIds Class
clas [Id]
tyvars [Id]
dfun_ev_vars
[PredType]
inst_tys Id
sel_id
; let lm_bind :: HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
lm_bind = HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
meth_bind { fun_id :: LIdP (GhcPass 'Renamed)
fun_id = forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
bndr_loc)
(Id -> Name
idName Id
local_meth_id) }
; (Implication
meth_implic, EvBindsVar
ev_binds_var, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
tc_bind)
<- forall result. TcM result -> TcM (Implication, EvBindsVar, result)
checkInstConstraints forall a b. (a -> b) -> a -> b
$
HsSigFun
-> Id -> Id -> LHsBind (GhcPass 'Renamed) -> TcM (LHsBinds GhcTc)
tcMethodBodyHelp HsSigFun
sig_fn Id
sel_id Id
local_meth_id (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
bind_loc HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
lm_bind)
; Id
global_meth_id <- Id -> [LSig (GhcPass 'Renamed)] -> TcM Id
addInlinePrags Id
global_meth_id [LSig (GhcPass 'Renamed)]
prags
; [LTcSpecPrag]
spec_prags <- Id -> [LSig (GhcPass 'Renamed)] -> TcM [LTcSpecPrag]
tcSpecPrags Id
global_meth_id [LSig (GhcPass 'Renamed)]
prags
; let specs :: TcSpecPrags
specs = Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags
mk_meth_spec_prags Id
global_meth_id [LTcSpecPrag]
spec_inst_prags [LTcSpecPrag]
spec_prags
export :: ABExport GhcTc
export = ABE { abe_ext :: XABE GhcTc
abe_ext = NoExtField
noExtField
, abe_poly :: IdP GhcTc
abe_poly = Id
global_meth_id
, abe_mono :: IdP GhcTc
abe_mono = Id
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 { abs_ext :: XAbsBinds GhcTc GhcTc
abs_ext = NoExtField
noExtField
, abs_tvs :: [Id]
abs_tvs = [Id]
tyvars
, abs_ev_vars :: [Id]
abs_ev_vars = [Id]
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))
tc_bind
, abs_sig :: Bool
abs_sig = Bool
True }
; forall (m :: * -> *) a. Monad m => a -> m a
return (Id
global_meth_id, forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
bind_loc HsBindLR GhcTc GhcTc
full_bind, forall a. a -> Maybe a
Just Implication
meth_implic) }
where
add_meth_ctxt :: TcM
(Id, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication)
-> TcM
(Id, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication)
add_meth_ctxt TcM
(Id, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication)
thing
| Bool
is_derived = forall a. SDoc -> TcM a -> TcM a
addLandmarkErrCtxt (Id -> Class -> [PredType] -> SDoc
derivBindCtxt Id
sel_id Class
clas [PredType]
inst_tys) TcM
(Id, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication)
thing
| Bool
otherwise = TcM
(Id, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication)
thing
tcMethodBodyHelp :: HsSigFun -> Id -> TcId
-> LHsBind GhcRn -> TcM (LHsBinds GhcTc)
tcMethodBodyHelp :: HsSigFun
-> Id -> Id -> LHsBind (GhcPass 'Renamed) -> TcM (LHsBinds GhcTc)
tcMethodBodyHelp HsSigFun
hs_sig_fn Id
sel_id Id
local_meth_id LHsBind (GhcPass 'Renamed)
meth_bind
| Just LHsSigType (GhcPass 'Renamed)
hs_sig_ty <- HsSigFun
hs_sig_fn Name
sel_name
= do { (PredType
sig_ty, HsWrapper
hs_wrap)
<- forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsSigType (GhcPass 'Renamed)
hs_sig_ty) forall a b. (a -> b) -> a -> b
$
do { Bool
inst_sigs <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.InstanceSigs
; Bool -> SDoc -> TcRn ()
checkTc Bool
inst_sigs (Name -> LHsSigType (GhcPass 'Renamed) -> SDoc
misplacedInstSig Name
sel_name LHsSigType (GhcPass 'Renamed)
hs_sig_ty)
; PredType
sig_ty <- UserTypeCtxt -> LHsSigType (GhcPass 'Renamed) -> TcM PredType
tcHsSigType (Name -> Bool -> UserTypeCtxt
FunSigCtxt Name
sel_name Bool
False) LHsSigType (GhcPass 'Renamed)
hs_sig_ty
; let local_meth_ty :: PredType
local_meth_ty = Id -> PredType
idType Id
local_meth_id
ctxt :: UserTypeCtxt
ctxt = Name -> Bool -> UserTypeCtxt
FunSigCtxt Name
sel_name Bool
False
; let orig :: CtOrigin
orig = Name -> PredType -> PredType -> CtOrigin
InstanceSigOrigin Name
sel_name PredType
sig_ty PredType
local_meth_ty
; HsWrapper
hs_wrap <- forall a. (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
addErrCtxtM (Name -> PredType -> PredType -> TidyEnv -> TcM (TidyEnv, SDoc)
methSigCtxt Name
sel_name PredType
sig_ty PredType
local_meth_ty) forall a b. (a -> b) -> a -> b
$
CtOrigin -> UserTypeCtxt -> PredType -> PredType -> TcM HsWrapper
tcSubTypeSigma CtOrigin
orig UserTypeCtxt
ctxt PredType
sig_ty PredType
local_meth_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (PredType
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 :: Id
inner_meth_id = HasDebugCallStack => Name -> PredType -> PredType -> Id
mkLocalId Name
inner_meth_name PredType
Many PredType
sig_ty
inner_meth_sig :: TcIdSigInfo
inner_meth_sig = CompleteSig { sig_bndr :: Id
sig_bndr = Id
inner_meth_id
, sig_ctxt :: UserTypeCtxt
sig_ctxt = UserTypeCtxt
ctxt
, sig_loc :: SrcSpan
sig_loc = forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsSigType (GhcPass 'Renamed)
hs_sig_ty }
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
tc_bind, [Id
inner_id]) <- TcPragEnv
-> TcIdSigInfo
-> LHsBind (GhcPass 'Renamed)
-> TcM (LHsBinds GhcTc, [Id])
tcPolyCheck NameEnv [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
no_prag_fn TcIdSigInfo
inner_meth_sig LHsBind (GhcPass 'Renamed)
meth_bind
; let export :: ABExport GhcTc
export = ABE { abe_ext :: XABE GhcTc
abe_ext = NoExtField
noExtField
, abe_poly :: IdP GhcTc
abe_poly = Id
local_meth_id
, abe_mono :: IdP GhcTc
abe_mono = Id
inner_id
, abe_wrap :: HsWrapper
abe_wrap = HsWrapper
hs_wrap
, abe_prags :: TcSpecPrags
abe_prags = TcSpecPrags
noSpecPrags }
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Bag a
unitBag forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L (forall l e. GenLocated l e -> l
getLoc LHsBind (GhcPass 'Renamed)
meth_bind) forall a b. (a -> b) -> a -> b
$
AbsBinds { abs_ext :: XAbsBinds GhcTc GhcTc
abs_ext = NoExtField
noExtField, abs_tvs :: [Id]
abs_tvs = [], abs_ev_vars :: [Id]
abs_ev_vars = []
, abs_exports :: [ABExport GhcTc]
abs_exports = [ABExport GhcTc
export]
, abs_binds :: LHsBinds GhcTc
abs_binds = Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
tc_bind, abs_ev_binds :: [TcEvBinds]
abs_ev_binds = []
, abs_sig :: Bool
abs_sig = Bool
True }) }
| Bool
otherwise
= do { let ctxt :: UserTypeCtxt
ctxt = Name -> Bool -> UserTypeCtxt
FunSigCtxt Name
sel_name Bool
False
tc_sig :: TcIdSigInfo
tc_sig = UserTypeCtxt -> Id -> TcIdSigInfo
completeSigFromId UserTypeCtxt
ctxt Id
local_meth_id
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
tc_bind, [Id]
_) <- TcPragEnv
-> TcIdSigInfo
-> LHsBind (GhcPass 'Renamed)
-> TcM (LHsBinds GhcTc, [Id])
tcPolyCheck NameEnv [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
no_prag_fn TcIdSigInfo
tc_sig LHsBind (GhcPass 'Renamed)
meth_bind
; forall (m :: * -> *) a. Monad m => a -> m a
return Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
tc_bind }
where
sel_name :: Name
sel_name = Id -> Name
idName Id
sel_id
no_prag_fn :: TcPragEnv
no_prag_fn = TcPragEnv
emptyPragEnv
mkMethIds :: Class -> [TcTyVar] -> [EvVar]
-> [TcType] -> Id -> TcM (TcId, TcId)
mkMethIds :: Class -> [Id] -> [Id] -> [PredType] -> Id -> TcM (Id, Id)
mkMethIds Class
clas [Id]
tyvars [Id]
dfun_ev_vars [PredType]
inst_tys Id
sel_id
= do { 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 :: Id
poly_meth_id = HasDebugCallStack => Name -> PredType -> PredType -> Id
mkLocalId Name
poly_meth_name PredType
Many PredType
poly_meth_ty
local_meth_id :: Id
local_meth_id = HasDebugCallStack => Name -> PredType -> PredType -> Id
mkLocalId Name
local_meth_name PredType
Many PredType
local_meth_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (Id
poly_meth_id, Id
local_meth_id) }
where
sel_name :: Name
sel_name = Id -> Name
idName Id
sel_id
sel_occ :: OccName
sel_occ = Name -> OccName
nameOccName Name
sel_name
local_meth_ty :: PredType
local_meth_ty = Class -> Id -> [PredType] -> PredType
instantiateMethod Class
clas Id
sel_id [PredType]
inst_tys
poly_meth_ty :: PredType
poly_meth_ty = [Id] -> [PredType] -> PredType -> PredType
mkSpecSigmaTy [Id]
tyvars [PredType]
theta PredType
local_meth_ty
theta :: [PredType]
theta = forall a b. (a -> b) -> [a] -> [b]
map Id -> PredType
idType [Id]
dfun_ev_vars
methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
methSigCtxt :: Name -> PredType -> PredType -> TidyEnv -> TcM (TidyEnv, SDoc)
methSigCtxt Name
sel_name PredType
sig_ty PredType
meth_ty TidyEnv
env0
= do { (TidyEnv
env1, PredType
sig_ty) <- TidyEnv -> PredType -> TcM (TidyEnv, PredType)
zonkTidyTcType TidyEnv
env0 PredType
sig_ty
; (TidyEnv
env2, PredType
meth_ty) <- TidyEnv -> PredType -> TcM (TidyEnv, PredType)
zonkTidyTcType TidyEnv
env1 PredType
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 (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
<+> forall a. Outputable a => a -> SDoc
ppr PredType
sig_ty
, String -> SDoc
text String
" Class sig:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr PredType
meth_ty ])
; forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
env2, SDoc
msg) }
misplacedInstSig :: Name -> LHsSigType GhcRn -> SDoc
misplacedInstSig :: Name -> LHsSigType (GhcPass 'Renamed) -> SDoc
misplacedInstSig Name
name LHsSigType (GhcPass 'Renamed)
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 (forall a. NamedThing a => a -> SDoc
pprPrefixName Name
name)
Int
2 (SDoc
dcolon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr LHsSigType (GhcPass 'Renamed)
hs_ty))
, String -> SDoc
text String
"(Use InstanceSigs to allow this)" ]
mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags
mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags
mk_meth_spec_prags Id
meth_id [LTcSpecPrag]
spec_inst_prags [LTcSpecPrag]
spec_prags_for_me
= [LTcSpecPrag] -> TcSpecPrags
SpecPrags ([LTcSpecPrag]
spec_prags_for_me forall a. [a] -> [a] -> [a]
++ [LTcSpecPrag]
spec_prags_from_inst)
where
spec_prags_from_inst :: [LTcSpecPrag]
spec_prags_from_inst
| InlinePragma -> Bool
isInlinePragma (Id -> InlinePragma
idInlinePragma Id
meth_id)
= []
| Bool
otherwise
= [ forall l e. l -> e -> GenLocated l e
L SrcSpan
inst_loc (Id -> HsWrapper -> InlinePragma -> TcSpecPrag
SpecPrag Id
meth_id HsWrapper
wrap InlinePragma
inl)
| L SrcSpan
inst_loc (SpecPrag Id
_ HsWrapper
wrap InlinePragma
inl) <- [LTcSpecPrag]
spec_inst_prags]
mkDefMethBind :: DFunId -> Class -> Id -> Name
-> TcM (LHsBind GhcRn, [LSig GhcRn])
mkDefMethBind :: Id
-> Class
-> Id
-> Name
-> TcM (LHsBind (GhcPass 'Renamed), [LSig (GhcPass 'Renamed)])
mkDefMethBind Id
dfun_id Class
clas Id
sel_id Name
dm_name
= do { DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
; Id
dm_id <- Name -> TcM Id
tcLookupId Name
dm_name
; let inline_prag :: InlinePragma
inline_prag = Id -> InlinePragma
idInlinePragma Id
dm_id
inline_prags :: [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
inline_prags | InlinePragma -> Bool
isAnyInlinePragma InlinePragma
inline_prag
= [forall a an. a -> LocatedAn an a
noLocA (forall pass.
XInlineSig pass -> LIdP pass -> InlinePragma -> Sig pass
InlineSig forall a. EpAnn a
noAnn GenLocated SrcSpanAnnN Name
fn InlinePragma
inline_prag)]
| Bool
otherwise
= []
fn :: GenLocated SrcSpanAnnN Name
fn = forall a an. a -> LocatedAn an a
noLocA (Id -> Name
idName Id
sel_id)
visible_inst_tys :: [PredType]
visible_inst_tys = [ PredType
ty | (TyConBinder
tcb, PredType
ty) <- TyCon -> [TyConBinder]
tyConBinders (Class -> TyCon
classTyCon Class
clas) forall a b. [a] -> [b] -> [(a, b)]
`zip` [PredType]
inst_tys
, TyConBinder -> ArgFlag
tyConBinderArgFlag TyConBinder
tcb forall a. Eq a => a -> a -> Bool
/= ArgFlag
Inferred ]
rhs :: LocatedA (HsExpr (GhcPass 'Renamed))
rhs = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' LHsExpr (GhcPass 'Renamed)
-> PredType -> LHsExpr (GhcPass 'Renamed)
mk_vta (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar Name
dm_name) [PredType]
visible_inst_tys
bind :: GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
bind = forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ Origin
-> GenLocated SrcSpanAnnN Name
-> [LMatch (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))]
-> HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
mkTopFunBind Origin
Generated GenLocated SrcSpanAnnN Name
fn forall a b. (a -> b) -> a -> b
$
[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 (forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs GenLocated SrcSpanAnnN Name
fn) [] LocatedA (HsExpr (GhcPass 'Renamed))
rhs]
; 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 [forall a. Outputable a => a -> SDoc
ppr Class
clas SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [PredType]
inst_tys,
Int -> SDoc -> SDoc
nest Int
2 (forall a. Outputable a => a -> SDoc
ppr Id
sel_id SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr LocatedA (HsExpr (GhcPass 'Renamed))
rhs)]))
; forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
bind, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
inline_prags) }
where
([Id]
_, [PredType]
_, Class
_, [PredType]
inst_tys) = PredType -> ([Id], [PredType], Class, [PredType])
tcSplitDFunTy (Id -> PredType
idType Id
dfun_id)
mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn
mk_vta :: LHsExpr (GhcPass 'Renamed)
-> PredType -> LHsExpr (GhcPass 'Renamed)
mk_vta LHsExpr (GhcPass 'Renamed)
fun PredType
ty = forall a an. a -> LocatedAn an a
noLocA (forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType NoExtField
noExtField LHsExpr (GhcPass 'Renamed)
fun (forall thing. thing -> HsWildCardBndrs (GhcPass 'Renamed) thing
mkEmptyWildCardBndrs forall a b. (a -> b) -> a -> b
$ forall (p :: Pass). LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsParTy
forall a b. (a -> b) -> a -> b
$ forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall pass. XXType pass -> HsType pass
XHsType PredType
ty))
derivBindCtxt :: Id -> Class -> [Type ] -> SDoc
derivBindCtxt :: Id -> Class -> [PredType] -> SDoc
derivBindCtxt Id
sel_id Class
clas [PredType]
tys
= [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"When typechecking the code for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Id
sel_id)
, Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
text String
"in a derived instance for"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Class -> [PredType] -> SDoc
pprClassPred Class
clas [PredType]
tys) SDoc -> SDoc -> SDoc
<> SDoc
colon)
, Int -> SDoc -> SDoc
nest Int
2 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 :: ClassMinimalDef -> TcRn ()
warnUnsatisfiedMinimalDefinition ClassMinimalDef
mindef
= do { Bool
warn <- forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnMissingMethods
; WarnReason -> Bool -> SDoc -> TcRn ()
warnTc (WarningFlag -> WarnReason
Reason 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 forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => BooleanFormula a -> SDoc
pprBooleanFormulaNice ClassMinimalDef
mindef
]
tcSpecInstPrags :: DFunId -> InstBindings GhcRn
-> TcM ([LTcSpecPrag], TcPragEnv)
tcSpecInstPrags :: Id
-> InstBindings (GhcPass 'Renamed)
-> TcM ([LTcSpecPrag], TcPragEnv)
tcSpecInstPrags Id
dfun_id (InstBindings { ib_binds :: forall a. InstBindings a -> LHsBinds a
ib_binds = LHsBinds (GhcPass 'Renamed)
binds, ib_pragmas :: forall a. InstBindings a -> [LSig a]
ib_pragmas = [LSig (GhcPass 'Renamed)]
uprags })
= do { [LTcSpecPrag]
spec_inst_prags <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b an. (a -> TcM b) -> LocatedAn an a -> TcM (Located b)
wrapLocAM (Id -> Sig (GhcPass 'Renamed) -> TcM TcSpecPrag
tcSpecInst Id
dfun_id)) forall a b. (a -> b) -> a -> b
$
forall a. (a -> Bool) -> [a] -> [a]
filter forall p. UnXRec p => LSig p -> Bool
isSpecInstLSig [LSig (GhcPass 'Renamed)]
uprags
; forall (m :: * -> *) a. Monad m => a -> m a
return ([LTcSpecPrag]
spec_inst_prags, [LSig (GhcPass 'Renamed)]
-> LHsBinds (GhcPass 'Renamed) -> TcPragEnv
mkPragEnv [LSig (GhcPass 'Renamed)]
uprags LHsBinds (GhcPass 'Renamed)
binds) }
tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag
tcSpecInst :: Id -> Sig (GhcPass 'Renamed) -> TcM TcSpecPrag
tcSpecInst Id
dfun_id prag :: Sig (GhcPass 'Renamed)
prag@(SpecInstSig XSpecInstSig (GhcPass 'Renamed)
_ SourceText
_ LHsSigType (GhcPass 'Renamed)
hs_ty)
= forall a. SDoc -> TcM a -> TcM a
addErrCtxt (forall a. Outputable a => a -> SDoc
spec_ctxt Sig (GhcPass 'Renamed)
prag) forall a b. (a -> b) -> a -> b
$
do { PredType
spec_dfun_ty <- UserTypeCtxt -> LHsSigType (GhcPass 'Renamed) -> TcM PredType
tcHsClsInstType UserTypeCtxt
SpecInstCtxt LHsSigType (GhcPass 'Renamed)
hs_ty
; HsWrapper
co_fn <- UserTypeCtxt -> PredType -> PredType -> TcM HsWrapper
tcSpecWrapper UserTypeCtxt
SpecInstCtxt (Id -> PredType
idType Id
dfun_id) PredType
spec_dfun_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> HsWrapper -> InlinePragma -> TcSpecPrag
SpecPrag Id
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 (forall a. Outputable a => a -> SDoc
ppr a
prag)
tcSpecInst Id
_ Sig (GhcPass 'Renamed)
_ = forall a. String -> a
panic String
"tcSpecInst"
instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
instDeclCtxt1 :: LHsSigType (GhcPass 'Renamed) -> SDoc
instDeclCtxt1 LHsSigType (GhcPass 'Renamed)
hs_inst_ty
= SDoc -> SDoc
inst_decl_ctxt (forall a. Outputable a => a -> SDoc
ppr (forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
getLHsInstDeclHead LHsSigType (GhcPass 'Renamed)
hs_inst_ty))
instDeclCtxt2 :: Type -> SDoc
instDeclCtxt2 :: PredType -> SDoc
instDeclCtxt2 PredType
dfun_ty
= SDoc -> SDoc
inst_decl_ctxt (forall a. Outputable a => a -> SDoc
ppr (Class -> [PredType] -> PredType
mkClassPred Class
cls [PredType]
tys))
where
([Id]
_,[PredType]
_,Class
cls,[PredType]
tys) = PredType -> ([Id], [PredType], Class, [PredType])
tcSplitDFunTy PredType
dfun_ty
inst_decl_ctxt :: SDoc -> SDoc
inst_decl_ctxt :: SDoc -> SDoc
inst_decl_ctxt SDoc
doc = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
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 (forall a. Outputable a => a -> SDoc
ppr TyCon
tycon)
, Int -> SDoc -> SDoc
nest Int
2 forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc
parens (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 (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 (forall a. Outputable a => a -> SDoc
ppr TyCon
tc_name)
, Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc
parens 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 (forall a. Outputable a => a -> SDoc
ppr TyCon
tc)