%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 1996-2001, 2003-2012 The University of Melbourne.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%---------------------------------------------------------------------------%
%
% File: check_typeclass.m.
% Author: dgj, mark.
%
% This module checks conformance of instance declarations to the typeclass
% declaration. It takes various steps to do this.
%
% (1) In check_instance_declaration_types/4, we check that each type
% in the instance declaration is either a type with no arguments,
% or a polymorphic type whose arguments are all type variables.
% We also check that all of the types in exported instance declarations are
% in scope here. XXX The latter part should really be done earlier, but with
% the current implementation this is the most convenient spot.
%
% This step also checks that types in instance declarations are not abstract
% exported equivalence types defined in this module. Unfortunately, there is
% no way to check at compile time that it is not an abstract exported
% equivalence type defined in some *other* module.
%
% (2) In check_instance_decls/6, for every method of every instance we
% generate a new pred whose types and modes are as expected by the typeclass
% declaration, and whose body just calls the implementation provided by the
% instance declaration.
%
% For example, given the declarations:
%
% :- typeclass c(T) where [
%   pred m(T::in, T::out) is semidet
% ].
%
% :- instance c(int) where [
%   pred(m/2) is my_m
% ].
%
% we check the correctness of my_m/2 as an implementation of m/2
% by generating the following new predicate:
%
% :- pred 'implementation of m/2'(int::in, int::out) is semidet.
%
% 'implementation of m/2'(HeadVar_1, HeadVar_2) :-
%   my_m(HeadVar_1, HeadVar_2).
%
% By generating the new pred, we check the instance method for type, mode,
% determinism and uniqueness correctness since the generated pred is checked
% in each of those passes too. At this point, we add instance method pred/proc
% ids to the instance table of the HLDS. We also check that there are no
% missing, duplicate or bogus methods.
%
% In this pass we also call check_superclass_conformance/9, which checks that
% all superclass constraints are satisfied by the instance declaration. To do
% this, that predicate attempts to perform context reduction on the typeclass
% constraints, using the instance constraints as assumptions. At this point
% we fill in the super class proofs.
%
% (3) In check_for_cyclic_classes/4, we check for cycles in the typeclass
% hierarchy. A cycle occurs if we can start from any given typeclass
% declaration and follow the superclass constraints on classes to reach the
% same class that we started from. Only the class_id needs to be repeated;
% it doesn't need to have the parameters. Note that we follow the constraints
% on class declarations only, not those on instance declarations. While doing
% this, we fill in the fundeps_ancestors field in the class table.
%
% (4) In check_for_missing_concrete_instances/4, we check that each
% abstract instance has a corresponding concrete instance.
%
% (5) In check_functional_dependencies/4, all visible instances are
% checked for coverage and mutual consistency with respect to any functional
% dependencies. This doesn't necessarily catch all cases of inconsistent
% instances, however, since in general that cannot be done until link time.
% We try to catch as many cases as possible here, though, since we can give
% better error messages.
%
% (6) In check_typeclass_constraints/4, we check typeclass constraints on
% predicate and function declarations and on existentially typed data
% constructors for ambiguity, taking into consideration the information
% provided by functional dependencies. We also call check_constraint_quant/5
% to check that all type variables in constraints are universally quantified,
% or that they are all existentially quantified. We don't support constraints
% where some of the type variables are universal and some are existential.
%
%---------------------------------------------------------------------------%

:- module check_hlds.check_typeclass.
:- interface.

:- import_module hlds.
:- import_module hlds.hlds_module.
:- import_module hlds.make_hlds.
:- import_module parse_tree.
:- import_module parse_tree.error_util.

:- import_module list.

:- pred check_typeclasses(module_info::in, module_info::out,
    make_hlds_qual_info::in, make_hlds_qual_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%

:- implementation.

:- import_module check_hlds.type_util.
:- import_module check_hlds.typeclasses.
:- import_module hlds.add_pred.
:- import_module hlds.hlds_class.
:- import_module hlds.hlds_code_util.
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_error_util.
:- import_module hlds.hlds_pred.
:- import_module hlds.hlds_rtti.
:- import_module hlds.passes_aux.
:- import_module hlds.pred_table.
:- import_module hlds.status.
:- import_module libs.
:- import_module libs.file_util.
:- import_module libs.globals.
:- import_module libs.options.
:- import_module mdbcomp.
:- import_module mdbcomp.prim_data.
:- import_module mdbcomp.sym_name.
:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.parse_tree_out_term.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_type_subst.
:- import_module parse_tree.prog_util.

:- import_module assoc_list.
:- import_module bool.
:- import_module cord.
:- import_module int.
:- import_module map.
:- import_module maybe.
:- import_module multi_map.
:- import_module one_or_more.
:- import_module pair.
:- import_module require.
:- import_module set.
:- import_module string.
:- import_module term.
:- import_module varset.

%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%

check_typeclasses(!ModuleInfo, !QualInfo, !Specs) :-
    module_info_get_globals(!.ModuleInfo, Globals),
    globals.lookup_bool_option(Globals, verbose, Verbose),

    trace [io(!IO)] (
        get_progress_output_stream(!.ModuleInfo, ProgressStream, !IO),
        maybe_write_string(ProgressStream, Verbose,
            "% Checking instance declaration types...\n", !IO)
    ),
    check_instance_declaration_types(!ModuleInfo, !Specs),

    % If we encounter any errors while checking that the types in an
    % instance declaration are valid, then don't attempt the remaining passes.
    % Pass 2 cannot be run since the name mangling scheme we use
    % to generate the names of the method wrapper predicates may abort
    % if the types in an instance are not valid, e.g. if an instance head
    % contains a type variable that is not wrapped inside a functor.
    % Most of the other passes also depend upon information that is
    % calculated during pass 2.
    %
    % XXX It would be better to just remove the invalid instances at this
    % point and then continue on with the valid instances.

    (
        !.Specs = [],
        trace [io(!IO)] (
            get_progress_output_stream(!.ModuleInfo, ProgressStream, !IO),
            maybe_write_string(ProgressStream, Verbose,
                "% Checking typeclass instances...\n", !IO)
        ),
        check_instance_decls(!ModuleInfo, !QualInfo, !Specs),

        trace [io(!IO)] (
            get_progress_output_stream(!.ModuleInfo, ProgressStream, !IO),
            maybe_write_string(ProgressStream, Verbose,
                "% Checking for cyclic classes...\n", !IO)
        ),
        check_for_cyclic_classes(!ModuleInfo, !Specs),

        trace [io(!IO)] (
            get_progress_output_stream(!.ModuleInfo, ProgressStream, !IO),
            maybe_write_string(ProgressStream, Verbose,
                "% Checking for missing concrete instances...\n", !IO)
        ),
        check_for_missing_concrete_instances(!.ModuleInfo, !Specs),

        trace [io(!IO)] (
            get_progress_output_stream(!.ModuleInfo, ProgressStream, !IO),
            maybe_write_string(ProgressStream, Verbose,
                "% Checking functional dependencies on instances...\n", !IO)
        ),
        check_functional_dependencies(!.ModuleInfo, !Specs),

        trace [io(!IO)] (
            get_progress_output_stream(!.ModuleInfo, ProgressStream, !IO),
            maybe_write_string(ProgressStream, Verbose,
                "% Checking typeclass constraints...\n", !IO)
        ),
        check_typeclass_constraints(!.ModuleInfo, !Specs)
    ;
        !.Specs = [_ | _]
    ).

%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%

    % In check_instance_declaration_types/4, we check that each type
    % in the instance declaration must be either a type with no arguments,
    % or a polymorphic type whose arguments are all distinct type variables.
    %
:- pred check_instance_declaration_types(module_info::in, module_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

check_instance_declaration_types(!ModuleInfo, !Specs) :-
    module_info_get_instance_table(!.ModuleInfo, InstanceTable),
    map.foldl(check_instance_declaration_types_for_class(!.ModuleInfo),
        InstanceTable, !Specs).

:- pred check_instance_declaration_types_for_class(module_info::in,
    class_id::in, list(hlds_instance_defn)::in,
    list(error_spec)::in, list(error_spec)::out) is det.

check_instance_declaration_types_for_class(ModuleInfo, ClassId,
        InstanceDefns, !Specs) :-
    list.foldl(
        check_instance_declaration_types_for_instance(ModuleInfo, ClassId),
        InstanceDefns, !Specs).

:- pred check_instance_declaration_types_for_instance(module_info::in,
    class_id::in, hlds_instance_defn::in,
    list(error_spec)::in, list(error_spec)::out) is det.

check_instance_declaration_types_for_instance(ModuleInfo,
        ClassId, InstanceDefn, !Specs) :-
    OriginalTypes = InstanceDefn ^ instdefn_orig_types,
    list.foldl2(is_valid_instance_orig_type(ModuleInfo, ClassId, InstanceDefn),
        OriginalTypes, 1, _, !Specs),
    Types = InstanceDefn ^ instdefn_types,
    list.foldl2(is_valid_instance_type(ModuleInfo, ClassId, InstanceDefn),
        Types, 1, _, !Specs).

:- pred is_valid_instance_orig_type(module_info::in,
    class_id::in, hlds_instance_defn::in, mer_type::in,
    int::in, int::out, list(error_spec)::in, list(error_spec)::out) is det.

is_valid_instance_orig_type(ModuleInfo, ClassId, InstanceDefn, Type,
        N, N+1, !Specs) :-
    (
        Type = defined_type(_TypeName, _, _),
        ( if type_to_type_defn(ModuleInfo, Type, TypeDefn) then
            get_type_defn_body(TypeDefn, TypeBody),
            (
                TypeBody = hlds_eqv_type(_),
                get_type_defn_status(TypeDefn, TypeDefnStatus),
                ( if
                    TypeDefnStatus = type_status(status_abstract_exported),
                    % If the instance definition is itself abstract exported,
                    % we want to generate only one error message, instead of
                    % two error messages, one for the abstract and one for the
                    % concrete instance definition.
                    InstanceDefn ^ instdefn_body = instance_body_concrete(_)
                then
                    Spec = abstract_eqv_instance_type_msg(ClassId,
                        InstanceDefn, N, Type),
                    !:Specs = [Spec | !.Specs]
                else
                    true
                )
            ;
                ( TypeBody = hlds_du_type(_)
                ; TypeBody = hlds_foreign_type(_)
                ; TypeBody = hlds_solver_type(_)
                ; TypeBody = hlds_abstract_type(_)
                )
            )
        else
            % The type is either a builtin type or a type variable.
            true
        )
    ;
        ( Type = builtin_type(_)
        ; Type = higher_order_type(_, _, _, _, _)
        ; Type = apply_n_type(_, _, _)
        ; Type = type_variable(_, _)
        ; Type = tuple_type(_, _)
        )
    ;
        Type = kinded_type(_, _),
        unexpected("check_typeclass", "kinded_type")
    ).

    % Each of these types in the instance declaration must be either
    % (a) a type with no arguments, or (b) a polymorphic type whose arguments
    % are all distinct type variables.
    %
:- pred is_valid_instance_type(module_info::in,
    class_id::in, hlds_instance_defn::in, mer_type::in,
    int::in, int::out, list(error_spec)::in, list(error_spec)::out) is det.

is_valid_instance_type(ModuleInfo, ClassId, InstanceDefn, Type,
        N, N+1, !Specs) :-
    (
        Type = builtin_type(_)
    ;
        (
            Type = higher_order_type(_, _, _, _, _),
            KindPiece = words("is a higher order type;")
        ;
            Type = apply_n_type(_, _, _),
            KindPiece = words("is an apply/N type;")
        ;
            Type = type_variable(_, _),
            KindPiece = words("is a type variable;")
        ),
        TVarSet = InstanceDefn ^ instdefn_tvarset,
        TypeStr = mercury_type_to_string(TVarSet, print_name_only, Type),
        EndPieces = [words("the"), nth_fixed(N), words("instance type"),
            quote(TypeStr), KindPiece, words("it should be"),
            words("a type constructor applied to zero or more"),
            words("type variables."), nl],
        Spec = bad_instance_type_msg(ClassId, InstanceDefn, EndPieces,
            badly_formed),
        !:Specs = [Spec | !.Specs]
    ;
        Type = tuple_type(ArgTypes, _),
        find_non_type_variables(ArgTypes, 1, NonTVarArgs),
        (
            NonTVarArgs = []
        ;
            NonTVarArgs = [_ | _],
            TypeCtor =
                type_ctor(unqualified("{}"), list.length(ArgTypes)),
            Spec = badly_formed_instance_type_msg(ClassId, InstanceDefn,
                N, TypeCtor, NonTVarArgs),
            !:Specs = [Spec | !.Specs]
        )
    ;
        Type = defined_type(TypeName, ArgTypes, _),
        find_non_type_variables(ArgTypes, 1, NonTVarArgs),
        (
            NonTVarArgs = [],
            ( if type_to_type_defn(ModuleInfo, Type, TypeDefn) then
                get_type_defn_body(TypeDefn, TypeBody),
                (
                    TypeBody = hlds_eqv_type(EqvType),
                    is_valid_instance_type(ModuleInfo, ClassId, InstanceDefn,
                        EqvType, N, _, !Specs)
                ;
                    ( TypeBody = hlds_du_type(_)
                    ; TypeBody = hlds_foreign_type(_)
                    ; TypeBody = hlds_solver_type(_)
                    ; TypeBody = hlds_abstract_type(_)
                    )
                )
            else
                % The type is either a builtin type or a type variable.
                true
            )
        ;
            NonTVarArgs = [_ | _],
            TypeCtor = type_ctor(TypeName, list.length(ArgTypes)),
            Spec = badly_formed_instance_type_msg(ClassId, InstanceDefn,
                N, TypeCtor, NonTVarArgs),
            !:Specs = [Spec | !.Specs]
        )
    ;
        Type = kinded_type(_, _),
        unexpected("check_typeclass", "kinded_type")
    ).

:- pred find_non_type_variables(list(mer_type)::in, int::in,
    assoc_list(int, mer_type)::out) is det.

find_non_type_variables([], _, []).
find_non_type_variables([ArgType | ArgTypes], ArgNum, NonTVarArgs) :-
    find_non_type_variables(ArgTypes, ArgNum + 1, TailNonTVarArgs),
    (
        ArgType = type_variable(_, _),
        NonTVarArgs = TailNonTVarArgs
    ;
        ( ArgType = defined_type(_, _, _)
        ; ArgType = builtin_type(_)
        ; ArgType = higher_order_type(_, _, _, _, _)
        ; ArgType = tuple_type(_, _)
        ; ArgType = apply_n_type(_, _, _)
        ; ArgType = kinded_type(_, _)
        ),
        NonTVarArgs = [ArgNum - ArgType | TailNonTVarArgs]
    ).

:- func badly_formed_instance_type_msg(class_id, hlds_instance_defn, int,
    type_ctor, assoc_list(int, mer_type)) = error_spec.

badly_formed_instance_type_msg(ClassId, InstanceDefn, N, TypeCtor,
        NonTVarArgs) = Spec :-
    TVarSet = InstanceDefn ^ instdefn_tvarset,
    NonTVarArgPieceLists =
        list.map(non_tvar_arg_to_pieces(TVarSet), NonTVarArgs),
    NonTVarArgPieces = component_lists_to_pieces("and", NonTVarArgPieceLists),
    EndPieces = [words("in the"), nth_fixed(N), words("instance type,"),
        words(choose_number(NonTVarArgs, "one", "some")),
        words("of the arguments of the type constructor"),
        unqual_type_ctor(TypeCtor),
        words(choose_number(NonTVarArgs,
            "is not a type variable, but should be. This is",
            "are not type variables, but should be. These are"))
        | NonTVarArgPieces] ++ [suffix("."), nl],
    Spec = bad_instance_type_msg(ClassId, InstanceDefn, EndPieces,
        badly_formed).

:- func non_tvar_arg_to_pieces(tvarset, pair(int, mer_type))
    = list(format_component).

non_tvar_arg_to_pieces(TVarSet, ArgNum - ArgType) = Pieces :-
    TypeStr = mercury_type_to_string(TVarSet, print_name_only, ArgType),
    Pieces = [words("the"), nth_fixed(ArgNum), words("argument,"),
        quote(TypeStr)].

:- func abstract_eqv_instance_type_msg(class_id, hlds_instance_defn, int,
    mer_type) = error_spec.

abstract_eqv_instance_type_msg(ClassId, InstanceDefn, N, Type) = Spec :-
    TVarSet = InstanceDefn ^ instdefn_tvarset,
    TypeStr = mercury_type_to_string(TVarSet, print_name_only, Type),
    EndPieces = [words("the"), nth_fixed(N), words("instance type"),
        quote(TypeStr), words("is an abstract exported equivalence type."),
        nl],
    Spec = bad_instance_type_msg(ClassId, InstanceDefn, EndPieces,
        abstract_exported_eqv).

:- type bad_instance_type_kind
    --->    badly_formed
    ;       abstract_exported_eqv.

:- func bad_instance_type_msg(class_id, hlds_instance_defn,
    list(format_component), bad_instance_type_kind) = error_spec.

bad_instance_type_msg(ClassId, InstanceDefn, EndPieces, Kind) = Spec :-
    ClassId = class_id(ClassName, _),
    ClassNameString = unqualify_name(ClassName),

    InstanceVarSet = InstanceDefn ^ instdefn_tvarset,
    InstanceContext = InstanceDefn ^ instdefn_context,
    (
        Kind = badly_formed,
        % We are generating the error message because the type is badly formed
        % as expanded. The unexpanded version may be correctly formed.
        InstanceTypes = InstanceDefn ^ instdefn_types
    ;
        Kind = abstract_exported_eqv,
        % Messages about the expanded type being an equivalence type
        % would not make sense.
        InstanceTypes = InstanceDefn ^ instdefn_orig_types
    ),
    % XXX Removing the module qualification from the type constructors
    % in InstanceTypes before converting them to strings would make
    % the error message less cluttered.
    InstanceTypesString = mercury_type_list_to_string(InstanceVarSet,
        InstanceTypes),

    HeaderPieces = [words("In instance declaration for"),
        words_quote(ClassNameString ++ "(" ++ InstanceTypesString ++ ")"),
        suffix(":"), nl],
    (
        Kind = abstract_exported_eqv,
        HeadingMsg = simple_msg(InstanceContext,
            [always(HeaderPieces), always(EndPieces)])
    ;
        Kind = badly_formed,
        VerbosePieces =
            [words("(Every type in an instance declaration must consist of"),
            words("a type constructor applied to zero or more type variables"),
            words("as arguments.)"), nl],
        HeadingMsg = simple_msg(InstanceContext,
            [always(HeaderPieces), always(EndPieces),
            verbose_only(verbose_once, VerbosePieces)])
    ),
    Spec = error_spec($pred, severity_error, phase_type_check, [HeadingMsg]).

%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%

:- pred check_instance_decls(module_info::in, module_info::out,
    make_hlds_qual_info::in, make_hlds_qual_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

check_instance_decls(!ModuleInfo, !QualInfo, !Specs) :-
    module_info_get_class_table(!.ModuleInfo, ClassTable),
    module_info_get_instance_table(!.ModuleInfo, InstanceTable0),
    map.map_foldl3(check_one_class(ClassTable), InstanceTable0, InstanceTable,
        !ModuleInfo, !QualInfo, [], NewSpecs),
    module_info_get_globals(!.ModuleInfo, Globals),
    Errors = contains_errors(Globals, NewSpecs),
    (
        Errors = no,
        module_info_set_instance_table(InstanceTable, !ModuleInfo)
    ;
        Errors = yes
    ),
    !:Specs = NewSpecs ++ !.Specs.

    % Check all the instances of one class.
    %
:- pred check_one_class(class_table::in, class_id::in,
    list(hlds_instance_defn)::in, list(hlds_instance_defn)::out,
    module_info::in, module_info::out,
    make_hlds_qual_info::in, make_hlds_qual_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

check_one_class(ClassTable, ClassId, InstanceDefns0, InstanceDefns,
        !ModuleInfo, !QualInfo, !Specs) :-
    map.lookup(ClassTable, ClassId, ClassDefn),
    ClassDefn = hlds_class_defn(TypeClassStatus, SuperClasses, _FunDeps,
        _Ancestors, ClassVars, _Kinds, Interface, ClassInterface,
        ClassVarSet, ClassContext, MaybeBadDefn),
    ( if
        typeclass_status_defined_in_this_module(TypeClassStatus) = yes,
        Interface = class_interface_abstract
    then
        (
            MaybeBadDefn = has_no_bad_class_defn,
            Pieces = [words("Error: no definition for typeclass"),
                unqual_class_id(ClassId), suffix("."), nl],
            Spec = simplest_spec($pred, severity_error, phase_type_check,
                ClassContext, Pieces),
            !:Specs = [Spec | !.Specs]
        ;
            MaybeBadDefn = has_bad_class_defn
            % If the class had a definition that was not added to the HLDS
            % because it had an error in it, reporting that the class
            % has *no* definition would be misleading.
        ),
        InstanceDefns = InstanceDefns0
    else
        ClassProcPredIds0 = list.map(
            pred_proc_id_project_pred_id, ClassInterface),
        list.sort_and_remove_dups(ClassProcPredIds0, ClassProcPredIds),
        list.map_foldl3(
            check_class_instance(ClassId, SuperClasses, ClassVars,
                ClassInterface, Interface, ClassVarSet, ClassProcPredIds),
            InstanceDefns0, InstanceDefns,
            !ModuleInfo, !QualInfo, !Specs)
    ).

    % Check one instance of one class.
    %
:- pred check_class_instance(class_id::in, list(prog_constraint)::in,
    list(tvar)::in, hlds_class_interface::in, class_interface::in,
    tvarset::in, list(pred_id)::in,
    hlds_instance_defn::in, hlds_instance_defn::out,
    module_info::in, module_info::out,
    make_hlds_qual_info::in, make_hlds_qual_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

check_class_instance(ClassId, SuperClasses, Vars, HLDSClassInterface,
        ClassInterface, ClassVarSet, ClassPredIds, !InstanceDefn,
        !ModuleInfo, !QualInfo, !Specs):-
    % Check conformance of the instance body.
    !.InstanceDefn = hlds_instance_defn(_, _, _, _, TermContext, _,
        InstanceBody, _, _, _),
    (
        InstanceBody = instance_body_abstract
    ;
        InstanceBody = instance_body_concrete(InstanceMethods),
        check_concrete_class_instance(ClassId, Vars,
            HLDSClassInterface, ClassInterface,
            ClassPredIds, TermContext, InstanceMethods,
            !InstanceDefn, !ModuleInfo, !QualInfo, !Specs)
    ),
    % Check that the superclass constraints are satisfied for the types
    % in this instance declaration.
    check_superclass_conformance(ClassId, SuperClasses, Vars, ClassVarSet,
        !.ModuleInfo, !InstanceDefn, !Specs).

:- pred check_concrete_class_instance(class_id::in, list(tvar)::in,
    hlds_class_interface::in, class_interface::in,
    list(pred_id)::in, term.context::in,
    list(instance_method)::in, hlds_instance_defn::in, hlds_instance_defn::out,
    module_info::in, module_info::out,
    make_hlds_qual_info::in, make_hlds_qual_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

check_concrete_class_instance(ClassId, Vars, HLDSClassInterface,
        ClassInterface, ClassPredIds, TermContext, InstanceMethods,
        !InstanceDefn, !ModuleInfo, !QualInfo, !Specs) :-
    (
        ClassInterface = class_interface_abstract,
        Pieces = [words("Error: instance declaration for abstract typeclass"),
            unqual_class_id(ClassId), suffix("."), nl],
        Spec = simplest_spec($pred, severity_error, phase_type_check,
            TermContext, Pieces),
        !:Specs = [Spec | !.Specs]
    ;
        ClassInterface = class_interface_concrete(_),
        list.foldl5(check_instance_pred(ClassId, Vars, HLDSClassInterface),
            ClassPredIds, !InstanceDefn, [], RevInstanceMethods,
            !ModuleInfo, !QualInfo, !Specs),

        % We need to make sure that the MaybePredProcs field is set to yes(_)
        % after this pass. Normally that will be handled by
        % check_instance_pred, but we also need to handle it below,
        % in case the class has no methods.
        MaybePredProcs1 = !.InstanceDefn ^ instdefn_hlds_interface,
        (
            MaybePredProcs1 = yes(_),
            MaybePredProcs = MaybePredProcs1
        ;
            MaybePredProcs1 = no,
            MaybePredProcs = yes([])
        ),

        % Make sure the list of instance methods is in the same order
        % as the methods in the class definition. intermod.m relies on this.
        OrderedInstanceMethods = list.reverse(RevInstanceMethods),

        !InstanceDefn ^ instdefn_hlds_interface := MaybePredProcs,
        !InstanceDefn ^ instdefn_body :=
            instance_body_concrete(OrderedInstanceMethods),

        % Check if there are any instance methods left over, which did not
        % match any of the methods from the class interface.
        % XXX This is not a check for *left over* methods, since we don't
        % subtract the methods we have successfully processed from any
        % initial InstanceMethods.
        Context = !.InstanceDefn ^ instdefn_context,
        check_for_unknown_methods(InstanceMethods, ClassId, ClassPredIds,
            Context, !.ModuleInfo, !Specs)
    ).

    % Check if there are any instance methods left over, which did not match
    % any of the methods from the class interface. If so, add an appropriate
    % error message to the list of error messages.
    %
:- pred check_for_unknown_methods(list(instance_method)::in, class_id::in,
    list(pred_id)::in, prog_context::in, module_info::in,
    list(error_spec)::in, list(error_spec)::out) is det.

check_for_unknown_methods(InstanceMethods, ClassId, ClassPredIds, Context,
        ModuleInfo, !Specs) :-
    module_info_get_predicate_table(ModuleInfo, PredTable),
    list.filter(method_is_known(PredTable, ClassPredIds), InstanceMethods,
        _KnownInstanceMethods, UnknownInstanceMethods),
    (
        UnknownInstanceMethods = []
    ;
        UnknownInstanceMethods = [HeadMethod | TailMethods],
        report_unknown_instance_methods(ClassId, HeadMethod, TailMethods,
            Context, !Specs)
    ).

:- pred method_is_known(predicate_table::in, list(pred_id)::in,
    instance_method::in) is semidet.

method_is_known(PredTable, ClassPredIds, Method) :-
    % Find this method definition's p/f, name, arity.
    Method = instance_method(MethodPredOrFunc, MethodName, _MethodDefn,
        MethodArity, _Context),
    % Search for pred_ids matching that p/f, name, arity, and succeed
    % if the method definition p/f, name, and arity matches at least one
    % of the methods from the class interface.
    adjust_func_arity(MethodPredOrFunc, MethodArity, MethodPredArity),
    predicate_table_lookup_pf_sym_arity(PredTable, is_fully_qualified,
        MethodPredOrFunc, MethodName, MethodPredArity, MatchingPredIds),
    some [PredId] (
        list.member(PredId, MatchingPredIds),
        list.member(PredId, ClassPredIds)
    ).

%---------------------------------------------------------------------------%

    % Check one pred in one instance of one class.
    %
:- pred check_instance_pred(class_id::in, list(tvar)::in,
    hlds_class_interface::in, pred_id::in,
    hlds_instance_defn::in, hlds_instance_defn::out,
    list(instance_method)::in, list(instance_method)::out,
    module_info::in, module_info::out,
    make_hlds_qual_info::in, make_hlds_qual_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

check_instance_pred(ClassId, ClassVars, ClassInterface, PredId,
        InstanceDefn0, InstanceDefn, !RevOrderedMethods,
        !ModuleInfo, !QualInfo, !Specs) :-
    GetClassProcProcId =
        ( pred(ClassProc::in, ClassProcProcId::out) is semidet :-
            ClassProc = proc(PredId, ClassProcProcId)
        ),
    list.filter_map(GetClassProcProcId, ClassInterface, ClassProcProcIds0),
    list.sort_and_remove_dups(ClassProcProcIds0, ClassProcProcIds),
    module_info_pred_info(!.ModuleInfo, PredId, PredInfo),
    pred_info_get_arg_types(PredInfo, ArgTypeVars, ExistQVars, ArgTypes),
    pred_info_get_class_context(PredInfo, ClassContext0),
    pred_info_get_markers(PredInfo, Markers0),
    remove_marker(marker_class_method, Markers0, Markers),
    % The first constraint in the class context of a class method is always
    % the constraint for the class of which it is a member. Seeing that we are
    % checking an instance declaration, we don't check that constraint...
    % the instance declaration itself satisfies it!
    ( if ClassContext0 = constraints([_ | OtherUnivCs], ExistCs) then
        UnivCs = OtherUnivCs,
        ClassContext = constraints(UnivCs, ExistCs)
    else
        unexpected($pred, "no constraint on class method")
    ),
    MethodName0 = pred_info_name(PredInfo),
    PredModule = pred_info_module(PredInfo),
    MethodName = qualified(PredModule, MethodName0),
    PredArity = pred_info_orig_arity(PredInfo),
    PredOrFunc = pred_info_is_pred_or_func(PredInfo),
    adjust_func_arity(PredOrFunc, Arity, PredArity),
    pred_info_get_proc_table(PredInfo, ProcTable),
    list.map(
        ( pred(TheProcId::in, ModesAndDetism::out) is det :-
            map.lookup(ProcTable, TheProcId, ProcInfo),
            proc_info_get_argmodes(ProcInfo, Modes),
            % If the determinism declaration on the method was omitted,
            % then make_hlds will have already issued an error message,
            % so don't complain here.
            proc_info_get_declared_determinism(ProcInfo, MaybeDetism),
            proc_info_get_inst_varset(ProcInfo, InstVarSet),
            ModesAndDetism = modes_and_detism(Modes, InstVarSet, MaybeDetism)
        ), ClassProcProcIds, ArgModes),

    InstanceDefn0 = hlds_instance_defn(_, InstanceTypes, _, InstanceStatus,
        _, _, _, _, _, _),

    % Work out the name of the predicate that we will generate
    % to check this instance method.
    make_introduced_pred_name(ClassId, MethodName, Arity,
        InstanceTypes, PredName),

    CheckInfo0 = check_instance_method_info(PredOrFunc, PredName, Arity,
        ExistQVars, ArgTypes, ClassContext, ArgModes, ArgTypeVars,
        InstanceStatus),
    check_instance_pred_procs(ClassId, ClassVars, MethodName, Markers,
        CheckInfo0, InstanceDefn0, InstanceDefn, !RevOrderedMethods,
        !ModuleInfo, !QualInfo, !Specs).

%---------------------------------------------------------------------------%

    % This structure holds the information we need to check
    % a particular instance method.
:- type check_instance_method_info
    --->    check_instance_method_info(
                % Is the method pred or func?
                cimi_method_pred_or_func    :: pred_or_func,

                % Name that the introduced pred should be given.
                cimi_introduced_pred_name   :: sym_name,

                % Arity of the method. (For funcs, this is the original arity,
                % not the arity as a predicate.)
                cimi_method_arity           :: arity,

                % Existentially quantified type variables.
                cimi_existq_tvars           :: existq_tvars,

                % Expected types of arguments.
                cimi_expected_arg_types     :: list(mer_type),

                % Constraints from class method.
                cimi_method_constraints     :: prog_constraints,

                % Modes and determinisms of the required procs.
                cimi_modes_and_detism       :: list(modes_and_detism),

                cimi_tvarset                :: tvarset,

                % Import status of instance decl.
                cimi_import_status          :: instance_status
            ).

:- type modes_and_detism
    --->    modes_and_detism(
                list(mer_mode),
                inst_varset,
                maybe(determinism)
            ).

:- pred check_instance_pred_procs(class_id::in, list(tvar)::in, sym_name::in,
    pred_markers::in, check_instance_method_info::in,
    hlds_instance_defn::in, hlds_instance_defn::out,
    list(instance_method)::in, list(instance_method)::out,
    module_info::in, module_info::out,
    make_hlds_qual_info::in, make_hlds_qual_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

check_instance_pred_procs(ClassId, ClassVars, MethodName, Markers,
        CheckInfo, InstanceDefn0, InstanceDefn,
        !RevInstanceMethods, !ModuleInfo, !QualInfo, !Specs) :-
    InstanceDefn0 = hlds_instance_defn(InstanceModuleName,
        InstanceTypes, _OriginalTypes, _InstanceStatus, _InstanceContext,
        InstanceConstraints, InstanceBody, MaybeInstancePredProcs,
        InstanceVarSet, _InstanceProofs),
    PredOrFunc = CheckInfo ^ cimi_method_pred_or_func,
    Arity = CheckInfo ^ cimi_method_arity,
    get_matching_instance_defns(InstanceBody, PredOrFunc, MethodName, Arity,
        MatchingInstanceMethods),
    (
        MatchingInstanceMethods = [InstanceMethod],
        !:RevInstanceMethods = [InstanceMethod | !.RevInstanceMethods],
        InstanceMethod = instance_method(_, _, InstancePredDefn, _, Context),
        produce_auxiliary_procs(ClassId, ClassVars, MethodName, Markers,
            InstanceTypes, InstanceConstraints,
            InstanceVarSet, InstanceModuleName,
            InstancePredDefn, Context,
            InstancePredId, InstanceProcIds,
            CheckInfo, !ModuleInfo, !QualInfo, !Specs),
        MakeClassProc =
            ( pred(TheProcId::in, PredProcId::out) is det :-
                PredProcId = proc(InstancePredId, TheProcId)
            ),
        list.map(MakeClassProc, InstanceProcIds, InstancePredProcs1),
        (
            MaybeInstancePredProcs = yes(InstancePredProcs0),
            InstancePredProcs = InstancePredProcs0 ++ InstancePredProcs1
        ;
            MaybeInstancePredProcs = no,
            InstancePredProcs = InstancePredProcs1
        ),
        InstanceDefn = InstanceDefn0
            ^ instdefn_hlds_interface := yes(InstancePredProcs)
    ;
        MatchingInstanceMethods = [_, _ | _],
        InstanceDefn = InstanceDefn0,
        report_duplicate_method_defn(ClassId, InstanceDefn0, PredOrFunc,
            MethodName, Arity, MatchingInstanceMethods, !Specs)
    ;
        MatchingInstanceMethods = [],
        InstanceDefn = InstanceDefn0,
        report_undefined_method(ClassId, InstanceDefn0, PredOrFunc,
            MethodName, Arity, !Specs)
    ).

    % Get all the instance definitions which match the specified
    % predicate/function name/arity, with multiple clause definitions
    % being combined into a single definition.
    %
:- pred get_matching_instance_defns(instance_body::in, pred_or_func::in,
    sym_name::in, arity::in, list(instance_method)::out) is det.

get_matching_instance_defns(instance_body_abstract, _, _, _, []).
get_matching_instance_defns(instance_body_concrete(InstanceMethods),
        PredOrFunc, MethodName, MethodArity, ResultList) :-
    % First find the instance method definitions that match this
    % predicate/function's name and arity
    list.filter(
        ( pred(Method::in) is semidet :-
            Method = instance_method(PredOrFunc, MethodName, _MethodDefn,
                MethodArity, _Context)
        ),
        InstanceMethods, MatchingMethods),
    ( if
        MatchingMethods = [First, _Second | _],
        FirstContext = First ^ instance_method_decl_context,
        not (
            list.member(DefnViaName, MatchingMethods),
            DefnViaName = instance_method(_, _, InstanceProcDef, _, _),
            InstanceProcDef = DefnViaName ^ instance_method_proc_def,
            InstanceProcDef = instance_proc_def_name(_)
        )
    then
        % If all of the instance method definitions for this pred/func
        % are clauses, and there are more than one of them, then we must
        % combine them all into a single definition.
        MethodToClause =
            ( pred(Method::in, Clauses::out) is semidet :-
                Method = instance_method(_, _, Defn, _, _),
                Defn = instance_proc_def_clauses(Clauses)
            ),
        list.filter_map(MethodToClause, MatchingMethods, ClausesList),
        list.condense(ClausesList, FlattenedClauses),
        CombinedMethod = instance_method(PredOrFunc, MethodName,
            instance_proc_def_clauses(FlattenedClauses), MethodArity,
            FirstContext),
        ResultList = [CombinedMethod]
    else
        % If there are less than two matching method definitions,
        % or if any of the instance method definitions is a method name,
        % then we are done.
        ResultList = MatchingMethods
    ).

:- pred produce_auxiliary_procs(class_id::in, list(tvar)::in, sym_name::in,
    pred_markers::in, list(mer_type)::in, list(prog_constraint)::in,
    tvarset::in, module_name::in, instance_proc_def::in, prog_context::in,
    pred_id::out, list(proc_id)::out,
    check_instance_method_info::in, module_info::in, module_info::out,
    make_hlds_qual_info::in, make_hlds_qual_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

produce_auxiliary_procs(ClassId, ClassVars, MethodName, Markers0,
        InstanceTypes0, InstanceConstraints0, InstanceVarSet,
        InstanceModuleName, InstancePredDefn, Context, PredId, InstanceProcIds,
        CheckInfo0, !ModuleInfo, !QualInfo, !Specs) :-
    CheckInfo0 = check_instance_method_info(PredOrFunc, PredName, Arity,
        ExistQVars0, ArgTypes0, ClassMethodClassContext0, ArgModes,
        TVarSet0, InstanceStatus0),
    UnsubstArgTypes = ArgTypes0,

    % Rename the instance variables apart from the class variables.
    tvarset_merge_renaming(TVarSet0, InstanceVarSet, TVarSet1, Renaming),
    apply_variable_renaming_to_type_list(Renaming, InstanceTypes0,
        InstanceTypes1),
    apply_variable_renaming_to_prog_constraint_list(Renaming,
        InstanceConstraints0, InstanceConstraints1),

    % Work out what the type variables are bound to for this
    % instance, and update the class types appropriately.
    map.from_corresponding_lists(ClassVars, InstanceTypes1, TypeSubst),
    apply_subst_to_type_list(TypeSubst, ArgTypes0, ArgTypes1),
    apply_subst_to_prog_constraints(TypeSubst, ClassMethodClassContext0,
        ClassMethodClassContext1),

    % Calculate which type variables we need to keep. This includes all
    % type variables appearing in the arguments, the class method context and
    % the instance constraints. (Type variables in the existq_tvars must
    % occur either in the argument types or in the class method context;
    % type variables in the instance types must appear in the arguments.)
    type_vars_list(ArgTypes1, ArgTVars),
    prog_constraints_get_tvars(ClassMethodClassContext1, MethodContextTVars),
    constraint_list_get_tvars(InstanceConstraints1, InstanceTVars),
    list.condense([ArgTVars, MethodContextTVars, InstanceTVars], VarsToKeep0),
    list.sort_and_remove_dups(VarsToKeep0, VarsToKeep),

    % Project away the unwanted type variables.
    varset.squash(TVarSet1, VarsToKeep, TVarSet2, SquashSubst),
    apply_variable_renaming_to_type_list(SquashSubst, ArgTypes1, ArgTypes),
    apply_variable_renaming_to_prog_constraints(SquashSubst,
        ClassMethodClassContext1, ClassMethodClassContext),
    apply_partial_map_to_list(SquashSubst, ExistQVars0, ExistQVars),
    apply_variable_renaming_to_type_list(SquashSubst, InstanceTypes1,
        InstanceTypes),
    apply_variable_renaming_to_prog_constraint_list(SquashSubst,
        InstanceConstraints1, InstanceConstraints),

    % Add the constraints from the instance declaration to the constraints
    % from the class method. This allows an instance method to have constraints
    % on it which are not part of the instance declaration as a whole.
    ClassMethodClassContext = constraints(UnivConstraints1, ExistConstraints),
    list.append(InstanceConstraints, UnivConstraints1, UnivConstraints),
    ClassContext = constraints(UnivConstraints, ExistConstraints),

    % Introduce a new predicate which calls the implementation
    % given in the instance declaration.
    map.init(Proofs),
    map.init(ConstraintMap),
    add_marker(marker_class_instance_method, Markers0, Markers1),
    (
        InstancePredDefn = instance_proc_def_name(_),
        % For instance methods which are defined using the named syntax
        % (e.g. "pred(...) is ...") rather than the clauses syntax, we record
        % an additional marker; the only effect of this marker is that we
        % output slightly different error messages for such predicates.
        add_marker(marker_named_class_instance_method, Markers1, Markers)
    ;
        InstancePredDefn = instance_proc_def_clauses(_),
        Markers = Markers1
    ),

    IsImported = instance_status_is_imported(InstanceStatus0),
    (
        IsImported = yes,
        InstanceStatus = instance_status(status_opt_imported)
    ;
        IsImported = no,
        InstanceStatus = InstanceStatus0
    ),

    adjust_func_arity(PredOrFunc, Arity, PredArity),
    produce_instance_method_clauses(InstancePredDefn, PredOrFunc,
        PredArity, ArgTypes, Markers, Context, InstanceStatus, ClausesInfo,
        TVarSet2, TVarSet, !ModuleInfo, !QualInfo, !Specs),

    % Fill in some information in the pred_info which is used by polymorphism
    % to make sure the type-infos and typeclass-infos are added in the correct
    % order.
    MethodConstraints = instance_method_constraints(ClassId,
        InstanceTypes, InstanceConstraints, ClassMethodClassContext),
    PredOrigin = origin_instance_method(MethodName, MethodConstraints),
    map.init(VarNameRemap),
    % XXX STATUS
    InstanceStatus = instance_status(OldImportStatus),
    PredStatus = pred_status(OldImportStatus),
    CurUserDecl = maybe.no,
    GoalType = goal_not_for_promise(np_goal_type_none),
    pred_info_init(InstanceModuleName, PredName, PredArity, PredOrFunc,
        Context, PredOrigin, PredStatus, CurUserDecl, GoalType, Markers,
        ArgTypes, TVarSet, ExistQVars, ClassContext, Proofs, ConstraintMap,
        ClausesInfo, VarNameRemap, PredInfo0),
    pred_info_set_clauses_info(ClausesInfo, PredInfo0, PredInfo1),
    pred_info_set_instance_method_arg_types(UnsubstArgTypes,
        PredInfo1, PredInfo2),

    % Add procs with the expected modes and determinisms.
    AddProc =
        ( pred(ModeAndDet::in, NewProcId::out,
                OldPredInfo::in, NewPredInfo::out) is det :-
            ModeAndDet = modes_and_detism(Modes, InstVarSet, MaybeDet),
            ItemNumber = item_no_seq_num,
            % Before the simplification pass, HasParallelConj
            % is not meaningful.
            HasParallelConj = has_no_parallel_conj,
            add_new_proc(Context, ItemNumber, PredArity,
                InstVarSet, Modes, yes(Modes), no, detism_decl_implicit,
                MaybeDet, address_is_taken, HasParallelConj,
                OldPredInfo, NewPredInfo, NewProcId)
        ),
    list.map_foldl(AddProc, ArgModes, InstanceProcIds, PredInfo2, PredInfo),

    module_info_get_predicate_table(!.ModuleInfo, PredicateTable1),
    module_info_get_partial_qualifier_info(!.ModuleInfo, PQInfo),
    % XXX Why do we need to pass may_be_unqualified here, rather than passing
    % must_be_qualified or calling the predicate_table_insert/4 version?
    predicate_table_insert_qual(PredInfo, may_be_unqualified, PQInfo, PredId,
        PredicateTable1, PredicateTable),
    module_info_set_predicate_table(PredicateTable, !ModuleInfo).

%---------------------------------------------------------------------------%

    % Make the name of the introduced pred used to check a particular
    % instance of a particular class method
    %
    % XXX This isn't quite perfect, I suspect
    %
:- pred make_introduced_pred_name(class_id::in, sym_name::in, arity::in,
    list(mer_type)::in, sym_name::out) is det.

make_introduced_pred_name(ClassId, MethodName, Arity, InstanceTypes,
        PredName) :-
    ClassId = class_id(ClassName, _ClassArity),
    ClassNameString = sym_name_to_string_sep(ClassName, "__"),
    MethodNameString = sym_name_to_string_sep(MethodName, "__"),
    % Perhaps we should include the arity in this mangled string?
    string.int_to_string(Arity, ArityString),
    make_instance_string(InstanceTypes, InstanceString),
    string.append_list(
        [introduced_pred_name_prefix,
        ClassNameString, "____",
        InstanceString, "____",
        MethodNameString, "_",
        ArityString],
        PredNameString),
    PredName = unqualified(PredNameString).

    % The prefix added to the class method name for the predicate
    % used to call a class method for a specific instance.
    %
:- func introduced_pred_name_prefix = string.

introduced_pred_name_prefix = "ClassMethod_for_".

%---------------------------------------------------------------------------%

    % Check that the superclass constraints are satisfied for the
    % types in this instance declaration.
    %
:- pred check_superclass_conformance(class_id::in, list(prog_constraint)::in,
    list(tvar)::in, tvarset::in, module_info::in,
    hlds_instance_defn::in, hlds_instance_defn::out,
    list(error_spec)::in, list(error_spec)::out) is det.

check_superclass_conformance(ClassId, ProgSuperClasses0, ClassVars0,
        ClassVarSet, ModuleInfo, InstanceDefn0, InstanceDefn, !Specs) :-
    InstanceDefn0 = hlds_instance_defn(ModuleName,
        InstanceTypes, OriginalTypes, Status, Context, InstanceProgConstraints,
        Body, Interface, InstanceVarSet0, Proofs0),
    tvarset_merge_renaming(InstanceVarSet0, ClassVarSet, InstanceVarSet1,
        Renaming),

    % Make the constraints in terms of the instance variables.
    apply_variable_renaming_to_prog_constraint_list(Renaming,
        ProgSuperClasses0, ProgSuperClasses),

    % Now handle the class variables.
    apply_variable_renaming_to_tvar_list(Renaming, ClassVars0, ClassVars),

    % Calculate the bindings.
    map.from_corresponding_lists(ClassVars, InstanceTypes, TypeSubst),

    module_info_get_class_table(ModuleInfo, ClassTable),
    module_info_get_instance_table(ModuleInfo, InstanceTable),

    % Build a suitable constraint context for checking the instance.
    % To do this, we assume any constraints on the instance declaration
    % (that is, treat them as universal constraints on a predicate) and try
    % to prove the constraints on the class declaration (that is, treat them
    % as existential constraints on a predicate).
    %
    % We don't bother assigning ids to these constraints, since the resulting
    % constraint map is not used anyway.
    %
    init_hlds_constraint_list(ProgSuperClasses, SuperClasses),
    init_hlds_constraint_list(InstanceProgConstraints, InstanceConstraints),
    make_hlds_constraints(ClassTable, InstanceVarSet1, SuperClasses,
        InstanceConstraints, Constraints0),

    % Try to reduce the superclass constraints, using the declared instance
    % constraints and the usual context reduction rules.
    map.init(ConstraintMap0),
    typeclasses.reduce_context_by_rule_application(ClassTable, InstanceTable,
        ClassVars, TypeSubst, _, InstanceVarSet1, InstanceVarSet2,
        Proofs0, Proofs1, ConstraintMap0, _, Constraints0, Constraints),
    UnprovenConstraints = Constraints ^ hcs_unproven,

    (
        UnprovenConstraints = [],
        InstanceDefn = hlds_instance_defn(ModuleName,
            InstanceTypes, OriginalTypes, Status, Context,
            InstanceProgConstraints, Body, Interface, InstanceVarSet2, Proofs1)
    ;
        UnprovenConstraints = [_ | _],
        ClassId = class_id(ClassName, _ClassArity),
        ClassNameString = unqualify_name(ClassName),
        InstanceTypesString = mercury_type_list_to_string(InstanceVarSet2,
            InstanceTypes),
        constraint_list_to_string(ClassVarSet, UnprovenConstraints,
            ConstraintsString),
        Pieces = [words("In instance declaration for"),
            words_quote(ClassNameString ++ "(" ++ InstanceTypesString ++ ")"),
            suffix(":"), nl,
            words("the following superclass"),
            words(choose_number(UnprovenConstraints,
                "constraint is", "constraints are")),
            words("not satisfied:"), nl,
            words(ConstraintsString), suffix("."), nl],
        Spec = simplest_spec($pred, severity_error, phase_type_check,
            Context, Pieces),
        !:Specs = [Spec | !.Specs],
        InstanceDefn = InstanceDefn0
    ).

:- pred constraint_list_to_string(tvarset::in, list(hlds_constraint)::in,
    string::out) is det.

constraint_list_to_string(_, [], "").
constraint_list_to_string(VarSet, [C | Cs], String) :-
    retrieve_prog_constraint(C, P),
    PString = mercury_constraint_to_string(VarSet, P),
    constraint_list_to_comma_strings(VarSet, Cs, TailStrings),
    Strings = ["`", PString, "'" | TailStrings],
    String = string.append_list(Strings).

:- pred constraint_list_to_comma_strings(tvarset::in,
    list(hlds_constraint)::in, list(string)::out) is det.

constraint_list_to_comma_strings(_VarSet, [], []).
constraint_list_to_comma_strings(VarSet, [C | Cs], Strings) :-
    retrieve_prog_constraint(C, P),
    PString = mercury_constraint_to_string(VarSet, P),
    constraint_list_to_comma_strings(VarSet, Cs, TailStrings),
    Strings = [", `", PString, "'" | TailStrings].

%---------------------------------------------------------------------------%

    % Check that every abstract instance in the module has a
    % corresponding concrete instance in the implementation.
    %
:- pred check_for_missing_concrete_instances(module_info::in,
    list(error_spec)::in, list(error_spec)::out) is det.

check_for_missing_concrete_instances(ModuleInfo, !Specs) :-
    module_info_get_instance_table(ModuleInfo, InstanceTable),
    % Grab all the instance declarations that occur in this module
    % and partition them into two sets: abstract instance declarations
    % and concrete instance declarations.
    gather_abstract_and_concrete_instances(InstanceTable,
        AbstractInstances, ConcreteInstances),
    map.foldl(check_for_corresponding_instances(ConcreteInstances),
        AbstractInstances, !Specs).

    % Search the instance_table and create a table of abstract instances
    % that occur in the module and a table of concrete instances that
    % occur in the module. Imported instances are not included at all.
    %
:- pred gather_abstract_and_concrete_instances(instance_table::in,
    instance_table::out, instance_table::out) is det.

gather_abstract_and_concrete_instances(InstanceTable, Abstracts, Concretes) :-
    map.foldl2(partition_instances_for_class, InstanceTable,
        multi_map.init, Abstracts, multi_map.init, Concretes).

    % Partition all the non-imported instances for a particular class
    % into two groups, those that are abstract and those that are concrete.
    %
:- pred partition_instances_for_class(class_id::in,
    list(hlds_instance_defn)::in, instance_table::in, instance_table::out,
    instance_table::in, instance_table::out) is det.

partition_instances_for_class(ClassId, Instances, !Abstracts, !Concretes) :-
    list.foldl2(partition_instances_for_class_2(ClassId), Instances,
        !Abstracts, !Concretes).

:- pred partition_instances_for_class_2(class_id::in, hlds_instance_defn::in,
    instance_table::in, instance_table::out,
    instance_table::in, instance_table::out) is det.

partition_instances_for_class_2(ClassId, InstanceDefn,
        !Abstracts, !Concretes) :-
    InstanceStatus = InstanceDefn ^ instdefn_status,
    IsImported = instance_status_is_imported(InstanceStatus),
    (
        IsImported = no,
        Body = InstanceDefn ^ instdefn_body,
        (
            Body = instance_body_abstract,
            multi_map.add(ClassId, InstanceDefn, !Abstracts)
        ;
            Body = instance_body_concrete(_),
            multi_map.add(ClassId, InstanceDefn, !Concretes)
        )
    ;
        IsImported = yes
    ).

:- pred check_for_corresponding_instances(instance_table::in,
    class_id::in, list(hlds_instance_defn)::in,
    list(error_spec)::in, list(error_spec)::out) is det.

check_for_corresponding_instances(Concretes, ClassId, InstanceDefns, !Specs) :-
    list.foldl(check_for_corresponding_instances_2(Concretes, ClassId),
        InstanceDefns, !Specs).

:- pred check_for_corresponding_instances_2(instance_table::in, class_id::in,
    hlds_instance_defn::in,
    list(error_spec)::in, list(error_spec)::out) is det.

check_for_corresponding_instances_2(Concretes, ClassId, AbstractInstance,
        !Specs) :-
    AbstractTypes = AbstractInstance ^ instdefn_types,
    ( if multi_map.search(Concretes, ClassId, ConcreteInstances) then
        ( if
            list.member(ConcreteInstance, ConcreteInstances),
            ConcreteTypes = ConcreteInstance ^ instdefn_types,
            ConcreteTypes = AbstractTypes
        then
            MissingConcreteError = no
        else
            % There were concrete instances for ClassId in the implementation
            % but none of them matches the abstract instance we have.
            MissingConcreteError = yes
        )
    else
        % There were no concrete instances for ClassId in the implementation.
        MissingConcreteError = yes
    ),
    (
        MissingConcreteError = yes,
        ClassId = class_id(ClassName, _),
        ClassNameString = sym_name_to_string(ClassName),
        AbstractTypesString = mercury_type_list_to_string(
            AbstractInstance ^ instdefn_tvarset, AbstractTypes),
        AbstractInstanceName = ClassNameString ++
            "(" ++ AbstractTypesString ++ ")",
        % XXX Should we mention any constraints on the instance declaration?
        Pieces = [words("Error: abstract instance declaration"),
            words("for"), quote(AbstractInstanceName),
            words("has no corresponding concrete"),
            words("instance in the implementation."), nl],
        AbstractInstanceContext = AbstractInstance ^ instdefn_context,
        Spec = simplest_spec($pred, severity_error, phase_type_check,
            AbstractInstanceContext, Pieces),
        !:Specs = [Spec | !.Specs]
    ;
        MissingConcreteError = no
    ).

%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%

    % Check for cyclic classes in the class table by traversing the class
    % hierarchy for each class. While we are doing this, calculate the set
    % of ancestors with functional dependencies for each class, and enter
    % this information in the class table.
    %
:- pred check_for_cyclic_classes(module_info::in, module_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

check_for_cyclic_classes(!ModuleInfo, !Specs) :-
    module_info_get_class_table(!.ModuleInfo, ClassTable0),
    ClassIds = map.keys(ClassTable0),
    list.foldl3(find_cycles([]), ClassIds, ClassTable0, ClassTable,
        set.init, _, [], Cycles),
    !:Specs = list.map(report_cyclic_classes(ClassTable), Cycles) ++ !.Specs,
    module_info_set_class_table(ClassTable, !ModuleInfo).

:- type class_path == list(class_id).

    % find_cycles(Path, ClassId, !ClassTable, !Visited, !Cycles)
    %
    % Perform a depth first traversal of the class hierarchy, starting
    % from ClassId. Path contains a list of nodes joining the current node
    % to the root. When we reach a node that has already been visited,
    % check whether there is a cycle in the Path.
    %
:- pred find_cycles(class_path::in, class_id::in,
    class_table::in, class_table::out, set(class_id)::in, set(class_id)::out,
    list(class_path)::in, list(class_path)::out) is det.

find_cycles(Path, ClassId, !ClassTable, !Visited, !Cycles) :-
    find_cycles_2(Path, ClassId, _, _, !ClassTable, !Visited, !Cycles).

    % As above, but also return this class's parameters and ancestor list.
    %
:- pred find_cycles_2(class_path::in, class_id::in, list(tvar)::out,
    list(prog_constraint)::out, class_table::in, class_table::out,
    set(class_id)::in, set(class_id)::out,
    list(class_path)::in, list(class_path)::out) is det.

find_cycles_2(Path, ClassId, Params, Ancestors, !ClassTable, !Visited,
        !Cycles) :-
    ClassDefn0 = map.lookup(!.ClassTable, ClassId),
    Params = ClassDefn0 ^ classdefn_vars,
    Kinds = ClassDefn0 ^ classdefn_kinds,
    ( if set.member(ClassId, !.Visited) then
        ( if find_cycle(ClassId, Path, [ClassId], Cycle) then
            !:Cycles = [Cycle | !.Cycles]
        else
            true
        ),
        Ancestors = ClassDefn0 ^ classdefn_fundep_ancestors
    else
        set.insert(ClassId, !Visited),

        % Make this class its own ancestor, but only if it has fundeps on it.
        FunDeps = ClassDefn0 ^ classdefn_fundeps,
        (
            FunDeps = [],
            Ancestors0 = []
        ;
            FunDeps = [_ | _],
            ClassId = class_id(ClassName, _),
            prog_type.var_list_to_type_list(Kinds, Params, Args),
            Ancestors0 = [constraint(ClassName, Args)]
        ),
        Superclasses = ClassDefn0 ^ classdefn_supers,
        list.foldl4(find_cycles_3([ClassId | Path]), Superclasses,
            !ClassTable, !Visited, !Cycles, Ancestors0, Ancestors),
        ClassDefn = ClassDefn0 ^ classdefn_fundep_ancestors := Ancestors,
        map.det_update(ClassId, ClassDefn, !ClassTable)
    ).

    % As we go, accumulate the ancestors from all the superclasses,
    % with the class parameters bound to the corresponding arguments.
    % Note that we don't need to merge varsets because typeclass
    % parameters are guaranteed to be distinct variables.
    %
:- pred find_cycles_3(class_path::in, prog_constraint::in,
    class_table::in, class_table::out,
    set(class_id)::in, set(class_id)::out,
    list(class_path)::in, list(class_path)::out,
    list(prog_constraint)::in, list(prog_constraint)::out) is det.

find_cycles_3(Path, Constraint, !ClassTable, !Visited, !Cycles, !Ancestors) :-
    Constraint = constraint(Name, Args),
    list.length(Args, Arity),
    ClassId = class_id(Name, Arity),
    find_cycles_2(Path, ClassId, Params, NewAncestors0, !ClassTable,
        !Visited, !Cycles),
    map.from_corresponding_lists(Params, Args, Binding),
    apply_subst_to_prog_constraint_list(Binding, NewAncestors0, NewAncestors),
    list.append(NewAncestors, !Ancestors).

    % find_cycle(ClassId, PathRemaining, PathSoFar, Cycle):
    %
    % Check if ClassId is present in PathRemaining, and if so then make
    % a cycle out of the front part of the path up to the point where
    % the ClassId is found. The part of the path checked so far is
    % accumulated in PathSoFar.
    %
:- pred find_cycle(class_id::in, class_path::in, class_path::in,
    class_path::out) is semidet.

find_cycle(ClassId, [Head | Tail], Path0, Cycle) :-
    Path = [Head | Path0],
    ( if ClassId = Head then
        Cycle = Path
    else
        find_cycle(ClassId, Tail, Path, Cycle)
    ).

    % The error message for cyclic classes is intended to look like this:
    %
    %   module.m:NNN: Error: cyclic superclass relation detected:
    %   module.m:NNN:   `foo/N' <= `bar/N' <= `baz/N' <= `foo/N'
    %
:- func report_cyclic_classes(class_table, class_path) = error_spec.

report_cyclic_classes(ClassTable, ClassPath) = Spec :-
    (
        ClassPath = [],
        unexpected($pred, "empty cycle found.")
    ;
        ClassPath = [ClassId | Tail],
        Context = map.lookup(ClassTable, ClassId) ^ classdefn_context,
        StartPieces =
            [words("Error: cyclic superclass relation detected:"), nl,
            qual_class_id(ClassId), nl],
        list.foldl(add_path_element, Tail, cord.init, LaterLinesCord),
        Pieces = StartPieces ++ cord.list(LaterLinesCord),
        Spec = simplest_spec($pred, severity_error, phase_parse_tree_to_hlds,
            Context, Pieces)
    ).

:- pred add_path_element(class_id::in,
    cord(format_component)::in, cord(format_component)::out) is det.

add_path_element(ClassId, !LaterLines) :-
    Line = [words("<="), qual_class_id(ClassId), nl],
    !:LaterLines = !.LaterLines ++ cord.from_list(Line).

%---------------------------------------------------------------------------%

    % Check that all instances are range restricted with respect to the
    % functional dependencies. This means that, for each functional dependency,
    % the set of tvars in the range arguments must be a subset of the set
    % of tvars in the domain arguments. (Note that with the requirement of
    % distinct variables as arguments, this implies that all range arguments
    % must be ground. However, this code should work even if that requirement
    % is lifted in the future.)
    %
    % Also, check that all pairs of visible instances are mutually consistent
    % with respect to the functional dependencies. This is true iff the most
    % general unifier of corresponding domain arguments (if it exists) is
    % also a unifier of the corresponding range arguments.
    %
:- pred check_functional_dependencies(module_info::in,
    list(error_spec)::in, list(error_spec)::out) is det.

check_functional_dependencies(ModuleInfo, !Specs) :-
    module_info_get_instance_table(ModuleInfo, InstanceTable),
    map.keys(InstanceTable, ClassIds),
    list.foldl(check_fundeps_for_class(ModuleInfo), ClassIds, !Specs).

:- pred check_fundeps_for_class(module_info::in, class_id::in,
    list(error_spec)::in, list(error_spec)::out) is det.

check_fundeps_for_class(ModuleInfo, ClassId, !Specs) :-
    module_info_get_class_table(ModuleInfo, ClassTable),
    map.lookup(ClassTable, ClassId, ClassDefn),
    module_info_get_instance_table(ModuleInfo, InstanceTable),
    map.lookup(InstanceTable, ClassId, InstanceDefns),
    FunDeps = ClassDefn ^ classdefn_fundeps,
    check_coverage_for_instance_defns(ModuleInfo, ClassId, InstanceDefns,
        FunDeps, !Specs),
    module_info_get_globals(ModuleInfo, Globals),
    % Abstract definitions will always overlap with concrete definitions,
    % so we filter out the abstract definitions for this module. If
    % --intermodule-optimization is enabled then we strip out the imported
    % abstract definitions for all modules, since we will have the concrete
    % definitions for imported instances from the .opt files. If it is not
    % enabled, then we keep the abstract definitions for imported instances
    % since doing so may allow us to detect errors.
    globals.lookup_bool_option(Globals, intermodule_optimization, IntermodOpt),
    (
        IntermodOpt = yes,
        list.filter(is_concrete_instance_defn, InstanceDefns,
            ConcreteInstanceDefns)
    ;
        IntermodOpt = no,
        list.filter(is_concrete_or_imported_instance_defn, InstanceDefns,
            ConcreteInstanceDefns)
    ),
    check_consistency(ClassId, ClassDefn, ConcreteInstanceDefns, FunDeps,
        !Specs).

:- pred is_concrete_instance_defn(hlds_instance_defn::in) is semidet.

is_concrete_instance_defn(InstanceDefn) :-
    InstanceDefn ^ instdefn_body = instance_body_concrete(_).

:- pred is_concrete_or_imported_instance_defn(hlds_instance_defn::in)
    is semidet.

is_concrete_or_imported_instance_defn(InstanceDefn) :-
    (
        is_concrete_instance_defn(InstanceDefn)
    ;
        instance_status_is_imported(InstanceDefn ^ instdefn_status) = yes
    ).

:- pred check_coverage_for_instance_defns(module_info::in, class_id::in,
    list(hlds_instance_defn)::in, hlds_class_fundeps::in,
    list(error_spec)::in, list(error_spec)::out) is det.

check_coverage_for_instance_defns(_, _, [], _, !Specs).
check_coverage_for_instance_defns(ModuleInfo, ClassId,
        [InstanceDefn | InstanceDefns], FunDeps, !Specs) :-
    list.foldl(
        check_coverage_for_instance_defn(ModuleInfo, ClassId, InstanceDefn),
        FunDeps, !Specs),
    check_coverage_for_instance_defns(ModuleInfo, ClassId,
        InstanceDefns, FunDeps, !Specs).

:- pred check_coverage_for_instance_defn(module_info::in, class_id::in,
    hlds_instance_defn::in, hlds_class_fundep::in,
    list(error_spec)::in, list(error_spec)::out) is det.

check_coverage_for_instance_defn(ModuleInfo, ClassId, InstanceDefn, FunDep,
        !Specs) :-
    TVarSet = InstanceDefn ^ instdefn_tvarset,
    Types = InstanceDefn ^ instdefn_types,
    FunDep = fundep(Domain, Range),
    DomainTypes = restrict_list_elements(Domain, Types),
    type_vars_list(DomainTypes, DomainVars),
    RangeTypes = restrict_list_elements(Range, Types),
    type_vars_list(RangeTypes, RangeVars),
    Constraints = InstanceDefn ^ instdefn_constraints,
    get_unbound_tvars(ModuleInfo, TVarSet, DomainVars, RangeVars,
        Constraints, UnboundVars),
    (
        UnboundVars = []
    ;
        UnboundVars = [_ | _],
        Spec = report_coverage_error(ClassId, InstanceDefn, UnboundVars),
        !:Specs = [Spec | !.Specs]
    ).

    % Check the consistency of each (unordered) pair of instances.
    %
:- pred check_consistency(class_id::in, hlds_class_defn::in,
    list(hlds_instance_defn)::in, hlds_class_fundeps::in,
    list(error_spec)::in, list(error_spec)::out) is det.

check_consistency(_, _, [], _, !Specs).
check_consistency(ClassId, ClassDefn, [Instance | Instances], FunDeps,
        !Specs) :-
    list.foldl(check_consistency_pair(ClassId, ClassDefn, FunDeps, Instance),
        Instances, !Specs),
    check_consistency(ClassId, ClassDefn, Instances, FunDeps,
        !Specs).

:- pred check_consistency_pair(class_id::in, hlds_class_defn::in,
    hlds_class_fundeps::in, hlds_instance_defn::in, hlds_instance_defn::in,
    list(error_spec)::in, list(error_spec)::out) is det.

check_consistency_pair(ClassId, ClassDefn, FunDeps, InstanceA, InstanceB,
        !Specs) :-
    % If both instances are imported from the same module, then we do not
    % need to check the consistency, since this would have been checked
    % when compiling that module.
    ( if
        InstanceA ^ instdefn_module = InstanceB ^ instdefn_module,
        instance_status_is_imported(InstanceA ^ instdefn_status) = yes
    then
        true
    else
        list.foldl(
            check_consistency_pair_2(ClassId, ClassDefn, InstanceA, InstanceB),
            FunDeps, !Specs)
    ).

:- pred check_consistency_pair_2(class_id::in, hlds_class_defn::in,
    hlds_instance_defn::in, hlds_instance_defn::in, hlds_class_fundep::in,
    list(error_spec)::in, list(error_spec)::out) is det.

check_consistency_pair_2(ClassId, ClassDefn, InstanceA, InstanceB, FunDep,
        !Specs) :-
    TVarSetA = InstanceA ^ instdefn_tvarset,
    TVarSetB = InstanceB ^ instdefn_tvarset,
    tvarset_merge_renaming(TVarSetA, TVarSetB, _, Renaming),

    TypesA = InstanceA ^ instdefn_types,
    TypesB0 = InstanceB ^ instdefn_types,
    apply_variable_renaming_to_type_list(Renaming, TypesB0, TypesB),

    FunDep = fundep(Domain, Range),
    DomainA = restrict_list_elements(Domain, TypesA),
    DomainB = restrict_list_elements(Domain, TypesB),

    ( if type_unify_list(DomainA, DomainB, [], map.init, Subst) then
        RangeA0 = restrict_list_elements(Range, TypesA),
        RangeB0 = restrict_list_elements(Range, TypesB),
        apply_rec_subst_to_type_list(Subst, RangeA0, RangeA),
        apply_rec_subst_to_type_list(Subst, RangeB0, RangeB),
        ( if RangeA = RangeB then
            true
        else
            Spec = report_consistency_error(ClassId, ClassDefn,
                InstanceA, InstanceB, FunDep),
            !:Specs = [Spec | !.Specs]
        )
    else
        true
    ).

    % The coverage error message is intended to look like this:
    %
    % long_module_name:001: In instance for typeclass `long_class/2':
    % long_module_name:001:   functional dependency not satisfied: type
    % long_module_name:001:   variables T1, T2 and T3 occur in the range of a
    % long_module_name:001:   functional dependency, but are not determined
    % long_module_name:001:   by the domain.
    %
:- func report_coverage_error(class_id, hlds_instance_defn, list(tvar))
    = error_spec.

report_coverage_error(ClassId, InstanceDefn, Vars) = Spec :-
    TVarSet = InstanceDefn ^ instdefn_tvarset,
    VarsStrs = list.map(mercury_var_to_name_only(TVarSet), Vars),
    Pieces = [words("In instance for typeclass"),
        unqual_class_id(ClassId), suffix(":"), nl,
        words("functional dependency not satisfied:"),
        words(choose_number(Vars, "type variable", "type variables"))]
        ++ list_to_quoted_pieces(VarsStrs) ++
        [words(choose_number(Vars, "occurs", "occur")),
        words("in the range of the functional dependency, but"),
        words(choose_number(Vars, "is", "are")),
        words("not determined by the domain."), nl],
    Context = InstanceDefn ^ instdefn_context,
    Spec = simplest_spec($pred, severity_error, phase_type_check,
        Context, Pieces).

:- func report_consistency_error(class_id, hlds_class_defn,
    hlds_instance_defn, hlds_instance_defn, hlds_class_fundep) = error_spec.

report_consistency_error(ClassId, ClassDefn, InstanceA, InstanceB, FunDep)
        = Spec :-
    Params = ClassDefn ^ classdefn_vars,
    TVarSet = ClassDefn ^ classdefn_tvarset,
    ContextA = InstanceA ^ instdefn_context,
    ContextB = InstanceB ^ instdefn_context,

    FunDep = fundep(Domain, Range),
    DomainParams = restrict_list_elements(Domain, Params),
    RangeParams = restrict_list_elements(Range, Params),
    Domains = mercury_vars_to_name_only(TVarSet, DomainParams),
    Ranges = mercury_vars_to_name_only(TVarSet, RangeParams),

    PiecesA = [words("Inconsistent instance declaration for typeclass"),
        qual_class_id(ClassId), words("with functional dependency"),
        quote("(" ++ Domains ++ " -> " ++ Ranges ++ ")"), suffix("."), nl],
    PiecesB = [words("Here is the conflicting instance."), nl],

    MsgA = simplest_msg(ContextA, PiecesA),
    MsgB = error_msg(yes(ContextB), always_treat_as_first, 0,
        [always(PiecesB)]),
    Spec = error_spec($pred, severity_error, phase_parse_tree_to_hlds,
        [MsgA, MsgB]).

%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%

    % Look for pred or func declarations for which the type variables in
    % the constraints are not all determined by the type variables in the type
    % and the functional dependencies. Likewise look for constructors for which
    % the existential type variables in the constraints are not all determined
    % by the type variables in the constructor arguments and the functional
    % dependencies.
    %
:- pred check_typeclass_constraints(module_info::in,
    list(error_spec)::in, list(error_spec)::out) is det.

check_typeclass_constraints(ModuleInfo, !Specs) :-
    module_info_get_valid_pred_ids(ModuleInfo, PredIds),
    list.foldl(check_typeclass_constraints_on_pred(ModuleInfo),
        PredIds, !Specs),
    module_info_get_type_table(ModuleInfo, TypeTable),
    get_all_type_ctor_defns(TypeTable, TypeCtorsDefns),
    list.foldl(check_typeclass_constraints_on_type_ctor(ModuleInfo),
        TypeCtorsDefns, !Specs).

:- pred check_typeclass_constraints_on_pred(module_info::in, pred_id::in,
    list(error_spec)::in, list(error_spec)::out) is det.

check_typeclass_constraints_on_pred(ModuleInfo, PredId, !Specs) :-
    module_info_pred_info(ModuleInfo, PredId, PredInfo),
    pred_info_get_class_context(PredInfo, Constraints),
    Constraints = constraints(UnivConstraints, ExistConstraints),
    ( if
        ( UnivConstraints = [_ | _]
        ; ExistConstraints = [_ | _]
        )
    then
        % We are checking only the forms of the constraints, so for now,
        % the distinction between universally and existentially quantified
        % constraints does not matter.
        AllConstraints = UnivConstraints ++ ExistConstraints,
        trace [io(!IO)] (
            write_pred_progress_message(ModuleInfo,
                "Checking typeclass constraints on", PredId, !IO)
        ),

        % Check that all class ids mentioned in the constraints
        % actually exist.
        %
        % Code in the type checker does map.lookups of class_ids
        % in the class table, and these will abort the compiler
        % if invoked on a class id that does not exist in the class table.
        % I (zs) have tried to change that code to do a map.search instead,
        % and report the nonexistence of the class id then, but that turned
        % out to be quite complicated, mostly because the code that does
        % the lookup is called from several different places, each of which
        % would need to handle this error in its own way. It seems simpler
        % to look for and report such errors before typechecking even begins.
        %
        % Normally, module qualification, operating on the parse tree
        % before the HLDS is even constructed, will find and report such
        % errors. However, it does such checks *only* on the code of
        % the curent module; it does *not* check the information read in
        % from .int* files. Any references to nonexistent typeclasses
        % in other modules, that this module imports, will be reported
        % when that other module is compiled, and *could* be reported
        % when the other module's interface file is generated, but for now,
        % the latter is inhibited by the fact that halt_at_invalid_interface
        % can't really be set to "yes" just yet. This allows such errors
        % to slip into .int* files silently. The code here exists
        % to catch and report them. And if this phase reports any errors,
        % the compiler will stop before the typecheck phase.

        module_info_get_class_table(ModuleInfo, ClassTable),
        find_bad_class_ids_in_constraints(ClassTable, AllConstraints,
            set.init, BadClassSNAsSet),
        set.to_sorted_list(BadClassSNAsSet, BadClassSNAs),
        (
            BadClassSNAs = [HeadBadClassSNA | TailBadClassSNAs],
            BadClassIdsSpec = report_bad_class_ids_in_pred_decl(ModuleInfo,
                PredInfo, HeadBadClassSNA, TailBadClassSNAs),
            !:Specs = [BadClassIdsSpec | !.Specs]
        ;
            BadClassSNAs = [],
            % In the presence of any BadClassSNAs, the map.lookups done
            % in the class table by code indirectly invoked by
            % get_unbound_tvars could cause a compiler abort.
            %
            % Any ambiguity errors can be reported *after* the programmer
            % fixes the references to nonexistent typeclasses.
            pred_info_get_status(PredInfo, Status),
            NeedsAmbiguityCheck = pred_needs_ambiguity_check(Status),
            (
                NeedsAmbiguityCheck = no
            ;
                NeedsAmbiguityCheck = yes,
                check_pred_type_ambiguities(ModuleInfo, PredInfo, !Specs),
                check_constraint_quant(PredInfo, !Specs)
            )
        )
    else
        true
    ).

%---------------------%

:- func pred_needs_ambiguity_check(pred_status) = bool.

pred_needs_ambiguity_check(pred_status(status_imported(_))) =             no.
pred_needs_ambiguity_check(pred_status(status_external(_))) =             yes.
pred_needs_ambiguity_check(pred_status(status_abstract_imported)) =       no.
pred_needs_ambiguity_check(pred_status(status_pseudo_imported)) =         no.
pred_needs_ambiguity_check(pred_status(status_opt_imported)) =            no.
pred_needs_ambiguity_check(pred_status(status_exported)) =                yes.
pred_needs_ambiguity_check(pred_status(status_opt_exported)) =            yes.
pred_needs_ambiguity_check(pred_status(status_abstract_exported)) =       yes.
pred_needs_ambiguity_check(pred_status(status_pseudo_exported)) =         yes.
pred_needs_ambiguity_check(pred_status(status_exported_to_submodules)) =  yes.
pred_needs_ambiguity_check(pred_status(status_local)) =                   yes.

:- pred check_pred_type_ambiguities(module_info::in, pred_info::in,
    list(error_spec)::in, list(error_spec)::out) is det.

check_pred_type_ambiguities(ModuleInfo, PredInfo, !Specs) :-
    pred_info_get_typevarset(PredInfo, TVarSet),
    pred_info_get_arg_types(PredInfo, ArgTypes),
    pred_info_get_class_context(PredInfo, Constraints),
    type_vars_list(ArgTypes, ArgTVars),
    prog_constraints_get_tvars(Constraints, ConstrainedTVars),
    Constraints = constraints(UnivCs, ExistCs),
    get_unbound_tvars(ModuleInfo, TVarSet, ArgTVars, ConstrainedTVars,
        UnivCs ++ ExistCs, UnboundTVars),
    (
        UnboundTVars = []
    ;
        UnboundTVars = [_ | _],
        Spec = report_unbound_tvars_in_pred_context(UnboundTVars, PredInfo),
        !:Specs = [Spec | !.Specs]
    ).

%---------------------------------------------------------------------------%

:- pred check_typeclass_constraints_on_type_ctor(module_info::in,
    pair(type_ctor, hlds_type_defn)::in,
    list(error_spec)::in, list(error_spec)::out) is det.

check_typeclass_constraints_on_type_ctor(ModuleInfo, TypeCtor - TypeDefn,
        !Specs) :-
    get_type_defn_body(TypeDefn, Body),
    (
        Body = hlds_du_type(type_body_du(Ctors, _, _, _, _)),
        list.foldl(
            check_typeclass_constraints_on_data_ctor(ModuleInfo, TypeCtor,
                TypeDefn),
            one_or_more_to_list(Ctors), !Specs)
    ;
        ( Body = hlds_eqv_type(_)
        ; Body = hlds_foreign_type(_)
        ; Body = hlds_solver_type(_)
        ; Body = hlds_abstract_type(_)
        )
    ).

:- pred check_typeclass_constraints_on_data_ctor(module_info::in, type_ctor::in,
    hlds_type_defn::in, constructor::in,
    list(error_spec)::in, list(error_spec)::out) is det.

check_typeclass_constraints_on_data_ctor(ModuleInfo, TypeCtor, TypeDefn,
        Ctor, !Specs) :-
    Ctor = ctor(_, MaybeExistConstraints, _, CtorArgs, _, _),
    (
        MaybeExistConstraints = no_exist_constraints
    ;
        MaybeExistConstraints = exist_constraints(ExistConstraints),
        ExistConstraints = cons_exist_constraints(ExistQVars, Constraints,
            _UnconstrainedQVars, _ConstrainedQVars),

        module_info_get_class_table(ModuleInfo, ClassTable),
        find_bad_class_ids_in_constraints(ClassTable, Constraints,
            set.init, BadClassSNAsSet),
        set.to_sorted_list(BadClassSNAsSet, BadClassSNAs),
        (
            BadClassSNAs = [HeadBadClassSNA | TailBadClassSNAs],
            BadClassIdsSpec = report_bad_class_ids_in_data_ctor(TypeCtor,
                TypeDefn, HeadBadClassSNA, TailBadClassSNAs),
            !:Specs = [BadClassIdsSpec | !.Specs]
        ;
            BadClassSNAs = [],
            % In the presence of any BadClassSNAs, the map.lookups done
            % in the class table by code indirectly invoked by
            % get_unbound_tvars could cause a compiler abort.
            %
            % Any ambiguity errors can be reported *after* the programmer
            % fixes the references to nonexistent typeclasses.
            get_ctor_arg_types(CtorArgs, ArgTypes),
            type_vars_list(ArgTypes, ArgTVars),
            list.filter((pred(V::in) is semidet :- list.member(V, ExistQVars)),
                ArgTVars, ExistQArgTVars),
            % Sanity check.
            list.filter(list.contains(ExistQVars), ArgTVars, ExistQArgTVarsB),
            expect(unify(ExistQArgTVars, ExistQArgTVarsB), $pred,
                "ExistQArgTVars != ExistQArgTVarsB"),
            constraint_list_get_tvars(Constraints, ConstrainedTVars),
            get_type_defn_tvarset(TypeDefn, TVarSet),
            get_unbound_tvars(ModuleInfo, TVarSet,
                ExistQArgTVars, ConstrainedTVars, Constraints, UnboundTVars),
            (
                UnboundTVars = []
            ;
                UnboundTVars = [_ | _],
                Spec = report_unbound_tvars_in_ctor_context(UnboundTVars,
                    TypeCtor, TypeDefn),
                !:Specs = [Spec | !.Specs]
            )
        )
    ).

%---------------------%

    % The error messages for ambiguous types are intended to look like this:
    %
    % long_module_name:001: In declaration for function `long_function/2':
    % long_module_name:001:   error in type class constraints: type variables
    % long_module_name:001:   T1, T2 and T3 occur in the constraints, but are
    % long_module_name:001:   not determined by the function's argument or
    % long_module_name:001:   result types.
    %
    % long_module_name:002: In declaration for predicate `long_predicate/3':
    % long_module_name:002:   error in type class constraints: type variable
    % long_module_name:002:   T occurs in the constraints, but is not
    % long_module_name:002:   determined by the predicate's argument types.
    %
    % long_module_name:002: In declaration for type `long_type/3':
    % long_module_name:002:   error in type class constraints: type variable
    % long_module_name:002:   T occurs in the constraints, but is not
    % long_module_name:002:   determined by the constructor's argument types.
    %
:- func report_unbound_tvars_in_pred_context(list(tvar), pred_info)
    = error_spec.

report_unbound_tvars_in_pred_context(Vars, PredInfo) = Spec :-
    pred_info_get_context(PredInfo, Context),
    pred_info_get_arg_types(PredInfo, TVarSet, _, ArgTypes),
    PredName = pred_info_name(PredInfo),
    Module = pred_info_module(PredInfo),
    SymName = qualified(Module, PredName),
    Arity = length(ArgTypes),
    PredOrFunc = pred_info_is_pred_or_func(PredInfo),

    VarsStrs = list.map(mercury_var_to_name_only(TVarSet), Vars),

    PFSymNameArity = pf_sym_name_arity(PredOrFunc, SymName, Arity),
    Pieces0 = [words("In declaration for"),
        unqual_pf_sym_name_orig_arity(PFSymNameArity), suffix(":"), nl,
        words("error in type class constraints:"),
        words(choose_number(Vars, "type variable", "type variables"))]
        ++ list_to_quoted_pieces(VarsStrs) ++
        [words(choose_number(Vars, "occurs", "occur")),
        words("in the constraints, but"),
        words(choose_number(Vars, "is", "are")),
        words("not determined by the")],
    (
        PredOrFunc = pf_predicate,
        Pieces = Pieces0 ++ [words("predicate's argument types."), nl]
    ;
        PredOrFunc = pf_function,
        Pieces = Pieces0 ++ [words("function's argument or result types."), nl]
    ),
    Msg = simple_msg(Context,
        [always(Pieces),
        verbose_only(verbose_once, report_unbound_tvars_explanation)]),
    Spec = error_spec($pred, severity_error, phase_type_check, [Msg]).

:- func report_unbound_tvars_in_ctor_context(list(tvar), type_ctor,
    hlds_type_defn) = error_spec.

report_unbound_tvars_in_ctor_context(Vars, TypeCtor, TypeDefn) = Spec :-
    get_type_defn_context(TypeDefn, Context),
    get_type_defn_tvarset(TypeDefn, TVarSet),
    VarsStrs = list.map(mercury_var_to_name_only(TVarSet), Vars),

    Pieces = [words("In declaration for type"), qual_type_ctor(TypeCtor),
        suffix(":"), nl,
        words("error in type class constraints:"),
        words(choose_number(Vars, "type variable", "type variables"))]
        ++ list_to_quoted_pieces(VarsStrs) ++
        [words(choose_number(Vars, "occurs", "occur")),
        words("in the constraints, but"),
        words(choose_number(Vars, "is", "are")),
        words("not determined by the constructor's argument types."), nl],
    Msg = simple_msg(Context,
        [always(Pieces),
        verbose_only(verbose_once, report_unbound_tvars_explanation)]),
    Spec = error_spec($pred, severity_error, phase_type_check, [Msg]).

:- func report_unbound_tvars_explanation = list(format_component).

report_unbound_tvars_explanation =
    [words("All types occurring in typeclass constraints"),
    words("must be fully determined."),
    words("A type is fully determined if one of the"),
    words("following holds:"),
    nl,
    words("1) All type variables occurring in the type"),
    words("are determined."),
    nl,
    words("2) The type occurs in a constraint argument,"),
    words("that argument is in the range of some"),
    words("functional dependency for that class, and"),
    words("the types in all of the domain arguments for"),
    words("that functional dependency are fully"),
    words("determined."),
    nl,
    words("A type variable is determined if one of the"),
    words("following holds:"),
    nl,
    words("1) The type variable occurs in the argument"),
    words("types of the predicate, function, or"),
    words("constructor which is constrained."),
    nl,
    words("2) The type variable occurs in a type which"),
    words("is fully determined."),
    nl,
    words("See the ""Functional dependencies"" section"),
    words("of the reference manual for details."), nl].

%---------------------%

:- pred find_bad_class_ids_in_constraints(class_table::in,
    list(prog_constraint)::in,
    set(class_id)::in, set(class_id)::out) is det.

find_bad_class_ids_in_constraints(_, [], !BadClassIds).
find_bad_class_ids_in_constraints(ClassTable, [C | Cs], !BadClassIds) :-
    find_bad_class_ids_in_constraint(ClassTable, C, !BadClassIds),
    find_bad_class_ids_in_constraints(ClassTable, Cs, !BadClassIds).

:- pred find_bad_class_ids_in_constraint(class_table::in,
    prog_constraint::in,
    set(class_id)::in, set(class_id)::out) is det.

find_bad_class_ids_in_constraint(ClassTable, C, !BadClassIds) :-
    C = constraint(ClassSymName, ArgTypes),
    list.length(ArgTypes, Arity),
    ClassId = class_id(ClassSymName, Arity),
    ( if map.search(ClassTable, ClassId, _) then
        true
    else
        set.insert(ClassId, !BadClassIds)
    ).

:- func report_bad_class_ids_in_pred_decl(module_info, pred_info,
    class_id, list(class_id)) = error_spec.

report_bad_class_ids_in_pred_decl(ModuleInfo, PredInfo,
        HeadBadClassId, TailBadClassIds) = Spec :-
    pred_info_get_context(PredInfo, Context),
    PredOrFunc = pred_info_is_pred_or_func(PredInfo),
    PredName = pred_info_name(PredInfo),
    PredModuleName = pred_info_module(PredInfo),
    module_info_get_name(ModuleInfo, CurModuleName),
    % Module qualify the name of the predicate we are complaining about
    % *only* if it is not from the current module.
    ( if CurModuleName = PredModuleName then
        PredSymName = unqualified(PredName)
    else
        PredSymName = qualified(PredModuleName, PredName)
    ),
    pred_info_get_arg_types(PredInfo, _TVarSet, _, ArgTypes),
    PredArity = length(ArgTypes),
    PFSymNameArity = pf_sym_name_arity(PredOrFunc, PredSymName, PredArity),
    StartPieces = [words("In declaration for"),
        unqual_pf_sym_name_orig_arity(PFSymNameArity), suffix(":"), nl],
    Pieces = StartPieces ++
        report_bad_class_ids(HeadBadClassId, TailBadClassIds),
    Spec = simplest_spec($pred, severity_error, phase_type_check,
        Context, Pieces).

:- func report_bad_class_ids_in_data_ctor(type_ctor,
    hlds_type_defn, class_id, list(class_id)) = error_spec.

report_bad_class_ids_in_data_ctor(TypeCtor, TypeDefn,
        HeadBadClassId, TailBadClassIds) = Spec :-
    get_type_defn_context(TypeDefn, Context),
    StartPieces = [words("In declaration for type"), qual_type_ctor(TypeCtor),
        suffix(":"), nl],
    Pieces = StartPieces ++
        report_bad_class_ids(HeadBadClassId, TailBadClassIds),
    Spec = simplest_spec($pred, severity_error, phase_type_check,
        Context, Pieces).

:- func report_bad_class_ids(class_id, list(class_id))
    = list(format_component).

report_bad_class_ids(HeadClassId, TailClassIds) = Pieces :-
    WrapQualClassId = (func(ClassId) = qual_class_id(ClassId)),
    QualHeadClassId = WrapQualClassId(HeadClassId),
    (
        TailClassIds = [],
        Pieces = [words("error: the type class"), QualHeadClassId,
            words("does not exist."), nl]
    ;
        TailClassIds = [_ | _],
        QualTailClassIds = list.map(WrapQualClassId, TailClassIds),
        QualClassIds = [QualHeadClassId | QualTailClassIds],
        Pieces = [words("error: the type classes")] ++
            component_list_to_pieces("and", QualClassIds) ++
            [words("do not exist."), nl]
    ).

%---------------------------------------------------------------------------%

    % Check that all types appearing in universal (existential) constraints are
    % universally (existentially) quantified.
    %
:- pred check_constraint_quant(pred_info::in,
    list(error_spec)::in, list(error_spec)::out) is det.

check_constraint_quant(PredInfo, !Specs) :-
    pred_info_get_exist_quant_tvars(PredInfo, ExistQVars),
    pred_info_get_class_context(PredInfo, Constraints),
    Constraints = constraints(UnivCs, ExistCs),
    prog_type.constraint_list_get_tvars(UnivCs, UnivTVars),
    set.list_to_set(ExistQVars, ExistQVarsSet),
    set.list_to_set(UnivTVars, UnivTVarsSet),
    set.intersect(ExistQVarsSet, UnivTVarsSet, BadUnivTVarsSet),
    maybe_report_badly_quantified_vars(PredInfo, universal_constraint,
        set.to_sorted_list(BadUnivTVarsSet), !Specs),
    prog_type.constraint_list_get_tvars(ExistCs, ExistTVars),
    list.delete_elems(ExistTVars, ExistQVars, BadExistTVars),
    maybe_report_badly_quantified_vars(PredInfo, existential_constraint,
        BadExistTVars, !Specs).

:- pred maybe_report_badly_quantified_vars(pred_info::in, quant_error_type::in,
    list(tvar)::in,
    list(error_spec)::in, list(error_spec)::out) is det.

maybe_report_badly_quantified_vars(PredInfo, QuantErrorType, TVars, !Specs) :-
    (
        TVars = []
    ;
        TVars = [_ | _],
        Spec = report_badly_quantified_vars(PredInfo, QuantErrorType, TVars),
        !:Specs = [Spec | !.Specs]
    ).

:- type quant_error_type
    --->    universal_constraint
    ;       existential_constraint.

:- func report_badly_quantified_vars(pred_info, quant_error_type, list(tvar))
    = error_spec.

report_badly_quantified_vars(PredInfo, QuantErrorType, TVars) = Spec :-
    pred_info_get_typevarset(PredInfo, TVarSet),
    pred_info_get_context(PredInfo, Context),

    InDeclaration = [words("In declaration of")] ++
        describe_one_pred_info_name(should_module_qualify, PredInfo) ++
        [suffix(":"), nl],
    TypeVariables = [words("type variable"),
        suffix(choose_number(TVars, "", "s"))],
    TVarsStrs = list.map(mercury_var_to_name_only(TVarSet), TVars),
    TVarsPart = list_to_quoted_pieces(TVarsStrs),
    Are = words(choose_number(TVars, "is", "are")),
    (
        QuantErrorType = universal_constraint,
        BlahConstrained = words("universally constrained"),
        BlahQuantified = words("existentially quantified")
    ;
        QuantErrorType = existential_constraint,
        BlahConstrained = words("existentially constrained"),
        BlahQuantified = words("universally quantified")
    ),
    Pieces = InDeclaration ++ TypeVariables ++ TVarsPart ++
        [Are, BlahConstrained, suffix(","), words("but"), Are,
        BlahQuantified, suffix("."), nl],
    Spec = simplest_spec($pred, severity_error, phase_type_check,
        Context, Pieces).

%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
%
% Utility predicates.
%

:- pred get_unbound_tvars(module_info::in, tvarset::in, list(tvar)::in,
    list(tvar)::in, list(prog_constraint)::in, list(tvar)::out) is det.

get_unbound_tvars(ModuleInfo, TVarSet, RootTVars, AllTVars, Constraints,
        UnboundTVars) :-
    module_info_get_class_table(ModuleInfo, ClassTable),
    InducedFunDeps = compute_induced_fundeps(ClassTable, TVarSet, Constraints),
    FunDepsClosure =
        compute_fundeps_closure(InducedFunDeps, list_to_set(RootTVars)),
    UnboundTVarsSet = set.difference(list_to_set(AllTVars), FunDepsClosure),
    UnboundTVars = set.to_sorted_list(UnboundTVarsSet).

:- type induced_fundeps == list(induced_fundep).
:- type induced_fundep
    --->    fundep(
                domain      :: set(tvar),
                range       :: set(tvar)
            ).

:- func compute_induced_fundeps(class_table, tvarset, list(prog_constraint))
    = induced_fundeps.

compute_induced_fundeps(ClassTable, TVarSet, Constraints) = FunDeps :-
    list.foldl(acc_induced_fundeps_for_constraint(ClassTable, TVarSet),
        Constraints, [], FunDeps).

:- pred acc_induced_fundeps_for_constraint(class_table::in, tvarset::in,
    prog_constraint::in, induced_fundeps::in, induced_fundeps::out) is det.

acc_induced_fundeps_for_constraint(ClassTable, TVarSet, Constraint,
        !FunDeps) :-
    Constraint = constraint(Name, Args),
    Arity = length(Args),
    ClassDefn = map.lookup(ClassTable, class_id(Name, Arity)),
    % The ancestors includes all superclasses of Constraint which have
    % functional dependencies on them (possibly including Constraint itself).
    ClassAncestors = ClassDefn ^ classdefn_fundep_ancestors,
    (
        % Optimize the common case.
        ClassAncestors = []
    ;
        ClassAncestors = [_ | _],
        ClassTVarSet = ClassDefn ^ classdefn_tvarset,
        ClassParams = ClassDefn ^ classdefn_vars,

        % We can ignore the resulting tvarset, since any new variables
        % will become bound when the arguments are bound. (This follows
        % from the fact that constraints on class declarations can only use
        % variables that appear in the head of the declaration.)

        tvarset_merge_renaming(TVarSet, ClassTVarSet, _, Renaming),
        apply_variable_renaming_to_prog_constraint_list(Renaming,
            ClassAncestors, RenamedAncestors),
        apply_variable_renaming_to_tvar_list(Renaming, ClassParams,
            RenamedParams),
        map.from_corresponding_lists(RenamedParams, Args, Subst),
        apply_subst_to_prog_constraint_list(Subst, RenamedAncestors,
            Ancestors),
        list.foldl(induced_fundeps_3(ClassTable), Ancestors, !FunDeps)
    ).

:- pred induced_fundeps_3(class_table::in, prog_constraint::in,
    induced_fundeps::in, induced_fundeps::out) is det.

induced_fundeps_3(ClassTable, Constraint, !FunDeps) :-
    Constraint = constraint(Name, Args),
    Arity = length(Args),
    ClassDefn = map.lookup(ClassTable, class_id(Name, Arity)),
    list.foldl(induced_fundep(Args), ClassDefn ^ classdefn_fundeps, !FunDeps).

:- pred induced_fundep(list(mer_type)::in, hlds_class_fundep::in,
    induced_fundeps::in, induced_fundeps::out) is det.

induced_fundep(Args, fundep(Domain0, Range0), !FunDeps) :-
    Domain = set.fold(induced_vars(Args), Domain0, set.init),
    Range = set.fold(induced_vars(Args), Range0, set.init),
    !:FunDeps = [fundep(Domain, Range) | !.FunDeps].

:- func induced_vars(list(mer_type), int, set(tvar)) = set(tvar).

induced_vars(Args, ArgNum, Vars) = union(Vars, NewVars) :-
    Arg = list.det_index1(Args, ArgNum),
    type_vars(Arg, ArgVars),
    NewVars = set.list_to_set(ArgVars).

:- func compute_fundeps_closure(induced_fundeps, set(tvar)) = set(tvar).

compute_fundeps_closure(FunDeps, TVars0) = TVars :-
    fundeps_closure_loop(FunDeps, TVars0, set.init, TVars).

:- pred fundeps_closure_loop(induced_fundeps::in, set(tvar)::in,
    set(tvar)::in, set(tvar)::out) is det.

fundeps_closure_loop(FunDeps0, NewVars0, Result0, Result) :-
    ( if set.is_empty(NewVars0) then
        Result = Result0
    else
        Result1 = set.union(Result0, NewVars0),
        FunDeps1 = list.map(remove_vars(NewVars0), FunDeps0),
        list.foldl2(collect_determined_vars, FunDeps1, [], FunDeps,
            set.init, NewVars),
        fundeps_closure_loop(FunDeps, NewVars, Result1, Result)
    ).

:- func remove_vars(set(tvar), induced_fundep) = induced_fundep.

remove_vars(Vars, fundep(Domain0, Range0)) = fundep(Domain, Range) :-
    Domain = set.difference(Domain0, Vars),
    Range = set.difference(Range0, Vars).

:- pred collect_determined_vars(induced_fundep::in, induced_fundeps::in,
    induced_fundeps::out, set(tvar)::in, set(tvar)::out) is det.

collect_determined_vars(FunDep @ fundep(Domain, Range), !FunDeps, !Vars) :-
    ( if set.is_empty(Domain) then
        !:Vars = set.union(Range, !.Vars)
    else
        !:FunDeps = [FunDep | !.FunDeps]
    ).

%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
%
% Error reporting.
%

    % Duplicate method definition error.
    %
:- pred report_duplicate_method_defn(class_id::in, hlds_instance_defn::in,
    pred_or_func::in, sym_name::in, arity::in, list(instance_method)::in,
    list(error_spec)::in, list(error_spec)::out) is det.

report_duplicate_method_defn(ClassId, InstanceDefn, PredOrFunc, MethodName,
        Arity, MatchingInstanceMethods, !Specs) :-
    InstanceVarSet = InstanceDefn ^ instdefn_tvarset,
    InstanceTypes = InstanceDefn ^ instdefn_types,
    InstanceContext = InstanceDefn ^ instdefn_context,
    ClassId = class_id(ClassName, _ClassArity),
    ClassNameString = unqualify_name(ClassName),
    InstanceTypesString = mercury_type_list_to_string(InstanceVarSet,
        InstanceTypes),
    HeaderPieces =
        [words("In instance declaration for"),
        words_quote(ClassNameString ++ "(" ++ InstanceTypesString ++ ")"),
        suffix(":"), nl,
        words("multiple implementations of type class"),
        p_or_f(PredOrFunc), words("method"),
        unqual_sym_name_arity(sym_name_arity(MethodName, Arity)),
        suffix("."), nl],
    HeadingMsg = simplest_msg(InstanceContext, HeaderPieces),
    (
        MatchingInstanceMethods = [FirstInstance | LaterInstances]
    ;
        MatchingInstanceMethods = [],
        unexpected($pred, "no matching instances")
    ),
    FirstInstanceContext = FirstInstance ^ instance_method_decl_context,
    FirstPieces = [words("First definition appears here."), nl],
    FirstMsg = simplest_msg(FirstInstanceContext, FirstPieces),
    DefnToMsg =
        ( pred(Definition::in, Msg::out) is det :-
            TheContext = Definition ^ instance_method_decl_context,
            SubsequentPieces =
                [words("Subsequent definition appears here."), nl],
            Msg = simplest_msg(TheContext, SubsequentPieces)
        ),
    list.map(DefnToMsg, LaterInstances, LaterMsgs),

    Spec = error_spec($pred, severity_error, phase_type_check,
        [HeadingMsg, FirstMsg | LaterMsgs]),
    !:Specs = [Spec | !.Specs].

%---------------------------------------------------------------------------%

:- pred report_undefined_method(class_id::in, hlds_instance_defn::in,
    pred_or_func::in, sym_name::in, arity::in,
    list(error_spec)::in, list(error_spec)::out) is det.

report_undefined_method(ClassId, InstanceDefn, PredOrFunc, MethodName, Arity,
        !Specs) :-
    InstanceVarSet = InstanceDefn ^ instdefn_tvarset,
    InstanceTypes = InstanceDefn ^ instdefn_types,
    InstanceContext = InstanceDefn ^ instdefn_context,
    ClassId = class_id(ClassName, _ClassArity),
    ClassNameString = unqualify_name(ClassName),
    InstanceTypesString = mercury_type_list_to_string(InstanceVarSet,
        InstanceTypes),

    Pieces = [words("In instance declaration for"),
        words_quote(ClassNameString ++ "(" ++ InstanceTypesString ++ ")"),
        suffix(":"), nl,
        words("no implementation for type class"), p_or_f(PredOrFunc),
        words("method"),
        unqual_sym_name_arity(sym_name_arity(MethodName, Arity)),
        suffix("."), nl],
    Spec = simplest_spec($pred, severity_error, phase_type_check,
        InstanceContext, Pieces),
    !:Specs = [Spec | !.Specs].

%---------------------------------------------------------------------------%

:- pred report_unknown_instance_methods(class_id::in,
    instance_method::in, list(instance_method)::in,
    prog_context::in, list(error_spec)::in, list(error_spec)::out) is det.

report_unknown_instance_methods(ClassId, HeadMethod, TailMethods, Context,
        !Specs) :-
    (
        TailMethods = [],
        HeadMethod = instance_method(HeadPredOrFunc, HeadMethodName, _Defn,
            HeadArity, _Context),
        adjust_func_arity(HeadPredOrFunc, HeadArity, HeadPredArity),
        Pieces = [words("In instance declaration for"),
            unqual_class_id(ClassId), suffix(":"), nl,
            words("the type class has no"),
            p_or_f(HeadPredOrFunc), words("method named"),
            unqual_sym_name_arity(
                sym_name_arity(HeadMethodName, HeadPredArity)),
            suffix("."), nl]
    ;
        TailMethods = [_ | _],
        Pieces1 = [words("In instance declaration for"),
            unqual_class_id(ClassId), suffix(":"), nl,
            words("the type class has none of these methods:"), nl],
        format_method_names(HeadMethod, TailMethods, Pieces2),
        Pieces = Pieces1 ++ Pieces2
    ),

    Spec = simplest_spec($pred, severity_error, phase_type_check,
        Context, Pieces),
    !:Specs = [Spec | !.Specs].

:- pred format_method_names(instance_method::in, list(instance_method)::in,
    list(format_component)::out) is det.

format_method_names(HeadMethod, TailMethods, Pieces) :-
    HeadMethod = instance_method(PredOrFunc, Name, _Defn, Arity, _Context),
    adjust_func_arity(PredOrFunc, Arity, PredArity),
    (
        TailMethods = [],
        Pieces = [p_or_f(PredOrFunc),
            unqual_sym_name_arity(sym_name_arity(Name, PredArity)),
            suffix("."), nl]
    ;
        TailMethods = [HeadTailMethod | TailTailMethods],
        format_method_names(HeadTailMethod, TailTailMethods, TailPieces),
        Pieces = [p_or_f(PredOrFunc),
            unqual_sym_name_arity(sym_name_arity(Name, PredArity)),
            suffix(","), words("or"), nl | TailPieces]
    ).

%---------------------------------------------------------------------------%
:- end_module check_hlds.check_typeclass.
%---------------------------------------------------------------------------%
