package Type::Tiny::Class;

use 5.006001;
use strict;
use warnings;

BEGIN {
	if ($] < 5.008) { require Devel::TypeTiny::Perl56Compat };
}

BEGIN {
	$Type::Tiny::Class::AUTHORITY = 'cpan:TOBYINK';
	$Type::Tiny::Class::VERSION   = '0.022';
}

use Scalar::Util qw< blessed >;

sub _croak ($;@) { require Type::Exception; goto \&Type::Exception::croak }

use base "Type::Tiny";

sub new {
	my $proto = shift;
	return $proto->class->new(@_) if blessed $proto; # DWIM
	
	my %opts = @_;
	_croak "Class type constraints cannot have a parent constraint passed to the constructor" if exists $opts{parent};
	_croak "Class type constraints cannot have a constraint coderef passed to the constructor" if exists $opts{constraint};
	_croak "Class type constraints cannot have a inlining coderef passed to the constructor" if exists $opts{inlined};
	_croak "Need to supply class name" unless exists $opts{class};
	
	return $proto->SUPER::new(%opts);
}

sub class       { $_[0]{class} }
sub inlined     { $_[0]{inlined} ||= $_[0]->_build_inlined }

sub has_inlined { !!1 }

sub _build_constraint
{
	my $self  = shift;
	my $class = $self->class;
	return sub { blessed($_) and $_->isa($class) };
}

sub _build_inlined
{
	my $self  = shift;
	my $class = $self->class;
	sub {
		my $var = $_[1];
		qq{Scalar::Util::blessed($var) and $var->isa(q[$class])};
	};
}

sub _build_default_message
{
	my $self = shift;
	my $c = $self->class;
	return sub { sprintf 'value "%s" did not pass type constraint (not isa %s)', $_[0], $c } if $self->is_anon;
	my $name = "$self";
	return sub { sprintf 'value "%s" did not pass type constraint "%s" (not isa %s)', $_[0], $name, $c };
}

sub _instantiate_moose_type
{
	my $self = shift;
	my %opts = @_;
	delete $opts{parent};
	delete $opts{constraint};
	delete $opts{inlined};
	require Moose::Meta::TypeConstraint::Class;
	return "Moose::Meta::TypeConstraint::Class"->new(%opts, class => $self->class);
}

sub plus_constructors
{
	my $self = shift;
	
	unless (@_)
	{
		require Types::Standard;
		push @_, Types::Standard::HashRef(), "new";
	}
	
	require B;
	require Types::TypeTiny;
	
	my $class = B::perlstring($self->class);
	
	my @r;
	while (@_)
	{
		my $source = shift;
		Types::TypeTiny::TypeTiny->check($source)
			or _croak "Expected type constraint; got $source";
		
		my $constructor = shift;
		Types::TypeTiny::StringLike->check($constructor)
			or _croak "Expected string; got $constructor";
		
		push @r, $source, sprintf('%s->%s($_)', $class, $constructor);
	}
	
	return $self->plus_coercions(\@r);
}

sub has_parent
{
	!!1;
}

sub parent
{
	$_[0]{parent} ||= $_[0]->_build_parent;
}

sub _build_parent
{
	my $self  = shift;
	my $class = $self->class;
	
	my @isa = grep $class->isa($_), do { no strict "refs"; no warnings; @{"$class\::ISA"} };
	
	if (@isa == 0)
	{
		require Types::Standard;
		return Types::Standard::Object();
	}
	
	if (@isa == 1)
	{
		return ref($self)->new(class => $isa[0])
	}
	
	require Type::Tiny::Intersection;
	"Type::Tiny::Intersection"->new(
		type_constraints => [ map ref($self)->new(class => $_), @isa ],
	);
}

1;

__END__

=pod

=encoding utf-8

=head1 NAME

Type::Tiny::Class - type constraints based on the "isa" method

=head1 DESCRIPTION

Type constraints of the general form C<< { $_->isa("Some::Class") } >>.

This package inherits from L<Type::Tiny>; see that for most documentation.
Major differences are listed below:

=head2 Constructor

=over

=item C<new>

When the constructor is called on an I<instance> of Type::Tiny::Class, it
passes the call through to the constructor of the class for the constraint.
So for example:

   my $type = Type::Tiny::Class->new(class => "Foo::Bar");
   my $obj  = $type->new(hello => "World");
   say ref($obj);   # prints "Foo::Bar"

This little bit of DWIM was borrowed from L<MooseX::Types::TypeDecorator>,
but Type::Tiny doesn't take the idea quite as far.

=back

=head2 Attributes

=over

=item C<class>

The class for the constraint.

=item C<constraint>

Unlike Type::Tiny, you should generally I<not> pass a constraint to the
constructor. Instead rely on the default.

=item C<inlined>

Unlike Type::Tiny, you should generally I<not> pass an inlining coderef to
the constructor. Instead rely on the default.

=item C<parent>

Parent is automatically calculated, and cannot be passed to the constructor.

=back

=head2 Methods

=over

=item C<< plus_constructors($source, $method_name) >>

Much like C<plus_coercions> but adds coercions that go via a constructor.
(In fact, this is implemented as a wrapper for C<plus_coercions>.)

Example:

   package MyApp::Minion;
   
   use Moose; extends "MyApp::Person";
   
   use Types::Standard qw( HashRef Str );
   use Type::Utils qw( class_type );
   
   my $Person = class_type({ class => "MyApp::Person" });
   
   has boss => (
      is     => "ro",
      isa    => $Person->plus_constructors(
         HashRef,     "new",
         Str,         "_new_from_name",
      ),
      coerce => 1,
   );
   
   package main;
   
   MyApp::Minion->new(
      ...,
      boss => "Bob",  ## via MyApp::Person->_new_from_name
   );
   
   MyApp::Minion->new(
      ...,
      boss => { name => "Bob" },  ## via MyApp::Person->new
   );

Because coercing C<HashRef> via constructor is a common desire, if
you call C<plus_constructors> with no arguments at all, this is the
default.

   $classtype->plus_constructors(Types::Standard::HashRef, "new")
   $classtype->plus_constructors()  ## identical to above

This is handy for Moose/Mouse/Moo-based classes.

=back

=head1 BUGS

Please report any bugs to
L<http://rt.cpan.org/Dist/Display.html?Queue=Type-Tiny>.

=head1 SEE ALSO

L<Type::Tiny::Manual>.

L<Type::Tiny>.

L<Moose::Meta::TypeConstraint::Class>.

=head1 AUTHOR

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

=head1 COPYRIGHT AND LICENCE

This software is copyright (c) 2013 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.

=head1 DISCLAIMER OF WARRANTIES

THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.

