=pod

=encoding utf-8

=head1 PURPOSE

Check type constraints work with L<Moose>. Checks values that should pass
and should fail; checks error messages.

=head1 DEPENDENCIES

Uses the bundled BiggerLib.pm type library.

Test is skipped if Moose 2.0000 is not available.

=head1 AUTHOR

Toby Inkster E<lt>tobyink@cpan.orgE<gt>.

=head1 COPYRIGHT AND LICENCE

This software is copyright (c) 2013-2014 by Toby Inkster.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut

use strict;
use warnings;
use lib qw( ./lib ./t/lib ../inc ./inc );

use Test::More;
use Test::Requires { Moose => 2.0000 };
use Test::Fatal;

note "The basics";

{
	package Local::Class;
	
	use Moose;
	use BiggerLib -all;
	
	has small => (is => "ro", isa => SmallInteger);
	has big   => (is => "ro", isa => BigInteger);
}

is(
	exception { "Local::Class"->new(small => 9, big => 12) },
	undef,
	"some values that should pass their type constraint",
);

use Test::TypeTiny qw( matchfor );

is(
	exception { "Local::Class"->new(small => 100) },
	matchfor(
		'Moose::Exception::ValidationFailedForTypeConstraint',
		qr{^Attribute \(small\) does not pass the type constraint}
	),
	"direct violation of type constraint",
);

is(
	exception { "Local::Class"->new(small => 5.5) },
	matchfor(
		'Moose::Exception::ValidationFailedForTypeConstraint',
		qr{^Attribute \(small\) does not pass the type constraint}
	),
	"violation of parent type constraint",
);

is(
	exception { "Local::Class"->new(small => "five point five") },
	matchfor(
		'Moose::Exception::ValidationFailedForTypeConstraint',
		qr{^Attribute \(small\) does not pass the type constraint}
	),
	"violation of grandparent type constraint",
);

is(
	exception { "Local::Class"->new(small => []) },
	matchfor(
		'Moose::Exception::ValidationFailedForTypeConstraint',
		qr{^Attribute \(small\) does not pass the type constraint}
	),
	"violation of great-grandparent type constraint",
);

note "Coercion...";

{
	package TmpNS1;
	use Moose::Util::TypeConstraints;
	subtype 'MyInt', as 'Int';
	coerce 'MyInt', from 'ArrayRef', via { scalar(@$_) };
	
	my $type = Types::TypeTiny::to_TypeTiny(find_type_constraint('MyInt'));
	
	::ok($type->has_coercion, 'types converted from Moose retain coercions');
	::is($type->coerce([qw/a b c/]), 3, '... which work');
}

note "Introspection, comparisons, conversions...";

require Types::Standard;
ok(
	Types::Standard::Num->moose_type->equals(
		Moose::Util::TypeConstraints::find_type_constraint("Num")
	),
	"equivalence between Types::Standard types and core Moose types",
);

require Type::Utils;
my $classtype = Type::Utils::class_type(LocalClass => { class => "Local::Class" })->moose_type;
isa_ok(
	$classtype,
	"Moose::Meta::TypeConstraint::Class",
	'$classtype',
);
is(
	$classtype->class,
	"Local::Class",
	"Type::Tiny::Class provides meta information to Moose::Meta::TypeConstraint::Class",
);
isa_ok(
	$classtype->Types::TypeTiny::to_TypeTiny,
	'Type::Tiny::Class',
	'$classtype->Types::TypeTiny::to_TypeTiny',
);

my $roletype = Type::Utils::role_type(LocalRole => { class => "Local::Role" })->moose_type;
isa_ok(
	$roletype,
	"Moose::Meta::TypeConstraint",
	'$roletype',
);
ok(
	!$roletype->isa("Moose::Meta::TypeConstraint::Role"),
	"NB! Type::Tiny::Role does not inflate to Moose::Meta::TypeConstraint::Role because of differing notions as to what constitutes a role.",
);
isa_ok(
	$roletype->Types::TypeTiny::to_TypeTiny,
	'Type::Tiny::Role',
	'$roletype->Types::TypeTiny::to_TypeTiny',
);

my $ducktype = Type::Utils::duck_type(Darkwing => [qw/ foo bar baz /])->moose_type;
isa_ok(
	$ducktype,
	"Moose::Meta::TypeConstraint::DuckType",
	'$ducktype',
);
is_deeply(
	[sort @{$ducktype->methods}],
	[sort qw/ foo bar baz /],
	"Type::Tiny::Duck provides meta information to Moose::Meta::TypeConstraint::DuckType",
);
isa_ok(
	$ducktype->Types::TypeTiny::to_TypeTiny,
	'Type::Tiny::Duck',
	'$ducktype->Types::TypeTiny::to_TypeTiny',
);

my $enumtype = Type::Utils::enum(MyEnum => [qw/ foo bar baz /])->moose_type;
isa_ok(
	$enumtype,
	"Moose::Meta::TypeConstraint::Enum",
	'$classtype',
);
is_deeply(
	[sort @{$enumtype->values}],
	[sort qw/ foo bar baz /],
	"Type::Tiny::Enum provides meta information to Moose::Meta::TypeConstraint::Enum",
);
isa_ok(
	$enumtype->Types::TypeTiny::to_TypeTiny,
	'Type::Tiny::Enum',
	'$enumtype->Types::TypeTiny::to_TypeTiny',
);

my $union = Type::Utils::union(ICU => [$classtype->Types::TypeTiny::to_TypeTiny, $roletype->Types::TypeTiny::to_TypeTiny])->moose_type;
isa_ok(
	$union,
	"Moose::Meta::TypeConstraint::Union",
	'$union',
);
is_deeply(
	[sort @{$union->type_constraints}],
	[sort $classtype, $roletype],
	"Type::Tiny::Union provides meta information to Moose::Meta::TypeConstraint::Union",
);
isa_ok(
	$union->Types::TypeTiny::to_TypeTiny,
	'Type::Tiny::Union',
	'$union->Types::TypeTiny::to_TypeTiny',
);
is(
	[sort @{$union->type_constraints}]->[0]->Types::TypeTiny::to_TypeTiny->{uniq},
	$classtype->Types::TypeTiny::to_TypeTiny->{uniq},
	'$union->type_constraints->[$i]->Types::TypeTiny::to_TypeTiny provides access to underlying Type::Tiny objects'
);

my $intersect = Type::Utils::intersection(Chuck => [$classtype->Types::TypeTiny::to_TypeTiny, $roletype->Types::TypeTiny::to_TypeTiny])->moose_type;
isa_ok(
	$intersect,
	"Moose::Meta::TypeConstraint",
	'$intersect',
);
isa_ok(
	$intersect->Types::TypeTiny::to_TypeTiny,
	'Type::Tiny::Intersection',
	'$intersect->Types::TypeTiny::to_TypeTiny',
);
is(
	Scalar::Util::refaddr( $intersect->Types::TypeTiny::to_TypeTiny ),
	Scalar::Util::refaddr( $intersect->Types::TypeTiny::to_TypeTiny->moose_type->Types::TypeTiny::to_TypeTiny->moose_type->Types::TypeTiny::to_TypeTiny ),
	'round-tripping between ->moose_type and ->Types::TypeTiny::to_TypeTiny preserves reference address'
);

note "Native attribute traits";

{
	package MyCollection;
	use Moose;
	use Types::Standard qw( ArrayRef Object );
	has things => (
		is      => 'ro',
		isa     => ArrayRef[ Object ],
		traits  => [ 'Array' ],
		handles => { add => 'push' },
	);
}

my $coll = MyCollection->new(things => []);

ok(
	!exception { $coll->add(bless {}, "Monkey") },
	'pushing ok value',
);

is(
	exception { $coll->add({})},
	matchfor(
		'Moose::Exception::ValidationFailedForInlineTypeConstraint',
		qr{^A new member value for things does not pass its type constraint because:},
	),
	'pushing not ok value',
);

use Types::Standard -types;
my %attributes = (
	hashref      => HashRef,
	hashref_int  => HashRef[Int],
	map          => Map,
	map_strint   => Map[Str, Int],
);

{
	package MyHashes;
	use Moose;
	while (my ($attr, $type) = each %attributes)
	{
		has $attr => (
			traits  => ['Hash'],
			is      => 'ro',
			isa     => $type,
			handles => {
				"$attr\_get" => 'get',
				"$attr\_set" => 'set',
				"$attr\_has" => 'exists',
			},
			default => sub { +{} },
		);
	}
}

for my $attr (sort keys %attributes)
{
	my $type      = $attributes{$attr};
	my $getter    = "$attr\_get";
	my $setter    = "$attr\_set";
	my $predicate = "$attr\_has";
	
	subtest "Hash trait with type $type" => sub
	{
		my $obj = MyHashes->new;
		is_deeply($obj->$attr, {}, 'default empty hash');
		
		$obj->$setter(foo => 666);
		$obj->$setter(bar => 999);
		is($obj->$getter('foo'), 666, 'getter');
		is($obj->$getter('bar'), 999, 'getter');
		$obj->$setter(bar => 42);
		is($obj->$getter('bar'), 42, 'setter');
		ok($obj->$predicate('foo'), 'predicate');
		ok($obj->$predicate('bar'), 'predicate');
		ok(!$obj->$predicate('baz'), 'predicate - negatory');
		is_deeply($obj->$attr, { foo => 666, bar => 42 }, 'correct hash');
		
		like(
			exception { $obj->$setter(baz => 3.141592) },
			qr/type constraint/,
			'cannot add non-Int value',
		) if $attr =~ /int$/;
		
		done_testing;
	};
}

done_testing;