- tc_data_decl uniq name full_name arity tyvars con_decls derivings pragmas src_loc
- = addSrcLocB_Tc src_loc (
- let
- (tve, new_tyvars, _) = mkTVE tyvars
- rec_tycon = lookupTCE rec_tce name
- -- We know the lookup will succeed, because we are just
- -- about to put it in the outgoing TCE!
-
- spec_sigs = get_spec_sigs name
- in
- tcSpecDataSigs rec_tce spec_sigs [] `thenB_Tc` \ user_spec_infos ->
-
- recoverIgnoreErrorsB_Tc ([], []) (
- tcDataPragmas rec_tce tve rec_tycon new_tyvars pragmas
- ) `thenB_Tc` \ (pragma_con_decls, pragma_spec_infos) ->
- let
- (condecls_to_use, ignore_condecl_errors_if_pragma)
- = if null pragma_con_decls then
- (con_decls, id)
- else
- if null con_decls
- then (pragma_con_decls, recoverIgnoreErrorsB_Tc nullGVE)
- else panic "tcTyDecls:data: user and pragma condecls!"
-
- specinfos_to_use
- = if null pragma_spec_infos then
- user_spec_infos
- else
- if null user_spec_infos
- then pragma_spec_infos
- else panic "tcTyDecls:data: user and pragma specinfos!"
-
- specenv_to_use = mkSpecEnv specinfos_to_use
- in
- ignore_condecl_errors_if_pragma
- (tcConDecls rec_tce tve rec_tycon new_tyvars specenv_to_use condecls_to_use)
- `thenB_Tc` \ gve ->
- let
- condecls = map snd gve
-
- derived_classes = map (lookupCE rec_ce) derivings
-
- new_tycon
- = mkDataTyCon uniq
- full_name arity new_tyvars condecls
- derived_classes
- (null pragma_con_decls)
- -- if constrs are from pragma we are *abstract*
-
- spec_list
- = map (\ (SpecInfo maybe_tys _ _) -> maybe_tys) specinfos_to_use
-
- spec_map
- = if null spec_list then
- emptyFM
- else
- singletonFM rec_tycon spec_list
- in
- returnB_Tc (unitTCE uniq new_tycon, gve, spec_map)
- -- It's OK to return pragma condecls in gve, even
- -- though some of those names should be "invisible",
- -- because the *renamer* is supposed to have dealt with
- -- naming/scope issues already.
- )
+mkDataBinds :: [TyCon] -> TcM s ([Id], TcHsBinds s)
+mkDataBinds [] = returnTc ([], EmptyBinds)
+mkDataBinds (tycon : tycons)
+ | isSynTyCon tycon = mkDataBinds tycons
+ | otherwise = mkDataBinds_one tycon `thenTc` \ (ids1, b1) ->
+ mkDataBinds tycons `thenTc` \ (ids2, b2) ->
+ returnTc (ids1++ids2, b1 `ThenBinds` b2)
+
+mkDataBinds_one tycon
+ = ASSERT( isDataTyCon tycon || isNewTyCon tycon )
+ mapAndUnzipTc mkConstructor data_cons `thenTc` \ (con_ids, con_binds) ->
+ mapAndUnzipTc (mkRecordSelector tycon) groups `thenTc` \ (sel_ids, sel_binds) ->
+ returnTc (con_ids ++ sel_ids,
+ SingleBind $ NonRecBind $
+ foldr AndMonoBinds
+ (foldr AndMonoBinds EmptyMonoBinds sel_binds)
+ con_binds
+ )
+ where
+ data_cons = tyConDataCons tycon
+ fields = [ (con, field) | con <- data_cons,
+ field <- dataConFieldLabels con
+ ]
+
+ -- groups is list of fields that share a common name
+ groups = equivClasses cmp_name fields
+ cmp_name (_, field1) (_, field2)
+ = fieldLabelName field1 `cmp` fieldLabelName field2