mercury/compiler/mlds_to_java_class.m

%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 2000-2012 The University of Melbourne.
% Copyright (C) 2013-2018, 2020 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.
%---------------------------------------------------------------------------%
%
% Output class declarations and definitions in Java.
%
%---------------------------------------------------------------------------%

:- module ml_backend.mlds_to_java_class.
:- interface.

:- import_module libs.
:- import_module libs.indent.
:- import_module ml_backend.mlds.
:- import_module ml_backend.mlds_to_java_util.

:- import_module io.
:- import_module map.

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

:- pred output_class_defn_for_java(java_out_info::in,
    io.text_output_stream::in, indent::in, mlds_class_defn::in,
    io::di, io::uo) is det.

:- pred output_enum_class_defn_for_java(java_out_info::in,
    io.text_output_stream::in, indent::in, mlds_enum_class_defn::in,
    io::di, io::uo) is det.

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

    % Rename class names which are too long. Each class results in a separate
    % `.class' file, so a long class name may exceed filesystem limits.
    % The long names tend to be automatically generated by the compiler.
    %
:- pred maybe_shorten_long_class_name(
    mlds_class_defn::in, mlds_class_defn::out,
    map(mlds_class_name, mlds_class_name)::in,
    map(mlds_class_name, mlds_class_name)::out) is det.

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

    % Succeeds iff a given string matches the unqualified interface name
    % of a interface in Mercury's Java runtime system.
    %
:- pred interface_is_special_for_java(string::in) is semidet.

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

:- implementation.

:- import_module backend_libs.
:- import_module backend_libs.c_util.
:- import_module hlds.
:- import_module hlds.hlds_module.
:- import_module mdbcomp.
:- import_module mdbcomp.sym_name.
:- import_module ml_backend.ml_code_util.
:- import_module ml_backend.mlds_to_java_data.
:- import_module ml_backend.mlds_to_java_func.
:- import_module ml_backend.mlds_to_java_name.
:- import_module ml_backend.mlds_to_java_type.
:- import_module ml_backend.mlds_to_target_util.
:- import_module parse_tree.
:- import_module parse_tree.java_names.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_foreign.

:- import_module bool.
:- import_module char.
:- import_module int.
:- import_module list.
:- import_module maybe.
:- import_module require.
:- import_module string.
:- import_module term.

%---------------------------------------------------------------------------%
%
% Code to output classes.
%

output_class_defn_for_java(Info0, Stream, Indent, ClassDefn, !IO) :-
    ClassDefn = mlds_class_defn(ClassName, ClassArity, Context, Flags, Kind,
        _Imports, Inherits, Implements, TypeParams,
        MemberFields, MemberClasses, MemberMethods, Ctors),
    indent_line_after_context(Stream, Info0 ^ joi_line_numbers,
        marker_comment, Context, Indent, !IO),
    output_class_decl_flags_for_java(Info0, Stream, Flags, !IO),

    Info1 = Info0 ^ joi_univ_tvars := TypeParams,
    % Use generics in the output of this predicate if this class represents
    % a Mercury type. Note that we do NOT return Info1 or Info to our caller.
    ( if list.member(ml_java_mercury_type_interface, Implements) then
        Info = Info1 ^ joi_output_generics := do_output_generics
    else
        Info = Info1
    ),

    KindStr = class_kind_to_string_for_java(Kind),
    ClassNameStr = unqual_class_name_to_string_for_java(ClassName, ClassArity),
    io.format(Stream, "%s %s", [s(KindStr), s(ClassNameStr)], !IO),
    OutputGenerics = Info ^ joi_output_generics,
    (
        OutputGenerics = do_output_generics,
        output_generic_tvars(Stream, TypeParams, !IO)
    ;
        OutputGenerics = do_not_output_generics
    ),
    io.nl(Stream, !IO),

    Indent1 = Indent + 1,
    output_inherits_list(Info, Stream, Indent1, Inherits, !IO),
    output_implements_list(Stream, Indent1, Implements, !IO),
    IndentStr = indent2_string(Indent),
    io.format(Stream, "%s{\n", [s(IndentStr)], !IO),
    (
        ( Kind = mlds_class
        ; Kind = mlds_interface
        ),
        list.foldl(
            output_field_var_defn_for_java(Info, Stream, Indent1),
            MemberFields, !IO),
        list.foldl(
            output_class_defn_for_java(Info, Stream, Indent1),
            MemberClasses, !IO),
        list.foldl(
            output_function_defn_for_java(Info, Stream, Indent1, oa_none),
            MemberMethods, !IO)
    ;
        Kind = mlds_struct,
        unexpected($pred, "structs not supported in Java")
    ),
    io.nl(Stream, !IO),
    list.foldl(
        output_function_defn_for_java(Info, Stream, Indent1,
            oa_cname(ClassName, ClassArity)),
        Ctors, !IO),
    io.format(Stream, "%s}\n\n", [s(IndentStr)], !IO).

output_enum_class_defn_for_java(Info0, Stream, Indent, EnumDefn, !IO) :-
    EnumDefn = mlds_enum_class_defn(ClassName, ClassArity, Context,
        Inherits, Implements, TypeParams, _ValueField, EnumConsts, Ctors),

    Info1 = Info0 ^ joi_univ_tvars := TypeParams,
    % Use generics in the output of this predicate if this class represents
    % a Mercury type. Note that we do NOT return Info1 or Info to our caller.
    ( if
        Implements = yes(Interface),
        Interface = ml_java_mercury_type_interface
    then
        InterfaceStr = interface_to_string_for_java(Interface),
        Info = Info1 ^ joi_output_generics := do_output_generics
    else
        unexpected($pred, "no ml_java_mercury_type_interface")
    ),

    indent_line_after_context(Stream, Info0 ^ joi_line_numbers,
        marker_comment, Context, Indent, !IO),
    ClassNameStr = unqual_class_name_to_string_for_java(ClassName, ClassArity),
    io.format(Stream, "public static class %s", [s(ClassNameStr)], !IO),
    output_generic_tvars(Stream, TypeParams, !IO),
    io.nl(Stream, !IO),

    IndentStr = indent2_string(Indent),
    Indent1 = Indent + 1,
    output_enum_inherits_list(Info, Stream, Indent1, Inherits, !IO),
    io.format(Stream, "%simplements %s\n",
        [s(IndentStr), s(InterfaceStr)], !IO),
    io.format(Stream, "%s{\n", [s(IndentStr)], !IO),
    list.foldl(
        output_enum_constant_for_java(Stream, Indent1, ClassName, ClassArity),
        EnumConsts, !IO),
    io.nl(Stream, !IO),
    output_enum_ctor_for_java(Stream, Indent1, ClassName, ClassArity, !IO),
    ClassAux = oa_cname(ClassName, ClassArity),
    list.foldl(
        output_function_defn_for_java(Info, Stream, Indent1, ClassAux),
        Ctors, !IO),
    io.format(Stream, "%s}\n\n", [s(IndentStr)], !IO).

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

:- func class_kind_to_string_for_java(mlds_class_kind) = string.

class_kind_to_string_for_java(Kind) = KindStr :-
    (
        Kind = mlds_interface,
        KindStr = "interface"
    ;
        ( Kind = mlds_class
        ; Kind = mlds_struct
        ),
        KindStr = "class"
    ).

    % Output superclass that this class extends. Java does not support
    % multiple inheritance, so more than one superclass is an error.
    %
:- pred output_inherits_list(java_out_info::in, io.text_output_stream::in,
    indent::in, mlds_class_inherits::in, io::di, io::uo) is det.

output_inherits_list(Info, Stream, Indent, Inherits, !IO) :-
    (
        Inherits = inherits_nothing
    ;
        (
            Inherits = inherits_class(BaseClassId),
            BaseType = mlds_class_type(BaseClassId)
        ;
            Inherits = inherits_generic_env_ptr_type,
            BaseType = mlds_generic_env_ptr_type
        ),
        IndentStr = indent2_string(Indent),
        BaseTypeStr = type_to_string_for_java(Info, BaseType),
        io.format(Stream, "%sextends %s\n",
            [s(IndentStr), s(BaseTypeStr)], !IO)
    ).

:- pred output_enum_inherits_list(java_out_info::in, io.text_output_stream::in,
    indent::in, mlds_enum_class_inherits::in, io::di, io::uo) is det.

output_enum_inherits_list(Info, Stream, Indent, Inherits, !IO) :-
    (
        Inherits = inherits_nothing
    ;
        Inherits = inherits_class(BaseClassId),
        BaseType = mlds_class_type(BaseClassId),
        IndentStr = indent2_string(Indent),
        BaseTypeStr = type_to_string_for_java(Info, BaseType),
        io.format(Stream, "%sextends %s\n",
            [s(IndentStr), s(BaseTypeStr)], !IO)
    ).

    % Output list of interfaces that this class implements.
    %
:- pred output_implements_list(io.text_output_stream::in, indent::in,
    list(mlds_interface_id)::in, io::di, io::uo) is det.

output_implements_list(Stream, Indent, InterfaceList, !IO)  :-
    (
        InterfaceList = []
    ;
        InterfaceList = [_ | _],
        IndentStr = indent2_string(Indent),
        InterfaceStrs = list.map(interface_to_string_for_java, InterfaceList),
        InterfacesStr = string.join_list(", ", InterfaceStrs),
        io.format(Stream, "%simplements %s\n",
            [s(IndentStr), s(InterfacesStr)], !IO)
    ).

:- func interface_to_string_for_java(mlds_interface_id) = string.

interface_to_string_for_java(Interface) = String :-
    Interface = mlds_interface_id(QualClassName, Arity, _),
    QualClassName = qual_class_name(ModuleQualifier, QualKind, ClassName),
    SymName = mlds_module_name_to_sym_name(ModuleQualifier),
    mangle_sym_name_for_java(SymName, convert_qual_kind(QualKind),
        ".", ModuleNameStr),
    % Check if the interface is one of the ones in the runtime system.
    % If it is, we don't need to output the arity.
    ( if interface_is_special_for_java(ClassName) then
        string.format("%s.%s", [s(ModuleNameStr), s(ClassName)], String)
    else
        string.format("%s.%s%d", [s(ModuleNameStr), s(ClassName), i(Arity)],
            String)
    ).

%---------------------------------------------------------------------------%
%
% Code for generating enumerations.
%
% Enumerations are a bit different from normal classes, because although
% the code generator generates them as classes, it treats them as integers.
% Here we treat them as objects (instantiations of the classes) rather than
% just as integers.

    % Output a (Java) constructor for the class representing the enumeration.
    %
:- pred output_enum_ctor_for_java(io.text_output_stream::in, indent::in,
    mlds_class_name::in, arity::in, io::di, io::uo) is det.

output_enum_ctor_for_java(Stream, Indent, ClassName, ClassArity, !IO) :-
    IndentStr = indent2_string(Indent),
    Indent1Str = indent2_string(Indent + 1),
    UnqualClassnameStr =
        unqual_class_name_to_string_for_java(ClassName, ClassArity),
    io.format(Stream, "%sprivate %s(int val) {\n",
        [s(IndentStr), s(UnqualClassnameStr)], !IO),
    % Call the MercuryEnum constructor, which will set the MR_value field.
    io.format(Stream, "%ssuper(val);\n", [s(Indent1Str)], !IO),
    io.format(Stream, "%s}\n", [s(IndentStr)], !IO).

:- pred output_enum_constant_for_java(io.text_output_stream::in,
    indent::in, mlds_class_name::in, arity::in, mlds_enum_const_defn::in,
    io::di, io::uo) is det.

output_enum_constant_for_java(Stream, Indent, ClassName, ClassArity,
        EnumConstDefn, !IO) :-
    EnumConstDefn = mlds_enum_const_defn(FieldVarName, _Context, EnumConst),
    % Make a static instance of the constant. The MLDS doesn't retain enum
    % constructor names (that shouldn't be hard to change now) so it is
    % easier to derive the name of the constant later by naming them after
    % the integer values.
    IndentStr = indent2_string(Indent),
    UnqualClassNameStr =
        unqual_class_name_to_string_for_java(ClassName, ClassArity),
    FieldVarNameStr = field_var_name_to_string_for_java(FieldVarName),
    (
        EnumConst = mlds_enum_const_uint(EnumUInt),
        io.format(Stream,
            "%spublic static final %s K%u = new %s(%u); /* %s */\n",
            [s(IndentStr), s(UnqualClassNameStr), u(EnumUInt),
            s(UnqualClassNameStr), u(EnumUInt), s(FieldVarNameStr)], !IO)
    ;
        EnumConst = mlds_enum_const_foreign(_Lang, _EnumNameStr, _Type),
        % Foreign enums are not currently supported by the Java backend.
        unexpected($pred, "not mlconst_enum")
    ).

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

:- pred output_field_var_decl_for_java(java_out_info::in,
    io.text_output_stream::in, mlds_field_var_name::in, mlds_type::in,
    io::di, io::uo) is det.

output_field_var_decl_for_java(Info, Stream, FieldVarName, Type, !IO) :-
    TypeStr = type_to_string_for_java(Info, Type),
    FieldVarNameStr = field_var_name_to_string_for_java(FieldVarName),
    io.format(Stream, "%s %s", [s(TypeStr), s(FieldVarNameStr)], !IO).

:- pred output_field_var_defn_for_java(java_out_info::in,
    io.text_output_stream::in, indent::in, mlds_field_var_defn::in,
    io::di, io::uo) is det.

output_field_var_defn_for_java(Info, Stream, Indent, FieldVarDefn, !IO) :-
    FieldVarDefn = mlds_field_var_defn(FieldVarName, Context, Flags, Type,
        Initializer, _),
    indent_line_after_context(Stream, Info ^ joi_line_numbers, marker_comment,
        Context, Indent, !IO),
    output_field_var_decl_flags_for_java(Stream, Flags, !IO),
    output_field_var_decl_for_java(Info, Stream, FieldVarName, Type, !IO),
    output_initializer_for_java(Info, Stream, oa_none, Indent + 1,
        Type, Initializer, ";", !IO).

%---------------------------------------------------------------------------%
%
% Code to output declaration specifiers.
%

:- pred output_field_var_decl_flags_for_java(io.text_output_stream::in,
    mlds_field_var_decl_flags::in, io::di, io::uo) is det.

output_field_var_decl_flags_for_java(Stream, Flags, !IO) :-
    Flags = mlds_field_var_decl_flags(PerInstance, Constness),
    io.write_string(Stream, "public ", !IO),
    (
        PerInstance = per_instance
    ;
        PerInstance = one_copy,
        io.write_string(Stream, "static ", !IO)
    ),
    output_overridability_constness_for_java(Stream, overridable,
        Constness, !IO).

:- pred output_class_decl_flags_for_java(java_out_info::in,
    io.text_output_stream::in, mlds_class_decl_flags::in,
    io::di, io::uo) is det.

output_class_decl_flags_for_java(_Info, Stream, Flags, !IO) :-
    Flags = mlds_class_decl_flags(Access, Overrability, Constness),
    (
        Access = class_public,
        io.write_string(Stream, "public ", !IO)
    ;
        Access = class_private,
        io.write_string(Stream, "private ", !IO)
    ),
    % PerInstance = one_copy,
    io.write_string(Stream, "static ", !IO),
    output_overridability_constness_for_java(Stream, Overrability,
        Constness, !IO).

:- pred output_overridability_constness_for_java(io.text_output_stream::in,
    overridability::in, constness::in, io::di, io::uo) is det.

output_overridability_constness_for_java(Stream, Overridability,
        Constness, !IO) :-
    ( if
        ( Overridability = sealed
        ; Constness = const
        )
    then
        io.write_string(Stream, "final ", !IO)
    else
        true
    ).

%---------------------------------------------------------------------------%
%
% Code to rename long class names.
%

maybe_shorten_long_class_name(!ClassDefn, !Renaming) :-
    !.ClassDefn = mlds_class_defn(ClassName0, _ClassArity, _Context, Flags,
        _ClassKind, _Imports, _Inherits, _Implements, _TypeParams,
        _MemberFields, _MemberClasses, _MemberMethods, _Ctors),
    Flags = mlds_class_decl_flags(Access, _Overridability, _Constness),
    (
        % We only rename private classes for now.
        Access = class_private,
        ClassName = shorten_class_name(ClassName0),
        ( if ClassName = ClassName0 then
            true
        else
            !ClassDefn ^ mcd_class_name := ClassName,
            map.det_insert(ClassName0, ClassName, !Renaming)
        )
    ;
        Access = class_public
    ).

:- func shorten_class_name(string) = string.

shorten_class_name(ClassName0) = ClassName :-
    MangledClassName0 = name_mangle_no_leading_digit(ClassName0),
    ( if string.length(MangledClassName0) < 100 then
        ClassName = ClassName0
    else
        % The new name must not require name mangling, as then the name may
        % again be too long. We replace all non-alphanumeric or underscore
        % characters by underscores. The s_ prefix avoids having f_ as the
        % prefix which is used to indicate a mangled name.
        Left = string.left(ClassName0, 44),
        Middle = c_util.hex_hash32(ClassName0),
        Right = string.right(ClassName0, 44),
        GenName = string.format("s_%s_%s_%s", [s(Left), s(Middle), s(Right)]),
        GenList = string.to_char_list(GenName),
        FilterList = list.map(replace_non_alphanum_underscore, GenList),
        ClassName = string.from_char_list(FilterList)
    ).

:- func replace_non_alphanum_underscore(char) = char.

replace_non_alphanum_underscore(Char) =
    ( if char.is_alnum_or_underscore(Char) then
        Char
    else
        '_'
    ).

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

interface_is_special_for_java("MercuryType").
interface_is_special_for_java("MethodPtr").
interface_is_special_for_java("MethodPtr1").
interface_is_special_for_java("MethodPtr2").
interface_is_special_for_java("MethodPtr3").
interface_is_special_for_java("MethodPtr4").
interface_is_special_for_java("MethodPtr5").
interface_is_special_for_java("MethodPtr6").
interface_is_special_for_java("MethodPtr7").
interface_is_special_for_java("MethodPtr8").
interface_is_special_for_java("MethodPtr9").
interface_is_special_for_java("MethodPtr10").
interface_is_special_for_java("MethodPtr11").
interface_is_special_for_java("MethodPtr12").
interface_is_special_for_java("MethodPtr13").
interface_is_special_for_java("MethodPtr14").
interface_is_special_for_java("MethodPtr15").
interface_is_special_for_java("MethodPtrN").

%---------------------------------------------------------------------------%
:- end_module ml_backend.mlds_to_java_class.
%---------------------------------------------------------------------------%