use strict;
use warnings;
use Test::More tests => 87;
use Test::Deep qw( cmp_deeply code );
use Test::PDL qw( :deep eq_pdl eq_pdl_diag );
use Test::Builder::Tester;
use Test::Exception;
use PDL;

my @types = qw( byte short ushort long longlong float double );

isa_ok test_pdl( 1,2,3 ), 'Test::Deep::PDL';
for my $type ( @types ) {
	no strict 'refs';
	my $sub = "test_$type";
	isa_ok $sub->( 1,2,3 ), 'Test::Deep::PDL';
}

{
	my $pdl1     = pdl( 1,2,3.13 );
	my $got      = { name => 'Histogram', data => $pdl1 };
	my $pdl2     = pdl( 1,2,3.13 );
	my $expected = { name => 'Histogram', data => $pdl2 };
	throws_ok { ok $pdl1 == $pdl2 } qr/multielement piddle in conditional expression at /, '== dies with an error message';
	throws_ok { is $pdl1, $pdl2 } qr/multielement piddle in conditional expression at /, 'is() dies with an error message';
	throws_ok { is_deeply $got, $expected } qr/^multielement piddle in conditional expression at /, 'is_deeply() dies with the same error message';
}

{
	my $pdl      = pdl( 1,2,3.13 );
	my $got      = { name => 'Histogram', data => $pdl };
	my $expected = { name => 'Histogram', data => $pdl };
	throws_ok { ok $pdl == $pdl } qr/^multielement piddle in conditional expression at /, 'even shallow reference comparisons do not work with ==';
	throws_ok { is_deeply $got, $expected } qr/^multielement piddle in conditional expression at /, '... neither with is_deeply()';
}

{
	my $pdl      = pdl( 1,2,3.13 );
	my $got      = { name => 'Histogram', data => $pdl };
	my $expected = { name => 'Histogram', data => $pdl };
	test_out 'ok 1';
	cmp_deeply $got, $expected;
	test_test 'cmp_deeply() without test_pdl() performs only shallow reference comparison';
}

{
	my $pdl      = pdl( 1,2,3.13 );
	my $got      = { name => 'Histogram', data => $pdl };
	my $expected = { name => 'Histogram', data => $pdl->copy };
	test_out 'not ok 1';
	test_fail +4;
	test_diag 'Compared ${$data->{"data"}}';
	test_err  "/#    got : '\\d+'/",
		  "/# expect : '\\d+'/";
	cmp_deeply $got, $expected;
	test_test 'but shallow reference comparison is not powerful enough';
}

=pod

The following test code may be a bit hard to follow. We're basically trying to
ensure that

	my @vals     = ( ... );
	my $got      = { data => long( @vals ) };
	my $expected = { data => test_long( @vals ) };
	cmp_deeply $got, $expected;

passes for every conceivable type of piddle (not only I<long>), and for
different sets of values @vals, some of which may contain bad values. We also
test that

	{ data => test_long( @vals ) }
	{ data => test_pdl( long(@vals) ) }
	{ data => code( sub { eq_pdl_diag shift, long(@vals) } ) }

yield the same results.

=cut

for my $vals ( [ 0 ], [ 2,3,0,1,99 ], [ 99,99,99 ] ) {
	for my $type ( @types ) {
		my @vals      = @$vals;
		my $ctor      = do { local *slot = $PDL::{ $type }; *slot{CODE} };
		my $tester    = do { local *slot = $Test::PDL::{ 'test_' . $type }; *slot{CODE} };
		my $pdl       = $ctor->( @vals )->inplace->setvaltobad( 99 );
		note 'test with pdl = ', $pdl->info('%-8T'), ' ', $pdl;
		my $got       = { data => $pdl };
		my $expected1 = { data => $tester->( @vals ) };
		$expected1->{data}->{expected}->inplace->setvaltobad( 99 );
		test_out 'ok 1';
		cmp_deeply $got, $expected1;
		test_test 'succeeds when it should succeed, with piddle supplied as values';
		my $expected2 = { data => test_pdl( $pdl ) };
		test_out 'ok 1';
		cmp_deeply $got, $expected2;
		test_test '... also when piddle is supplied directly';
		my $expected3 = { data => code( sub { eq_pdl_diag shift, $pdl } ) };
		test_out 'ok 1';
		cmp_deeply $got, $expected3;
		test_test '... and it\'s the same thing as using code()';
	}
}

{
	my $pdl1 = 2;
	my $pdl2 = pdl( 3,4,9.999 );
	ok !eq_pdl( $pdl1, $pdl2 ), 'piddles are unequal to begin with';
	my $got = { data => $pdl1 };
	my $expected = { data => test_pdl( $pdl2 ) };
	test_out 'not ok 1';
	test_fail +5;
	test_diag 'Comparing $data->{"data"} as a piddle:',
		  'received value is not a piddle';
	test_err  "/#    got : \\('2'\\)/",
		  '/# expect : Double\s+D\s+\[3\].*/';
	cmp_deeply $got, $expected;
	test_test 'fails with correct message and diagnostics when received value is not a piddle';
	test_out 'not ok 1';
	test_fail +6;
	test_diag 'Ran coderef at $data->{"data"} on',
		  '',
		  "'2'",
		  'and it said',
		  'received value is not a piddle';
	cmp_deeply $got, { data => code( sub { eq_pdl_diag shift, $pdl2 } ) };
	test_test '... but the diagnostics are better than with code()';
}

{
	my $pdl1 = pdl( 3,4,9.999 );
	my $pdl2 = pdl( 3,4,10 );
	ok !eq_pdl( $pdl1, $pdl2 ), 'piddles are unequal to begin with';
	my $got = { data => $pdl1 };
	my $expected = { data => test_pdl( $pdl2 ) };
	test_out 'not ok 1';
	test_fail +5;
	test_diag 'Comparing $data->{"data"} as a piddle:',
		  'values do not match';
	test_err  '/#    got : Double\s+D\s+\[3\].*/',
		  '/# expect : Double\s+D\s+\[3\].*/';
	cmp_deeply $got, $expected;
	test_test 'fails with correct message and diagnostics on value mismatch';
	test_out 'not ok 1';
	test_fail +6;
	test_diag 'Ran coderef at $data->{"data"} on',
		  '';
	test_err  '/# PDL=SCALAR\(0x[0-9A-Fa-f]+\)/';
	test_diag 'and it said',
		  'values do not match';
	cmp_deeply $got, { data => code( sub { eq_pdl_diag shift, $pdl2 } ) };
	test_test '... but the diagnostics are better than with code()';
}

{
	my $pdl1 = short( 3,4,-6 );
	my $pdl2 = long( 3,4,10 );
	ok !eq_pdl( $pdl1, $pdl2 ), 'piddles are unequal to begin with';
	my $got = { data => $pdl1 };
	my $expected = { data => test_pdl( $pdl2 ) };
	test_out 'not ok 1';
	test_fail +5;
	test_diag 'Comparing $data->{"data"} as a piddle:',
		  'types do not match (EQUAL_TYPES is true)';
	test_err  '/#    got : Short\s+D\s+\[3\].*/',
		  '/# expect : Long\s+D\s+\[3\].*/';
	cmp_deeply $got, $expected;
	test_test 'fails with correct message and diagnostics on type mismatch';
	test_out 'not ok 1';
	test_fail +6;
	test_diag 'Ran coderef at $data->{"data"} on',
		  '';
	test_err  '/# PDL=SCALAR\(0x[0-9A-Fa-f]+\)/';
	test_diag 'and it said',
		  'types do not match (EQUAL_TYPES is true)';
	cmp_deeply $got, { data => code( sub { eq_pdl_diag shift, $pdl2 } ) };
	test_test '... but the diagnostics are better than with code()';
}