%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 2006-2011 The University of Melbourne.
% Copyright (C) 2014-2026 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.
%-----------------------------------------------------------------------------%
%
% File: prog_event.m.
% Author: zs.
%
% This module defines the database of information the compiler has about
% events other than the built-in set of execution tracing events.
%
%-----------------------------------------------------------------------------%

:- module parse_tree.prog_event.
:- interface.

:- import_module parse_tree.error_spec.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_data_event.

:- import_module io.
:- import_module list.

    % read_event_set(FileName, EventSetName, EventSpecMap, ErrorSpecs, !IO):
    %
    % Read in a set of event specifications from FileName, and return them
    % in EventSetName and EventSpecMap. Set ErrorSpecs to a list of all the
    % errors discovered during the process.
    %
:- pred read_event_set(string::in, string::out, event_spec_map::out,
    list(err_spec)::out, io::di, io::uo) is det.

    % Return a description of the given event set.
    %
:- func derive_event_set_data(event_set) = event_set_data.

    % Given an event name, returns its number.
    %
:- pred event_number(event_spec_map::in, string::in, int::out) is semidet.

    % Given an event name, returns the attributes of the event.
    %
:- pred event_attributes(event_spec_map::in, string::in,
    list(event_attribute)::out) is semidet.

    % Given an event name, returns the types of the arguments of the event.
    %
:- pred event_arg_types(event_spec_map::in, string::in, list(mer_type)::out)
    is semidet.

    % Given an event name, returns the modes of the arguments of the event.
    %
:- pred event_arg_modes(event_spec_map::in, string::in, list(mer_mode)::out)
    is semidet.

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

:- implementation.

:- import_module mdbcomp.
:- import_module mdbcomp.sym_name.
:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_type_construct.

:- import_module assoc_list.
:- import_module bimap.
:- import_module digraph.
:- import_module int.
:- import_module io.file.
:- import_module map.
:- import_module maybe.
:- import_module pair.
:- import_module require.
:- import_module set.
:- import_module string.
:- import_module term_context.

read_event_set(SpecsFileName, EventSetName, EventSpecMap, ErrorSpecs, !IO) :-
    % Currently, we convert the event specification file into a Mercury term
    % by using the yacc parser in the trace directory to create a C data
    % structure to represent its contents, writing out that data structure
    % as a Mercury term to a file (TermFileName), and then reading in the term
    % from that file.
    %
    % This is a clumsy approach, since it requires access to the C code in the
    % trace directory (via the event_spec library) and a temporary file.
    % Using Mercury scanners and parsers generated by mscangen and mparsegen
    % respectively would be a much better and more direct approach, but
    % those tools are not yet mature enough. When they are, we should switch
    % to using them.

    make_temp_file_and_open_it(read_specs_file(SpecsFileName),
        TermFileResult, !IO),
    (
        TermFileResult = ok({TermFileName, TermStream}),
        io.read(TermStream, TermReadRes, !IO),
        (
            TermReadRes = ok(EventSetTerm),
            EventSetTerm = event_set_spec(EventSetName,
                EventSpecsTerm),
            convert_list_to_spec_map(SpecsFileName, EventSpecsTerm,
                map.init, EventSpecMap, [], ErrorSpecs)
        ;
            TermReadRes = eof,
            EventSetName = "",
            EventSpecMap = map.init,
            Pieces = [words("Error: unexpected end-of-file"),
                words("in term specification file."), nl],
            ErrorSpec = no_ctxt_spec($pred, severity_error, phase_t2pt,
                Pieces),
            ErrorSpecs = [ErrorSpec]
        ;
            TermReadRes = error(TermReadMsg, LineNumber),
            EventSetName = "",
            EventSpecMap = map.init,
            Pieces = [words(TermReadMsg), nl],
            ErrorSpec = spec($pred, severity_error, phase_t2pt,
                term_context.context(TermFileName, LineNumber), Pieces),
            ErrorSpecs = [ErrorSpec]
        ),
        io.close_input(TermStream, !IO),
        io.file.remove_file(TermFileName, _RemoveRes, !IO)
    ;
        TermFileResult = error(ErrorMessage),
        EventSetName = "",
        EventSpecMap = map.init,
        Pieces = [words("Error:"), lower_case_next_if_not_first,
            words(ErrorMessage), nl],
        ErrorSpec = no_ctxt_spec($pred, severity_error, phase_t2pt, Pieces),
        ErrorSpecs = [ErrorSpec]
    ).

    % make_temp_file_and_open_it(WritePred, Result, !IO):
    %
    % Create a temporary file and call WritePred which will write data to it.
    % If successful, return the file's name and a freshly opened input stream.
    % On error, remove the temporary file.
    %
:- pred make_temp_file_and_open_it(
    pred(string, maybe_error, io, io)::in(pred(in, out, di, uo) is det),
    maybe_error({string, text_input_stream})::out,
    io::di, io::uo) is det.

make_temp_file_and_open_it(WritePred, Result, !IO) :-
    io.file.make_temp_file(TempFileResult, !IO),
    (
        TempFileResult = ok(TempFileName),
        WritePred(TempFileName, PredResult, !IO),
        (
            PredResult = ok,
            io.open_input(TempFileName, OpenResult, !IO),
            (
                OpenResult = ok(Stream),
                Result = ok({TempFileName, Stream})
            ;
                OpenResult = error(Error),
                ErrorMessage = string.format("could not open `%s': %s",
                    [s(TempFileName), s(error_message(Error))]),
                Result = error(ErrorMessage),
                io.file.remove_file(TempFileName, _, !IO)
            )
        ;
            PredResult = error(ErrorMessage),
            io.file.remove_file(TempFileName, _, !IO),
            Result = error(ErrorMessage)
        )
    ;
        TempFileResult = error(Error),
        ErrorMessage = string.format("could not create temporary file: %s",
            [s(error_message(Error))]),
        Result = error(ErrorMessage)
    ).

:- pred read_specs_file(string::in, string::in, maybe_error::out,
    io::di, io::uo) is det.

read_specs_file(SpecsFile, TermFile, Result, !IO) :-
    read_specs_file_2(SpecsFile, TermFile, Problem, !IO),
    ( if Problem = "" then
        Result = ok
    else
        Result = error(Problem)
    ).

:- pragma foreign_decl("C",
"
#include ""mercury_event_spec.h""
#include <stdio.h>
#include <fcntl.h>

MR_String   read_specs_file_2(MR_AllocSiteInfoPtr alloc_id,
                MR_String specs_file_name, MR_String term_file_name);
MR_String   read_specs_file_3(MR_AllocSiteInfoPtr alloc_id,
                MR_String specs_file_name, MR_String term_file_name,
                int spec_fd);
MR_String   read_specs_file_4(MR_AllocSiteInfoPtr alloc_id,
                MR_String specs_file_name, MR_String term_file_name,
                int spec_fd, size_t size, char *spec_buf);
").

:- pred read_specs_file_2(string::in, string::in, string::out,
    io::di, io::uo) is det.
:- pragma no_determinism_warning(pred(read_specs_file_2/5)).

:- pragma foreign_proc("C",
    read_specs_file_2(SpecsFileName::in, TermFileName::in, Problem::out,
        _IO0::di, _IO::uo),
    [will_not_call_mercury, promise_pure, tabled_for_io, thread_safe],
"
    // We need to save/restore MR_hp so that we can allocate the return
    // value on Mercury's heap if necessary.
    MR_save_transient_hp();
    Problem = read_specs_file_2(MR_ALLOC_ID, SpecsFileName, TermFileName);
    MR_restore_transient_hp();
").

read_specs_file_2(_, _, Problem, IO, IO) :-
    Problem = "mmc can read event set specifications only when it itself " ++
        "is compiled in a grade that targets C code.".

:- pragma foreign_code("C", "

MR_String
read_specs_file_2(MR_AllocSiteInfoPtr alloc_id, MR_String specs_file_name,
    MR_String term_file_name)
{
    int         spec_fd;
    MR_String   problem;
    char        errbuf[MR_STRERROR_BUF_SIZE];

    // There are race conditions between opening the file, stat'ing the file
    // and reading the contents of the file, but the Unix API doesn't really
    // allow these race conditions to be resolved.

    spec_fd = open(specs_file_name, O_RDONLY);
    if (spec_fd < 0) {
        problem = MR_make_string(alloc_id, ""could not open %s: %s"",
            specs_file_name, MR_strerror(errno, errbuf, sizeof(errbuf)));
    } else {
        problem = read_specs_file_3(alloc_id, specs_file_name,
            term_file_name, spec_fd);
        (void) close(spec_fd);
    }
    return problem;
}

MR_String
read_specs_file_3(MR_AllocSiteInfoPtr alloc_id, MR_String specs_file_name,
    MR_String term_file_name, int spec_fd)
{
    struct stat stat_buf;
    MR_String   problem;

    if (fstat(spec_fd, &stat_buf) != 0) {
        problem = MR_make_string(alloc_id, ""could not stat %s"",
            specs_file_name);
    } else {
        char        *spec_buf;

        spec_buf = malloc(stat_buf.st_size + 1);
        if (spec_buf == NULL) {
            problem = MR_make_string(alloc_id,
                ""could not allocate memory for a copy of %s"",
                specs_file_name);
        } else {
            problem = read_specs_file_4(alloc_id, specs_file_name,
                term_file_name, spec_fd, stat_buf.st_size, spec_buf);
            free(spec_buf);
        }
    }
    return problem;
}

MR_String
read_specs_file_4(MR_AllocSiteInfoPtr alloc_id, MR_String specs_file_name,
    MR_String term_file_name, int spec_fd, size_t size, char *spec_buf)
{
    size_t      num_bytes_read;
    MR_String   problem;

    // XXX We don't handle successful but partial reads.
    do {
        num_bytes_read = read(spec_fd, spec_buf, size);
    } while (num_bytes_read == -1 && MR_is_eintr(errno));
    if (num_bytes_read != size) {
        problem = MR_make_string(alloc_id, ""could not read in %s"",
            specs_file_name);
    } else {
        MR_EventSet event_set;

        // NULL terminate the string we have read in.
        spec_buf[num_bytes_read] = '\\0';
        event_set = MR_read_event_set(specs_file_name, spec_buf);
        if (event_set == NULL) {
            problem = MR_make_string(alloc_id, ""could not parse %s"",
                specs_file_name);
        } else {
            FILE *term_fp;
            char errbuf[MR_STRERROR_BUF_SIZE];

            term_fp = fopen(term_file_name, ""w"");
            if (term_fp == NULL) {
                problem = MR_make_string(alloc_id, ""could not open %s: %s"",
                    term_file_name,
                    MR_strerror(errno, errbuf, sizeof(errbuf)));
            } else {
                MR_print_event_set(term_fp, event_set);
                fclose(term_fp);

                // Our caller tests Problem against the empty string, not NULL.
                problem = MR_make_string(alloc_id, """");
            }
        }
    }
    return problem;
}
").

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

:- type event_set_spec
    --->    event_set_spec(
                event_set_name      :: string,
                event_set_specs     :: list(event_spec_term)
            ).

:- type event_spec_term
    --->    event_spec_term(
                event_name          :: string,
                event_num           :: int,
                event_linenumber    :: int,
                event_attrs         :: list(event_attr_term)
            ).

:- type event_attr_term
    --->    event_attr_term(
                attr_name           :: string,
                attr_linenum        :: int,
                attr_type           :: event_attr_type
            ).

:- type event_attr_synth_call_term
    --->    event_attr_synth_call_term(
                func_attr_name  :: string,
                arg_attr_names  :: list(string)
            ).

:- type event_attr_function_kind
    --->    event_attr_pure_function
    ;       event_attr_impure_function.

:- type event_attr_type
    --->    event_attr_type_ordinary(
                event_attr_type_term
            )
    ;       event_attr_type_synthesized(
                event_attr_type_term,
                event_attr_synth_call_term
            )
    ;       event_attr_type_function(
                event_attr_function_kind
            ).

:- type event_attr_type_term
    --->    event_attr_type_term(
                string,
                list(event_attr_type_term)
            ).

:- pred convert_list_to_spec_map(string::in, list(event_spec_term)::in,
    event_spec_map::in, event_spec_map::out,
    list(err_spec)::in, list(err_spec)::out) is det.

convert_list_to_spec_map(_, [], !EventSpecMap, !ErrorSpecs).
convert_list_to_spec_map(FileName, [SpecTerm | SpecTerms],
        !EventSpecMap, !ErrorSpecs) :-
    convert_term_to_spec_map(FileName, SpecTerm, !EventSpecMap, !ErrorSpecs),
    convert_list_to_spec_map(FileName, SpecTerms, !EventSpecMap, !ErrorSpecs).

:- pred convert_term_to_spec_map(string::in, event_spec_term::in,
    event_spec_map::in, event_spec_map::out,
    list(err_spec)::in, list(err_spec)::out) is det.

convert_term_to_spec_map(FileName, SpecTerm, !EventSpecMap, !ErrorSpecs) :-
    SpecTerm = event_spec_term(EventName, EventNumber, EventLineNumber,
        AttrTerms),

    % We convert the event_spec_term we have read in to the event_spec_map
    % table entry we need in three stages.
    %
    % Stage 1 is done by build_plain_type_map. This records the types of all
    % of the ordinary and synthesized attributes in AttrTypeMap0, builds up
    % KeyMap, which maps each attribute name to its digraph_key in DepRel0,
    % and builds DepRel0, which at the end of stage 1 just contains one key
    % for each attribute with no relationships between them.
    %
    % Stage 2 is done by build_dep_map. This inserts into DepRel all the
    % dependencies of synthesized attributes on the attributes they are
    % synthesized from (including the attribute that provides the function).
    % It also computes the types of the function attributes that are used
    % to synthesize one or more other attributes.
    %
    % Stage 3, implemented by convert_terms_to_attrs, is the final pass.
    % It does the data format conversion, and performs the last checks.

    build_plain_type_map(EventName, FileName, EventLineNumber, AttrTerms,
        0, map.init, _AttrNumMap, map.init, AttrNameMap,
        map.init, AttrTypeMap0, bimap.init, KeyMap,
        digraph.init, DepRel0, !ErrorSpecs),
    build_dep_map(EventName, FileName, AttrNameMap, KeyMap, AttrTerms,
        AttrTypeMap0, AttrTypeMap, DepRel0, DepRel, !ErrorSpecs),
    convert_terms_to_attrs(EventName, FileName, AttrNameMap,
        AttrTypeMap, 0, AttrTerms, [], RevAttrs, !ErrorSpecs),
    ( if
        digraph.return_vertices_in_from_to_order(DepRel, AllAttrNameOrder)
    then
        % There is an order for computing the synthesized attributes.
        keep_only_synth_attr_nums(AttrNameMap, AllAttrNameOrder,
            SynthAttrNumOrder)
    else
        Context = term_context.context(FileName, EventLineNumber),
        Sccs = digraph.return_sccs_in_to_from_order(DepRel),
        list.filter(two_or_more_attrs_in_scc, Sccs, TooLargeSccs),
        digraph.to_assoc_list(DepRel, DepRelEdges),
        list.foldl(acc_self_dependent_nodes, DepRelEdges, [], RevSelfRecSccs),
        list.reverse(RevSelfRecSccs, SelfRecSccs),
        % Each scc in TooLargeSccs contains mutual recursion, while
        % each scc in SelfRecSccs contains self recursion.
        BadSccs = TooLargeSccs ++ SelfRecSccs,
        (
            BadSccs = [_ | _],
            list.foldl(acc_circular_synth_attr_error(Context, EventName),
                BadSccs, !ErrorSpecs)
        ;
            BadSccs = [],
            % Print an error message even if we can't blame a specific
            % subset of the synthesized attributes.
            acc_circular_synth_attr_error(Context, EventName,
                set.init, !ErrorSpecs)
        ),
        SynthAttrNumOrder = []
    ),
    list.reverse(RevAttrs, Attrs),
    EventSpec = event_spec(EventNumber, EventName, EventLineNumber,
        Attrs, SynthAttrNumOrder),
    ( if map.search(!.EventSpecMap, EventName, OldEventSpec) then
        OldLineNumber = OldEventSpec ^ event_spec_linenum,
        Pieces1 = [words("Error: this specification for event")] ++
            color_as_subject([quote(EventName)]) ++
            color_as_incorrect([words("is a duplicate.")]),
        Pieces2 = [words("The previous specification of event"),
            quote(EventName), words("is here."), nl],
        EventContext = term_context.context(FileName, EventLineNumber),
        OldContext = term_context.context(FileName, OldLineNumber),
        DuplErrorSpec = gen_spec($pred, severity_error, phase_t2pt,
            [msg(EventContext, Pieces1),
            msg(OldContext, Pieces2)]),
        !:ErrorSpecs = [DuplErrorSpec | !.ErrorSpecs]
    else
        map.det_insert(EventName, EventSpec, !EventSpecMap)
    ).

:- pred two_or_more_attrs_in_scc(set(string)::in) is semidet.

two_or_more_attrs_in_scc(Scc) :-
    set.count(Scc) > 1.

:- pred acc_self_dependent_nodes(pair(string, string)::in,
    list(set(string))::in, list(set(string))::out) is det.

acc_self_dependent_nodes(From - To, !RevSelfRecSccs) :-
    ( if From = To then
        !:RevSelfRecSccs = [set.make_singleton_set(From) | !.RevSelfRecSccs]
    else
        true
    ).

:- pred acc_circular_synth_attr_error(prog_context::in, string::in,
    set(string)::in, list(err_spec)::in, list(err_spec)::out) is det.

acc_circular_synth_attr_error(Context, EventName, Scc, !ErrorSpecs) :-
    Attrs = set.to_sorted_list(Scc),
    (
        Attrs = [_, _ | _],
        Pieces =
            [words("Error: synthesized attributes")] ++
            quote_list_to_color_pieces(color_subject, "and", [], Attrs) ++
            [words("of event"), quote(EventName)] ++
            color_as_incorrect([words("depend on each other.")]) ++
            [nl]
    ;
        Attrs = [Attr],
        Pieces =
            [words("Error: synthesized attribute")] ++
            color_as_subject([quote(Attr)]) ++
            [words("of event"), quote(EventName)] ++
            color_as_incorrect([words("depends on itself.")]) ++
            [nl]
    ;
        Attrs = [],
        % This should never happen, as all circular dependencies
        % should be classifiable as due to either mutual or self recursion,
        % but just in case ...
        Pieces =
            [words("Error:")] ++
            color_as_incorrect([words("circular dependency")]) ++
            [words("among the synthesized attributes of")] ++
            color_as_subject([words("event"), quote(EventName),
                suffix(".")]) ++
            [nl]
    ),
    CircErrorSpec = spec($pred, severity_error, phase_t2pt, Context, Pieces),
    !:ErrorSpecs = [CircErrorSpec | !.ErrorSpecs].

:- pred keep_only_synth_attr_nums(attr_name_map::in, list(string)::in,
    list(int)::out) is det.

keep_only_synth_attr_nums(_, [], []).
keep_only_synth_attr_nums(AttrMap, [AttrName | AttrNames], SynthAttrNums) :-
    keep_only_synth_attr_nums(AttrMap, AttrNames, SynthAttrNumsTail),
    map.lookup(AttrMap, AttrName, attr_info(AttrNum, _, _, AttrType)),
    (
        ( AttrType = event_attr_type_ordinary(_)
        ; AttrType = event_attr_type_function(_)
        ),
        SynthAttrNums = SynthAttrNumsTail
    ;
        AttrType = event_attr_type_synthesized(_, _),
        SynthAttrNums = [AttrNum | SynthAttrNumsTail]
    ).

:- type attr_info
    --->    attr_info(
                attr_info_number        :: int,
                attr_info_name          :: string,
                attr_info_linenumber    :: int,
                attr_info_type          :: event_attr_type
            ).

:- func attr_info_number(attr_info) = int.

    % Given an attribute number, return information about that attribute.
:- type attr_num_map == map(int, attr_info).

    % Given an attribute name, return information about that attribute.
:- type attr_name_map == map(string, attr_info).

    % Given an attribute number, return that attribute's type.
:- type attr_type_map == map(string, mer_type).

    % The dependency relation has a node for each attribute. The links between
    % nodes represent the dependency of one attribute on another.
    %
    % The attr_key_map maps the name of each attribute to its key in
    % attr_dep_rel.
:- type attr_dep_rel == digraph(string).
:- type attr_key == digraph_key(string).
:- type attr_key_map == bimap(string, attr_key).

    % See the big comment in convert_term_to_spec_map for the documentation
    % of this predicate.
    %
:- pred build_plain_type_map(string::in, string::in, int::in,
    list(event_attr_term)::in, int::in, attr_num_map::in, attr_num_map::out,
    attr_name_map::in, attr_name_map::out,
    attr_type_map::in, attr_type_map::out,
    attr_key_map::in, attr_key_map::out, attr_dep_rel::in, attr_dep_rel::out,
    list(err_spec)::in, list(err_spec)::out) is det.

build_plain_type_map(_, _, _, [], _, !AttrNumMap, !AttrNameMap, !AttrTypeMap,
        !KeyMap, !DepRel, !ErrorSpecs).
build_plain_type_map(EventName, FileName, EventLineNumber,
        [AttrTerm | AttrTerms], AttrNum, !AttrNumMap, !AttrNameMap,
        !AttrTypeMap, !KeyMap, !DepRel, !ErrorSpecs) :-
    AttrTerm = event_attr_term(AttrName, AttrLineNumber, AttrTypeTerm),
    AttrInfo = attr_info(AttrNum, AttrName, AttrLineNumber, AttrTypeTerm),
    map.det_insert(AttrNum, AttrInfo, !AttrNumMap),
    digraph.add_vertex(AttrName, AttrKey, !DepRel),
    ( if bimap.insert(AttrName, AttrKey, !KeyMap) then
        map.det_insert(AttrName, AttrInfo, !AttrNameMap)
    else
        Pieces = [words("Error: event"), quote(EventName)] ++
            color_as_incorrect([words("has more than one")]) ++
            [words("attribute named")] ++
            color_as_subject([quote(AttrName), suffix(".")]) ++
            [nl],
        ErrorSpec = spec($pred, severity_error, phase_t2pt,
            term_context.context(FileName, EventLineNumber), Pieces),
        !:ErrorSpecs = [ErrorSpec | !.ErrorSpecs]
    ),
    (
        ( AttrTypeTerm = event_attr_type_ordinary(TypeTerm)
        ; AttrTypeTerm = event_attr_type_synthesized(TypeTerm, _SynthCall)
        ),
        Type = convert_term_to_type(TypeTerm),
        ( if map.search(!.AttrTypeMap, AttrName, _OldType) then
            % The error message has already been generated above.
            true
        else
            map.det_insert(AttrName, Type, !AttrTypeMap)
        )
    ;
        AttrTypeTerm = event_attr_type_function(_)
    ),
    build_plain_type_map(EventName, FileName, EventLineNumber, AttrTerms,
        AttrNum + 1, !AttrNumMap, !AttrNameMap, !AttrTypeMap, !KeyMap, !DepRel,
        !ErrorSpecs).

    % See the big comment in convert_term_to_spec_map for the documentation
    % of this predicate.
    %
:- pred build_dep_map(string::in, string::in,
    attr_name_map::in, attr_key_map::in, list(event_attr_term)::in,
    attr_type_map::in, attr_type_map::out, attr_dep_rel::in, attr_dep_rel::out,
    list(err_spec)::in, list(err_spec)::out) is det.

build_dep_map(_, _, _, _, [], !AttrTypeMap, !DepRel, !ErrorSpecs).
build_dep_map(EventName, FileName, AttrNameMap, KeyMap, [AttrTerm | AttrTerms],
        !AttrTypeMap, !DepRel, !ErrorSpecs) :-
    AttrTerm = event_attr_term(AttrName, AttrLineNumber, AttrTypeTerm),
    bimap.lookup(KeyMap, AttrName, AttrKey),
    (
        AttrTypeTerm = event_attr_type_synthesized(_TypeTerm, SynthCallTerm),
        SynthCallTerm = event_attr_synth_call_term(FuncAttrName, ArgAttrNames),
        record_arg_dependencies(EventName, FileName, AttrLineNumber, KeyMap,
            AttrName, AttrKey, ArgAttrNames, !DepRel, [], AttrErrorSpecs),
        (
            AttrErrorSpecs = [_ | _],
            % We still record the fact that FuncAttrName is used, to prevent
            % us from generating error messages saying that it is unused.
            map.det_insert(FuncAttrName, void_type, !AttrTypeMap),
            !:ErrorSpecs = AttrErrorSpecs ++ !.ErrorSpecs
        ;
            AttrErrorSpecs = [],
            ( if map.search(!.AttrTypeMap, AttrName, AttrType) then
                list.map(map.lookup(!.AttrTypeMap), ArgAttrNames, ArgTypes),
                ( if
                    map.search(AttrNameMap, FuncAttrName, FuncAttrInfo),
                    FuncAttrInfo ^ attr_info_type =
                        event_attr_type_function(FuncAttrPurity)
                then
                    (
                        FuncAttrPurity = event_attr_pure_function,
                        FuncPurity = purity_pure
                    ;
                        FuncAttrPurity = event_attr_impure_function,
                        FuncPurity = purity_impure
                    ),
                    construct_higher_order_func_type(FuncPurity,
                        ArgTypes, AttrType, FuncAttrType),
                    ( if
                        map.search(!.AttrTypeMap, FuncAttrName,
                            OldFuncAttrType)
                    then
                        ( if FuncAttrType = OldFuncAttrType then
                            % AttrTypeMap already contains the correct info.
                            true
                        else
                            FuncAttrLine =
                                FuncAttrInfo ^ attr_info_linenumber,
                            % XXX Maybe we should give the types themselves.
                            Pieces = [words("Error: attribute")] ++
                                color_as_subject([quote(FuncAttrName)]) ++
                                [words("is assigned")] ++
                                color_as_incorrect(
                                    [words("inconsistent types")]) ++
                                [words("by synthesized attributes."), nl],
                            Context = context(FileName, FuncAttrLine),
                            ErrorSpec = spec($pred, severity_error, phase_t2pt,
                                Context, Pieces),
                            !:ErrorSpecs = [ErrorSpec | !.ErrorSpecs]
                        )
                    else
                        map.det_insert(FuncAttrName, FuncAttrType,
                            !AttrTypeMap)
                    )
                else
                    Pieces = [words("Error: attribute")] ++
                        color_as_subject([quote(AttrName)]) ++
                        color_as_incorrect([words("cannot be synthesized")]) ++
                        [words("by non-function attribute"),
                        quote(FuncAttrName), suffix("."), nl],
                    Context = context(FileName, AttrLineNumber),
                    ErrorSpec = spec($pred, severity_error, phase_t2pt,
                        Context, Pieces),
                    !:ErrorSpecs = [ErrorSpec | !.ErrorSpecs]
                )
            else
                % The error message was already generated in the previous pass.
                true
            )
        )
    ;
        AttrTypeTerm = event_attr_type_ordinary(_TypeTerm)
    ;
        AttrTypeTerm = event_attr_type_function(_)
    ),
    build_dep_map(EventName, FileName, AttrNameMap, KeyMap, AttrTerms,
        !AttrTypeMap, !DepRel, !ErrorSpecs).

:- pred record_arg_dependencies(string::in, string::in, int::in,
    attr_key_map::in, string::in, attr_key::in,
    list(string)::in, attr_dep_rel::in, attr_dep_rel::out,
    list(err_spec)::in, list(err_spec)::out) is det.

record_arg_dependencies(_, _, _, _, _, _, [], !DepRel, !ErrorSpecs).
record_arg_dependencies(EventName, FileName, AttrLineNumber, KeyMap,
        SynthAttrName, SynthAttrKey, [AttrName | AttrNames],
        !DepRel, !ErrorSpecs) :-
    ( if bimap.search(KeyMap, AttrName, AttrKey) then
        digraph.add_edge(AttrKey, SynthAttrKey, !DepRel)
    else
        Pieces = [words("Error: attribute")] ++
            color_as_subject([quote(SynthAttrName)]) ++
            [words("of event"), quote(EventName), words("uses")] ++
            color_as_incorrect([words("nonexistent attribute"),
                quote(AttrName)]) ++
            [words("in its synthesis."), nl],
        ErrorSpec = spec($pred, severity_error, phase_t2pt,
            term_context.context(FileName, AttrLineNumber), Pieces),
        !:ErrorSpecs = [ErrorSpec | !.ErrorSpecs]
    ),
    record_arg_dependencies(EventName, FileName, AttrLineNumber, KeyMap,
        SynthAttrName, SynthAttrKey, AttrNames, !DepRel, !ErrorSpecs).

    % See the big comment in convert_term_to_spec_map for the documentation
    % of this predicate.
    %
:- pred convert_terms_to_attrs(string::in, string::in, attr_name_map::in,
    attr_type_map::in, int::in, list(event_attr_term)::in,
    list(event_attribute)::in, list(event_attribute)::out,
    list(err_spec)::in, list(err_spec)::out) is det.

convert_terms_to_attrs(_, _, _, _, _, [], !RevAttrs, !ErrorSpecs).
convert_terms_to_attrs(EventName, FileName, AttrNameMap,
        AttrTypeMap, AttrNum, [AttrTerm | AttrTerms], !RevAttrs,
        !ErrorSpecs) :-
    AttrTerm = event_attr_term(AttrName, AttrLineNumber, AttrTypeTerm),
    (
        AttrTypeTerm = event_attr_type_ordinary(_),
        map.lookup(AttrTypeMap, AttrName, AttrType),
        EventAttr = event_attribute(AttrNum, AttrName, AttrType, in_mode, no),
        !:RevAttrs = [EventAttr | !.RevAttrs]
    ;
        AttrTypeTerm = event_attr_type_synthesized(_, SynthCallTerm),
        map.lookup(AttrTypeMap, AttrName, AttrType),
        SynthCallTerm = event_attr_synth_call_term(FuncAttrName, ArgAttrNames),
        ( if
            map.search(AttrNameMap, FuncAttrName, FuncAttrInfo),
            FuncAttrNum = FuncAttrInfo ^ attr_info_number,
            list.map(map.search(AttrNameMap), ArgAttrNames, ArgAttrInfos)
        then
            ArgAttrNums = list.map(attr_info_number, ArgAttrInfos),
            ArgAttrNameNums = assoc_list.from_corresponding_lists(ArgAttrNames,
                ArgAttrNums),
            compute_prev_synth_attr_order(AttrNameMap, AttrName,
                set.init, set.init, _, PrevSynthAttrOrder),
            SynthCall = event_attr_synth_call(FuncAttrName - FuncAttrNum,
                ArgAttrNameNums, PrevSynthAttrOrder),
            EventAttr = event_attribute(AttrNum, AttrName, AttrType, in_mode,
                yes(SynthCall)),
            !:RevAttrs = [EventAttr | !.RevAttrs]
        else
            % The error that caused the map search failure has already had
            % an error message generated for it.
            true
        )
    ;
        AttrTypeTerm = event_attr_type_function(_),
        ( if map.search(AttrTypeMap, AttrName, AttrType) then
            EventAttr = event_attribute(AttrNum, AttrName, AttrType, in_mode,
                no),
            !:RevAttrs = [EventAttr | !.RevAttrs]
        else
            Pieces = [words("Error: event"), quote(EventName)] ++
                color_as_incorrect([words("does not use")]) ++
                [words("the function attribute")] ++
                color_as_subject([quote(AttrName), suffix(".")]) ++
                [nl],
            ErrorSpec = spec($pred, severity_error, phase_t2pt,
                term_context.context(FileName, AttrLineNumber), Pieces),
            !:ErrorSpecs = [ErrorSpec | !.ErrorSpecs]
        )
    ),
    convert_terms_to_attrs(EventName, FileName, AttrNameMap, AttrTypeMap,
        AttrNum + 1, AttrTerms, !RevAttrs, !ErrorSpecs).

:- func convert_term_to_type(event_attr_type_term) = mer_type.

convert_term_to_type(Term) = Type :-
    Term = event_attr_type_term(Name, Args),
    ( if
        Args = [],
        builtin_type_name(BuiltinType, Name)
    then
        Type = builtin_type(BuiltinType)
    else
        SymName = string_to_sym_name(Name),
        ArgTypes = list.map(convert_term_to_type, Args),
        Type = defined_type(SymName, ArgTypes, kind_star)
    ).

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

:- pred compute_prev_synth_attr_order(attr_name_map::in, string::in,
    set(string)::in, set(string)::in, set(string)::out, list(int)::out) is det.

compute_prev_synth_attr_order(AttrNameMap, AttrName, Ancestors,
        !AlreadyComputed, PrevSynthOrder) :-
    ( if set.member(AttrName, Ancestors) then
        % There is a circularity among the dependencies, which means that
        % PrevSynthOrder won't actually be used.
        PrevSynthOrder = []
    else
        ( if map.search(AttrNameMap, AttrName, AttrInfo) then
            AttrTerm = AttrInfo ^ attr_info_type,
            (
                ( AttrTerm = event_attr_type_ordinary(_)
                ; AttrTerm = event_attr_type_function(_)
                ),
                PrevSynthOrder = []
            ;
                AttrTerm = event_attr_type_synthesized(_, SynthCall),
                SynthCall = event_attr_synth_call_term(FuncAttrName,
                    ArgAttrNames),
                set.insert(AttrName, Ancestors, SubAncestors),
                compute_prev_synth_attr_order_for_args(AttrNameMap,
                    [FuncAttrName | ArgAttrNames], SubAncestors,
                    !AlreadyComputed, SubPrevSynthOrder),
                set.insert(AttrName, !AlreadyComputed),
                % This append at the end makes our algorithm O(n^2),
                % but since n will always be small, this doesn't matter.
                AttrNum = AttrInfo ^ attr_info_number,
                PrevSynthOrder = SubPrevSynthOrder ++ [AttrNum]
            )
        else
            % An error has occurred somewhere, which means that
            % PrevSynthOrder won't actually be used.
            PrevSynthOrder = []
        )
    ).

:- pred compute_prev_synth_attr_order_for_args(attr_name_map::in,
    list(string)::in, set(string)::in, set(string)::in, set(string)::out,
    list(int)::out) is det.

compute_prev_synth_attr_order_for_args(_AttrNameMap, [],
        _Ancestors, !AlreadyComputed, []).
compute_prev_synth_attr_order_for_args(AttrNameMap, [ArgName | ArgNames],
        Ancestors, !AlreadyComputed, PrevSynthOrder) :-
    compute_prev_synth_attr_order(AttrNameMap, ArgName,
        Ancestors, !AlreadyComputed, PrevSynthOrderArg),
    compute_prev_synth_attr_order_for_args(AttrNameMap, ArgNames,
        Ancestors, !AlreadyComputed, PrevSynthOrderArgs),
    PrevSynthOrder = PrevSynthOrderArg ++ PrevSynthOrderArgs.

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

derive_event_set_data(EventSet) = EventSetData :-
    EventSet = event_set(EventSetName, EventSpecMap),
    map.values(EventSpecMap, EventSpecList),
    list.sort(compare_event_specs_by_num, EventSpecList, SortedEventSpecList),
    EventDescStrings = list.map(describe_event_spec, SortedEventSpecList),
    string.append_list(EventDescStrings, EventDescs),
    Desc = "event set " ++ EventSetName ++ "\n" ++ EventDescs,
    list.foldl(update_max_num_attr, EventSpecList, -1, MaxNumAttr),
    EventSetData = event_set_data(EventSetName, Desc, SortedEventSpecList,
        MaxNumAttr).

:- pred update_max_num_attr(event_spec::in, int::in, int::out) is det.

update_max_num_attr(Spec, !MaxNumAttr) :-
    AllAttrs = Spec ^ event_spec_attrs,
    list.length(AllAttrs, NumAttr),
    !:MaxNumAttr = int.max(!.MaxNumAttr, NumAttr).

:- pred compare_event_specs_by_num(event_spec::in, event_spec::in,
    comparison_result::out) is det.

compare_event_specs_by_num(SpecA, SpecB, Result) :-
    compare(Result, SpecA ^ event_spec_num, SpecB ^ event_spec_num).

:- func describe_event_spec(event_spec) = string.

describe_event_spec(Spec) = Desc :-
    Spec = event_spec(_EventNumber, EventName, _EventLineNumber,
        Attrs, _SynthAttrNumOrder),
    AttrDescs = string.join_list(",\n", list.map(describe_event_attr, Attrs)),
    Desc = "event " ++ EventName ++ "(" ++ AttrDescs ++ ")\n".

:- func describe_event_attr(event_attribute) = string.

describe_event_attr(Attr) = Desc :-
    Attr = event_attribute(_Num, Name, Type, _Mode, MaybeSynthCall),
    TypeDesc = describe_attr_type(Type),
    (
        MaybeSynthCall = no,
        SynthCallDesc = ""
    ;
        MaybeSynthCall = yes(SynthCall),
        SynthCall = event_attr_synth_call(FuncAttrNameNum, ArgAttrNameNums,
            _Order),
        ArgAttrDesc = string.join_list(", ", assoc_list.keys(ArgAttrNameNums)),
        SynthCallDesc = " synthesized by " ++
            fst(FuncAttrNameNum) ++ "(" ++ ArgAttrDesc ++ ")"
    ),
    Desc = Name ++ ": " ++ TypeDesc ++ SynthCallDesc.

:- func describe_attr_type(mer_type) = string.

describe_attr_type(Type) = Desc :-
    (
        Type = defined_type(SymName, ArgTypes, Kind),
        expect(unify(Kind, kind_star), $pred, "not kind_star"),
        (
            ArgTypes = [],
            ArgTypeDescs = ""
        ;
            ArgTypes = [_ | _],
            ArgTypeDescs = "(" ++
                string.join_list(", ", list.map(describe_attr_type, ArgTypes))
                ++ ")"
        ),
        Desc = sym_name_to_string(SymName) ++ ArgTypeDescs
    ;
        Type = builtin_type(BuiltinType),
        builtin_type_name(BuiltinType, Desc)
    ;
        Type = higher_order_type(_, _, _, _),
        Desc = "function"
    ;
        ( Type = type_variable(_, _)
        ; Type = tuple_type(_, _)
        ; Type = apply_n_type(_, _, _)
        ; Type = kinded_type(_, _)
        ),
        unexpected($pred, "type not constructed by prog_event")
    ).

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

event_number(EventSpecMap, EventName, EventNumber) :-
    map.search(EventSpecMap, EventName, EventSpec),
    EventNumber = EventSpec ^ event_spec_num.

event_attributes(EventSpecMap, EventName, Attributes) :-
    map.search(EventSpecMap, EventName, EventSpec),
    Attributes = EventSpec ^ event_spec_attrs.

event_arg_types(EventSpecMap, EventName, ArgTypes) :-
    event_attributes(EventSpecMap, EventName, Attributes),
    list.filter_map(project_event_arg_type, Attributes, ArgTypes).

event_arg_modes(EventSpecMap, EventName, ArgModes) :-
    event_attributes(EventSpecMap, EventName, Attributes),
    list.filter_map(project_event_arg_mode, Attributes, ArgModes).

:- pred project_event_arg_type(event_attribute::in, mer_type::out) is semidet.

project_event_arg_type(Attribute, Attribute ^ attr_type) :-
    Attribute ^ attr_maybe_synth_call = no.

:- pred project_event_arg_mode(event_attribute::in, mer_mode::out) is semidet.

project_event_arg_mode(Attribute, Attribute ^ attr_mode) :-
    Attribute ^ attr_maybe_synth_call = no.

%-----------------------------------------------------------------------------%
:- end_module parse_tree.prog_event.
%-----------------------------------------------------------------------------%
