module BuildTyCl (
buildSynonymTyCon,
buildFamilyTyCon,
buildAlgTyCon,
buildDataCon,
buildPatSyn,
TcMethInfo, buildClass,
distinctAbstractTyConRhs, totallyAbstractTyConRhs,
mkNewTyConRhs, mkDataTyConRhs,
newImplicitBinder
) where
#include "HsVersions.h"
import IfaceEnv
import FamInstEnv( FamInstEnvs )
import DataCon
import PatSyn
import Var
import VarSet
import BasicTypes
import Name
import MkId
import Class
import TyCon
import Type
import Id
import Coercion
import TcType
import DynFlags
import TcRnMonad
import UniqSupply
import Util
import Outputable
buildSynonymTyCon :: Name -> [TyVar] -> [Role]
-> Type
-> Kind
-> TcRnIf m n TyCon
buildSynonymTyCon tc_name tvs roles rhs rhs_kind
= return (mkSynonymTyCon tc_name kind tvs roles rhs)
where kind = mkPiKinds tvs rhs_kind
buildFamilyTyCon :: Name -> [TyVar]
-> FamTyConFlav
-> Kind
-> TyConParent
-> TcRnIf m n TyCon
buildFamilyTyCon tc_name tvs rhs rhs_kind parent
= return (mkFamilyTyCon tc_name kind tvs rhs parent)
where kind = mkPiKinds tvs rhs_kind
distinctAbstractTyConRhs, totallyAbstractTyConRhs :: AlgTyConRhs
distinctAbstractTyConRhs = AbstractTyCon True
totallyAbstractTyConRhs = AbstractTyCon False
mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
mkDataTyConRhs cons
= DataTyCon {
data_cons = cons,
is_enum = not (null cons) && all is_enum_con cons
}
where
is_enum_con con
| (_tvs, theta, arg_tys, _res) <- dataConSig con
= null theta && null arg_tys
mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
mkNewTyConRhs tycon_name tycon con
= do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
; let co_tycon = mkNewTypeCo co_tycon_name tycon etad_tvs etad_roles etad_rhs
; traceIf (text "mkNewTyConRhs" <+> ppr co_tycon)
; return (NewTyCon { data_con = con,
nt_rhs = rhs_ty,
nt_etad_rhs = (etad_tvs, etad_rhs),
nt_co = co_tycon } ) }
where
tvs = tyConTyVars tycon
roles = tyConRoles tycon
inst_con_ty = applyTys (dataConUserType con) (mkTyVarTys tvs)
rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty
etad_tvs :: [TyVar]
etad_roles :: [Role]
etad_rhs :: Type
(etad_tvs, etad_roles, etad_rhs) = eta_reduce (reverse tvs) (reverse roles) rhs_ty
eta_reduce :: [TyVar]
-> [Role]
-> Type
-> ([TyVar], [Role], Type)
eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty,
Just tv <- getTyVar_maybe arg,
tv == a,
not (a `elemVarSet` tyVarsOfType fun)
= eta_reduce as rs fun
eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty)
buildDataCon :: FamInstEnvs
-> Name -> Bool
-> [HsBang]
-> [Name]
-> [TyVar] -> [TyVar]
-> [(TyVar,Type)]
-> ThetaType
-> [Type] -> Type
-> TyCon
-> TcRnIf m n DataCon
buildDataCon fam_envs src_name declared_infix arg_stricts field_lbls
univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
= do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
; us <- newUniqueSupply
; dflags <- getDynFlags
; let
stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
data_con = mkDataCon src_name declared_infix
arg_stricts field_lbls
univ_tvs ex_tvs eq_spec ctxt
arg_tys res_ty rep_tycon
stupid_ctxt dc_wrk dc_rep
dc_wrk = mkDataConWorkId work_name data_con
dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name data_con)
; return data_con }
mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType]
mkDataConStupidTheta tycon arg_tys univ_tvs
| null stupid_theta = []
| otherwise = filter in_arg_tys stupid_theta
where
tc_subst = zipTopTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs)
stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
arg_tyvars = tyVarsOfTypes arg_tys
in_arg_tys pred = not $ isEmptyVarSet $
tyVarsOfType pred `intersectVarSet` arg_tyvars
buildPatSyn :: Name -> Bool
-> (Id,Bool) -> Maybe (Id, Bool)
-> ([TyVar], ThetaType)
-> ([TyVar], ThetaType)
-> [Type]
-> Type
-> PatSyn
buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
(univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys pat_ty
= ASSERT((and [ univ_tvs == univ_tvs'
, ex_tvs == ex_tvs'
, pat_ty `eqType` pat_ty'
, prov_theta `eqTypes` prov_theta'
, req_theta `eqTypes` req_theta'
, arg_tys `eqTypes` arg_tys'
]))
mkPatSyn src_name declared_infix
(univ_tvs, req_theta) (ex_tvs, prov_theta)
arg_tys pat_ty
matcher builder
where
((_:univ_tvs'), req_theta', tau) = tcSplitSigmaTy $ idType matcher_id
([pat_ty', cont_sigma, _], _) = tcSplitFunTys tau
(ex_tvs', prov_theta', cont_tau) = tcSplitSigmaTy cont_sigma
(arg_tys', _) = tcSplitFunTys cont_tau
type TcMethInfo = (Name, DefMethSpec, Type)
buildClass :: Name -> [TyVar] -> [Role] -> ThetaType
-> [FunDep TyVar]
-> [ClassATItem]
-> [TcMethInfo]
-> ClassMinimalDef
-> RecFlag
-> TcRnIf m n Class
buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
= fixM $ \ rec_clas ->
do { traceIf (text "buildClass")
; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc
; op_items <- mapM (mk_op_item rec_clas) sig_stuff
; sc_sel_names <- mapM (newImplicitBinder tycon_name . mkSuperDictSelOcc)
[1..length sc_theta]
; let sc_sel_ids = [ mkDictSelId sc_name rec_clas
| sc_name <- sc_sel_names]
; let use_newtype = isSingleton arg_tys
args = sc_sel_names ++ op_names
op_tys = [ty | (_,_,ty) <- sig_stuff]
op_names = [op | (op,_,_) <- sig_stuff]
arg_tys = sc_theta ++ op_tys
rec_tycon = classTyCon rec_clas
; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
datacon_name
False
(map (const HsNoBang) args)
[]
tvs []
[]
[]
arg_tys
(mkTyConApp rec_tycon (mkTyVarTys tvs))
rec_tycon
; rhs <- if use_newtype
then mkNewTyConRhs tycon_name rec_tycon dict_con
else return (mkDataTyConRhs [dict_con])
; let { clas_kind = mkPiKinds tvs constraintKind
; tycon = mkClassTyCon tycon_name clas_kind tvs roles
rhs rec_clas tc_isrec
; result = mkClass tvs fds
sc_theta sc_sel_ids at_items
op_items mindef tycon
}
; traceIf (text "buildClass" <+> ppr tycon)
; return result }
where
mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
mk_op_item rec_clas (op_name, dm_spec, _)
= do { dm_info <- case dm_spec of
NoDM -> return NoDefMeth
GenericDM -> do { dm_name <- newImplicitBinder op_name mkGenDefMethodOcc
; return (GenDefMeth dm_name) }
VanillaDM -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
; return (DefMeth dm_name) }
; return (mkDictSelId op_name rec_clas, dm_info) }