package MooX::Types::MooseLike::Base;
use strict;
use warnings FATAL => 'all';
use Scalar::Util qw(blessed);
use List::Util;
use MooX::Types::MooseLike qw(exception_message);
use Exporter 5.57 'import';
our @EXPORT_OK = ();

our $VERSION = 0.18;

# These types act like those found in Moose::Util::TypeConstraints.
# Generally speaking, the same test is used.
sub some_basic_type_definitions {
  return
    (
    {
      name => 'Any',
      test => sub { 1 },
      message =>
        sub { "If you get here you've achieved the impossible, congrats." }
    },
    {
      name => 'Item',
      test => sub { 1 },
      message =>
        sub { "If you get here you've achieved the impossible, congrats" }
    },
    {
      name => 'Bool',

      #  	test    => sub { $_[0] == 0 || $_[0] == 1 },
      test => sub {
        !defined($_[0]) || $_[0] eq "" || "$_[0]" eq '1' || "$_[0]" eq '0';
        },
      message => sub { return exception_message($_[0], 'a Boolean') },
    },

    # Maybe has no test for itself, rather only the parameter type does
    {
      name    => 'Maybe',
      test    => sub { 1 },
      message => sub { 'Maybe only uses its parameterized type message' },
      parameterizable => sub { return if (not defined $_[0]); $_[0] },
    },
    {
      name    => 'Undef',
      test    => sub { !defined($_[0]) },
      message => sub { return exception_message($_[0], 'undef') },
    },
    );
}

sub defined_type_definitions {
  return
    ({
      name    => 'Defined',
      test    => sub { defined($_[0]) },
      message => sub { return exception_message($_[0], 'defined') },
    },
    {
      name    => 'Value',
      test    => sub { defined $_[0] and not ref($_[0]) },
      message => sub { return exception_message($_[0], 'a value') },
    },
    {
      name => 'Str',
      test => sub { defined $_[0] and (ref(\$_[0]) eq 'SCALAR') },
      message => sub { return exception_message($_[0], 'a string') },
    },
    {
      name    => 'Num',
      test    => sub { defined $_[0] and Scalar::Util::looks_like_number($_[0]) },
      message => sub {
        my $nbr = shift;
        if (not defined $nbr) {
          $nbr = 'undef';
        }
        elsif (not (length $nbr)) {
          $nbr = 'The empty string';
        }
        return exception_message($nbr, 'a number');
        },
    },
    {
      name    => 'Int',
      test    => sub { defined $_[0] and ("$_[0]" =~ /^-?[0-9]+$/x) },
      message => sub {
        my $nbr = shift;
        if (not defined $nbr) {
          $nbr = 'undef';
        }
        elsif (not (length $nbr)) {
          $nbr = 'The empty string';
        }
        return exception_message($nbr, 'an integer');
        },
    },
    );
}

sub ref_type_definitions {
  return
    (
    {
      name    => 'Ref',
      test    => sub { defined $_[0] and ref($_[0]) },
      message => sub { return exception_message($_[0], 'a reference') },
    },

    {
      name => 'ScalarRef',
      test => sub { defined $_[0] and ref($_[0]) eq 'SCALAR' },
      message => sub { return exception_message($_[0], 'a ScalarRef') },
      parameterizable => sub { ${ $_[0] } },
    },
    {
      name => 'ArrayRef',
      test => sub { defined $_[0] and ref($_[0]) eq 'ARRAY' },
      message => sub { return exception_message($_[0], 'an ArrayRef') },
      parameterizable => sub { @{ $_[0] } },
    },
    {
      name => 'HashRef',
      test => sub { defined $_[0] and ref($_[0]) eq 'HASH' },
      message => sub { return exception_message($_[0], 'a HashRef') },
      parameterizable => sub { values %{ $_[0] } },
    },
    {
      name => 'CodeRef',
      test => sub { defined $_[0] and ref($_[0]) eq 'CODE' },
      message => sub { return exception_message($_[0], 'a CodeRef') },
    },
    {
      name => 'RegexpRef',
      test => sub { defined $_[0] and ref($_[0]) eq 'Regexp' },
      message => sub { return exception_message($_[0], 'a RegexpRef') },
    },
    {
      name => 'GlobRef',
      test => sub { defined $_[0] and ref($_[0]) eq 'GLOB' },
      message => sub { return exception_message($_[0], 'a GlobRef') },
    },
    {
      name => 'AHRef',
      test => sub {
        defined $_[0] and
          (ref($_[0]) eq 'ARRAY')
          and ($_[0]->[0])
          and (List::Util::first { ref($_) eq 'HASH' } @{ $_[0] });
        },
      message => sub { return exception_message($_[0], 'an ArrayRef[HashRef]') },
    },
    );
}

sub filehandle_type_definitions {
  return
    (
    {
      name => 'FileHandle',
      test => sub {
        defined $_[0]
          and Scalar::Util::openhandle($_[0])
          or (blessed($_[0]) && $_[0]->isa("IO::Handle"));
        },
      message => sub { return exception_message($_[0], 'a FileHandle') },
    },
    );
}

sub blessed_type_definitions {## no critic qw(Subroutines::ProhibitExcessComplexity)
  return
    (
    {
      name => 'Object',
      test => sub { defined $_[0] and blessed($_[0]) and blessed($_[0]) ne 'Regexp' },
      message => sub { return exception_message($_[0], 'an Object') },
    },
    {
      name => 'InstanceOf',
      test => sub {
        my ($instance, @classes) = (shift, @_);
        return if not $instance;
        return if not blessed($instance);
        my @missing_classes = grep { !$instance->isa($_) } @classes;
        return (scalar @missing_classes ? 0 : 1);
        },
      message => sub {
        my $instance = shift;
        return "No instance given" if not $instance;
        return "$instance is not blessed" if not blessed($instance);
        my @missing_classes = grep { !$instance->isa($_) } @_;
        my $s = (scalar @missing_classes) > 1 ? 'es' : '';
        my $missing_classes = join ' ', @missing_classes;
        return "$instance is not an instance of the class${s}: $missing_classes";
        },
    },
    {
      name => 'ConsumerOf',
      test => sub {
        my ($instance, @roles) = (shift, @_);
        return if not $instance;
        return if not blessed($instance);
        return if (!$instance->can('does'));
        my @missing_roles = grep { !$instance->does($_) } @roles;
        return (scalar @missing_roles ? 0 : 1);
        },
      message => sub {
        my $instance = shift;
        return "No instance given" if not $instance;
        return "$instance is not blessed" if not blessed($instance);
        return "$instance is not a consumer of roles" if (!$instance->can('does'));
        my @missing_roles = grep { !$instance->does($_) } @_;
        my $s = (scalar @missing_roles) > 1 ? 's' : '';
        my $missing_roles = join ' ', @missing_roles;
        return "$instance does not consume the required role${s}: $missing_roles";
        },
    },
    {
      name => 'HasMethods',
      test => sub {
        my ($instance, @methods) = (shift, @_);
        return if not $instance;
        return if not blessed($instance);
        my @missing_methods = grep { !$instance->can($_) } @methods;
        return (scalar @missing_methods ? 0 : 1);
        },
      message => sub {
        my $instance = shift;
        return "No instance given" if not $instance;
        return "$instance is not blessed" if not blessed($instance);
        my @missing_methods = grep { !$instance->can($_) } @_;
        my $s = (scalar @missing_methods) > 1 ? 's' : '';
        my $missing_methods = join ' ', @missing_methods;
        return "$instance does not have the required method${s}: $missing_methods";
        },
    },
    );
}

sub logic_type_definitions {
  return
    (
    {
      name => 'AnyOf',
      test => sub {
        my ($value, @types) = @_;
        foreach my $type (@types) {
          return 1 if (eval {$type->($value); 1;});
        }
        return;
        },
      message => sub { return exception_message($_[0], 'any of the types') },
    },
    {
      name => 'AllOf',
      test => sub { return 1; },
      message => sub { 'AllOf only uses its parameterized type messages' },
      parameterizable => sub { $_[0] },
    },
    );
}
sub type_definitions {
  return
    [
    some_basic_type_definitions()
    ,defined_type_definitions()
    ,ref_type_definitions()
    ,filehandle_type_definitions()
    ,blessed_type_definitions()
    ,logic_type_definitions()
    ];
}

MooX::Types::MooseLike::register_types(type_definitions(), __PACKAGE__);

# Export an 'all' tag so one can easily import all types like so:
# use MooX::Types::MooseLike::Base qw(:all)
our %EXPORT_TAGS = ('all' => \@EXPORT_OK);

1;

__END__

=head1 NAME

MooX::Types::MooseLike::Base - Moose like types for Moo

=head1 SYNOPSIS

    package MyPackage;
    use Moo;
    use MooX::Types::MooseLike::Base qw(:all);

    has "beers_by_day_of_week" => (
        isa => HashRef
    );
    has "current_BAC" => (
        isa => Num
    );

    # Also supporting is_$type.  For example, is_Int() can be used as follows
    has 'legal_age' => (
        is => 'ro',
        isa => sub { die "$_[0] is not of legal age"
        	           unless (is_Int($_[0]) && $_[0] > 17) },
    );

=head1 DESCRIPTION

Moo attributes (like Moose) have an 'isa' property.
This module provides some basic types for this property.
One can import all types with ':all' tag or import
a list of types like:

    use MooX::Types::MooseLike::Base qw/HashRef CodeRef/;

so one could then declare some attributtes like:

	has 'contact' => (
	  is => 'ro',
	  isa => HashRef,
	);
	has 'guest_list' => (
	  is => 'ro',
	  isa => ArrayRef,
	);
	has 'records' => (
	  is => 'ro',
	  isa => ArrayRef[Int],
	);

These types provide a check that the contact attribute is a hash reference,
that the guest_list is an array reference, and that the records are an array
of hash references.

=head1 TYPES (subroutines)

=head2 Any

Any type (test is always true)

=head2 Item

Synonymous with Any type

=head2 Undef

A type that is not defined

=head2 Defined

A type that is defined

=head2 Bool

A boolean 1|0 type

=head2 Value

A non-reference type

=head2 Ref

A reference type

=head2 Str

A non-reference type where a reference to it is a SCALAR

=head2 Num

A number type

=head2 Int

An integer type

=head2 ArrayRef

An ArrayRef (ARRAY) type

=head2 HashRef

A HashRef (HASH) type

=head2 CodeRef

A CodeRef (CODE) type

=head2 RegexpRef

A regular expression reference type

=head2 GlobRef

A glob reference type

=head2 FileHandle

A type that is either a builtin perl filehandle or an IO::Handle object

=head2 Object

A type that is an object (think blessed)

=head1 PARAMETERIZED TYPES

=head2 Parameterizing Types With Other Types

The following types can be parameterized with other types.

=head3 ArrayRef

For example, ArrayRef[HashRef]

=head3 HashRef

=head3 ScalarRef 

=head3 Maybe

For example, Maybe[Int] would be an integer or undef
 
=head2 Parameterizing Types With Strings

In addition, we have some parameterized types that take string arguments.

=head3 InstanceOf

Check if the attribute is an object instance of one or more classes.  
Uses C<blessed> and C<isa> to do so.
Takes a list of class names as the argument. For example:

  isa => InstanceOf['MyClass','MyOtherClass']
  
Note: InstanceOf is passed an ArrayRef[Str]

=head3 ConsumerOf

Check if the attribute is blessed and consumes one or more roles.
Uses C<blessed> and C<does> to do so.
Takes a list of role names as the arguments. For example:

  isa => ConsumerOf['My::Role', 'My::AnotherRole'] 

=head3 HasMethods

Check if the attribute is blessed and has one or more methods.
Uses C<blessed> and C<can> to do so.
Takes a list of method names as the arguments. For example:

  isa => HasMethods[qw/postulate contemplate liberate/]

=head3 AnyOf

Check if the attribute is any of the listed types (think union)
Takes a list of types as the argument. For example:

  isa => AnyOf[Int, ArrayRef[Int], HashRef[Int]]

Note: AnyOf is passed an ArrayRef[CodeRef]

=head3 AllOf

Check if the attribute is all of the listed types (think intersection)
Takes a list of types as the argument. For example:

  isa => AllOf[
    InstanceOf['Human'], 
    ConsumerOf['Air'], 
    HasMethods['breath', 'dance']
  ],

=head1 AUTHOR

Mateu Hunter C<hunter@missoula.org>

=head1 THANKS

mst has provided critical guidance on the design

=head1 COPYRIGHT

Copyright 2011-2013 Mateu Hunter

=head1 LICENSE

You may distribute this code under the same terms as Perl itself.

=cut
