+ where
+ syn_ctxt = TySynCtxt name
+ name = tyConName tc
+ syn_rhs = synTyConRhs tc
+ data_cons = tyConDataCons tc
+
+ groups = equivClasses cmp_fld (concatMap get_fields data_cons)
+ cmp_fld (f1,_) (f2,_) = f1 `compare` f2
+ get_fields con = dataConFieldLabels con `zip` repeat con
+ -- dataConFieldLabels may return the empty list, which is fine
+
+ -- XXX - autrijus - Make this far more complex to acommodate
+ -- for different return types. Add res_ty to the mix,
+ -- comparing them in two steps, all for good error messages.
+ -- Plan: Use Unify.tcMatchTys to compare the first candidate's
+ -- result type against other candidates' types (check bothways).
+ -- If they magically agrees, take the substitution and
+ -- apply them to the latter ones, and see if they match perfectly.
+ -- check_fields fields@((first_field_label, field_ty) : other_fields)
+ check_fields fields@((label, con1) : other_fields)
+ -- These fields all have the same name, but are from
+ -- different constructors in the data type
+ = recoverM (return ()) $ mapM_ checkOne other_fields
+ -- 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
+ where
+ tvs1 = mkVarSet (dataConTyVars con1)
+ res1 = dataConResTys con1
+ fty1 = dataConFieldType con1 label
+
+ checkOne (_, con2) -- Do it bothways to ensure they are structurally identical
+ = do { checkFieldCompat label con1 con2 tvs1 res1 res2 fty1 fty2
+ ; checkFieldCompat label con2 con1 tvs2 res2 res1 fty2 fty1 }
+ where
+ tvs2 = mkVarSet (dataConTyVars con2)
+ res2 = dataConResTys con2
+ fty2 = dataConFieldType con2 label
+
+checkFieldCompat fld con1 con2 tvs1 res1 res2 fty1 fty2
+ = do { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2)
+ ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) }
+ where
+ mb_subst1 = tcMatchTys tvs1 res1 res2
+ mb_subst2 = tcMatchTyX tvs1 (expectJust "checkFieldCompat" mb_subst1) fty1 fty2
+
+-------------------------------
+checkValidDataCon :: TyCon -> DataCon -> TcM ()
+checkValidDataCon tc con
+ = setSrcSpan (srcLocSpan (getSrcLoc con)) $
+ addErrCtxt (dataConCtxt con) $
+ do { checkTc (dataConTyCon con == tc) (badDataConTyCon con)
+ ; checkValidType ctxt (idType (dataConWrapId con)) }
+
+ -- This checks the argument types and
+ -- ambiguity of the existential context (if any)
+ --
+ -- Note [Sept 04] Now that tvs is all the tvs, this
+ -- test doesn't actually check anything
+-- ; checkFreeness tvs ex_theta }
+ where
+ ctxt = ConArgCtxt (dataConName con)
+-- (tvs, ex_theta, _, _, _) = dataConSig con
+
+
+-------------------------------
+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