%---------------------------------------------------------------------------%
% vim: ts=4 sw=4 et ft=mercury
%---------------------------------------------------------------------------%
%
% Test case for functor, arg, deconstruct and their variants.
%
% Author: zs
%
% There are two expected output files for this test case.
% The .exp file is for LLDS grades.
% The .exp2 file is for MLDS grades.
%
% According to the first log entry of the .exp2 file, they are different
% because of missing information in closure layout structures in hlc grades.
%
%---------------------------------------------------------------------------%

:- module deconstruct_arg.
:- interface.
:- import_module io.

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

:- implementation.

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

:- import_module array.
:- import_module assoc_list.
:- import_module float.
:- import_module list.
:- import_module string.
:- import_module deconstruct.
:- import_module maybe.
:- import_module pair.
:- import_module stream.
:- import_module stream.string_writer.
:- import_module univ.

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

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

:- type thingie
    --->    foo
    ;       bar(int)
    ;       bar(int, int)
    ;       qux(int)
    ;       quux(int)
    ;       quuux(int, int)
    ;       wombat
    ;       zoom(int)
    ;       zap(int, float, int)
    ;       zip(int, int, int, int)
    ;       zop(float, float)
    ;       moomoo(
                moo     :: int,
                'mooo!' :: string
            )
    ;       packed(
                packed1 :: int,
                packed2 :: enum,
                packed3 :: enum,
                packed4 :: enum,
                packed5 :: string
            ).

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

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

:- type set(T)
    --->    set_rep(list(T))
    where equality is set_equal.

    % An enum type whose representation takes 1 bit.
:- type flag
    --->    flag_clear
    ;       flag_set.

    % An enum type whose representation takes 2 bits.
:- type color
    --->    red
    ;       green
    ;       blue.

    % An enum type whose representation takes 3 bits.
:- type packed_fruit
    --->    apple
    ;       pear
    ;       peach
    ;       orange
    ;       banana.

    % Every function symbol fN* should be allocated primary tag N.
    % The function symbols whose names end in _[abc] share their
    % primary tags, being distinguished by a local (f0) or remote (f7)
    % secondary tag. These all have an initial sequence of subword-sized
    % arguments that the compiler should pack next to the secondary tag.
:- type t
    --->    f0_a
    ;       f0_b(f0_b1 :: flag, f0_b2 :: color, f0_b3 :: packed_fruit)
    ;       f0_c(f0_c1 :: color, f0_c2 :: packed_fruit, f0_c3 :: flag)
    ;       f1(int)
    ;       f2(int)
    ;       f3(int)
    ;       f4(int)
    ;       f5(int)
    ;       f6(int)
    ;       f7_a(f7_a1 :: int)
    ;       f7_b(f7_b1 :: flag, f7_b2 :: color, f7_b3 :: packed_fruit)
    ;       f7_c(f7_c1 :: packed_fruit, f7_c2 :: flag, f7_c3 :: color,
                f7_c4 :: int).

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

% convert list to set
:- func set(list(T)) = set(T).

set(List) = set_rep(List).

% convert set to sorted list
:- func set_to_sorted_list(set(T)) = list(T).

set_to_sorted_list(Set) = Sorted :-
    promise_equivalent_solutions [Sorted] (
        Set = set_rep(Unsorted),
        list.sort_and_remove_dups(Unsorted, Sorted)
    ).

:- pred set_equal(set(T)::in, set(T)::in) is semidet.

set_equal(Set1, Set2) :-
    set_to_sorted_list(Set1) = set_to_sorted_list(Set2).

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

main(!IO) :-
    % test enumerations
    % test_all(one, !IO),

    % test primary tags
    test_all(apple([]), !IO),
    test_all(apple([9, 5, 1]), !IO),

    % test remote secondary tags
    test_all(zop(3.3, 2.03), !IO),
    test_all(zap(50, 51.0, 52), !IO),
    test_all(zip(50, 51, 52, 53), !IO),

    % test local secondary tags
    test_all(wombat, !IO),

    % test notag
    test_all(qwerty(5), !IO),

    % test named arguments
    test_all(moomoo(50, "moo."), !IO),

    % test terms with arguments packed next to the local secondary tag
    test_all(f0_a, !IO),
    test_all(f0_b(flag_set, blue, peach), !IO),
    test_all(f0_c(green, orange, flag_clear), !IO),

    % test terms with arguments packed next to the remote secondary tag
    test_all(f7_a(41), !IO),
    test_all(f7_b(flag_clear, red, peach), !IO),
    test_all(f7_c(pear, flag_set, green, 43), !IO),

    % test characters
    test_all('a', !IO),
    test_all(' ', !IO),
    test_all('\a', !IO),
    test_all('\b', !IO),
    test_all('\r', !IO),
    test_all('\f', !IO),
    test_all('\t', !IO),
    test_all('\n', !IO),
    test_all('\v', !IO),
    test_all('\\', !IO),
    test_all('\'', !IO),
    test_all('~', !IO),

    % test C0 control characters
    test_all('\001\', !IO),
    test_all('\037\', !IO),
    test_all('\177\', !IO),
    % test C1 control characters
    test_all('\200\', !IO),
    test_all('\237\', !IO),
    % No-break space (next codepoint after C1 control characters)
    test_all('\240\', !IO),

    % test a character that requires more than one byte in its
    % UTF-8 encoding.
    test_all('Ω', !IO),

    % test strings (that do not require escapes)
    test_all("", !IO),
    test_all("azBZ09", !IO),
    test_all("\u03b1\u2200\U0001f713", !IO),

    % test strings (that do require escapes)
    test_all("\a\b\f\n\t\r\v\"\\", !IO),
    test_all("\x1\\a\x1f\AZ[`az~\x7f\", !IO),
    test_all("\x80\\a\x9f\\xa0\\xc0\\xff\", !IO),
    test_all("α\nβ\tγ,a\nα\001\α\001\a\001\α", !IO),

    % test a float which requires 17 digits of precision
    test_all(0.12345678901234566, !IO),

    % test infinite floats
    test_all(float.infinity, !IO),
    NegInf : float = -float.infinity,
    test_all(NegInf, !IO),

    % test integers
    test_all(4, !IO),

    % test unsigned integers
    test_all(561u, !IO),

    % test fixed size integers.
    test_all(42i8, !IO),
    test_all(42u8, !IO),
    test_all(42i16, !IO),
    test_all(42u16, !IO),
    test_all(42i32, !IO),
    test_all(43u32, !IO),
    test_all(66i64, !IO),
    test_all(67u64, !IO),

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

    % test noncanonical type
    test_all(set([1, 2, 3, 3]), !IO),

    % test predicates
    test_all(newline, !IO),
    test_all(test_all([1, 2]), !IO),
    test_all(p(1, 2.2, "three"), !IO),

    % test tuples
    test_all({1, 'b'}, !IO),
    test_all({3, 'c', "3rd"}, !IO),
    test_all({5, 'd', "third", {1, 2, 3, 4}}, !IO),

    % test arrays
    test_all(array([1000, 2000]), !IO),
    test_all(array([100, 200, 300]), !IO),
    test_all(array([10, 20, 30, 40]), !IO),

    % test packed fields
    test_all(packed(100, one, two, three, "four"), !IO).

:- pred p(int::in, float::in, string::in, io::di, io::uo) is det.

p(_, _, _, !IO).

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

newline(!IO) :-
    io.write_char('\n', !IO).

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

:- pred test_all(T::in, io::di, io::uo) is cc_multi.

test_all(T, !IO) :-
    io.write_string("test term: ", !IO),
    io.write_line(T, !IO),
    test_deconstruct_functor(T, MaybeConstant, !IO),

    some [!RevPairs] (
        !:RevPairs = [],
        test_deconstruct_arg(T, 0, !RevPairs),
        test_deconstruct_arg(T, 1, !RevPairs),
        test_deconstruct_arg(T, 2, !RevPairs),
        test_deconstruct_arg(T, 3, !RevPairs),
        test_deconstruct_named_arg(T, "moo", !RevPairs),
        test_deconstruct_named_arg(T, "mooo!", !RevPairs),
        test_deconstruct_named_arg(T, "packed1", !RevPairs),
        test_deconstruct_named_arg(T, "packed2", !RevPairs),
        test_deconstruct_named_arg(T, "packed3", !RevPairs),
        test_deconstruct_named_arg(T, "f0_b1", !RevPairs),
        test_deconstruct_named_arg(T, "f0_b2", !RevPairs),
        test_deconstruct_named_arg(T, "f0_b3", !RevPairs),
        test_deconstruct_named_arg(T, "f0_c1", !RevPairs),
        test_deconstruct_named_arg(T, "f0_c2", !RevPairs),
        test_deconstruct_named_arg(T, "f0_c3", !RevPairs),
        test_deconstruct_named_arg(T, "f7_a1", !RevPairs),
        test_deconstruct_named_arg(T, "f7_b1", !RevPairs),
        test_deconstruct_named_arg(T, "f7_b2", !RevPairs),
        test_deconstruct_named_arg(T, "f7_b3", !RevPairs),
        test_deconstruct_named_arg(T, "f7_c1", !RevPairs),
        test_deconstruct_named_arg(T, "f7_c2", !RevPairs),
        test_deconstruct_named_arg(T, "f7_c3", !RevPairs),
        test_deconstruct_named_arg(T, "f7_c4", !RevPairs),
        list.reverse(!.RevPairs, Pairs),

        % Do not bore readers with each negative result individually;
        % print just one message for them all collectively, and even that
        % only if is not the expected result.
        list.filter(has_arg, Pairs, HasArgPairs, NoArgPairs),
        (
            HasArgPairs = [],
            (
                MaybeConstant = constant(_)
                % Not being able to get any arguments is not surprising
                % for terms that do not have any.
            ;
                MaybeConstant = not_constant(_, _),
                io.write_string("no argument access succeeded\n", !IO)
            )
        ;
            HasArgPairs = [_ | _],
            list.foldl(write_arg_pair, HasArgPairs, !IO),
            (
                NoArgPairs = [_ | _],
                io.write_string("no other argument access succeeded\n", !IO)
            ;
                NoArgPairs = []
            )
        )
    ),

    test_deconstruct_deconstruct(MaybeConstant, T, !IO),
    test_deconstruct_limited_deconstruct(MaybeConstant, T, 3, !IO),
    io.nl(!IO).

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

:- type maybe_constant
    --->    not_constant(string, int)
    ;       constant(string).

:- pred test_deconstruct_functor(T::in, maybe_constant::out,
    io::di, io::uo) is cc_multi.

test_deconstruct_functor(T, MaybeConstant, !IO) :-
    deconstruct.functor(T, include_details_cc, Functor, Arity),
    ( if Arity = 0 then
        MaybeConstant = constant(Functor)
    else
        MaybeConstant = not_constant(Functor, Arity)
    ),
    io.format("deconstruct functor: %s/%d\n", [s(Functor), i(Arity)], !IO).

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

:- pred test_deconstruct_arg(T::in, int::in,
    assoc_list(string, maybe_arg)::in, assoc_list(string, maybe_arg)::out)
    is cc_multi.

test_deconstruct_arg(T, ArgNum, !RevPairs) :-
    string.format("argument #%d: ", [i(ArgNum)], Desc),
    deconstruct.arg_cc(T, ArgNum, MaybeArg),
    !:RevPairs = [Desc - MaybeArg | !.RevPairs].

:- pred test_deconstruct_named_arg(T::in, string::in,
    assoc_list(string, maybe_arg)::in, assoc_list(string, maybe_arg)::out)
    is cc_multi.

test_deconstruct_named_arg(T, Name, !RevPairs) :-
    string.format("argument named '%s': ", [s(Name)], Desc),
    deconstruct.named_arg_cc(T, Name, MaybeArg),
    !:RevPairs = [Desc - MaybeArg | !.RevPairs].

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

:- pred has_arg(pair(string, maybe_arg)::in) is semidet.

has_arg(_Desc - arg(_)).

:- pred write_arg_pair(pair(string, maybe_arg)::in, io::di, io::uo) is det.

write_arg_pair(Desc - MaybeArg, !IO) :-
    io.write_string(Desc, !IO),
    (
        MaybeArg = arg(Arg),
        io.write(Arg, !IO),
        io.nl(!IO)
    ;
        MaybeArg = no_arg,
        io.write_string("does not exist\n", !IO)
    ).

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

:- pred test_deconstruct_deconstruct(maybe_constant::in, T::in,
    io::di, io::uo) is cc_multi.

test_deconstruct_deconstruct(MaybeConstant, T, !IO) :-
    Desc = "plain deconstruct:",
    deconstruct.deconstruct(T, include_details_cc, Functor, Arity, ArgUnivs),
    write_deconstruct_results_if_interesting(Desc, MaybeConstant,
        Functor, Arity, ArgUnivs, !IO).

:- pred test_deconstruct_limited_deconstruct(maybe_constant::in, T::in,
    int::in, io::di, io::uo) is cc_multi.

test_deconstruct_limited_deconstruct(MaybeConstant, T, Limit, !IO) :-
    string.format("limited deconstruct %d:", [i(Limit)], Desc),
    deconstruct.limited_deconstruct_cc(T, Limit, Result),
    (
        Result = yes({Functor, Arity, ArgUnivs}),
        write_deconstruct_results_if_interesting(Desc, MaybeConstant,
            Functor, Arity, ArgUnivs, !IO)
    ;
        Result = no,
        io.format("%s failed\n", [s(Desc)], !IO)
    ).

:- pred write_deconstruct_results_if_interesting(string::in,
    maybe_constant::in, string::in, int::in, list(univ)::in,
    io::di, io::uo) is det.

write_deconstruct_results_if_interesting(Desc, MaybeConstant,
        Functor, Arity, ArgUnivs, !IO) :-
    ( if
        MaybeConstant = constant(ConstantFunctor),
        Functor = ConstantFunctor,
        Arity = 0,
        ArgUnivs = []
    then
        % The result of the deconstruct operation is exactly what we expected.
        % The test_deconstruct_functor predicate has already printed
        % the functor and the arity, so there is nothing interesting for us
        % to print here.
        true
    else
        io.format("%s\n", [s(Desc)], !IO),
        io.format("functor %s arity %d ", [s(Functor), i(Arity)], !IO),
        io.write_string("[", !IO),
        io.write_list(ArgUnivs, ", ", write_arg_univ, !IO),
        io.write_string("]\n", !IO)
    ).

:- pred write_arg_univ(univ::in, io::di, io::uo) is det.

write_arg_univ(Univ, !IO) :-
    io.stdout_stream(Stdout, !IO),
    stream.string_writer.write_univ(Stdout, Univ, !IO).

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