-getTyBinding1 :: RenamedTyClDecl -> NF_TcM s (Name, (TcKind, Maybe Arity, TcTyThing))
-getTyBinding1 (TySynonym name tyvars _ _)
- = mapNF_Tc kcHsTyVar tyvars `thenNF_Tc` \ arg_kinds ->
- newKindVar `thenNF_Tc` \ result_kind ->
- returnNF_Tc (name, (foldr mkArrowKind result_kind arg_kinds,
- Just (length tyvars),
- ATyCon (pprPanic "ATyCon: syn" (ppr name))))
-
-getTyBinding1 (TyData _ _ name tyvars _ _ _ _)
- = mapNF_Tc kcHsTyVar tyvars `thenNF_Tc` \ arg_kinds ->
- returnNF_Tc (name, (foldr mkArrowKind boxedTypeKind arg_kinds,
- Nothing,
- ATyCon (error "ATyCon: data")))
-
-getTyBinding1 (ClassDecl _ name tyvars _ _ _ _ _ _ _ _ _)
- = mapNF_Tc kcHsTyVar tyvars `thenNF_Tc` \ arg_kinds ->
- returnNF_Tc (name, (foldr mkArrowKind boxedTypeKind arg_kinds,
- Just (length tyvars),
- AClass (error "AClass")))
-
--- Zonk the kind to its final form, and lookup the
--- recursive tycon/class
-getTyBinding2 rec_env (name, (tc_kind, maybe_arity, thing))
- = zonkTcKindToKind tc_kind `thenNF_Tc` \ kind ->
- returnNF_Tc (name, (kind, maybe_arity, mk_thing thing (lookupUFM rec_env name)))
+buildTyConOrClass
+ :: (Name -> AlgTyConFlavour -> RecFlag) -- Whether it's recursive
+ -> NameEnv Kind
+ -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
+ -> RenamedTyClDecl -> TyThing
+
+buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
+ (TySynonym {tcdName = tycon_name, tcdTyVars = tyvar_names})
+ = ATyCon tycon
+ where
+ tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
+ tycon_kind = lookupNameEnv_NF kenv tycon_name
+ arity = length tyvar_names
+ tyvars = mkTyClTyVars tycon_kind tyvar_names
+ SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name
+ argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
+
+buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
+ (TyData {tcdND = data_or_new, tcdName = tycon_name,
+ tcdTyVars = tyvar_names})
+ = ATyCon tycon
+ where
+ tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
+ data_cons sel_ids flavour
+ (rec_tycon tycon_name flavour) gen_info
+
+ DataTyDetails ctxt data_cons sel_ids gen_info = lookupNameEnv_NF rec_details tycon_name
+
+ tycon_kind = lookupNameEnv_NF kenv tycon_name
+ tyvars = mkTyClTyVars tycon_kind tyvar_names
+ argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
+
+ -- Watch out! mkTyConApp asks whether the tycon is a NewType,
+ -- so flavour has to be able to answer this question without consulting rec_details
+ flavour = case data_or_new of
+ NewType -> NewTyCon (mkNewTyConRep tycon)
+ DataType | all_nullary data_cons -> EnumTyCon
+ | otherwise -> DataTyCon
+
+ all_nullary (DataCons cons) = all (null . dataConOrigArgTys) cons
+ all_nullary other = False -- Safe choice for unknown data types
+ -- NB (null . dataConOrigArgTys). It used to say isNullaryDataCon
+ -- but that looks at the *representation* arity, and that in turn
+ -- depends on deciding whether to unpack the args, and that
+ -- depends on whether it's a data type or a newtype --- so
+ -- in the recursive case we can get a loop. This version is simple!
+
+buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
+ (ForeignType {tcdName = tycon_name, tcdExtName = tycon_ext_name})
+ = ATyCon (mkForeignTyCon tycon_name tycon_ext_name liftedTypeKind 0 [])
+
+buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
+ (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names, tcdFDs = fundeps} )
+ = AClass clas