%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 2015-2018 The Mercury team.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%---------------------------------------------------------------------------%
%
% This module checks the correctness of Mercury name to foreign name mappings
% in foreign enum and foreign export enum declarations.
%
%---------------------------------------------------------------------------%

:- module parse_tree.prog_foreign_enum.
:- interface.

:- import_module mdbcomp.
:- import_module mdbcomp.sym_name.
:- import_module parse_tree.error_spec.
:- import_module parse_tree.prog_data.

:- import_module assoc_list.
:- import_module bimap.
:- import_module list.
:- import_module set_tree234.

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

:- type for_fe_or_fee
    --->    for_foreign_enum
    ;       for_foreign_export_enum.

    % build_ctor_name_to_foreign_name_map_loop(ForWhat, Context, ContextPieces,
    %   TypeModuleName, ValidCtorNames, MercuryForeignAL, MercuryForeignBiMap,
    %   !Specs):
    %
    % Given MercuryForeignAL, a list of pairs of Mercury and foreign names,
    % check that all the Mercury names are correctly module qualified
    % (i.e. they are in module TypeModuleName), that they name a valid data
    % constructor (i.e. one in ValidCtorNames) and try to construct a bimap
    % (MercuryForeignBiMap) between those two sets of names, using the rules
    % appropriate for either foreign_enum or foreign_export_enum pragmas,
    % as selected by ForWhat.
    %
    % Generate an error message for each Mercury name that is not correctly
    % module qualified, for each name that is not a valid ctor, and for each
    % deviation of MercuryForeignAL from the relevant rules. Use ContextPieces
    % as the first half of each error message, and Context as their context.
    %
:- pred build_ctor_name_to_foreign_name_map(for_fe_or_fee::in,
    prog_context::in, list(format_piece)::in, module_name::in,
    set_tree234(string)::in, assoc_list(sym_name, string)::in,
    bimap(string, string)::out,
    list(error_spec)::in, list(error_spec)::out) is det.

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

:- implementation.

:- import_module bool.
:- import_module cord.
:- import_module pair.
:- import_module string.

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

build_ctor_name_to_foreign_name_map(ForWhat, Context, ContextPieces,
        TypeModuleName, ValidCtorNames, MercuryForeignAL,
        MercuryForeignBiMap, !Specs) :-
    MercuryForeignBiMap0 = bimap.init,
    SeenCtorNames0 = set_tree234.init,
    SeenForeignNames0 = set_tree234.init,
    BadQualCtorSymNamesCord0 = cord.init,
    InvalidCtorSymNamesCord0 = cord.init,
    RepeatedCtorNamesCord0 = cord.init,
    RepeatedForeignNamesCord0 = cord.init,
    build_ctor_name_to_foreign_name_map_loop(TypeModuleName, ValidCtorNames,
        MercuryForeignAL, MercuryForeignBiMap0, MercuryForeignBiMap,
        SeenCtorNames0, SeenCtorNames, SeenForeignNames0,
        BadQualCtorSymNamesCord0, BadQualCtorSymNamesCord,
        InvalidCtorSymNamesCord0, InvalidCtorSymNamesCord,
        RepeatedCtorNamesCord0, RepeatedCtorNamesCord,
        RepeatedForeignNamesCord0, RepeatedForeignNamesCord),

    % Badly qualified data constructor names should have been caught by
    % parse_pragma.m, and should have prevented the construction
    % of the foreign_enum pragma, for at least one of our callers
    % (check_type_inst_mode_defns.m), but maybe not the other
    % (add_foreign_enum.m).
    ( if cord.is_empty(BadQualCtorSymNamesCord) then
        true
    else
        add_bad_qual_ctors_error(Context, ContextPieces,
            cord.to_list(BadQualCtorSymNamesCord), !Specs)
    ),
    ( if cord.is_empty(InvalidCtorSymNamesCord) then
        true
    else
        add_unknown_ctors_error(Context, ContextPieces,
            cord.to_list(InvalidCtorSymNamesCord), !Specs)
    ),
    RepeatedCtorNames = cord.to_list(RepeatedCtorNamesCord),
    RepeatedForeignNames = cord.to_list(RepeatedForeignNamesCord),
    ( if
        RepeatedCtorNames = [],
        RepeatedForeignNames = []
    then
        true
    else
        % How should we describe the contents of RepeatedForeignNames
        % in error messages: as "names" or "values"?
        %
        % (The variable is RepeatedForeignNames because
        % RepeatedForeignNamesOrValues would be too long.)
        (
            ForWhat = for_foreign_export_enum,
            % Foreign_export_enums specify name of the foreign lval
            % (variable name or macro name) to set to the representation
            % of the Mercury constant chosen by the Mercury compiler.
            NameOrValue = "name",
            NamesOrValues = "names"
        ;
            ForWhat = for_foreign_enum,
            % Foreign_enums tell the Mercury compiler what rval it should
            % use to represent the Mercury constant. The rval may be
            % the value of a variable, but it may also be a constant
            % (or possibly even a constant expression).
            NameOrValue = "value",
            NamesOrValues = "values"
        ),
        MainPieces = ContextPieces ++
            [invis_order_default_start(3, ""),
            words("error: the specified")] ++
            color_as_subject([words("mapping between"),
                words("the names of Mercury constructors and"),
                words("the corresponding foreign"), words(NamesOrValues)]) ++
            [words("is")] ++
            color_as_incorrect([words("inconsistent.")]) ++
            [nl],
        (
            RepeatedCtorNames = [],
            CtorNamePieces = []
        ;
            RepeatedCtorNames = [_ | _],
            RepeatedCtorPieces =
                list.map((func(N) = quote(N)), RepeatedCtorNames),
            CtorNamePieces =
                [words("The following Mercury constructor"),
                words(choose_number(RepeatedCtorNames,
                    "name is", "names are"))] ++
                color_as_incorrect([words("repeated:")]) ++
                [nl_indent_delta(1)] ++
                piece_list_to_color_pieces(color_incorrect, "and",
                    [suffix(".")], RepeatedCtorPieces) ++
                [nl_indent_delta(-1)]
        ),
        (
            RepeatedForeignNames = [],
            ForeignNamePieces = []
        ;
            RepeatedForeignNames = [_ | _],
            RepeatedForeignPieces =
                list.map((func(N) = quote(N)), RepeatedForeignNames),
            ForeignNamePieces =
                [words("The following foreign"),
                words(choose_number(RepeatedForeignNames,
                    NameOrValue ++ " is", NamesOrValues ++ " are"))] ++
                color_as_incorrect([words("repeated:")]) ++
                [nl_indent_delta(1)] ++
                piece_list_to_color_pieces(color_incorrect, "and",
                    [suffix(".")], RepeatedForeignPieces) ++
                [nl_indent_delta(-1)]
        ),
        Pieces = MainPieces ++ CtorNamePieces ++ ForeignNamePieces,
        Spec = spec($pred, severity_error, phase_pt2h, Context, Pieces),
        !:Specs = [Spec | !.Specs]
    ),
    (
        ForWhat = for_foreign_export_enum
    ;
        ForWhat = for_foreign_enum,
        set_tree234.difference(ValidCtorNames, SeenCtorNames, UnseenCtorNames),
        set_tree234.to_sorted_list(UnseenCtorNames, UnseenCtorNamesList),
        (
            UnseenCtorNamesList = []
        ;
            UnseenCtorNamesList = [_ | _],
            add_foreign_enum_unmapped_ctors_error(Context, ContextPieces,
                UnseenCtorNamesList, !Specs)
        )
    ).

:- pred build_ctor_name_to_foreign_name_map_loop(module_name::in,
    set_tree234(string)::in, assoc_list(sym_name, string)::in,
    bimap(string, string)::in, bimap(string, string)::out,
    set_tree234(string)::in, set_tree234(string)::out, set_tree234(string)::in,
    cord(sym_name)::in, cord(sym_name)::out,
    cord(sym_name)::in, cord(sym_name)::out,
    cord(string)::in, cord(string)::out,
    cord(string)::in, cord(string)::out) is det.

build_ctor_name_to_foreign_name_map_loop(_, _, [], !MercuryForeignBiMap,
        !SeenCtorNames, _SeenForeignNames, !BadQualCtorSymNames,
        !InvalidCtorSymNames, !RepeatedCtorNames, !RepeatedForeignNames).
build_ctor_name_to_foreign_name_map_loop(TypeModuleName, ValidCtorNames,
        [MercuryForeign | MercuryForeignAL], !MercuryForeignBiMap,
        !SeenCtorNames, !.SeenForeignNames, !BadQualCtorSymNames,
        !InvalidCtorSymNames, !RepeatedCtorNames, !RepeatedForeignNames) :-
    MercuryForeign = CtorSymName - ForeignName,
    some [!OK] (
        !:OK = yes,
        (
            CtorSymName = qualified(CtorModuleName, CtorName),
            ( if CtorModuleName = TypeModuleName then
                true
            else
                cord.snoc(CtorSymName, !BadQualCtorSymNames),
                !:OK = no
            )
        ;
            CtorSymName = unqualified(CtorName)
        ),
        ( if set_tree234.contains(ValidCtorNames, CtorName) then
            true
        else
            cord.snoc(CtorSymName, !InvalidCtorSymNames),
            !:OK = no
        ),
        ( if set_tree234.insert_new(CtorName, !SeenCtorNames) then
            true
        else
            !:RepeatedCtorNames = cord.snoc(!.RepeatedCtorNames, CtorName),
            !:OK = no
        ),
        ( if set_tree234.insert_new(ForeignName, !SeenForeignNames) then
            true
        else
            cord.snoc(ForeignName, !RepeatedForeignNames),
            !:OK = no
        ),
        (
            !.OK = yes,
            bimap.det_insert(CtorName, ForeignName, !MercuryForeignBiMap)
        ;
            !.OK = no
        )
    ),
    build_ctor_name_to_foreign_name_map_loop(TypeModuleName, ValidCtorNames,
        MercuryForeignAL, !MercuryForeignBiMap,
        !SeenCtorNames, !.SeenForeignNames, !BadQualCtorSymNames,
        !InvalidCtorSymNames, !RepeatedCtorNames, !RepeatedForeignNames).

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

:- pred add_bad_qual_ctors_error(prog_context::in, list(format_piece)::in,
    list(sym_name)::in, list(error_spec)::in, list(error_spec)::out) is det.

add_bad_qual_ctors_error(Context, ContextPieces, Ctors, !Specs) :-
    HasOrHave = choose_number(Ctors, "symbol has", "symbols have"),
    QualCtors = list.map(qual_ctor_to_format_piece, Ctors),
    ErrorPieces = [invis_order_default_start(2, ""),
        words("error: the following"),
        words(HasOrHave), words("a module qualification that is")] ++
        color_as_incorrect(
            [words("not compatible with the type definition:")]) ++
        [nl_indent_delta(1)] ++
        pieces_list_to_color_line_pieces(color_incorrect, [suffix(".")],
            QualCtors) ++
        [nl_indent_delta(-1)],
    Spec = spec($pred, severity_error, phase_pt2h, Context,
        ContextPieces ++ ErrorPieces),
    !:Specs = [Spec | !.Specs].

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

:- func qual_ctor_to_format_piece(sym_name) = list(format_piece).

qual_ctor_to_format_piece(SymName) = [qual_sym_name(SymName)].

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

    % add_unknown_ctors_error(Context, ContextPieces, Ctors, !Specs):
    %
    % Given ContextPieces as the first half of an error message that
    % identifies a type, generate a complete error message about Ctors
    % not being constructor(s) of that type.
    %
:- pred add_unknown_ctors_error(prog_context::in, list(format_piece)::in,
    list(sym_name)::in, list(error_spec)::in, list(error_spec)::out) is det.

add_unknown_ctors_error(Context, ContextPieces, Ctors, !Specs) :-
    IsOrAre = choose_number(Ctors, "symbol is", "symbols are"),
    NotConstructors = choose_number(Ctors,
        "not a constructor", "not constructors"),
    UnqualCtors = list.map(unqual_ctor_to_format_piece, Ctors),
    ErrorPieces = [invis_order_default_start(1, ""),
        words("error: the following"), words(IsOrAre)] ++
        color_as_incorrect([words(NotConstructors)]) ++
        [words("of the type:"), nl_indent_delta(1)] ++
        pieces_list_to_color_line_pieces(color_incorrect, [suffix(".")],
            UnqualCtors) ++
        [nl_indent_delta(-1)],
    Spec = spec($pred, severity_error, phase_pt2h, Context,
        ContextPieces ++ ErrorPieces),
    !:Specs = [Spec | !.Specs].

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

:- func unqual_ctor_to_format_piece(sym_name) = list(format_piece).

unqual_ctor_to_format_piece(SymName) = [unqual_sym_name(SymName)].

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

    % add_foreign_enum_unmapped_ctors_error(Context, ContextPieces, CtorNames,
    %   !Specs):
    %
    % Given ContextPieces as the first half of an error message that
    % identifies a type, generate a complete error message about CtorNames
    % not being mapped to a foreign language value.
    %
:- pred add_foreign_enum_unmapped_ctors_error(prog_context::in,
    list(format_piece)::in,
    list(string)::in(non_empty_list),
    list(error_spec)::in, list(error_spec)::out) is det.

add_foreign_enum_unmapped_ctors_error(Context, ContextPieces, CtorNames0,
        !Specs) :-
    list.sort(CtorNames0, CtorNames),
    list.split_upto(10, CtorNames, CtorsStart, CtorsEnd),
    CtorOrCtors = choose_number(CtorNames, "constructor", "constructors"),
    DoOrDoes = choose_number(CtorNames, "does", "do"),
    PrefixPieces = ContextPieces ++
        [words("error: the following"), words(CtorOrCtors)] ++
        color_as_incorrect([words(DoOrDoes),
            words("not have a foreign value:")]),
    (
        CtorsEnd = [],
        CtorsPieces =
            [nl_indent_delta(1)] ++
            quote_list_to_color_line_pieces(color_incorrect, [suffix(".")],
                CtorNames) ++
            [nl_indent_delta(-1)],
        CtorsComponent = always(CtorsPieces)
    ;
        CtorsEnd = [_ | _],
        list.length(CtorsEnd, NumEndCtors),
        NonVerboseCtorsPieces =
            [nl_indent_delta(1)] ++
            quote_list_to_color_line_pieces(color_incorrect,
                [suffix(","), fixed("...")], CtorsStart) ++
            [nl_indent_delta(-1), words("and"),
            int_fixed(NumEndCtors), words("more."), nl],
        VerboseCtorsPieces =
            [nl_indent_delta(1)] ++
            quote_list_to_color_line_pieces(color_incorrect, [suffix(".")],
                CtorNames) ++
            [nl_indent_delta(-1)],
        CtorsComponent =
            verbose_and_nonverbose(VerboseCtorsPieces, NonVerboseCtorsPieces)
    ),
    Msg = simple_msg(Context, [always(PrefixPieces), CtorsComponent]),
    Spec = error_spec($pred, severity_error, phase_pt2h, [Msg]),
    !:Specs = [Spec | !.Specs].

%---------------------------------------------------------------------------%
:- end_module parse_tree.prog_foreign_enum.
%---------------------------------------------------------------------------%
