use v6.d;
use lib $?FILE.IO.parent(2).add("packages");
use Test;
use Test::Util;

=begin description

Tests that || and && and // really short circuit, and do not call their
rhs when the lhs is enough to deduce the result.

Also, test new ^^ operator here: even though it does not short circuit,
it is closely related to || and && and //.

=end description

plan 84;

my $accum = '';
sub f1($s)   { $accum ~= $s; 1 }
sub f0($s)   { $accum ~= $s; 0 }
sub fAny($s) { $accum ~= $s; Any }

#?DOES 1
sub accumtest($expect, $op) {
    is $accum, $expect, "$op operator short circuiting exactly when needed";
    $accum = '';
}

{
    my $x = 1;
    my $y = 2;
    $x == 1 || ($y = 42);

    is($y, 2, "|| operator short circuiting");

    f0('a') || f0('b') || f1('c') || f0('d') || f1('e');
    accumtest 'abc', '||';
}

{
    my $x = 1;
    my $y = 2;
    $x == 1 or $y = 42;

    is($y, 2, "'or' operator short circuiting");

    f0('a') or f0('b') or f1('c') or f0('d') or f1('e');
    accumtest 'abc', "'or'";
}

{
    my $x = 1;
    my $y = 2;
    $x != 1 && ($y = 42);

    is($y, 2, "&& operator short circuiting");

    f1('a') && f1('b') && f1('c') && f0('d') && f1('e');
    accumtest 'abcd', '&&';
}

{
    my $x = 1;
    my $y = 2;
    $x != 1 and $y = 42;

    is($y, 2, "'and' operator short circuiting");

    f1('a') and f1('b') and f1('c') and f0('d') and f1('e');
    accumtest 'abcd', "'and'";
}

{
    my $x = 1;
    my $y = 2;
    $x // ($y = 42);

    is($y, 2, "// operator short circuiting");

    fAny('a') // fAny('b') // f0('c') // f1('d') // fAny('e');
    accumtest 'abc', '//';

    fAny('a') // f1('b') // f0('c');
    accumtest 'ab', '//';
}

{
    my $x = 1;
    my $y = 2;
    $x orelse $y = 42;

    is($y, 2, "'orelse' operator short circuiting");

    fAny('a') orelse fAny('b') orelse f0('c') orelse f1('d') orelse fAny('e');
    accumtest 'abc', "'orelse'";

    fAny('a') orelse f1('b') orelse f0('c');
    accumtest 'ab', "'orelse'";
}

{
    my $x;      # should be Mu
    my $y = 2;
    $x // ($y = 42);

    is($y, 42, "// operator working");
}

{
    my $x;      # should be Mu
    my $y = 2;
    $x orelse $y = 42;

    is($y, 42, "'orelse' operator working");
}

{
    my $x;      # should be Mu
    my $y = 2;
    $x ^^ ($y = 42);

    is($y, 42, "^^ operator not short circuiting");

    $x = 0;
    1 ^^ 2 ^^ ($x = 5);
    is($x, 0, "^^ operator short circuiting");

    f0('a') ^^ f0('b') ^^ f1('c') ^^ f0('d') ^^
        f0('e') ^^ f1('f') ^^ f0('g') ^^ f0('h');
    accumtest 'abcdef', '^^';
}

{
    my $x;      # should be Mu
    my $y = 2;
    $x xor $y = 42;

    is($y, 42, "xor operator not short circuiting");

    $x = 0;
    1 xor 2 xor ($x = 5);
    is($x, 0, "xor operator short circuiting");

    f0('a') xor f0('b') xor f1('c') xor f0('d') xor
        f0('e') xor f1('f') xor f0('g') xor f0('h');
    accumtest 'abcdef', 'xor';
}

{
    is(1 && 42,        42, "&&   operator working");
    is((1 and 42),     42, "and  operator working");

    is(0 || 42,        42, "||   operator working");
    is((0 or 42),      42, "or   operator working");

    is((Mu // 42),  42, "//   operator working"); #"
    is((Mu orelse 42), 42, "orelse  operator working");

    is(0 ^^ 42,        42, "^^  operator working (one true)");
    is(42 ^^ 0,        42, "^^  operator working (one true)");
    is(1 ^^ 42,       Nil, "^^  operator working (both true)");
    is(0 ^^ 0,          0, "^^  operator working (both false)");
    is((0 xor 42),     42, "xor operator working (one true)");
    is((42 xor 0),     42, "xor operator working (one true)");
    is((0 xor 42),     42, "xor operator working (one true)");
    is((42 xor 0),     42, "xor operator working (one true)");
    ok(!(1 xor 42),        "xor operator working (both true)");
    ok(!(0 xor 0),         "xor operator working (both false)");
}

# L<S03/Tight or precedence/'if all arguments are false'>
# RT #72826 infix ^^ return wrong types
{
    is 0 ^^ False ^^ '', '', '^^ given all false values returns last (1)';
    is False ^^ '' ^^ 0, 0, '^^ given all false values returns last (2)';
    is False ^^ 42 ^^ '', 42, '^^ given one true value returns it (1)';
    is 0 ^^ Int ^^ 'plugh', 'plugh', '^^ given one true value returns it (2)';
    is 15 ^^ 0 ^^ 'quux', Nil, '^^ given two true values returns False (1)';
    is 'a' ^^ 'b' ^^ 0, Nil, '^^ given two true values returns False (2)';

    is (0 xor False xor ''), '', 'xor given all false values returns last (1)';
    is (False xor '' xor 0), 0, 'xor given all false values returns last (2)';
    is (False xor 42 xor ''), 42, 'xor given one true value returns it (1)';
    is (0 xor Int xor 'plugh'), 'plugh', 'xor given one true value returns it (2)';
    is (15 xor 0 xor 'quux'), Nil, 'xor given two true values returns False (1)';
    is ('a' xor 'b' xor 0), Nil, 'xor given two true values returns False (2)';

    isa-ok 7 ^^ 7, Nil, '^^ can return a Bool';
    isa-ok 7 ^^ Mu, Int, '^^ can return an Int';
    isa-ok 0 ^^ ^7, Range, '^^ can return a Range';
    isa-ok ^7 ^^ 0, Range, '^^ can return a Range';
    isa-ok 7.5i ^^ Mu, Complex, '^^ can return a Complex';
    isa-ok Inf ^^ Mu, Num, '^^ can return a Num';
    isa-ok 'Inf' ^^ Mu, Str, '^^ can return a Str';

    my @a = (1,2,3);
    my @b = (4,5,6);
    my (@c, @d);

    is (@a ^^ @c), '1 2 3', 'Array ^^ true returns true array';
    is (@c ^^ @a), '1 2 3', 'Array ^^ true returns true array';
    ok (@a ^^ @b) == (), 'Array ^^ true returns empty list';
    ok (@c ^^ @d) == (), 'Array ^^ true returns empty list';
    is (@a ^^ ()), '1 2 3', 'True array ^^ empty list returns array';
    is (() ^^ @a), '1 2 3', 'Empty list ^^ true array returns array';
    ok (() ^^ @c) == (), 'Empty list ^^ empty array returns ()';
}

{
    my $x0 = 0;
    my @a0 = () and $x0 = 1;
    is($x0, 0,    "'and' operator short circuiting");
    ok(+@a0 == 0, "'and' operator working with list assignment");
}

{
    my $x0 = 0;
    my @a0 = () or $x0 = 1;
    is($x0,  1, "'or' operator short circuiting");
    is(+@a0, 0, "'or' operator working with list assignment");
}

# L<S03/Chained comparisons/Each argument chain will evaluate at most once>
{
    my $x = 0;
    my $y = 0;
    ok(($x++ < ++$y < ++$y), "chained comparison (truth - 1)");
    # expect x=1, y=2
    is($y, 2, "chained comparison short-circuit: not re-evaluating middle");
}

# L<S03/Chained comparisons/A chain of comparisons short-circuits>
{
    my $x = 0;
    my $y = 0;
    ok(not(++$x < $y++ < $y++), "chained comparison (truth - 2)");
    # expect x=1, y=1
    is($y, 1, "chained comparison short-circuit: stopping soon enough");
}

{
    my $a = sub { 1 };
    my $b;
    sub c($code) { if $code and $code() { return 1 }; return 2 }

    is c($a), 1, 'shortcircuit idiom given coderef works';

    is c($b), 2, 'shortcircuit idiom given Mu works';
}

ok (0 || 0 || 1), '0 || 0 || 1 is true';

# RT #77864
{
    my $x;
    $x &&= 5;
    ok !defined($x), '&&= on a fresh variable works';
    my $y ||= 'moin';
    is $y, 'moin', '||= on a fresh variable works';

}

{
    my $a = 0;
    my $b = 0;
    $a //= ($b = 1);
    is $a, 0, 'basic //=';
    is $b, 0, '//= short-circuits';

    $a = 1;
    $b = 0;
    $a ||= ($b = 2);
    is $a, 1, 'basic ||=';
    is $b, 0, '||= short-circuits';

}

# RT #90158
{
    my @a = 1;
    @a ||= ();
    is ~@a, '1', '||= works with array on the LHS';
}

# RT #116230
{
    my role SomeRole { };
    my $x = SomeRole;
    $x //= SomeRole.new;
    ok $x.defined, '//= can cope with role type objects';
}

# https://github.com/rakudo/rakudo/issues/1389
subtest 'xor warns when used with bad precedence' => {
    plan 3;
    is_run ｢uc 'f♥oo' xor 'b♥ar'｣, {:err{.contains: 'Useless' & 'b♥ar' & none 'f♥oo'}}, '2-arg';
    is_run ｢uc 'f♥oo' xor 'b♥ar' xor 'b♥er' xor 'b♥az'｣,
        {:err{.contains: <Useless b♥ar b♥er b♥az>.all & none 'f♥oo'}}, '4-arg';
    is_run ｢uc 'f♥oo' xor 'b♥ar'.uc xor 'b♥er'.uc xor 'b♥az'｣,
        {:err{.contains: <Useless b♥az>.all & <f♥oo b♥ar b♥er>.none}},
        '4-arg, with all but last args wanted';
}

# vim: ft=perl6
