{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Tc.TyCl.Build (
buildDataCon,
buildPatSyn,
TcMethInfo, MethInfo, buildClass,
mkNewTyConRhs,
newImplicitBinder, newTyConRepName
) where
import GHC.Prelude
import GHC.Iface.Env
import GHC.Builtin.Types
import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.Monad
import GHC.Core.DataCon
import GHC.Core.PatSyn
import GHC.Core.Class
import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Core.Multiplicity
import GHC.Core.FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom )
import GHC.Types.SrcLoc( SrcSpan, noSrcSpan )
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.Types.SourceText
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 { co_tycon_name <- Name -> (OccName -> OccName) -> TcRnIf m n Name
forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
tycon_name OccName -> OccName
mkNewTyCoOcc
; let 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
; traceIf (text "mkNewTyConRhs" <+> ppr nt_ax)
; return (NewTyCon { data_con = con,
nt_rhs = rhs_ty,
nt_etad_rhs = (etad_tvs, etad_rhs),
nt_co = nt_ax,
nt_fixed_rep = isFixedRuntimeRepKind 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
rhs_ty :: Type
rhs_ty
| [Scaled Type
_ Type
arg_ty] <- DataCon -> [Scaled Type]
dataConRepArgTys DataCon
con
, [TyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([TyVar] -> Bool) -> [TyVar] -> Bool
forall a b. (a -> b) -> a -> b
$ DataCon -> [TyVar]
dataConExTyCoVars DataCon
con
= [TyVar] -> ThetaType -> Type -> Type
HasDebugCallStack => [TyVar] -> ThetaType -> Type -> Type
substTyWith (DataCon -> [TyVar]
dataConUnivTyVars DataCon
con)
([TyVar] -> ThetaType
mkTyVarTys [TyVar]
tvs) Type
arg_ty
| Bool
otherwise
= Type
unitTy
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 ([TyVar] -> [TyVar]
forall a. [a] -> [a]
reverse [TyVar]
tvs) ([Role] -> [Role]
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 TyVar -> TyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TyVar
a
, Bool -> Bool
not (TyVar
a TyVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
fun)
, HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
fun HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` HasDebugCallStack => Type -> Type
Type -> Type
typeKind (TyCon -> ThetaType -> Type
mkTyConApp TyCon
tycon ([TyVar] -> ThetaType
mkTyVarTys ([TyVar] -> ThetaType) -> [TyVar] -> ThetaType
forall a b. (a -> b) -> a -> b
$ [TyVar] -> [TyVar]
forall a. [a] -> [a]
reverse [TyVar]
as))
= [TyVar] -> [Role] -> Type -> ([TyVar], [Role], Type)
eta_reduce [TyVar]
as [Role]
rs Type
fun
eta_reduce [TyVar]
as [Role]
rs Type
ty = ([TyVar] -> [TyVar]
forall a. [a] -> [a]
reverse [TyVar]
as, [Role] -> [Role]
forall a. [a] -> [a]
reverse [Role]
rs, Type
ty)
buildDataCon :: FamInstEnvs
-> DataConBangOpts
-> Name
-> Bool
-> TyConRepName
-> [HsSrcBang]
-> [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
-> DataConBangOpts
-> Name
-> Bool
-> Name
-> [HsSrcBang]
-> [FieldLabel]
-> [TyVar]
-> [TyVar]
-> [InvisTVBinder]
-> [EqSpec]
-> ThetaType
-> [Scaled Type]
-> Type
-> TyCon
-> NameEnv ConTag
-> TcRnIf m n DataCon
buildDataCon FamInstEnvs
fam_envs DataConBangOpts
dc_bang_opts 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
TyCon
rep_tycon NameEnv ConTag
tag_map
= do { wrap_name <- Name -> (OccName -> OccName) -> TcRnIf m n Name
forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
src_name OccName -> OccName
mkDataConWrapperOcc
; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
; traceIf (text "buildDataCon 1" <+> ppr src_name)
; us <- newUniqueSupply
; let stupid_ctxt = TyCon -> ThetaType -> [TyVar] -> ThetaType
mkDataConStupidTheta TyCon
rep_tycon ((Scaled Type -> Type) -> [Scaled Type] -> ThetaType
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled Type]
arg_tys) [TyVar]
univ_tvs
tag = NameEnv ConTag -> Name -> ConTag
forall a. NameEnv a -> Name -> a
lookupNameEnv_NF NameEnv ConTag
tag_map Name
src_name
data_con = Name
-> Bool
-> Name
-> [HsSrcBang]
-> [HsImplBang]
-> [StrictnessMark]
-> [FieldLabel]
-> [TyVar]
-> [TyVar]
-> ConcreteTyVars
-> [InvisTVBinder]
-> [EqSpec]
-> ThetaType
-> [Scaled Type]
-> Type
-> PromDataConInfo
-> TyCon
-> ConTag
-> ThetaType
-> TyVar
-> DataConRep
-> DataCon
mkDataCon Name
src_name Bool
declared_infix Name
prom_info
[HsSrcBang]
src_bangs [HsImplBang]
impl_bangs [StrictnessMark]
str_marks [FieldLabel]
field_lbls
[TyVar]
univ_tvs [TyVar]
ex_tvs
ConcreteTyVars
noConcreteTyVars
[InvisTVBinder]
user_tvbs [EqSpec]
eq_spec ThetaType
ctxt
[Scaled Type]
arg_tys Type
res_ty PromDataConInfo
NoPromInfo TyCon
rep_tycon ConTag
tag
ThetaType
stupid_ctxt TyVar
dc_wrk DataConRep
dc_rep
dc_wrk = Name -> DataCon -> TyVar
mkDataConWorkId Name
work_name DataCon
data_con
(dc_rep, impl_bangs, str_marks) =
initUs_ us (mkDataConRep dc_bang_opts fam_envs wrap_name data_con)
; traceIf (text "buildDataCon 2" <+> ppr src_name)
; return data_con }
mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType]
mkDataConStupidTheta :: TyCon -> ThetaType -> [TyVar] -> ThetaType
mkDataConStupidTheta TyCon
tycon ThetaType
arg_tys [TyVar]
univ_tvs
| ThetaType -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ThetaType
stupid_theta = []
| Bool
otherwise = (Type -> Bool) -> ThetaType -> ThetaType
forall a. (a -> Bool) -> [a] -> [a]
filter Type -> Bool
in_arg_tys ThetaType
stupid_theta
where
tc_subst :: Subst
tc_subst = [TyVar] -> ThetaType -> Subst
HasDebugCallStack => [TyVar] -> ThetaType -> Subst
zipTvSubst (TyCon -> [TyVar]
tyConTyVars TyCon
tycon)
([TyVar] -> ThetaType
mkTyVarTys [TyVar]
univ_tvs)
stupid_theta :: ThetaType
stupid_theta = HasDebugCallStack => Subst -> ThetaType -> ThetaType
Subst -> ThetaType -> ThetaType
substTheta Subst
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)
-> [FRRType]
-> 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
=
Bool -> SDoc -> PatSyn -> PatSyn
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ [InvisTVBinder]
univ_tvs [InvisTVBinder] -> [TyVar] -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` [TyVar]
univ_tvs1
, [InvisTVBinder]
ex_tvs [InvisTVBinder] -> [TyVar] -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` [TyVar]
ex_tvs1
, Type
pat_ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
pat_ty1)
, ThetaType
prov_theta ThetaType -> ThetaType -> Bool
`eqTypes` HasDebugCallStack => Subst -> ThetaType -> ThetaType
Subst -> ThetaType -> ThetaType
substTys Subst
subst ThetaType
prov_theta1
, ThetaType
req_theta ThetaType -> ThetaType -> Bool
`eqTypes` HasDebugCallStack => Subst -> ThetaType -> ThetaType
Subst -> ThetaType -> ThetaType
substTys Subst
subst ThetaType
req_theta1
, ThetaType -> ThetaType -> Bool
compareArgTys ThetaType
arg_tys (HasDebugCallStack => Subst -> ThetaType -> ThetaType
Subst -> ThetaType -> ThetaType
substTys Subst
subst ((Scaled Type -> Type) -> [Scaled Type] -> ThetaType
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled Type]
arg_tys1))
])
([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ [InvisTVBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InvisTVBinder]
univ_tvs SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
twiddle SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
univ_tvs1
, [InvisTVBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InvisTVBinder]
ex_tvs SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
twiddle SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
ex_tvs1
, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
pat_ty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
twiddle SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Scaled Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Scaled Type
pat_ty1
, ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaType
prov_theta SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
twiddle SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaType
prov_theta1
, ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaType
req_theta SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
twiddle SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaType
req_theta1
, ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaType
arg_tys SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
twiddle SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Scaled Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Scaled Type]
arg_tys1]) (PatSyn -> PatSyn) -> PatSyn -> PatSyn
forall a b. (a -> b) -> a -> b
$
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 (Type -> ([TyVar], ThetaType, Type))
-> Type -> ([TyVar], ThetaType, Type)
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 (Scaled Type -> Type
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
forall doc. IsLine doc => Char -> doc
char Char
'~'
subst :: Subst
subst = [TyVar] -> ThetaType -> Subst
HasDebugCallStack => [TyVar] -> ThetaType -> Subst
zipTvSubst ([TyVar]
univ_tvs1 [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
ex_tvs1)
([TyVar] -> ThetaType
mkTyVarTys ([InvisTVBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars ([InvisTVBinder]
univ_tvs [InvisTVBinder] -> [InvisTVBinder] -> [InvisTVBinder]
forall a. [a] -> [a] -> [a]
++ [InvisTVBinder]
ex_tvs)))
compareArgTys :: [Type] -> [Type] -> Bool
compareArgTys :: ThetaType -> ThetaType -> Bool
compareArgTys [] [Type
x] = Type
x HasCallStack => Type -> Type -> Bool
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
= (Class -> IOEnv (Env m n) Class) -> IOEnv (Env m n) Class
forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM ((Class -> IOEnv (Env m n) Class) -> IOEnv (Env m n) Class)
-> (Class -> IOEnv (Env m n) Class) -> IOEnv (Env m n) Class
forall a b. (a -> b) -> a -> b
$ \ Class
rec_clas ->
do { SDoc -> TcRnIf m n ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"buildClass")
; tc_rep_name <- Name -> TcRnIf m n Name
forall gbl lcl. Name -> TcRnIf gbl lcl Name
newTyConRepName Name
tycon_name
; let univ_tvs = [TyConBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
binders
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 = Name -> [TyVar] -> [FunDep TyVar] -> TyCon -> Class
mkAbstractClass Name
tycon_name [TyVar]
univ_tvs [FunDep TyVar]
fds TyCon
tycon
; traceIf (text "buildClass" <+> ppr tycon)
; return 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))
= (Class -> IOEnv (Env m n) Class) -> IOEnv (Env m n) Class
forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM ((Class -> IOEnv (Env m n) Class) -> IOEnv (Env m n) Class)
-> (Class -> IOEnv (Env m n) Class) -> IOEnv (Env m n) Class
forall a b. (a -> b) -> a -> b
$ \ Class
rec_clas ->
do { SDoc -> TcRnIf m n ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"buildClass")
; datacon_name <- Name -> (OccName -> OccName) -> TcRnIf m n Name
forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
tycon_name OccName -> OccName
mkClassDataConOcc
; tc_rep_name <- newTyConRepName tycon_name
; op_items <- mapM (mk_op_item rec_clas) sig_stuff
; sc_sel_names <- mapM (newImplicitBinder tycon_name . mkSuperDictSelOcc)
(takeList sc_theta [fIRST_TAG..])
; let sc_sel_ids = [ Name -> Class -> TyVar
mkDictSelId Name
sc_name Class
rec_clas
| Name
sc_name <- [Name]
sc_sel_names]
; let use_newtype = ThetaType -> Bool
forall a. [a] -> Bool
isSingleton (ThetaType
sc_theta ThetaType -> ThetaType -> ThetaType
forall a. [a] -> [a] -> [a]
++ ThetaType
op_tys)
args = [Name]
sc_sel_names [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
op_names
op_tys = [Type
ty | (Name
_,Type
ty,Maybe (DefMethSpec (SrcSpan, Type))
_) <- [KnotTied MethInfo]
sig_stuff]
op_names = [Name
op | (Name
op,Type
_,Maybe (DefMethSpec (SrcSpan, Type))
_) <- [KnotTied MethInfo]
sig_stuff]
rec_tycon = Class -> TyCon
classTyCon Class
rec_clas
univ_bndrs = [TyConBinder] -> [InvisTVBinder]
tyConInvisTVBinders [TyConBinder]
binders
univ_tvs = [InvisTVBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
univ_bndrs
bang_opts = [HsImplBang] -> DataConBangOpts
FixedBangOpts ((Name -> HsImplBang) -> [Name] -> [HsImplBang]
forall a b. (a -> b) -> [a] -> [b]
map (HsImplBang -> Name -> HsImplBang
forall a b. a -> b -> a
const HsImplBang
HsLazy) [Name]
args)
; rep_nm <- newTyConRepName datacon_name
; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
bang_opts
datacon_name
False
rep_nm
(map (const no_bang) args)
[]
univ_tvs
[]
univ_bndrs
[]
sc_theta
(map unrestricted op_tys)
(mkTyConApp rec_tycon (mkTyVarTys univ_tvs))
rec_tycon
(mkTyConTagMap rec_tycon)
; rhs <- case () of
()
_ | Bool
use_newtype
-> Name -> TyCon -> DataCon -> IOEnv (Env m n) AlgTyConRhs
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
-> AlgTyConRhs -> IOEnv (Env m n) AlgTyConRhs
forall a. a -> IOEnv (Env m n) a
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
-> AlgTyConRhs -> IOEnv (Env m n) AlgTyConRhs
forall a. a -> IOEnv (Env m n) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DataCon] -> AlgTyConRhs
mkDataTyConRhs [DataCon
dict_con])
; let { 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 = 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
}
; traceIf (text "buildClass" <+> ppr tycon)
; return result }
where
no_bang :: HsSrcBang
no_bang = SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
mkHsSrcBang 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 { dm_info <- Name
-> Maybe (DefMethSpec (SrcSpan, Type))
-> TcRnIf n m (Maybe (Name, DefMethSpec Type))
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
; return (mkDictSelId op_name rec_clas, 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
= Maybe (Name, DefMethSpec Type)
-> IOEnv (Env n m) (Maybe (Name, DefMethSpec Type))
forall a. a -> IOEnv (Env n m) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Name, DefMethSpec Type)
forall a. Maybe a
Nothing
mk_dm_info Name
op_name (Just DefMethSpec (SrcSpan, Type)
VanillaDM)
= do { dm_name <- Name -> (OccName -> OccName) -> TcRnIf n m Name
forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
op_name OccName -> OccName
mkDefaultMethodOcc
; return (Just (dm_name, VanillaDM)) }
mk_dm_info Name
op_name (Just (GenericDM (SrcSpan
loc, Type
dm_ty)))
= do { dm_name <- Name -> (OccName -> OccName) -> SrcSpan -> TcRnIf n m Name
forall m n.
Name -> (OccName -> OccName) -> SrcSpan -> TcRnIf m n Name
newImplicitBinderLoc Name
op_name OccName -> OccName
mkDefaultMethodOcc SrcSpan
loc
; return (Just (dm_name, GenericDM 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
= Name -> (OccName -> OccName) -> SrcSpan -> TcRnIf m n Name
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
= Module -> OccName -> SrcSpan -> TcRnIf m n Name
forall a b. Module -> OccName -> SrcSpan -> TcRnIf a b Name
newGlobalBinder Module
mod OccName
occ SrcSpan
loc
| Bool
otherwise
= do { uniq <- TcRnIf m n Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; return (mkInternalName uniq occ 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)
= Module -> OccName -> SrcSpan -> TcRnIf gbl lcl Name
forall a b. Module -> OccName -> SrcSpan -> TcRnIf a b Name
newGlobalBinder Module
mod OccName
occ SrcSpan
noSrcSpan
| Bool
otherwise
= Name -> (OccName -> OccName) -> TcRnIf gbl lcl Name
forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
tc_name OccName -> OccName
mkTyConRepOcc