-\subsection{Validity check for TyCons}
-%* *
-%************************************************************************
-
-checkValidTyCon is called once the mutually-recursive knot has been
-tied, so we can look at things freely.
-
-\begin{code}
-checkValidTyCon :: TyCon -> TcM ()
-checkValidTyCon tc
- | isSynTyCon tc = checkValidType (TySynCtxt name) syn_rhs
- | otherwise
- = -- Check the context on the data decl
- checkValidTheta (DataTyCtxt name) (tyConTheta tc) `thenM_`
-
- -- Check arg types of data constructors
- mappM_ checkValidDataCon data_cons `thenM_`
-
- -- Check that fields with the same name share a type
- mappM_ check_fields groups
-
- where
- name = tyConName tc
- (_, syn_rhs) = getSynTyConDefn tc
- data_cons = tyConDataCons tc
-
- fields = [field | con <- data_cons, field <- dataConFieldLabels con]
- groups = equivClasses cmp_name fields
- cmp_name field1 field2 = fieldLabelName field1 `compare` fieldLabelName field2
-
- check_fields fields@(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
- -- NB: this check assumes that all the constructors of a given
- -- data type use the same type variables
- checkTc (all (tcEqType field_ty) other_tys) (fieldTypeMisMatch field_name)
- where
- field_ty = fieldLabelType first_field_label
- field_name = fieldLabelName first_field_label
- other_tys = map fieldLabelType other_fields
-
-checkValidDataCon :: DataCon -> TcM ()
-checkValidDataCon con
- = checkValidType ctxt (idType (dataConWrapId con)) `thenM_`
- -- This checks the argument types and
- -- ambiguity of the existential context (if any)
- addErrCtxt (existentialCtxt con)
- (checkFreeness ex_tvs ex_theta)
- where
- ctxt = ConArgCtxt (dataConName con)
- (_, _, ex_tvs, ex_theta, _, _) = dataConSig con
-
-
-fieldTypeMisMatch field_name
- = sep [ptext SLIT("Different constructors give different types for field"), quotes (ppr field_name)]
-
-existentialCtxt con = ptext SLIT("When checking the existential context of constructor")
- <+> quotes (ppr con)
-\end{code}
-
-
-checkValidClass is called once the mutually-recursive knot has been
-tied, so we can look at things freely.
-
-\begin{code}
-checkValidClass :: Class -> TcM ()
-checkValidClass cls
- = -- CHECK ARITY 1 FOR HASKELL 1.4
- doptM Opt_GlasgowExts `thenM` \ gla_exts ->
-
- -- Check that the class is unary, unless GlaExs
- checkTc (notNull tyvars) (nullaryClassErr cls) `thenM_`
- checkTc (gla_exts || unary) (classArityErr cls) `thenM_`
-
- -- Check the super-classes
- checkValidTheta (ClassSCCtxt (className cls)) theta `thenM_`
-
- -- Check the class operations
- mappM_ check_op op_stuff `thenM_`
-
- -- Check that if the class has generic methods, then the
- -- class has only one parameter. We can't do generic
- -- multi-parameter type classes!
- checkTc (unary || no_generics) (genericMultiParamErr cls)
-
- where
- (tyvars, theta, _, op_stuff) = classBigSig cls
- unary = isSingleton tyvars
- no_generics = null [() | (_, GenDefMeth) <- op_stuff]
-
- check_op (sel_id, dm)
- = checkValidTheta SigmaCtxt (tail theta) `thenM_`
- -- The 'tail' removes the initial (C a) from the
- -- class itself, leaving just the method type
-
- checkValidType (FunSigCtxt op_name) tau `thenM_`
-
- -- Check that for a generic method, the type of
- -- the method is sufficiently simple
- checkTc (dm /= GenDefMeth || validGenericMethodType op_ty)
- (badGenericMethodType op_name op_ty)
- where
- op_name = idName sel_id
- op_ty = idType sel_id
- (_,theta,tau) = tcSplitSigmaTy op_ty
-
-nullaryClassErr cls
- = ptext SLIT("No parameters for class") <+> quotes (ppr cls)
-
-classArityErr cls
- = vcat [ptext SLIT("Too many parameters for class") <+> quotes (ppr cls),
- parens (ptext SLIT("Use -fglasgow-exts to allow multi-parameter classes"))]
-
-genericMultiParamErr clas
- = ptext SLIT("The multi-parameter class") <+> quotes (ppr clas) <+>
- ptext SLIT("cannot have generic methods")
-
-badGenericMethodType op op_ty
- = hang (ptext SLIT("Generic method type is too complex"))
- 4 (vcat [ppr op <+> dcolon <+> ppr op_ty,
- ptext SLIT("You can only use type variables, arrows, and tuples")])
-\end{code}
-
-
-%************************************************************************
-%* *
projects / ghc-hetmet.git / blobdiff