%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 2002-2007, 2009-2012 The University of Melbourne.
% Copyright (C) 2013-2022 The Mercury team.
% This file is distributed under the terms specified in COPYING.LIB.
%---------------------------------------------------------------------------%
%
% File: type_desc.m.
% Main author: fjh, zs.
% Stability: low.
%
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%

:- module type_desc.
:- interface.

:- import_module list.

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

    % The `type_desc', `pseudo_type_desc' and `type_ctor_desc' types
    % provide access to type information.
    % A type_desc represents a type, e.g. `list(int)'.
    % A pseudo_type_desc represents a type that possibly contains type
    % variables, e.g. `list(T)'.
    % A type_ctor_desc represents a type constructor, e.g. `list/1'.
    %
:- type type_desc.
:- type pseudo_type_desc.
:- type type_ctor_desc.

    % The possibly nonground type represented by a pseudo_type_desc
    % is either a type constructor applied to zero or more
    % pseudo_type_descs, or a type variable. If the latter, the
    % type variable may be either universally or existentially quantified.
    % In either case, the type is identified by an integer, which has no
    % meaning beyond the fact that two type variables will be represented
    % by identical integers if and only if they are the same type variable.
    % Existentially quantified type variables may have type class
    % constraints placed on them, but for now we can't return these.
    %
:- type pseudo_type_rep
    --->    bound(type_ctor_desc, list(pseudo_type_desc))
    ;       univ_tvar(int)
    ;       exist_tvar(int).

:- pred pseudo_type_desc_is_ground(pseudo_type_desc::in) is semidet.

    % This function allows the caller to look into the structure
    % of the given pseudo_type_desc.
    %
:- func pseudo_type_desc_to_rep(pseudo_type_desc) = pseudo_type_rep.

    % Convert a type_desc, which by definition describes a ground type,
    % to a pseudo_type_desc.
    %
:- func type_desc_to_pseudo_type_desc(type_desc) = pseudo_type_desc.

    % Convert a pseudo_type_desc describing a ground type to a type_desc.
    % If the pseudo_type_desc describes a non-ground type, fail.
    %
:- func ground_pseudo_type_desc_to_type_desc(pseudo_type_desc) = type_desc
    is semidet.
% NOTE_TO_IMPLEMENTORS CFF :- pragma obsolete(func(ground_pseudo_type_desc_to_type_desc/1),
% NOTE_TO_IMPLEMENTORS CFF     [ground_pseudo_type_desc_to_type_desc/2]).
:- pred ground_pseudo_type_desc_to_type_desc(pseudo_type_desc::in,
    type_desc::out) is semidet.

    % Convert a pseudo_type_desc describing a ground type to a type_desc.
    % Throw an exception if the pseudo_type_desc describes a non-ground type.
    %
:- func det_ground_pseudo_type_desc_to_type_desc(pseudo_type_desc) = type_desc.

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

    % The function type_of/1 returns a representation of the type
    % of its argument.
    %
    % (Note: it is not possible for the type of a variable to be an unbound
    % type variable; if there are no constraints on a type variable, then the
    % typechecker will use the type `void'. `void' is a special (builtin) type
    % that has no constructors. There is no way of creating an object of
    % type `void'. `void' is not considered to be a discriminated union, so
    % get_functor/5 and construct/3 will fail if used upon a value of
    % this type.)
    %
:- func type_of(T::unused) = (type_desc::out) is det.

    % The predicate has_type/2 is basically an existentially typed inverse
    % to the function type_of/1. It constrains the type of the first argument
    % to be the type represented by the second argument.
    %
:- some [T] pred has_type(T::unused, type_desc::in) is det.

    % The predicate same_type/2 ensures type identity of the two arguments.
    %
:- pred same_type(T::unused, T::unused) is det.

    % type_name(Type) returns the name of the specified type
    % (e.g. type_name(type_of([2,3])) = "list.list(int)").
    % Any equivalence types will be fully expanded.
    % Builtin types (those defined in builtin.m) will not have
    % a module qualifier.
    %
:- func type_name(type_desc) = string.

    % type_ctor_and_args(Type, TypeCtor, TypeArgs):
    %
    % True iff TypeCtor is a representation of the top-level type constructor
    % for Type, and TypeArgs is a list of the corresponding type arguments
    % to TypeCtor, and TypeCtor is not an equivalence type.
    %
    % For example, type_ctor_and_args(type_of([2,3]), TypeCtor, TypeArgs)
    % will bind TypeCtor to a representation of the type constructor list/1,
    % and will bind TypeArgs to the list `[Int]', where Int is a
    % representation of the type `int'.
    %
    % Note that the requirement that TypeCtor not be an equivalence type
    % is fulfilled by fully expanding any equivalence types. For example,
    % if you have a declaration `:- type foo == bar.', then
    % type_ctor_and_args/3 will always return a representation of type
    % constructor `bar/0', not `foo/0'. (If you don't want them expanded,
    % you can use the reverse mode of make_type/2 instead.)
    %
:- pred type_ctor_and_args(type_desc::in,
    type_ctor_desc::out, list(type_desc)::out) is det.

    % pseudo_type_ctor_and_args(Type, TypeCtor, TypeArgs):
    %
    % True iff TypeCtor is a representation of the top-level type constructor
    % for Type, and TypeArgs is a list of the corresponding type arguments
    % to TypeCtor, and TypeCtor is not an equivalence type.
    %
    % Similar to type_ctor_and_args, but works on pseudo_type_infos.
    % Fails if the input pseudo_type_info is a variable.
    %
:- pred pseudo_type_ctor_and_args(pseudo_type_desc::in,
    type_ctor_desc::out, list(pseudo_type_desc)::out) is semidet.

    % type_ctor(Type) = TypeCtor :-
    %   type_ctor_and_args(Type, TypeCtor, _).
    %
:- func type_ctor(type_desc) = type_ctor_desc.

    % pseudo_type_ctor(Type) = TypeCtor :-
    %   pseudo_type_ctor_and_args(Type, TypeCtor, _).
    %
:- func pseudo_type_ctor(pseudo_type_desc) = type_ctor_desc is semidet.
% NOTE_TO_IMPLEMENTORS CFF :- pragma obsolete(func(pseudo_type_ctor/1), [pseudo_type_ctor/2]).
:- pred pseudo_type_ctor(pseudo_type_desc::in, type_ctor_desc::out) is semidet.

    % type_args(Type) = TypeArgs :-
    %   type_ctor_and_args(Type, _, TypeArgs).
    %
:- func type_args(type_desc) = list(type_desc).

    % pseudo_type_args(Type, TypeArgs) :-
    %   pseudo_type_ctor_and_args(Type, _, TypeArgs).
    %
:- func pseudo_type_args(pseudo_type_desc) = list(pseudo_type_desc) is semidet.
% NOTE_TO_IMPLEMENTORS CFF :- pragma obsolete(func(pseudo_type_args/1), [pseudo_type_args/2]).
:- pred pseudo_type_args(pseudo_type_desc::in, list(pseudo_type_desc)::out)
    is semidet.

    % type_ctor_name(TypeCtor) returns the name of specified type constructor.
    % (e.g. type_ctor_name(type_ctor(type_of([2,3]))) = "list").
    %
:- func type_ctor_name(type_ctor_desc) = string.

    % type_ctor_module_name(TypeCtor) returns the module name of specified
    % type constructor.
    % (e.g. type_ctor_module_name(type_ctor(type_of(2))) = "builtin").
    %
:- func type_ctor_module_name(type_ctor_desc) = string.

    % type_ctor_arity(TypeCtor) returns the arity of specified
    % type constructor.
    % (e.g. type_ctor_arity(type_ctor(type_of([2,3]))) = 1).
    %
:- func type_ctor_arity(type_ctor_desc) = int.

    % type_ctor_name_and_arity(TypeCtor, ModuleName, TypeName, Arity) :-
    %   Name = type_ctor_name(TypeCtor),
    %   ModuleName = type_ctor_module_name(TypeCtor),
    %   Arity = type_ctor_arity(TypeCtor).
    %
:- pred type_ctor_name_and_arity(type_ctor_desc::in,
    string::out, string::out, int::out) is det.

    % make_type(TypeCtor, TypeArgs) = Type:
    % make_type(TypeCtor, TypeArgs, Type):
    %
    % True iff Type is a type constructed by applying the type constructor
    % TypeCtor to the type arguments TypeArgs.
    %
    % Operationally, the forwards mode returns the type formed by applying
    % the specified type constructor to the specified argument types, or fails
    % if the length of TypeArgs is not the same as the arity of TypeCtor.
    % The reverse mode returns a type constructor and its argument types,
    % given a type_desc; the type constructor returned may be an equivalence
    % type (and hence this reverse mode of make_type may be more useful
    % for some purposes than the type_ctor/1 function).
    %
:- func make_type(type_ctor_desc, list(type_desc)) = type_desc.
:- mode make_type(in, in) = out is semidet.
:- mode make_type(out, out) = in is cc_multi.
% NOTE_TO_IMPLEMENTORS CFF :- pragma obsolete(func(make_type/2), [make_type/3]).
:- pred make_type(type_ctor_desc, list(type_desc), type_desc).
:- mode make_type(in, in, out) is semidet.
:- mode make_type(out, out, in) is cc_multi.

    % det_make_type(TypeCtor, TypeArgs):
    %
    % Returns the type formed by applying the specified type constructor
    % to the specified argument types. Throws an exception if the length of
    % TypeArgs is not the same as the arity of TypeCtor.
    %
:- func det_make_type(type_ctor_desc, list(type_desc)) = type_desc.

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

:- implementation.

% Everything below here is not intended to be part of the public interface,
% and will not be included in the Mercury library reference manual.

:- interface.

:- use_module rtti_implementation.

% The following predicates are exported for construct.m.

:- pred type_desc_to_type_info(type_desc::in,
    rtti_implementation.type_info::out) is det.

:- pred type_info_to_type_desc(rtti_implementation.type_info::in,
    type_desc::out) is det.

:- pred type_info_list_to_type_desc_list(
    list(rtti_implementation.type_info)::in, list(type_desc)::out) is det.

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

:- implementation.

:- import_module require.
:- import_module string.

:- pragma foreign_decl("C", "
#include ""mercury_heap.h""         // for MR_incr_hp_msg() etc.
#include ""mercury_misc.h""         // for MR_fatal_error()
#include ""mercury_string.h""       // for MR_make_aligned_string()
#include ""mercury_type_desc.h""
").

% The Java backend substitutes:
%
%   type_desc        == jmercury.runtime.TypeInfo_Struct
%   pseudo_type_desc == jmercury.runtime.PseudoTypeDesc
%   type_ctor_desc   == jmercury.runtime.TypeCtorInfo_Struct
%
% We can't use `:- pragma foreign_type' because the compiler will complain
% that non-Java grades are missing type definitions.

:- pragma foreign_decl("Java", local, "
// Any foreign_procs which use the unqualified names should be marked
// `may_not_duplicate' so as not to be written to .opt files.

import jmercury.runtime.PseudoTypeInfo;
import jmercury.runtime.TypeCtorInfo_Struct;
import jmercury.runtime.TypeInfo_Struct;
").

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

:- pragma no_determinism_warning(pred(pseudo_type_desc_is_ground/1)).

pseudo_type_desc_is_ground(PseudoTypeDesc) :-
    pseudo_type_ctor_and_args(PseudoTypeDesc, _TypeCtor, ArgPseudos),
    list.all_true(pseudo_type_desc_is_ground, ArgPseudos).

pseudo_type_desc_to_rep(PseudoTypeDesc) = PseudoTypeRep :-
    ( if pseudo_type_ctor_and_args(PseudoTypeDesc, TypeCtor, ArgPseudos) then
        PseudoTypeRep = bound(TypeCtor, ArgPseudos)
    else if is_exist_pseudo_type_desc(PseudoTypeDesc, UnivNum) then
        PseudoTypeRep = exist_tvar(UnivNum)
    else if is_univ_pseudo_type_desc(PseudoTypeDesc, UnivNum) then
        PseudoTypeRep = univ_tvar(UnivNum)
    else
        error($pred, "internal error")
    ).

:- pred is_univ_pseudo_type_desc(pseudo_type_desc::in, int::out) is semidet.

:- pragma foreign_proc("C",
    is_univ_pseudo_type_desc(PseudoTypeDesc::in, TypeVarNum::out),
    [will_not_call_mercury, thread_safe, promise_pure, will_not_modify_trail,
        no_sharing],
"
    MR_PseudoTypeInfo   pseudo_type_info;

    pseudo_type_info = (MR_PseudoTypeInfo) PseudoTypeDesc;
    if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pseudo_type_info) &&
        MR_TYPE_VARIABLE_IS_UNIV_QUANT(pseudo_type_info))
    {
        TypeVarNum = (MR_Integer) pseudo_type_info;
        SUCCESS_INDICATOR = MR_TRUE;
    } else {
        SUCCESS_INDICATOR = MR_FALSE;
    }
").

is_univ_pseudo_type_desc(PTD, N) :-
    pseudo_type_desc_to_pseudo_type_info(PTD, PTI),
    rtti_implementation.is_univ_pseudo_type_info(PTI, N).

:- pred is_exist_pseudo_type_desc(pseudo_type_desc::in, int::out) is semidet.

:- pragma foreign_proc("C",
    is_exist_pseudo_type_desc(PseudoTypeDesc::in, TypeVarNum::out),
    [will_not_call_mercury, thread_safe, promise_pure, will_not_modify_trail,
        no_sharing],
"
    MR_PseudoTypeInfo   pseudo_type_info;

    pseudo_type_info = (MR_PseudoTypeInfo) PseudoTypeDesc;
    if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pseudo_type_info) &&
        MR_TYPE_VARIABLE_IS_EXIST_QUANT(pseudo_type_info))
    {
        TypeVarNum = (MR_Integer) pseudo_type_info;
        SUCCESS_INDICATOR = MR_TRUE;
    } else {
        SUCCESS_INDICATOR = MR_FALSE;
    }
").

is_exist_pseudo_type_desc(PTD, N) :-
    pseudo_type_desc_to_pseudo_type_info(PTD, PTI),
    rtti_implementation.is_exist_pseudo_type_info(PTI, N).

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

:- pred pseudo_type_desc_to_pseudo_type_info(pseudo_type_desc::in,
    rtti_implementation.pseudo_type_info::out) is det.
:- pragma consider_used(pred(pseudo_type_desc_to_pseudo_type_info/2)).

pseudo_type_desc_to_pseudo_type_info(PseudoTypeDesc, PseudoTypeInfo) :-
    ( if type_info_desc_same_representation then
        private_builtin.unsafe_type_cast(PseudoTypeDesc, PseudoTypeInfo)
    else
        error("pseudo_type_desc_to_pseudo_type_info/2")
    ).

:- pred type_info_desc_same_representation is semidet.

type_info_desc_same_representation :-
    semidet_true.

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

:- pragma foreign_proc("C",
    type_desc_to_pseudo_type_desc(TypeDesc::in) = (PseudoTypeDesc::out),
    [will_not_call_mercury, thread_safe, promise_pure, will_not_modify_trail],
"
    PseudoTypeDesc = TypeDesc;
").

:- pragma foreign_proc("C#",
    type_desc_to_pseudo_type_desc(TypeDesc::in) = (PseudoTypeDesc::out),
    [will_not_call_mercury, thread_safe, promise_pure, will_not_modify_trail],
"
    PseudoTypeDesc = TypeDesc;
").

:- pragma foreign_proc("Java",
    type_desc_to_pseudo_type_desc(TypeDesc::in) = (PseudoTypeDesc::out),
    [will_not_call_mercury, thread_safe, promise_pure, will_not_modify_trail],
"
    PseudoTypeDesc = TypeDesc;
").

type_desc_to_pseudo_type_desc(_TypeDesc) = _PseudoTypeDesc :-
    % The backends in which we use this definition of this predicate
    % don't yet support pseudo_type_descs.
    private_builtin.sorry("type_desc_to_pseudo_type_desc").

ground_pseudo_type_desc_to_type_desc(PseudoTypeDesc) = TypeDesc :-
    ground_pseudo_type_desc_to_type_desc(PseudoTypeDesc, TypeDesc).

ground_pseudo_type_desc_to_type_desc(PseudoTypeDesc, TypeDesc) :-
    ( if pseudo_type_desc_is_ground(PseudoTypeDesc) then
        private_builtin.unsafe_type_cast(PseudoTypeDesc, TypeDesc)
    else
        fail
    ).

det_ground_pseudo_type_desc_to_type_desc(PseudoTypeDesc) = TypeDesc :-
    ( if pseudo_type_desc_is_ground(PseudoTypeDesc) then
        private_builtin.unsafe_type_cast(PseudoTypeDesc, TypeDesc)
    else
        error($pred, "not ground")
    ).

%---------------------------------------------------------------------------%
%
% Code for type manipulation.
%

:- pragma foreign_proc("C",
    type_of(_Value::unused) = (TypeInfo::out),
    [will_not_call_mercury, thread_safe, promise_pure, will_not_modify_trail,
        no_sharing],
"{
    TypeInfo = TypeInfo_for_T;

    // We used to collapse equivalences for efficiency here, but that is not
    // always desirable, due to the reverse mode of make_type/3, and efficiency
    // of type_infos probably isn't very important anyway.
#if 0
    MR_save_transient_registers();
    TypeInfo = (MR_Word) MR_collapse_equivalences(
        (MR_TypeInfo) TypeInfo_for_T);
    MR_restore_transient_registers();
#endif

}").

:- pragma foreign_proc("C#",
    type_of(_Value::unused) = (TypeInfo::out),
    [will_not_call_mercury, thread_safe, promise_pure],
"
    TypeInfo = TypeInfo_for_T;
").

:- pragma foreign_proc("Java",
    type_of(_Value::unused) = (TypeInfo::out),
    [will_not_call_mercury, thread_safe, promise_pure],
"
    TypeInfo = TypeInfo_for_T;
").

:- pragma foreign_proc("C",
    has_type(_Arg::unused, TypeInfo::in),
    [will_not_call_mercury, thread_safe, promise_pure, no_sharing],
"
    TypeInfo_for_T = TypeInfo;
").

:- pragma foreign_proc("C#",
    has_type(_Arg::unused, TypeInfo::in),
    [will_not_call_mercury, thread_safe, promise_pure],
"
    TypeInfo_for_T = TypeInfo;
").

:- pragma foreign_proc("Java",
    has_type(_Arg::unused, TypeInfo::in),
    [will_not_call_mercury, thread_safe, promise_pure],
"
    TypeInfo_for_T = TypeInfo;
").

same_type(_, _).

% Export this function in order to use it in runtime/mercury_trace_external.c
:- pragma foreign_export("C", type_name(in) = out, "ML_type_name").

type_name(Type) = TypeName :-
    type_ctor_and_args(Type, TypeCtor, ArgTypes),
    type_ctor_name_and_arity(TypeCtor, ModuleName, Name, Arity),
    ( if Arity = 0 then
        UnqualifiedTypeName = Name
    else
        ( if ModuleName = "builtin", Name = "{}" then
            type_arg_names(ArgTypes, ArgTypeNames),
            TupleArgTypeNames = ["{" | ArgTypeNames] ++ ["}"],
            string.append_list(TupleArgTypeNames, UnqualifiedTypeName)
        else
            ( if ModuleName = "builtin", Name = "func" then
                det_split_last(ArgTypes, NonReturnArgTypes, ReturnArgType),
                ReturnArgTypeName = type_name(ReturnArgType),
                (
                    NonReturnArgTypes = [],
                    TypeNameStrs = ["((func) = ", ReturnArgTypeName, ")"]
                ;
                    NonReturnArgTypes = [HeadArgType | TailArgTypes],
                    type_arg_names_lag(HeadArgType, TailArgTypes,
                        NonReturnArgTypeNames),
                    TypeNameStrs = [Name, "(" | NonReturnArgTypeNames]
                        ++ [") = ", ReturnArgTypeName]
                )
            else
                type_arg_names(ArgTypes, ArgTypeNames),
                TypeNameStrs = [Name, "(" | ArgTypeNames] ++ [")"]
            ),
            string.append_list(TypeNameStrs, UnqualifiedTypeName)
        )
    ),
    ( if ModuleName = "builtin" then
        TypeName = UnqualifiedTypeName
    else
        string.append_list([ModuleName, ".", UnqualifiedTypeName], TypeName)
    ).

    % Turn the types into a list of strings representing an argument list,
    % adding commas as separators as required. For example:
    % ["TypeName1", ",", "TypeName2"].
    %
:- pred type_arg_names(list(type_desc)::in, list(string)::out) is det.

type_arg_names([], []).
type_arg_names([Type | Types], ArgNames) :-
    type_arg_names_lag(Type, Types, ArgNames).

:- pred type_arg_names_lag(type_desc::in, list(type_desc)::in,
    list(string)::out) is det.

type_arg_names_lag(HeadType, TailTypes, Names) :-
    HeadName = type_name(HeadType),
    (
        TailTypes = [],
        Names = [HeadName]
    ;
        TailTypes = [HeadTailType | TailTailTypes],
        type_arg_names_lag(HeadTailType, TailTailTypes, TailNames),
        Names = [HeadName, ", " | TailNames]
    ).

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

:- pragma foreign_proc("C",
    type_ctor_and_args(TypeDesc::in, TypeCtorDesc::out, ArgTypes::out),
    [will_not_call_mercury, thread_safe, promise_pure, will_not_modify_trail],
"{
    MR_TypeCtorDesc type_ctor_desc;
    MR_TypeInfo     type_info;

    MR_save_transient_registers();

    type_info = (MR_TypeInfo) TypeDesc;
    MR_type_ctor_and_args(type_info, MR_TRUE, &type_ctor_desc, &ArgTypes);
    TypeCtorDesc = (MR_Word) type_ctor_desc;

    MR_restore_transient_registers();
}").

type_ctor_and_args(TypeDesc, TypeCtorDesc, ArgTypeDescs) :-
    type_desc_to_type_info(TypeDesc, TypeInfo),
    rtti_implementation.type_ctor_and_args(TypeInfo, TypeCtorInfo,
        ArgTypeInfos),
    make_type_ctor_desc(TypeInfo, TypeCtorInfo, TypeCtorDesc),
    type_info_list_to_type_desc_list(ArgTypeInfos, ArgTypeDescs).

:- pragma foreign_proc("C",
    pseudo_type_ctor_and_args(PseudoTypeDesc::in, TypeCtorDesc::out,
        ArgPseudoTypeInfos::out),
    [will_not_call_mercury, thread_safe, promise_pure, will_not_modify_trail],
"{
    MR_TypeCtorDesc     type_ctor_desc;
    MR_PseudoTypeInfo   pseudo_type_info;
    MR_bool             success;

    pseudo_type_info = (MR_PseudoTypeInfo) PseudoTypeDesc;
    MR_save_transient_registers();
    success = MR_pseudo_type_ctor_and_args(pseudo_type_info, MR_TRUE,
        &type_ctor_desc, &ArgPseudoTypeInfos);
    TypeCtorDesc = (MR_Word) type_ctor_desc;
    MR_restore_transient_registers();
    SUCCESS_INDICATOR = success;
}").

pseudo_type_ctor_and_args(PseudoTypeDesc, TypeCtorDesc, ArgPseudoTypeDescs) :-
    pseudo_type_desc_to_pseudo_type_info(PseudoTypeDesc, PseudoTypeInfo),
    rtti_implementation.pseudo_type_ctor_and_args(PseudoTypeInfo,
        TypeCtorInfo, ArgPseudoTypeInfos),
    Arity = list.length(ArgPseudoTypeInfos),
    make_type_ctor_desc_with_arity(Arity, TypeCtorInfo, TypeCtorDesc),
    private_builtin.unsafe_type_cast(ArgPseudoTypeInfos, ArgPseudoTypeDescs).

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

:- pragma foreign_proc("C",
    type_ctor(TypeInfo::in) = (TypeCtor::out),
    [will_not_call_mercury, thread_safe, promise_pure, will_not_modify_trail],
"{
    MR_TypeCtorInfo type_ctor_info;
    MR_TypeInfo     type_info;

    MR_save_transient_registers();
    type_info = MR_collapse_equivalences((MR_TypeInfo) TypeInfo);
    MR_restore_transient_registers();

    type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);

    TypeCtor = (MR_Word) MR_make_type_ctor_desc(type_info, type_ctor_info);
}").

type_ctor(TypeDesc) = TypeCtorDesc :-
    type_desc_to_type_info(TypeDesc, TypeInfo),
    TypeCtorInfo = rtti_implementation.get_type_ctor_info(TypeInfo),
    make_type_ctor_desc(TypeInfo, TypeCtorInfo, TypeCtorDesc).

pseudo_type_ctor(PseudoTypeInfo) = TypeCtor :-
    pseudo_type_ctor(PseudoTypeInfo, TypeCtor).

:- pragma no_determinism_warning(pred(pseudo_type_ctor/2)).

:- pragma foreign_proc("C",
    pseudo_type_ctor(PseudoTypeInfo::in, TypeCtor::out),
    [will_not_call_mercury, thread_safe, promise_pure, will_not_modify_trail],
"{
    MR_TypeCtorInfo     type_ctor_info;
    MR_PseudoTypeInfo   pseudo_type_info;

    MR_save_transient_registers();
    pseudo_type_info = MR_collapse_equivalences_pseudo(
        (MR_PseudoTypeInfo) PseudoTypeInfo);
    MR_restore_transient_registers();

    if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pseudo_type_info)) {
        SUCCESS_INDICATOR = MR_FALSE;
    } else {
        type_ctor_info = MR_PSEUDO_TYPEINFO_GET_TYPE_CTOR_INFO(
            pseudo_type_info);
        TypeCtor = (MR_Word) MR_make_type_ctor_desc_pseudo(pseudo_type_info,
            type_ctor_info);
        SUCCESS_INDICATOR = MR_TRUE;
    }
}").

pseudo_type_ctor(_, _) :-
    private_builtin.sorry("pseudo_type_ctor/2").

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

type_args(Type) = ArgTypes :-
    type_ctor_and_args(Type, _TypeCtor, ArgTypes).

pseudo_type_args(PseudoType) = ArgPseudoTypes :-
    pseudo_type_args(PseudoType, ArgPseudoTypes).

pseudo_type_args(PseudoType, ArgPseudoTypes) :-
    pseudo_type_ctor_and_args(PseudoType, _TypeCtor, ArgPseudoTypes).

type_ctor_name(TypeCtor) = Name :-
    type_ctor_name_and_arity(TypeCtor, _ModuleName, Name, _Arity).

type_ctor_module_name(TypeCtor) = ModuleName :-
    type_ctor_name_and_arity(TypeCtor, ModuleName, _Name, _Arity).

type_ctor_arity(TypeCtor) = Arity :-
    type_ctor_name_and_arity(TypeCtor, _ModuleName, _Name, Arity).

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

    % Make a type_info_desc from a type_ctor_info. A type_info_desc is
    % different to a type_ctor_info in the case of variable arity types,
    % i.e. predicates, functions and tuples.
    %
    % The C implementation uses small integers to encode variable arity
    % type_ctor_infos (see mercury_type_desc.h). In the Java backend we simply
    % allocate new TypeCtorInfo_Struct objects and set the `arity' field.
    % Two equivalent type_ctor_descs may have different addresses.
    %
:- pred make_type_ctor_desc(rtti_implementation.type_info::in,
    rtti_implementation.type_ctor_info::in, type_ctor_desc::out) is det.
:- pragma consider_used(pred(make_type_ctor_desc/3)).
:- pragma no_determinism_warning(pred(make_type_ctor_desc/3)).

:- pragma foreign_proc("C#",
    make_type_ctor_desc(TypeInfo::in, TypeCtorInfo::in, TypeCtorDesc::out),
    [will_not_call_mercury, promise_pure, thread_safe, may_not_duplicate],
"
    runtime.TypeCtorInfo_Struct tci = TypeCtorInfo;

    // Handle variable arity types.
    switch (tci.type_ctor_rep) {
        case runtime.TypeCtorRep.MR_TYPECTOR_REP_PRED:
        case runtime.TypeCtorRep.MR_TYPECTOR_REP_FUNC:
        case runtime.TypeCtorRep.MR_TYPECTOR_REP_TUPLE:
            tci = new runtime.TypeCtorInfo_Struct(tci, TypeInfo.args.Length);
            break;
        default:
            break;
    }

    TypeCtorDesc = tci;
").

:- pragma foreign_proc("Java",
    make_type_ctor_desc(TypeInfo::in, TypeCtorInfo::in, TypeCtorDesc::out),
    [will_not_call_mercury, promise_pure, thread_safe, may_not_duplicate],
"
    TypeCtorInfo_Struct tci = TypeCtorInfo;

    // Handle variable arity types.
    switch (tci.type_ctor_rep.value) {
        case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_PRED:
        case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_FUNC:
        case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_TUPLE:
            tci = new TypeCtorInfo_Struct(tci, TypeInfo.args.length);
            break;
        default:
            break;
    }

    TypeCtorDesc = tci;
").

make_type_ctor_desc(_, _, _) :-
    private_builtin.sorry("make_type_ctor_desc/3").

:- pred make_type_ctor_desc_with_arity(int::in,
    rtti_implementation.type_ctor_info::in, type_ctor_desc::out) is det.
:- pragma consider_used(pred(make_type_ctor_desc_with_arity/3)).
:- pragma no_determinism_warning(pred(make_type_ctor_desc_with_arity/3)).

:- pragma foreign_proc("C#",
    make_type_ctor_desc_with_arity(Arity::in, TypeCtorInfo::in,
        TypeCtorDesc::out),
    [will_not_call_mercury, promise_pure, thread_safe, may_not_duplicate],
"
    runtime.TypeCtorInfo_Struct tci = TypeCtorInfo;

    // Handle variable arity types.
    switch (tci.type_ctor_rep) {
        case runtime.TypeCtorRep.MR_TYPECTOR_REP_PRED:
        case runtime.TypeCtorRep.MR_TYPECTOR_REP_FUNC:
        case runtime.TypeCtorRep.MR_TYPECTOR_REP_TUPLE:
            tci = new runtime.TypeCtorInfo_Struct(tci, Arity);
            break;
        default:
            break;
    }

    TypeCtorDesc = tci;
").

:- pragma foreign_proc("Java",
    make_type_ctor_desc_with_arity(Arity::in, TypeCtorInfo::in,
        TypeCtorDesc::out),
    [will_not_call_mercury, promise_pure, thread_safe, may_not_duplicate],
"
    TypeCtorInfo_Struct tci = TypeCtorInfo;

    // Handle variable arity types.
    switch (tci.type_ctor_rep.value) {
        case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_PRED:
        case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_FUNC:
        case jmercury.runtime.TypeCtorRep.MR_TYPECTOR_REP_TUPLE:
            tci = new TypeCtorInfo_Struct(tci, Arity);
            break;
        default:
            break;
    }

    TypeCtorDesc = tci;
").

make_type_ctor_desc_with_arity(_, _, _) :-
    private_builtin.sorry("make_type_ctor_desc_with_arity/3").

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

:- pragma foreign_proc("C",
    type_ctor_name_and_arity(TypeCtorDesc::in, TypeCtorModuleName::out,
        TypeCtorName::out, TypeCtorArity::out),
    [will_not_call_mercury, thread_safe, promise_pure, will_not_modify_trail],
"{
    MR_TypeCtorDesc type_ctor_desc;

    type_ctor_desc = (MR_TypeCtorDesc) TypeCtorDesc;

    if (MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(type_ctor_desc)) {
        TypeCtorModuleName = (MR_String) (MR_Word)
            MR_TYPECTOR_DESC_GET_VA_MODULE_NAME(type_ctor_desc);
        TypeCtorName = (MR_String) (MR_Word)
            MR_TYPECTOR_DESC_GET_VA_NAME(type_ctor_desc);
        TypeCtorArity = MR_TYPECTOR_DESC_GET_VA_ARITY(type_ctor_desc);
    } else {
        MR_TypeCtorInfo type_ctor_info;

        type_ctor_info =
            MR_TYPECTOR_DESC_GET_FIXED_ARITY_TYPE_CTOR_INFO(type_ctor_desc);

        // We cast away the const-ness of the module and type names,
        // because MR_String is defined as char *, not const char *.

        TypeCtorModuleName = (MR_String) (MR_Integer)
            MR_type_ctor_module_name(type_ctor_info);
        TypeCtorName = (MR_String) (MR_Integer)
            MR_type_ctor_name(type_ctor_info);
        TypeCtorArity = type_ctor_info->MR_type_ctor_arity;
    }
}").

type_ctor_name_and_arity(TypeCtorDesc, ModuleName, TypeCtorName,
        TypeCtorArity) :-
    type_ctor_desc_to_type_ctor_info(TypeCtorDesc, TypeCtorInfo),
    rtti_implementation.type_ctor_name_and_arity(TypeCtorInfo,
        ModuleName, TypeCtorName, TypeCtorArity).

:- pred type_ctor_desc_to_type_ctor_info(type_ctor_desc::in,
    rtti_implementation.type_ctor_info::out) is det.
:- pragma consider_used(pred(type_ctor_desc_to_type_ctor_info/2)).

type_ctor_desc_to_type_ctor_info(TypeCtorDesc, TypeCtorInfo) :-
    ( if type_info_desc_same_representation then
        private_builtin.unsafe_type_cast(TypeCtorDesc, TypeCtorInfo)
    else
        error("type_ctor_desc_to_type_ctor_info/2")
    ).

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

make_type(TypeCtorDesc, ArgTypes) = TypeDesc :-
    make_type(TypeCtorDesc, ArgTypes, TypeDesc).

:- pragma promise_equivalent_clauses(pred(make_type/3)).
:- pragma no_determinism_warning(pred(make_type/3)).

% This is the forwards mode of make_type/3: given a type constructor and
% a list of argument types, check that the length of the argument types
% matches the arity of the type constructor, and if so, use the type
% constructor to construct a new type with the specified arguments.

:- pragma foreign_proc("C",
    make_type(TypeCtorDesc::in, ArgTypes::in, TypeDesc::out),
    [promise_pure, will_not_call_mercury, thread_safe, will_not_modify_trail],
"{
    MR_TypeCtorDesc type_ctor_desc;
    MR_TypeCtorInfo type_ctor_info;
    MR_Word     arg_type;
    int     list_length;
    int     arity;

    type_ctor_desc = (MR_TypeCtorDesc) TypeCtorDesc;

    if (MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(type_ctor_desc)) {
        arity = MR_TYPECTOR_DESC_GET_VA_ARITY(type_ctor_desc);
    } else {
        type_ctor_info =
            MR_TYPECTOR_DESC_GET_FIXED_ARITY_TYPE_CTOR_INFO(type_ctor_desc);
        arity = type_ctor_info->MR_type_ctor_arity;
    }

    arg_type = ArgTypes;
    for (list_length = 0; ! MR_list_is_empty(arg_type); list_length++) {
        arg_type = MR_list_tail(arg_type);
    }

    if (list_length != arity) {
        SUCCESS_INDICATOR = MR_FALSE;
    } else {
        MR_save_transient_registers();
        TypeDesc = (MR_Word) MR_make_type(arity, type_ctor_desc, ArgTypes);
        MR_restore_transient_registers();
        SUCCESS_INDICATOR = MR_TRUE;
    }
}").

:- pragma foreign_proc("C#",
    make_type(TypeCtorDesc::in, ArgTypes::in, TypeDesc::out),
    [promise_pure, will_not_call_mercury, thread_safe, will_not_modify_trail,
        may_not_duplicate],
"{
    runtime.PseudoTypeInfo[] args =
        new runtime.PseudoTypeInfo[TypeCtorDesc.arity];

    SUCCESS_INDICATOR = true;
    list.List_1 arg_types = ArgTypes;
    for (int i = 0; i < TypeCtorDesc.arity; i++) {
        if (list.is_empty(arg_types)) {
            SUCCESS_INDICATOR = false;
            break;
        }
        args[i] = (runtime.PseudoTypeInfo) list.det_head(arg_types);
        arg_types = list.det_tail(arg_types);
    }

    if (SUCCESS_INDICATOR) {
        TypeDesc = new runtime.TypeInfo_Struct();
        TypeDesc.init(TypeCtorDesc, args);
    } else {
        TypeDesc = null;
    }
}").

:- pragma foreign_proc("Java",
    make_type(TypeCtorDesc::in, ArgTypes::in, TypeDesc::out),
    [promise_pure, will_not_call_mercury, thread_safe, will_not_modify_trail,
        may_not_duplicate],
"{
    PseudoTypeInfo[] as = new PseudoTypeInfo[TypeCtorDesc.arity];

    SUCCESS_INDICATOR = true;
    list.List_1<TypeInfo_Struct> arg_types = ArgTypes;
    for (int i = 0; i < TypeCtorDesc.arity; i++) {
        if (list.is_empty(arg_types)) {
            SUCCESS_INDICATOR = false;
            break;
        }
        as[i] = list.det_head(arg_types);
        arg_types = list.det_tail(arg_types);
    }

    if (SUCCESS_INDICATOR) {
        TypeDesc = new TypeInfo_Struct();
        TypeDesc.init(TypeCtorDesc, as);
    } else {
        TypeDesc = null;
    }
}").

% This is the reverse mode of make_type/3: given a type,
% split it up into a type constructor and a list of arguments.

:- pragma foreign_proc("C",
    make_type(TypeCtorDesc::out, ArgTypes::out, TypeDesc::in),
    [promise_pure, will_not_call_mercury, thread_safe, will_not_modify_trail],
"{
    MR_TypeCtorDesc type_ctor_desc;
    MR_TypeInfo     type_info;

    MR_save_transient_registers();

    type_info = (MR_TypeInfo) TypeDesc;
    MR_type_ctor_and_args(type_info, MR_FALSE, &type_ctor_desc, &ArgTypes);
    TypeCtorDesc = (MR_Word) type_ctor_desc;

    MR_restore_transient_registers();
}").

make_type(_TypeCtorDesc::in, _ArgTypes::in, _TypeDesc::out) :-
    private_builtin.sorry("make_type(in, in, out)").
make_type(_TypeCtorDesc::out, _ArgTypes::out, _TypeDesc::in) :-
    private_builtin.sorry("make_type(out, out, in)").

det_make_type(TypeCtor, ArgTypes) = Type :-
    ( if make_type(TypeCtor, ArgTypes, NewType) then
        Type = NewType
    else
        error($pred, "make_type/3 failed (wrong arity)")
    ).

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

    % This function returns the type_info for the builtin type "typeinfo"
    % itself. It is intended for use from C code, since Mercury code can access
    % this type_info easily enough even without this predicate.
    %
    % XXX This code relies on the type "type_desc" being the same type
    % as the builtin type "typeinfo".
    %
:- func get_type_info_for_type_info = type_desc.

:- pragma foreign_export("C", get_type_info_for_type_info = out,
    "ML_get_type_info_for_type_info").

get_type_info_for_type_info = TypeDesc :-
    Type = type_of(1),
    TypeDesc = type_of(Type).

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

:- pragma foreign_code("C#", "
    public static bool
    __Unify____type_desc_0_0(
        runtime.TypeInfo_Struct x,
        runtime.TypeInfo_Struct y)
    {
        return x.Equals(y);
    }

    public static bool
    __Unify____type_ctor_desc_0_0(
        runtime.TypeCtorInfo_Struct x,
        runtime.TypeCtorInfo_Struct y)
    {
        return x.Equals(y);
    }

    public static builtin.Comparison_result_0
    __Compare____type_desc_0_0(
        runtime.TypeInfo_Struct x,
        runtime.TypeInfo_Struct y)
    {
        return rtti_implementation.ML_compare_type_infos(x, y);
    }

    public static builtin.Comparison_result_0
    __Compare____type_ctor_desc_0_0(
        runtime.TypeCtorInfo_Struct x,
        runtime.TypeCtorInfo_Struct y)
    {
        return rtti_implementation.ML_compare_type_ctor_infos(x, y);
    }

    public static bool
    __Unify____pseudo_type_desc_0_0(
        runtime.PseudoTypeInfo x,
        runtime.PseudoTypeInfo y)
    {
        return x.Equals(y);
    }

    public static builtin.Comparison_result_0
    __Compare____pseudo_type_desc_0_0(
        runtime.PseudoTypeInfo x,
        runtime.PseudoTypeInfo y)
    {
        return rtti_implementation.ML_compare_pseudo_type_infos(x, y);
    }
").

:- pragma foreign_code("Java", "
    public static boolean
    __Unify____type_desc_0_0(TypeInfo_Struct x, TypeInfo_Struct y)
    {
        return x.unify(y);
    }

    public static boolean
    __Unify____type_ctor_desc_0_0(TypeCtorInfo_Struct x, TypeCtorInfo_Struct y)
    {
        return x.unify(y);
    }

    public static builtin.Comparison_result_0
    __Compare____type_desc_0_0(TypeInfo_Struct x, TypeInfo_Struct y)
    {
        return rtti_implementation.ML_compare_type_infos(x, y);
    }

    public static builtin.Comparison_result_0
    __Compare____type_ctor_desc_0_0(TypeCtorInfo_Struct x,
        TypeCtorInfo_Struct y)
    {
        return rtti_implementation.ML_compare_type_ctor_infos(x, y);
    }

    public static boolean
    __Unify____pseudo_type_desc_0_0(PseudoTypeInfo x, PseudoTypeInfo y)
    {
        return x.unify(y);
    }

    public static builtin.Comparison_result_0
    __Compare____pseudo_type_desc_0_0(PseudoTypeInfo x, PseudoTypeInfo y)
    {
        return rtti_implementation.ML_compare_pseudo_type_infos(x, y);
    }
").

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

type_desc_to_type_info(TypeDesc, TypeInfo) :-
    ( if type_info_desc_same_representation then
        private_builtin.unsafe_type_cast(TypeDesc, TypeInfo)
    else
        error("type_desc_to_type_info/2")
    ).

type_info_to_type_desc(TypeInfo, TypeDesc) :-
    ( if type_info_desc_same_representation then
        private_builtin.unsafe_type_cast(TypeInfo, TypeDesc)
    else
        error("type_info_to_type_desc/2")
    ).

type_info_list_to_type_desc_list(TypeInfoList, TypeDescList) :-
    ( if type_info_desc_same_representation then
        private_builtin.unsafe_type_cast(TypeInfoList, TypeDescList)
    else
        list.map(type_info_to_type_desc, TypeInfoList, TypeDescList)
    ).

%---------------------------------------------------------------------------%
:- end_module type_desc.
%---------------------------------------------------------------------------%
