-dataConTag :: DataCon -> ConTag -- will panic if not a DataCon
-dataConTag (Id _ _ _ (AlgConId tag _ _ _ _ _ _ _ _) _ _) = tag
-dataConTag (Id _ _ _ (TupleConId _) _ _) = fIRST_TAG
-dataConTag (Id _ _ _ (SpecId unspec _ _) _ _) = dataConTag unspec
-
-dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon
-dataConTyCon (Id _ _ _ (AlgConId _ _ _ _ _ _ _ _ tycon) _ _) = tycon
-dataConTyCon (Id _ _ _ (TupleConId a) _ _) = tupleTyCon a
-
-dataConSig :: DataCon -> ([TyVar], ThetaType, [TyVar], ThetaType, [TauType], TyCon)
- -- will panic if not a DataCon
-
-dataConSig (Id _ _ _ (AlgConId _ _ _ tyvars theta con_tyvars con_theta arg_tys tycon) _ _)
- = (tyvars, theta, con_tyvars, con_theta, arg_tys, tycon)
-
-dataConSig (Id _ _ _ (TupleConId arity) _ _)
- = (tyvars, [], [], [], tyvar_tys, tupleTyCon arity)
- where
- tyvars = take arity alphaTyVars
- tyvar_tys = mkTyVarTys tyvars
-dataConSig (Id _ _ _ (SpecId unspec ty_maybes _) _ _)
- = (spec_tyvars, spec_theta_ty, spec_con_tyvars, spec_con_theta, spec_arg_tys, spec_tycon)
- where
- (tyvars, theta_ty, con_tyvars, con_theta, arg_tys, tycon) = dataConSig unspec
-
- ty_env = tyvars `zip` ty_maybes
-
- spec_tyvars = foldr nothing_tyvars [] ty_env
- spec_con_tyvars = foldr nothing_tyvars [] (con_tyvars `zip` ty_maybes) -- Hmm..
-
- nothing_tyvars (tyvar, Nothing) l = tyvar : l
- nothing_tyvars (tyvar, Just ty) l = l
-
- spec_env = foldr just_env [] ty_env
- just_env (tyvar, Nothing) l = l
- just_env (tyvar, Just ty) l = (tyvar, ty) : l
- spec_arg_tys = map (instantiateTauTy spec_env) arg_tys
-
- spec_theta_ty = if null theta_ty then []
- else panic "dataConSig:ThetaTy:SpecDataCon1"
- spec_con_theta = if null con_theta then []
- else panic "dataConSig:ThetaTy:SpecDataCon2"
- spec_tycon = mkSpecTyCon tycon ty_maybes
-
-
--- dataConRepType returns the type of the representation of a contructor
--- This may differ from the type of the contructor Id itself for two reasons:
--- a) the constructor Id may be overloaded, but the dictionary isn't stored
--- b) the constructor may store an unboxed version of a strict field.
--- Here's an example illustrating both:
--- data Ord a => T a = MkT Int! a
--- Here
--- T :: Ord a => Int -> a -> T a
--- but the rep type is
--- Trep :: Int# -> a -> T a
--- Actually, the unboxed part isn't implemented yet!
-
-dataConRepType :: GenId (GenType tv u) -> GenType tv u
-dataConRepType con
- = mkForAllTys tyvars tau
- where
- (tyvars, theta, tau) = splitSigmaTy (idType con)
-
-dataConFieldLabels :: DataCon -> [FieldLabel]
-dataConFieldLabels (Id _ _ _ (AlgConId _ _ fields _ _ _ _ _ _) _ _) = fields
-dataConFieldLabels (Id _ _ _ (TupleConId _) _ _) = []
-#ifdef DEBUG
-dataConFieldLabels x@(Id _ _ _ idt _ _) =
- panic ("dataConFieldLabel: " ++
- (case idt of
- LocalId _ -> "l"
- SysLocalId _ -> "sl"
- PrimitiveId _ -> "p"
- SpecPragmaId _ _ -> "sp"
- ImportedId -> "i"
- RecordSelId _ -> "r"
- SuperDictSelId _ _ -> "sc"
- MethodSelId _ -> "m"
- DefaultMethodId _ -> "d"
- DictFunId _ _ -> "di"
- InstId _ -> "in"
- SpecId _ _ _ -> "spec"))
-#endif
-
-dataConStrictMarks :: DataCon -> [StrictnessMark]
-dataConStrictMarks (Id _ _ _ (AlgConId _ stricts _ _ _ _ _ _ _) _ _) = stricts
-dataConStrictMarks (Id _ _ _ (TupleConId arity) _ _)
- = nOfThem arity NotMarkedStrict
-
-dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience
-dataConRawArgTys con = case (dataConSig con) of { (_,_, _, _, arg_tys,_) -> arg_tys }
-
-dataConArgTys :: DataCon
- -> [Type] -- Instantiated at these types
- -> [Type] -- Needs arguments of these types
-dataConArgTys con_id inst_tys
- = map (instantiateTy tenv) arg_tys
- where
- (tyvars, _, _, _, arg_tys, _) = dataConSig con_id
- tenv = zipEqual "dataConArgTys" tyvars inst_tys
-\end{code}
-
-\begin{code}
-mkRecordSelId field_label selector_ty
- = addStandardIdInfo $ -- Record selectors have a standard unfolding
- Id (nameUnique name)
- name
- selector_ty
- (RecordSelId field_label)
- NoPragmaInfo
- noIdInfo
- where
- name = fieldLabelName field_label
-
-recordSelectorFieldLabel :: Id -> FieldLabel
-recordSelectorFieldLabel (Id _ _ _ (RecordSelId lbl) _ _) = lbl