-\begin{code}
-mkImplicitDataBinds :: [TyCon] -> TcM s ([Id], TcMonoBinds)
-mkImplicitDataBinds [] = returnTc ([], EmptyMonoBinds)
-mkImplicitDataBinds (tycon : tycons)
- | isSynTyCon tycon = mkImplicitDataBinds tycons
- | otherwise = mkImplicitDataBinds_one tycon `thenTc` \ (ids1, b1) ->
- mkImplicitDataBinds tycons `thenTc` \ (ids2, b2) ->
- returnTc (ids1++ids2, b1 `AndMonoBinds` b2)
-
-mkImplicitDataBinds_one tycon
- = mapTc (mkRecordSelector tycon) groups `thenTc` \ sel_ids ->
- let
- unf_ids = sel_ids ++ data_con_wrapper_ids ++ gen_ids
- all_ids = map dataConId data_cons ++ unf_ids
-
- -- For the locally-defined things
- -- we need to turn the unfoldings inside the selector Ids into bindings,
- -- and build bindigns for the constructor wrappers
- binds | isLocallyDefined tycon = idsToMonoBinds unf_ids
- | otherwise = EmptyMonoBinds
- in
- returnTc (all_ids, binds)
- where
- data_cons = tyConDataConsIfAvailable tycon
- -- Abstract types mean we don't bring the
- -- data cons into scope, which should be fine
- gen_ids = tyConGenIds tycon
- data_con_wrapper_ids = map dataConWrapId data_cons
-
- 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 `compare` fieldLabelName field2
-\end{code}
-
-\begin{code}
-mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
- -- These fields all have the same name, but are from
- -- different constructors in the data type
- -- Check that all the fields in the group have the same type
- -- This check assumes that all the constructors of a given
- -- data type use the same type variables
- = checkTc (all (== field_ty) other_tys)
- (fieldTypeMisMatch field_name) `thenTc_`
- tcLookupValueByKey unpackCStringIdKey `thenTc` \ unpack_id ->
- tcLookupValueByKey unpackCStringUtf8IdKey `thenTc` \ unpackUtf8_id ->
- returnTc (mkRecordSelId tycon first_field_label unpack_id unpackUtf8_id)
- where
- field_ty = fieldLabelType first_field_label
- field_name = fieldLabelName first_field_label
- other_tys = [fieldLabelType fl | (_, fl) <- other_fields]
-\end{code}
-