{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Tc.TyCl.Build (
buildDataCon,
buildPatSyn,
TcMethInfo, MethInfo, buildClass,
mkNewTyConRhs,
newImplicitBinder, newTyConRepName
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Iface.Env
import GHC.Core.FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom )
import GHC.Builtin.Types( isCTupleTyConName, unboxedUnitTy )
import GHC.Core.DataCon
import GHC.Core.PatSyn
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.Basic
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Id.Make
import GHC.Core.Class
import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Types.SourceText
import GHC.Tc.Utils.TcType
import GHC.Core.Multiplicity
import GHC.Types.SrcLoc( SrcSpan, noSrcSpan )
import GHC.Driver.Session
import GHC.Tc.Utils.Monad
import GHC.Types.Unique.Supply
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
mkNewTyConRhs :: forall m n. Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
mkNewTyConRhs Name
tycon_name TyCon
tycon DataCon
con
= do { Name
co_tycon_name <- forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
tycon_name OccName -> OccName
mkNewTyCoOcc
; let nt_ax :: CoAxiom Unbranched
nt_ax = Name -> TyCon -> [TyVar] -> [Role] -> Type -> CoAxiom Unbranched
mkNewTypeCoAxiom Name
co_tycon_name TyCon
tycon [TyVar]
etad_tvs [Role]
etad_roles Type
etad_rhs
; forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
text String
"mkNewTyConRhs" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr CoAxiom Unbranched
nt_ax)
; forall (m :: * -> *) a. Monad m => a -> m a
return (NewTyCon { data_con :: DataCon
data_con = DataCon
con,
nt_rhs :: Type
nt_rhs = Type
rhs_ty,
nt_etad_rhs :: ([TyVar], Type)
nt_etad_rhs = ([TyVar]
etad_tvs, Type
etad_rhs),
nt_co :: CoAxiom Unbranched
nt_co = CoAxiom Unbranched
nt_ax,
nt_lev_poly :: Bool
nt_lev_poly = Type -> Bool
isKindLevPoly Type
res_kind } ) }
where
tvs :: [TyVar]
tvs = TyCon -> [TyVar]
tyConTyVars TyCon
tycon
roles :: [Role]
roles = TyCon -> [Role]
tyConRoles TyCon
tycon
res_kind :: Type
res_kind = TyCon -> Type
tyConResKind TyCon
tycon
con_arg_ty :: Type
con_arg_ty = case DataCon -> [Scaled Type]
dataConRepArgTys DataCon
con of
[Scaled Type
arg_ty] -> forall a. Scaled a -> a
scaledThing Scaled Type
arg_ty
[Scaled Type]
tys -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkNewTyConRhs" (forall a. Outputable a => a -> SDoc
ppr DataCon
con SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [Scaled Type]
tys)
rhs_ty :: Type
rhs_ty = HasCallStack => [TyVar] -> ThetaType -> Type -> Type
substTyWith (DataCon -> [TyVar]
dataConUnivTyVars DataCon
con)
([TyVar] -> ThetaType
mkTyVarTys [TyVar]
tvs) Type
con_arg_ty
etad_tvs :: [TyVar]
etad_roles :: [Role]
etad_rhs :: Type
([TyVar]
etad_tvs, [Role]
etad_roles, Type
etad_rhs) = [TyVar] -> [Role] -> Type -> ([TyVar], [Role], Type)
eta_reduce (forall a. [a] -> [a]
reverse [TyVar]
tvs) (forall a. [a] -> [a]
reverse [Role]
roles) Type
rhs_ty
eta_reduce :: [TyVar]
-> [Role]
-> Type
-> ([TyVar], [Role], Type)
eta_reduce :: [TyVar] -> [Role] -> Type -> ([TyVar], [Role], Type)
eta_reduce (TyVar
a:[TyVar]
as) (Role
_:[Role]
rs) Type
ty | Just (Type
fun, Type
arg) <- Type -> Maybe (Type, Type)
splitAppTy_maybe Type
ty,
Just TyVar
tv <- Type -> Maybe TyVar
getTyVar_maybe Type
arg,
TyVar
tv forall a. Eq a => a -> a -> Bool
== TyVar
a,
Bool -> Bool
not (TyVar
a TyVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
fun)
= [TyVar] -> [Role] -> Type -> ([TyVar], [Role], Type)
eta_reduce [TyVar]
as [Role]
rs Type
fun
eta_reduce [TyVar]
tvs [Role]
rs Type
ty = (forall a. [a] -> [a]
reverse [TyVar]
tvs, forall a. [a] -> [a]
reverse [Role]
rs, Type
ty)
buildDataCon :: FamInstEnvs
-> Name
-> Bool
-> TyConRepName
-> [HsSrcBang]
-> Maybe [HsImplBang]
-> [FieldLabel]
-> [TyVar]
-> [TyCoVar]
-> [InvisTVBinder]
-> [EqSpec]
-> KnotTied ThetaType
-> [KnotTied (Scaled Type)]
-> KnotTied Type
-> KnotTied TyCon
-> NameEnv ConTag
-> TcRnIf m n DataCon
buildDataCon :: forall m n.
FamInstEnvs
-> Name
-> Bool
-> Name
-> [HsSrcBang]
-> Maybe [HsImplBang]
-> [FieldLabel]
-> [TyVar]
-> [TyVar]
-> [InvisTVBinder]
-> [EqSpec]
-> ThetaType
-> [Scaled Type]
-> Type
-> TyCon
-> NameEnv ConTag
-> TcRnIf m n DataCon
buildDataCon FamInstEnvs
fam_envs Name
src_name Bool
declared_infix Name
prom_info [HsSrcBang]
src_bangs Maybe [HsImplBang]
impl_bangs
[FieldLabel]
field_lbls [TyVar]
univ_tvs [TyVar]
ex_tvs [InvisTVBinder]
user_tvbs [EqSpec]
eq_spec ThetaType
ctxt [Scaled Type]
arg_tys Type
res_ty
TyCon
rep_tycon NameEnv ConTag
tag_map
= do { Name
wrap_name <- forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
src_name OccName -> OccName
mkDataConWrapperOcc
; Name
work_name <- forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
src_name OccName -> OccName
mkDataConWorkerOcc
; forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
text String
"buildDataCon 1" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Name
src_name)
; UniqSupply
us <- forall gbl lcl. TcRnIf gbl lcl UniqSupply
newUniqueSupply
; DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let stupid_ctxt :: ThetaType
stupid_ctxt = TyCon -> ThetaType -> [TyVar] -> ThetaType
mkDataConStupidTheta TyCon
rep_tycon (forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
scaledThing [Scaled Type]
arg_tys) [TyVar]
univ_tvs
tag :: ConTag
tag = forall a. NameEnv a -> Name -> a
lookupNameEnv_NF NameEnv ConTag
tag_map Name
src_name
data_con :: DataCon
data_con = Name
-> Bool
-> Name
-> [HsSrcBang]
-> [FieldLabel]
-> [TyVar]
-> [TyVar]
-> [InvisTVBinder]
-> [EqSpec]
-> ThetaType
-> [Scaled Type]
-> Type
-> RuntimeRepInfo
-> TyCon
-> ConTag
-> ThetaType
-> TyVar
-> DataConRep
-> DataCon
mkDataCon Name
src_name Bool
declared_infix Name
prom_info
[HsSrcBang]
src_bangs [FieldLabel]
field_lbls
[TyVar]
univ_tvs [TyVar]
ex_tvs [InvisTVBinder]
user_tvbs [EqSpec]
eq_spec ThetaType
ctxt
[Scaled Type]
arg_tys Type
res_ty RuntimeRepInfo
NoRRI TyCon
rep_tycon ConTag
tag
ThetaType
stupid_ctxt TyVar
dc_wrk DataConRep
dc_rep
dc_wrk :: TyVar
dc_wrk = Name -> DataCon -> TyVar
mkDataConWorkId Name
work_name DataCon
data_con
dc_rep :: DataConRep
dc_rep = forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
us (DynFlags
-> FamInstEnvs
-> Name
-> Maybe [HsImplBang]
-> DataCon
-> UniqSM DataConRep
mkDataConRep DynFlags
dflags FamInstEnvs
fam_envs Name
wrap_name
Maybe [HsImplBang]
impl_bangs DataCon
data_con)
; forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
text String
"buildDataCon 2" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Name
src_name)
; forall (m :: * -> *) a. Monad m => a -> m a
return DataCon
data_con }
mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType]
mkDataConStupidTheta :: TyCon -> ThetaType -> [TyVar] -> ThetaType
mkDataConStupidTheta TyCon
tycon ThetaType
arg_tys [TyVar]
univ_tvs
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null ThetaType
stupid_theta = []
| Bool
otherwise = forall a. (a -> Bool) -> [a] -> [a]
filter Type -> Bool
in_arg_tys ThetaType
stupid_theta
where
tc_subst :: TCvSubst
tc_subst = HasDebugCallStack => [TyVar] -> ThetaType -> TCvSubst
zipTvSubst (TyCon -> [TyVar]
tyConTyVars TyCon
tycon)
([TyVar] -> ThetaType
mkTyVarTys [TyVar]
univ_tvs)
stupid_theta :: ThetaType
stupid_theta = HasCallStack => TCvSubst -> ThetaType -> ThetaType
substTheta TCvSubst
tc_subst (TyCon -> ThetaType
tyConStupidTheta TyCon
tycon)
arg_tyvars :: VarSet
arg_tyvars = ThetaType -> VarSet
tyCoVarsOfTypes ThetaType
arg_tys
in_arg_tys :: Type -> Bool
in_arg_tys Type
pred = Type -> VarSet
tyCoVarsOfType Type
pred VarSet -> VarSet -> Bool
`intersectsVarSet` VarSet
arg_tyvars
buildPatSyn :: Name -> Bool
-> PatSynMatcher -> PatSynBuilder
-> ([InvisTVBinder], ThetaType)
-> ([InvisTVBinder], ThetaType)
-> [Type]
-> Type
-> [FieldLabel]
-> PatSyn
buildPatSyn :: Name
-> Bool
-> PatSynMatcher
-> PatSynBuilder
-> ([InvisTVBinder], ThetaType)
-> ([InvisTVBinder], ThetaType)
-> ThetaType
-> Type
-> [FieldLabel]
-> PatSyn
buildPatSyn Name
src_name Bool
declared_infix matcher :: PatSynMatcher
matcher@(Name
_, Type
matcher_ty,Bool
_) PatSynBuilder
builder
([InvisTVBinder]
univ_tvs, ThetaType
req_theta) ([InvisTVBinder]
ex_tvs, ThetaType
prov_theta) ThetaType
arg_tys
Type
pat_ty [FieldLabel]
field_labels
=
ASSERT2((and [ univ_tvs `equalLength` univ_tvs1
, ex_tvs `equalLength` ex_tvs1
, pat_ty `eqType` substTy subst (scaledThing pat_ty1)
, prov_theta `eqTypes` substTys subst prov_theta1
, req_theta `eqTypes` substTys subst req_theta1
, compareArgTys arg_tys (substTys subst (map scaledThing arg_tys1))
])
, (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1
, ppr ex_tvs <+> twiddle <+> ppr ex_tvs1
, ppr pat_ty <+> twiddle <+> ppr pat_ty1
, ppr prov_theta <+> twiddle <+> ppr prov_theta1
, ppr req_theta <+> twiddle <+> ppr req_theta1
, ppr arg_tys <+> twiddle <+> ppr arg_tys1]))
Name
-> Bool
-> ([InvisTVBinder], ThetaType)
-> ([InvisTVBinder], ThetaType)
-> ThetaType
-> Type
-> PatSynMatcher
-> PatSynBuilder
-> [FieldLabel]
-> PatSyn
mkPatSyn Name
src_name Bool
declared_infix
([InvisTVBinder]
univ_tvs, ThetaType
req_theta) ([InvisTVBinder]
ex_tvs, ThetaType
prov_theta)
ThetaType
arg_tys Type
pat_ty
PatSynMatcher
matcher PatSynBuilder
builder [FieldLabel]
field_labels
where
((TyVar
_:TyVar
_:[TyVar]
univ_tvs1), ThetaType
req_theta1, Type
tau) = Type -> ([TyVar], ThetaType, Type)
tcSplitSigmaTy forall a b. (a -> b) -> a -> b
$ Type
matcher_ty
([Scaled Type
pat_ty1, Scaled Type
cont_sigma, Scaled Type
_], Type
_) = Type -> ([Scaled Type], Type)
tcSplitFunTys Type
tau
([TyVar]
ex_tvs1, ThetaType
prov_theta1, Type
cont_tau) = Type -> ([TyVar], ThetaType, Type)
tcSplitSigmaTy (forall a. Scaled a -> a
scaledThing Scaled Type
cont_sigma)
([Scaled Type]
arg_tys1, Type
_) = (Type -> ([Scaled Type], Type)
tcSplitFunTys Type
cont_tau)
twiddle :: SDoc
twiddle = Char -> SDoc
char Char
'~'
subst :: TCvSubst
subst = HasDebugCallStack => [TyVar] -> ThetaType -> TCvSubst
zipTvSubst ([TyVar]
univ_tvs1 forall a. [a] -> [a] -> [a]
++ [TyVar]
ex_tvs1)
([TyVar] -> ThetaType
mkTyVarTys (forall tv argf. [VarBndr tv argf] -> [tv]
binderVars ([InvisTVBinder]
univ_tvs forall a. [a] -> [a] -> [a]
++ [InvisTVBinder]
ex_tvs)))
compareArgTys :: [Type] -> [Type] -> Bool
compareArgTys :: ThetaType -> ThetaType -> Bool
compareArgTys [] [Type
x] = Type
x Type -> Type -> Bool
`eqType` Type
unboxedUnitTy
compareArgTys ThetaType
arg_tys ThetaType
matcher_arg_tys = ThetaType
arg_tys ThetaType -> ThetaType -> Bool
`eqTypes` ThetaType
matcher_arg_tys
type TcMethInfo = MethInfo
type MethInfo
= ( Name
, Type
, Maybe (DefMethSpec (SrcSpan, Type)))
buildClass :: Name
-> [TyConBinder]
-> [Role]
-> [FunDep TyVar]
-> Maybe (KnotTied ThetaType, [ClassATItem], [KnotTied MethInfo], ClassMinimalDef)
-> TcRnIf m n Class
buildClass :: forall m n.
Name
-> [TyConBinder]
-> [Role]
-> [FunDep TyVar]
-> Maybe
(ThetaType, [ClassATItem], [KnotTied MethInfo], ClassMinimalDef)
-> TcRnIf m n Class
buildClass Name
tycon_name [TyConBinder]
binders [Role]
roles [FunDep TyVar]
fds Maybe
(ThetaType, [ClassATItem], [KnotTied MethInfo], ClassMinimalDef)
Nothing
= forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM forall a b. (a -> b) -> a -> b
$ \ Class
rec_clas ->
do { forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
text String
"buildClass")
; Name
tc_rep_name <- forall gbl lcl. Name -> TcRnIf gbl lcl Name
newTyConRepName Name
tycon_name
; let univ_tvs :: [TyVar]
univ_tvs = forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
binders
tycon :: TyCon
tycon = Name
-> [TyConBinder] -> [Role] -> AlgTyConRhs -> Class -> Name -> TyCon
mkClassTyCon Name
tycon_name [TyConBinder]
binders [Role]
roles
AlgTyConRhs
AbstractTyCon Class
rec_clas Name
tc_rep_name
result :: Class
result = Name -> [TyVar] -> [FunDep TyVar] -> TyCon -> Class
mkAbstractClass Name
tycon_name [TyVar]
univ_tvs [FunDep TyVar]
fds TyCon
tycon
; forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
text String
"buildClass" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TyCon
tycon)
; forall (m :: * -> *) a. Monad m => a -> m a
return Class
result }
buildClass Name
tycon_name [TyConBinder]
binders [Role]
roles [FunDep TyVar]
fds
(Just (ThetaType
sc_theta, [ClassATItem]
at_items, [KnotTied MethInfo]
sig_stuff, ClassMinimalDef
mindef))
= forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM forall a b. (a -> b) -> a -> b
$ \ Class
rec_clas ->
do { forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
text String
"buildClass")
; Name
datacon_name <- forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
tycon_name OccName -> OccName
mkClassDataConOcc
; Name
tc_rep_name <- forall gbl lcl. Name -> TcRnIf gbl lcl Name
newTyConRepName Name
tycon_name
; [ClassOpItem]
op_items <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall n m. Class -> KnotTied MethInfo -> TcRnIf n m ClassOpItem
mk_op_item Class
rec_clas) [KnotTied MethInfo]
sig_stuff
; [Name]
sc_sel_names <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
tycon_name forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConTag -> OccName -> OccName
mkSuperDictSelOcc)
(forall b a. [b] -> [a] -> [a]
takeList ThetaType
sc_theta [ConTag
fIRST_TAG..])
; let sc_sel_ids :: [TyVar]
sc_sel_ids = [ Name -> Class -> TyVar
mkDictSelId Name
sc_name Class
rec_clas
| Name
sc_name <- [Name]
sc_sel_names]
; let use_newtype :: Bool
use_newtype = forall a. [a] -> Bool
isSingleton ThetaType
arg_tys
args :: [Name]
args = [Name]
sc_sel_names forall a. [a] -> [a] -> [a]
++ [Name]
op_names
op_tys :: ThetaType
op_tys = [Type
ty | (Name
_,Type
ty,Maybe (DefMethSpec (SrcSpan, Type))
_) <- [KnotTied MethInfo]
sig_stuff]
op_names :: [Name]
op_names = [Name
op | (Name
op,Type
_,Maybe (DefMethSpec (SrcSpan, Type))
_) <- [KnotTied MethInfo]
sig_stuff]
arg_tys :: ThetaType
arg_tys = ThetaType
sc_theta forall a. [a] -> [a] -> [a]
++ ThetaType
op_tys
rec_tycon :: TyCon
rec_tycon = Class -> TyCon
classTyCon Class
rec_clas
univ_bndrs :: [InvisTVBinder]
univ_bndrs = [TyConBinder] -> [InvisTVBinder]
tyConInvisTVBinders [TyConBinder]
binders
univ_tvs :: [TyVar]
univ_tvs = forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
univ_bndrs
; Name
rep_nm <- forall gbl lcl. Name -> TcRnIf gbl lcl Name
newTyConRepName Name
datacon_name
; DataCon
dict_con <- forall m n.
FamInstEnvs
-> Name
-> Bool
-> Name
-> [HsSrcBang]
-> Maybe [HsImplBang]
-> [FieldLabel]
-> [TyVar]
-> [TyVar]
-> [InvisTVBinder]
-> [EqSpec]
-> ThetaType
-> [Scaled Type]
-> Type
-> TyCon
-> NameEnv ConTag
-> TcRnIf m n DataCon
buildDataCon (forall a. String -> a
panic String
"buildClass: FamInstEnvs")
Name
datacon_name
Bool
False
Name
rep_nm
(forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const HsSrcBang
no_bang) [Name]
args)
(forall a. a -> Maybe a
Just (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const HsImplBang
HsLazy) [Name]
args))
[]
[TyVar]
univ_tvs
[]
[InvisTVBinder]
univ_bndrs
[]
[]
(forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Scaled a
unrestricted ThetaType
arg_tys)
(TyCon -> ThetaType -> Type
mkTyConApp TyCon
rec_tycon ([TyVar] -> ThetaType
mkTyVarTys [TyVar]
univ_tvs))
TyCon
rec_tycon
(TyCon -> NameEnv ConTag
mkTyConTagMap TyCon
rec_tycon)
; AlgTyConRhs
rhs <- case () of
()
_ | Bool
use_newtype
-> forall m n. Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
mkNewTyConRhs Name
tycon_name TyCon
rec_tycon DataCon
dict_con
| Name -> Bool
isCTupleTyConName Name
tycon_name
-> forall (m :: * -> *) a. Monad m => a -> m a
return (TupleTyCon { data_con :: DataCon
data_con = DataCon
dict_con
, tup_sort :: TupleSort
tup_sort = TupleSort
ConstraintTuple })
| Bool
otherwise
-> forall (m :: * -> *) a. Monad m => a -> m a
return ([DataCon] -> AlgTyConRhs
mkDataTyConRhs [DataCon
dict_con])
; let { tycon :: TyCon
tycon = Name
-> [TyConBinder] -> [Role] -> AlgTyConRhs -> Class -> Name -> TyCon
mkClassTyCon Name
tycon_name [TyConBinder]
binders [Role]
roles
AlgTyConRhs
rhs Class
rec_clas Name
tc_rep_name
; result :: Class
result = Name
-> [TyVar]
-> [FunDep TyVar]
-> ThetaType
-> [TyVar]
-> [ClassATItem]
-> [ClassOpItem]
-> ClassMinimalDef
-> TyCon
-> Class
mkClass Name
tycon_name [TyVar]
univ_tvs [FunDep TyVar]
fds
ThetaType
sc_theta [TyVar]
sc_sel_ids [ClassATItem]
at_items
[ClassOpItem]
op_items ClassMinimalDef
mindef TyCon
tycon
}
; forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
text String
"buildClass" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TyCon
tycon)
; forall (m :: * -> *) a. Monad m => a -> m a
return Class
result }
where
no_bang :: HsSrcBang
no_bang = SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
NoSourceText SrcUnpackedness
NoSrcUnpack SrcStrictness
NoSrcStrict
mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
mk_op_item :: forall n m. Class -> KnotTied MethInfo -> TcRnIf n m ClassOpItem
mk_op_item Class
rec_clas (Name
op_name, Type
_, Maybe (DefMethSpec (SrcSpan, Type))
dm_spec)
= do { Maybe (Name, DefMethSpec Type)
dm_info <- forall n m.
Name
-> Maybe (DefMethSpec (SrcSpan, Type))
-> TcRnIf n m (Maybe (Name, DefMethSpec Type))
mk_dm_info Name
op_name Maybe (DefMethSpec (SrcSpan, Type))
dm_spec
; forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Class -> TyVar
mkDictSelId Name
op_name Class
rec_clas, Maybe (Name, DefMethSpec Type)
dm_info) }
mk_dm_info :: Name -> Maybe (DefMethSpec (SrcSpan, Type))
-> TcRnIf n m (Maybe (Name, DefMethSpec Type))
mk_dm_info :: forall n m.
Name
-> Maybe (DefMethSpec (SrcSpan, Type))
-> TcRnIf n m (Maybe (Name, DefMethSpec Type))
mk_dm_info Name
_ Maybe (DefMethSpec (SrcSpan, Type))
Nothing
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
mk_dm_info Name
op_name (Just DefMethSpec (SrcSpan, Type)
VanillaDM)
= do { Name
dm_name <- forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
op_name OccName -> OccName
mkDefaultMethodOcc
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (Name
dm_name, forall ty. DefMethSpec ty
VanillaDM)) }
mk_dm_info Name
op_name (Just (GenericDM (SrcSpan
loc, Type
dm_ty)))
= do { Name
dm_name <- forall m n.
Name -> (OccName -> OccName) -> SrcSpan -> TcRnIf m n Name
newImplicitBinderLoc Name
op_name OccName -> OccName
mkDefaultMethodOcc SrcSpan
loc
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (Name
dm_name, forall ty. ty -> DefMethSpec ty
GenericDM Type
dm_ty)) }
newImplicitBinder :: Name
-> (OccName -> OccName)
-> TcRnIf m n Name
newImplicitBinder :: forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
base_name OccName -> OccName
mk_sys_occ
= forall m n.
Name -> (OccName -> OccName) -> SrcSpan -> TcRnIf m n Name
newImplicitBinderLoc Name
base_name OccName -> OccName
mk_sys_occ (Name -> SrcSpan
nameSrcSpan Name
base_name)
newImplicitBinderLoc :: Name
-> (OccName -> OccName)
-> SrcSpan
-> TcRnIf m n Name
newImplicitBinderLoc :: forall m n.
Name -> (OccName -> OccName) -> SrcSpan -> TcRnIf m n Name
newImplicitBinderLoc Name
base_name OccName -> OccName
mk_sys_occ SrcSpan
loc
| Just Module
mod <- Name -> Maybe Module
nameModule_maybe Name
base_name
= forall a b. Module -> OccName -> SrcSpan -> TcRnIf a b Name
newGlobalBinder Module
mod OccName
occ SrcSpan
loc
| Bool
otherwise
= do { Unique
uniq <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; forall (m :: * -> *) a. Monad m => a -> m a
return (Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq OccName
occ SrcSpan
loc) }
where
occ :: OccName
occ = OccName -> OccName
mk_sys_occ (Name -> OccName
nameOccName Name
base_name)
newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName
newTyConRepName :: forall gbl lcl. Name -> TcRnIf gbl lcl Name
newTyConRepName Name
tc_name
| Just Module
mod <- Name -> Maybe Module
nameModule_maybe Name
tc_name
, (Module
mod, OccName
occ) <- Module -> OccName -> (Module, OccName)
tyConRepModOcc Module
mod (Name -> OccName
nameOccName Name
tc_name)
= forall a b. Module -> OccName -> SrcSpan -> TcRnIf a b Name
newGlobalBinder Module
mod OccName
occ SrcSpan
noSrcSpan
| Bool
otherwise
= forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
tc_name OccName -> OccName
mkTyConRepOcc