
package Moose::Util::TypeConstraints;

use strict;
use warnings;

use Sub::Name    'subname';
use Scalar::Util 'blessed';

our $VERSION = '0.01';

sub import {
	shift;
	my $pkg = shift || caller();
	return if $pkg eq ':no_export';
	no strict 'refs';
	foreach my $export (qw(
		type subtype as where
		)) {
		*{"${pkg}::${export}"} = \&{"${export}"};
	}
	
	foreach my $constraint (qw(
		Any 
		Value Ref
		Str Int
		ScalarRef ArrayRef HashRef CodeRef RegexpRef
		Object
		)) {
		*{"${pkg}::${constraint}"} = \&{"${constraint}"};
	}	
	
}

my %TYPES;

# might need this later
#sub find_type_constraint { $TYPES{$_[0]} }

sub type ($$) {
	my ($name, $check) = @_;
	my $pkg = caller();
	my $full_name = "${pkg}::${name}";
	no strict 'refs';
	*{$full_name} = $TYPES{$name} = subname $full_name => sub { 
		return $TYPES{$name} unless defined $_[0];
		local $_ = $_[0];
		return undef unless $check->($_[0]);
		$_[0];
	};
}

sub subtype ($$;$) {
	my ($name, $parent, $check) = @_;
	if (defined $check) {
		my $pkg = caller();
		my $full_name = "${pkg}::${name}";		
		no strict 'refs';
		$parent = $TYPES{$parent} unless $parent && ref($parent) eq 'CODE';
		*{$full_name} = $TYPES{$name} = subname $full_name => sub { 
			return $TYPES{$name} unless defined $_[0];			
			local $_ = $_[0];
			return undef unless defined $parent->($_[0]) && $check->($_[0]);
			$_[0];
		};	
	}
	else {
		($parent, $check) = ($name, $parent);
		$parent = $TYPES{$parent} unless $parent && ref($parent) eq 'CODE';		
		return subname((caller() . '::__anon_subtype__') => sub { 
			return $TYPES{$name} unless defined $_[0];			
			local $_ = $_[0];
			return undef unless defined $parent->($_[0]) && $check->($_[0]);
			$_[0];
		});		
	}
}

sub as    ($) { $_[0] }
sub where (&) { $_[0] }

# define some basic types

type Any => where { 1 };

type Value => where { !ref($_) };
type Ref   => where {  ref($_) };

subtype Int => as Value => where {  Scalar::Util::looks_like_number($_) };
subtype Str => as Value => where { !Scalar::Util::looks_like_number($_) };

subtype ScalarRef => as Ref => where { ref($_) eq 'SCALAR' };	
subtype ArrayRef  => as Ref => where { ref($_) eq 'ARRAY'  };
subtype HashRef   => as Ref => where { ref($_) eq 'HASH'   };	
subtype CodeRef   => as Ref => where { ref($_) eq 'CODE'   };
subtype RegexpRef => as Ref => where { ref($_) eq 'Regexp' };	

# NOTE: 
# blessed(qr/.../) returns true,.. how odd
subtype Object => as Ref => where { blessed($_) && blessed($_) ne 'Regexp' };

1;

__END__

=pod

=head1 NAME

Moose::Util::TypeConstraints - 

=head1 SYNOPSIS

  use Moose::Util::TypeConstraints;

  type Num => where { Scalar::Util::looks_like_number($_) };
  
  subtype Natural 
      => as Num 
      => where { $_ > 0 };
  
  subtype NaturalLessThanTen 
      => as Natural
      => where { $_ < 10 };

=head1 DESCRIPTION

=head1 FUNCTIONS

=head2 Type Constraint Constructors

=over 4

=item B<type>

=item B<subtype>

=item B<as>

=item B<where>

=back

=head2 Built-in Type Constraints

=over 4

=item B<Any>

=item B<Value>

=item B<Int>

=item B<Str>

=item B<Ref>

=item B<ArrayRef>

=item B<CodeRef>

=item B<HashRef>

=item B<RegexpRef>

=item B<ScalarRef>

=item B<Object>

=back

=head1 BUGS

All complex software has bugs lurking in it, and this module is no 
exception. If you find a bug please either email me, or add the bug
to cpan-RT.

=head1 CODE COVERAGE

I use L<Devel::Cover> to test the code coverage of my tests, below is the 
L<Devel::Cover> report on this module's test suite.

=head1 ACKNOWLEDGEMENTS

=head1 AUTHOR

Stevan Little E<lt>stevan@iinteractive.comE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2006 by Infinity Interactive, Inc.

L<http://www.iinteractive.com>

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

=cut