+
+-------------------------------
+checkValidClass :: Class -> TcM ()
+checkValidClass cls
+ = do { -- CHECK ARITY 1 FOR HASKELL 1.4
+ gla_exts <- doptM Opt_GlasgowExts
+
+ -- Check that the class is unary, unless GlaExs
+ ; checkTc (notNull tyvars) (nullaryClassErr cls)
+ ; checkTc (gla_exts || unary) (classArityErr cls)
+
+ -- Check the super-classes
+ ; checkValidTheta (ClassSCCtxt (className cls)) theta
+
+ -- Check the class operations
+ ; mappM_ (check_op gla_exts) op_stuff
+
+ -- 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 gla_exts (sel_id, dm)
+ = addErrCtxt (classOpCtxt sel_id tau) $ do
+ { checkValidTheta SigmaCtxt (tail theta)
+ -- The 'tail' removes the initial (C a) from the
+ -- class itself, leaving just the method type
+
+ ; checkValidType (FunSigCtxt op_name) tau
+
+ -- Check that the type mentions at least one of
+ -- the class type variables
+ ; checkTc (any (`elemVarSet` tyVarsOfType tau) tyvars)
+ (noClassTyVarErr cls sel_id)
+
+ -- Check that for a generic method, the type of
+ -- the method is sufficiently simple
+ ; checkTc (dm /= GenDefMeth || validGenericMethodType tau)
+ (badGenericMethodType op_name op_ty)
+ }
+ where
+ op_name = idName sel_id
+ op_ty = idType sel_id
+ (_,theta1,tau1) = tcSplitSigmaTy op_ty
+ (_,theta2,tau2) = tcSplitSigmaTy tau1
+ (theta,tau) | gla_exts = (theta1 ++ theta2, tau2)
+ | otherwise = (theta1, mkPhiTy (tail theta1) tau1)
+ -- Ugh! The function might have a type like
+ -- op :: forall a. C a => forall b. (Eq b, Eq a) => tau2
+ -- With -fglasgow-exts, we want to allow this, even though the inner
+ -- forall has an (Eq a) constraint. Whereas in general, each constraint
+ -- in the context of a for-all must mention at least one quantified
+ -- type variable. What a mess!
+
+
+---------------------------------------------------------------------
+resultTypeMisMatch field_name con1 con2
+ = vcat [sep [ptext SLIT("Constructors") <+> ppr con1 <+> ptext SLIT("and") <+> ppr con2,
+ ptext SLIT("have a common field") <+> quotes (ppr field_name) <> comma],
+ nest 2 $ ptext SLIT("but have different result types")]
+fieldTypeMisMatch field_name con1 con2
+ = sep [ptext SLIT("Constructors") <+> ppr con1 <+> ptext SLIT("and") <+> ppr con2,
+ ptext SLIT("give different types for field"), quotes (ppr field_name)]
+
+dataConCtxt con = ptext SLIT("In the definition of data constructor") <+> quotes (ppr con)
+
+classOpCtxt sel_id tau = sep [ptext SLIT("When checking the class method:"),
+ nest 2 (ppr sel_id <+> dcolon <+> ppr tau)]
+
+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"))]
+
+noClassTyVarErr clas op
+ = sep [ptext SLIT("The class method") <+> quotes (ppr op),
+ ptext SLIT("mentions none of the type variables of the class") <+>
+ ppr clas <+> hsep (map ppr (classTyVars clas))]
+
+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, lists, and tuples")])
+
+recSynErr syn_decls
+ = setSrcSpan (getLoc (head sorted_decls)) $
+ addErr (sep [ptext SLIT("Cycle in type synonym declarations:"),
+ nest 2 (vcat (map ppr_decl sorted_decls))])
+ where
+ sorted_decls = sortLocated syn_decls
+ ppr_decl (L loc decl) = ppr loc <> colon <+> ppr decl
+
+recClsErr cls_decls
+ = setSrcSpan (getLoc (head sorted_decls)) $
+ addErr (sep [ptext SLIT("Cycle in class declarations (via superclasses):"),
+ nest 2 (vcat (map ppr_decl sorted_decls))])