-mk_edges (TyD (TyData ctxt name _ condecls derivs _ _))
- = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets`
- get_cons condecls `unionUniqSets`
- get_deriv derivs))
-
-mk_edges (TyD (TyNew ctxt name _ condecl derivs _ _))
- = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets`
- get_con condecl `unionUniqSets`
- get_deriv derivs))
-
-mk_edges (TyD (TySynonym name _ rhs _))
- = (uniqueOf name, set_to_bag (get_ty rhs))
-
-mk_edges (ClD (ClassDecl ctxt name _ sigs _ _ _))
- = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_sigs sigs))
-
-get_ctxt ctxt
- = unionManyUniqSets (map (set_name.fst) ctxt)
-
-get_deriv Nothing = emptyUniqSet
-get_deriv (Just clss) = unionManyUniqSets (map set_name clss)
-
-get_cons cons
- = unionManyUniqSets (map get_con cons)
-
-get_con (ConDecl _ btys _)
- = unionManyUniqSets (map get_bty btys)
-get_con (ConOpDecl bty1 _ bty2 _)
- = unionUniqSets (get_bty bty1) (get_bty bty2)
-get_con (NewConDecl _ ty _)
- = get_ty ty
-get_con (RecConDecl _ nbtys _)
- = unionManyUniqSets (map (get_bty.snd) nbtys)
-
-get_bty (Banged ty) = get_ty ty
-get_bty (Unbanged ty) = get_ty ty
-
-get_ty (MonoTyVar name)
- = if isTvOcc (nameOccName name) then emptyUniqSet else set_name name
-get_ty (MonoTyApp ty1 ty2)
- = unionUniqSets (get_ty ty1) (get_ty ty2)
-get_ty (MonoFunTy ty1 ty2)
- = unionUniqSets (get_ty ty1) (get_ty ty2)
-get_ty (MonoListTy tc ty)
- = set_name tc `unionUniqSets` get_ty ty
-get_ty (MonoTupleTy tc tys)
- = set_name tc `unionUniqSets` get_tys tys
-get_ty (HsForAllTy _ ctxt mty)
- = get_ctxt ctxt `unionUniqSets` get_ty mty
-get_ty other = panic "TcTyClsDecls:get_ty"
-
-get_tys tys
- = unionManyUniqSets (map get_ty tys)
-
-get_sigs sigs
- = unionManyUniqSets (map get_sig sigs)
- where
- get_sig (ClassOpSig _ _ ty _) = get_ty ty
- get_sig other = panic "TcTyClsDecls:get_sig"
-
-set_name name = unitUniqSet (uniqueOf name)
-
-set_to_bag set = listToBag (uniqSetToList set)
+buildTyConOrClass
+ :: DynFlags
+ -> RecFlag -> NameEnv Kind
+ -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
+ -> RenamedTyClDecl -> TyThing
+
+buildTyConOrClass dflags is_rec 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 dflags is_rec kenv rec_vrcs rec_details
+ (TyData {tcdND = data_or_new, tcdName = tycon_name,
+ tcdTyVars = tyvar_names, tcdSysNames = sys_names})
+ = ATyCon tycon
+ where
+ tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
+ data_cons sel_ids
+ flavour is_rec gen_info
+ -- It's not strictly necesary to mark newtypes as
+ -- recursive if the loop is broken via a data type.
+ -- But I'm not sure it's worth the hassle of discovering that.
+
+ gen_info | not (dopt Opt_Generics dflags) = Nothing
+ | otherwise = mkTyConGenInfo tycon sys_names
+
+ DataTyDetails ctxt data_cons sel_ids = 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 dflags is_rec kenv rec_vrcs rec_details
+ (ForeignType {tcdName = tycon_name, tcdExtName = tycon_ext_name})
+ = ATyCon (mkForeignTyCon tycon_name tycon_ext_name liftedTypeKind 0 [])
+
+buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
+ (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names,
+ tcdFDs = fundeps, tcdSysNames = name_list} )
+ = AClass clas
+ where
+ (tycon_name, _, _, _) = getClassDeclSysNames name_list
+ clas = mkClass class_name tyvars fds
+ sc_theta sc_sel_ids op_items
+ tycon
+
+ tycon = mkClassTyCon tycon_name class_kind tyvars
+ argvrcs dict_con
+ clas -- Yes! It's a dictionary
+ flavour
+ is_rec
+ -- A class can be recursive, and in the case of newtypes
+ -- this matters. For example
+ -- class C a where { op :: C b => a -> b -> Int }
+ -- Because C has only one operation, it is represented by
+ -- a newtype, and it should be a *recursive* newtype.
+ -- [If we don't make it a recursive newtype, we'll expand the
+ -- newtype like a synonym, but that will lead toan inifinite type
+
+ ClassDetails sc_theta sc_sel_ids op_items dict_con = lookupNameEnv_NF rec_details class_name
+
+ class_kind = lookupNameEnv_NF kenv class_name
+ tyvars = mkTyClTyVars class_kind tyvar_names
+ argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
+
+ flavour = case dataConOrigArgTys dict_con of
+ -- The tyvars in the datacon are the same as in the class
+ [rep_ty] -> NewTyCon rep_ty
+ other -> DataTyCon
+
+ -- We can find the functional dependencies right away,
+ -- and it is vital to do so. Why? Because in the next pass
+ -- we check for ambiguity in all the type signatures, and we
+ -- need the functional dependcies to be done by then
+ fds = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps]
+ tyvar_env = mkNameEnv [(varName tv, tv) | tv <- tyvars]
+ lookup = lookupNameEnv_NF tyvar_env
+
+bogusVrcs = panic "Bogus tycon arg variances"