%---------------------------------------------------------------------------%
% vim: ts=4 sw=4 et ft=mercury
%---------------------------------------------------------------------------%
%
% Test case for construct, num_functors, type_of and get_functor.
%
% Original author: trd
%

:- module construct_test.
:- interface.
:- import_module io.

:- pred main(io::di, io::uo) is det.

:- implementation.

:- import_module list.
:- import_module int.
:- import_module univ.
:- import_module maybe.
:- import_module term.
:- import_module map.
:- import_module string.
:- import_module require.
:- import_module construct.
:- import_module type_desc.

:- type enum
    --->    one
    ;       two
    ;       three.

:- type fruit
    --->    apple(apple_list :: list(int))
    ;       banana(banana_list :: list(enum)).

:- type thingie
    --->    foo
    ;       bar(int)
    ;       bar(int, int)
    ;       qux(int)
    ;       quux(int)
    ;       quuux(int, int)
    ;       wombat
    ;       zoom(int)
    ;       zap(int, float)
    ;       zip(int, int)
    ;       zop(float, float).

:- type poly(A, B)
    --->    poly_one(A)
    ;       poly_two(B)
    ;       poly_three(B, poly3_field2 :: A, poly(B, A))
    ;       poly_four(A, B).

:- type no_tag
    --->    qwerty(qwerty_field :: int).

:- type dummy
    --->    dummy.

:- type unboxed_arg
    --->    no
    ;       unboxed_arg(unboxed_struct).

:- type unboxed_struct
    --->    unboxed_struct(int, int).

:- type exist_type
    --->    some [T] xyzzy(f21name :: T).

    % By using nine non-constant functors, we are forcing packed_8
    % and packed_9 to share a primary tag even on 64 bit systems.
    % packed_1 tests the secondary tag absent case in the construct predicate,
    % while and packed_8 tests the secondary tag present case.
:- type packed(T)
    --->    packed_1(int8, uint8, dummy, dummy, int8, uint8, T)
    ;       some [U] packed_2(dummy, U, int8, uint8, dummy, int8, uint8)
    ;       packed_3(int)
    ;       packed_4(int)
    ;       packed_5(int)
    ;       packed_6(int)
    ;       packed_7(int)
    ;       packed_8(T, dummy, int8, uint8, dummy, dummy, int8, uint8,
                float, int)
    ;       some [U] packed_9(T, dummy, U, int8, uint8, dummy, int8, uint8).

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

main(!IO) :-
    io.write_string("------- TESTING TYPE DESCRIPTIONS -------\n", !IO),

    describe_functors_in_du_types(!IO),
    describe_functors_in_polymorphic_types(!IO),
    describe_functors_in_builtin_types(!IO),
    describe_functors_in_other_types(!IO),

    io.write_string("\n------- TESTING CONSTRUCTION OF TERMS -------\n", !IO),
    test_construction(!IO).

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

:- pred describe_functors_in_du_types(io::di, io::uo) is det.

describe_functors_in_du_types(!IO) :-
    io.write_string("\nTESTING DISCRIMINATED UNIONS\n", !IO),

    % Test enumerations.
    describe_all_functors_of_type(two, !IO),
    describe_all_functors_of_type(one, !IO),
    describe_all_functors_of_type(three, !IO),

    % Test simple tags.
    describe_all_functors_of_type(apple([9, 5, 1]), !IO),
    describe_all_functors_of_type(banana([three, one, two]), !IO),

    % Test complicated tags.
    describe_all_functors_of_type(zop(3.3, 2.03), !IO),
    describe_all_functors_of_type(zip(3, 2), !IO),
    describe_all_functors_of_type(zap(3, -2.111), !IO),

    % Test complicated constants.
    describe_all_functors_of_type(wombat, !IO),
    describe_all_functors_of_type(foo, !IO).

:- pred describe_functors_in_polymorphic_types(io::di, io::uo) is det.

describe_functors_in_polymorphic_types(!IO) :-
    io.write_string("\nTESTING POLYMORPHISM\n", !IO),
    describe_all_functors_of_type(poly_three(3.33, 4, poly_one(9.11)), !IO),
    describe_all_functors_of_type(poly_two(3) : poly(dummy, int), !IO),
    describe_all_functors_of_type(poly_one([2399.3]) :
        poly(list(float), dummy), !IO).

:- pred describe_functors_in_builtin_types(io::di, io::uo) is det.

describe_functors_in_builtin_types(!IO) :-
    io.write_string("\nTESTING BUILTINS\n", !IO),

    % Test strings.
    describe_all_functors_of_type("", !IO),
    describe_all_functors_of_type("Hello, world\n", !IO),
    describe_all_functors_of_type("Foo%sFoo", !IO),
    describe_all_functors_of_type("""", !IO),

    % Test characters.
    describe_all_functors_of_type('a', !IO),
    describe_all_functors_of_type('&', !IO),

    % Test floats.
    describe_all_functors_of_type(3.14159, !IO),
    describe_all_functors_of_type(11.28324983E-22, !IO),
    describe_all_functors_of_type(22.3954899E22, !IO),

    % Test integers.
    describe_all_functors_of_type(-65, !IO),
    describe_all_functors_of_type(4, !IO),

    % Test unsigned integers.
    describe_all_functors_of_type(42u, !IO),

    % Test fixed size integers.
    describe_all_functors_of_type(42i8, !IO),
    describe_all_functors_of_type(42u8, !IO),
    describe_all_functors_of_type(42i16, !IO),
    describe_all_functors_of_type(42u16, !IO),
    describe_all_functors_of_type(42i32, !IO),
    describe_all_functors_of_type(42u32, !IO),
    describe_all_functors_of_type(42i64, !IO),
    describe_all_functors_of_type(42u64, !IO),

    % Test univ.
    % type_to_univ(["hi! I'm a univ!"], Univ),
    % describe_all_functors_of_type(Univ, !IO),

    % Test predicates.
    describe_all_functors_of_type(newline, !IO),

    % Test tuples.
    describe_all_functors_of_type({1, "a", 'a', {4, 'd'}}, !IO),

    % Test lists.
    describe_all_functors_of_type([1, 2, 3, 4], !IO).

:- pred describe_functors_in_other_types(io::di, io::uo) is det.

describe_functors_in_other_types(!IO) :-
    io.write_string("\nTESTING OTHER TYPES\n", !IO),

    term.init_var_supply(VarSupply : var_supply(int)),
    term.create_var(Var, VarSupply, NewVarSupply),
    describe_all_functors_of_type(Var, !IO),
    describe_all_functors_of_type(VarSupply, !IO),
    describe_all_functors_of_type(NewVarSupply, !IO),

    % Presently, at least, map is an equivalence and an abstract type.
    % Note: testing abstract types is always going to have results
    % that are dependent on the implementation. If someone changes
    % the implementation, the results of this test can change.
    map.init(Map : map(int, int)),
    describe_all_functors_of_type(Map, !IO),

    % A no tag type.
    describe_all_functors_of_type(qwerty(4), !IO),

    % A dummy type.
    describe_all_functors_of_type(dummy, !IO),

    % A functor with a single unboxed argument.
    describe_all_functors_of_type(unboxed_arg(unboxed_struct(12, 34)), !IO),

    % An existential type.
    ExistVal = 'new xyzzy'(8),
    describe_all_functors_of_type(ExistVal, !IO).

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

:- pred describe_all_functors_of_type(T::in, io::di, io::uo) is det.

describe_all_functors_of_type(T, !IO) :-
    io.nl(!IO),
    TypeInfo = type_desc.type_of(T),
    ( if NumFunctors = construct.num_functors(TypeInfo) then
        io.format("#functors in this type = %d\n", [i(NumFunctors)], !IO),
        describe_functors_of_type_loop(TypeInfo, 0, NumFunctors, !IO)
    else
        io.format("#functors in this type = %d\n", [i(0)], !IO)
    ).

:- pred describe_functors_of_type_loop(type_desc.type_desc::in,
    int::in, int::in, io::di, io::uo) is det.

describe_functors_of_type_loop(TypeInfo, Cur, NumFunctors, !IO) :-
    ( if Cur >= NumFunctors then
        true
    else
        describe_nth_functor_of_type(TypeInfo, Cur, !IO),
        describe_functors_of_type_loop(TypeInfo, Cur + 1, NumFunctors, !IO)
    ).

:- pred describe_nth_functor_of_type(type_desc.type_desc::in, int::in,
    io::di, io::uo) is det.

describe_nth_functor_of_type(TypeInfo, N, !IO) :-
    ( if
        % Ordinal = construct.get_functor_ordinal(TypeInfo, N),
        % Lex = construct.get_functor_lex(TypeInfo, Ordinal),
        Lex = construct.get_functor_lex(TypeInfo, N),
        Ordinal = construct.get_functor_ordinal(TypeInfo, Lex),
        construct.get_functor_with_names(TypeInfo, Lex,
            FunctorName, FunctorArity, _ArgTypesList, ArgMaybeNames)
    then
        ( if N = Ordinal then
            ArgNames = list.map(name_or_underscore, ArgMaybeNames),
            ArgNamesDesc = join_list(", ", ArgNames),
            FunctorNA = string.format("%s/%d",
                [s(FunctorName), i(FunctorArity)]),
            io.format("%2d - %-14s lex: %2d [%s]\n",
                [i(N), s(FunctorNA), i(Lex), s(ArgNamesDesc)], !IO)
        else
            io.format("N (%d) != Ordinal (%d)\n", [i(N), i(Ordinal)], !IO)
        )
    else
        io.format("%d failed\n", [i(N)], !IO)
    ).

:- func name_or_underscore(maybe(string)) = string.

name_or_underscore(MaybeName) = Str :-
    (
        MaybeName = yes(Name),
        Str = Name
    ;
        MaybeName = no,
        Str = "_"
    ).

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

:- pred newline(io::di, io::uo) is det.

newline(!IO) :-
    io.nl( !IO).

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

:- pred test_construction(io::di, io::uo) is det.

test_construction(!IO) :-
    % Valid tests.

    % Enumerations:

    test_construct(type_desc.type_of(one),
        "three", [], !IO),

    type_to_univ([1, 2, 3], NumList),
    test_construct(type_desc.type_of(apple([])),
        "apple", [NumList], !IO),

    type_to_univ([one, two, three], EnumList),
    test_construct(type_desc.type_of(apple([])),
        "banana", [EnumList], !IO),

    % Discriminated union:
    % (Simple, complicated and complicated constant tags).

    type_to_univ(1, One),
    type_to_univ(2.1, TwoPointOne),

    test_construct(type_desc.type_of(wombat),
        "foo", [], !IO),
    test_construct(type_desc.type_of(wombat),
        "bar", [One], !IO),
    test_construct(type_desc.type_of(wombat),
        "bar", [One, One], !IO),
    test_construct(type_desc.type_of(wombat),
        "qux", [One], !IO),
    test_construct(type_desc.type_of(wombat),
        "quux", [One], !IO),
    test_construct(type_desc.type_of(wombat),
        "quuux", [One, One], !IO),
    test_construct(type_desc.type_of(wombat),
        "wombat", [], !IO),
    test_construct(type_desc.type_of(wombat),
        "zoom", [One], !IO),
    test_construct(type_desc.type_of(wombat),
        "zap", [One, TwoPointOne], !IO),
    test_construct(type_desc.type_of(wombat),
        "zip", [One, One], !IO),
    test_construct(type_desc.type_of(wombat),
        "zop", [TwoPointOne, TwoPointOne], !IO),

    % No-tag type.
    test_construct(type_desc.type_of(qwerty(7)),
        "qwerty", [One], !IO),

    % Functor with single unboxed argument.
    type_to_univ(unboxed_struct(12, 34), UnboxedStruct),
    test_construct(type_desc.type_of(_ : unboxed_arg),
        "unboxed_arg", [UnboxedStruct], !IO),

    type_to_univ("goodbye", Bye),

    test_construct(type_desc.type_of(poly_four(3, "hello")),
        "poly_one", [One], !IO),
    test_construct(type_desc.type_of(poly_four(3, "hello")),
        "poly_two", [Bye], !IO),
    test_construct(type_desc.type_of(poly_four(3, "hello")),
        "poly_four", [One, Bye], !IO),
    test_construct(type_desc.type_of({1, "two", '3'}),
        "{}", [univ(4), univ("five"), univ('6')], !IO),

    io.nl(!IO),
    io.write_string("About to construct a tuple\n", !IO),
    Tuple = construct.construct_tuple([NumList, EnumList, One, TwoPointOne]),
    io.write(Tuple, !IO),
    io.nl(!IO),

    Packed =
        type_desc.type_of(packed_1(0i8, 0u8, dummy, dummy, 0i8, 0u8, "")),

    test_construct(Packed, "packed_1",
        [univ(-11i8), univ(11u8), univ(dummy), univ(dummy),
        univ(-127i8), univ(255u8), univ("abc")], !IO),
    % We cannot yet construct terms with existentially typed arguments.
%   test_construct(Packed, "packed_2",
%       [univ(dummy), univ(-11i8), univ(-11i8), univ(11u8), univ(dummy),
%       univ(-127i8), univ(255u8)], !IO),
    test_construct(Packed, "packed_8",
        [univ("def"), univ(dummy), univ(-11i8), univ(11u8),
        univ(dummy), univ(dummy), univ(-127i8), univ(255u8),
        univ(1234.567), univ(42)], !IO).
    % We cannot yet construct terms with existentially typed arguments.
%   test_construct(Packed, "packed_9",
%       [univ("def"), univ(dummy), univ(1234.56), univ(-25i8), univ(140u8),
%       univ(dummy), univ(-127i8), univ(255u8)], !IO).

:- pred test_construct(type_desc.type_desc::in, string::in,
    list(univ)::in, io::di, io::uo) is det.

test_construct(TypeInfo, FunctorName, Args, !IO) :-
    io.nl(!IO),
    list.length(Args, Arity),
    find_functor(TypeInfo, FunctorName, Arity, FunctorNumber),
    io.format("About to construct %s/%d\n", [s(FunctorName), i(Arity)], !IO),
    ( if construct.construct(TypeInfo, FunctorNumber, Args, Constructed) then
        io.print(Constructed, !IO),
        io.nl(!IO)
    else
        io.write_string("Construction failed.\n", !IO)
    ).

:- pred find_functor(type_desc.type_desc::in, string::in, int::in, int::out)
    is det.

find_functor(TypeInfo, Functor, Arity, FunctorNumber) :-
    ( if N = construct.num_functors(TypeInfo) then
        find_functor_loop(TypeInfo, Functor, Arity, N, FunctorNumber)
    else
        error("unable to find number of functors")
    ).

:- pred find_functor_loop(type_desc.type_desc::in, string::in, int::in,
    int::in, int::out) is det.

find_functor_loop(TypeInfo, Functor, Arity, Num, FunctorNumber) :-
    ( if Num < 0 then
        error("unable to find functor")
    else
        ( if construct.get_functor(TypeInfo, Num, Functor, Arity, _) then
            FunctorNumber = Num
        else
            find_functor_loop(TypeInfo, Functor, Arity, Num - 1,
                FunctorNumber)
        )
    ).

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