[gitmo/MooseX-Types-Structured.git] / lib / MooseX / Types / Structured.pm

package MooseX::Types::Structured;

use Moose;
use Moose::Util::TypeConstraints;
use MooseX::Meta::TypeConstraint::Structured;
use MooseX::Types -declare => [qw(Dict Tuple)];

	
our $VERSION = '0.01';
our $AUTHORITY = 'cpan:JJNAPIORK';

=head1 NAME

MooseX::Types::Structured; Structured Type Constraints for Moose

=head1 SYNOPSIS

The following is example usage for this module.  You can define a class that has
an attribute with a structured type like so:

	package MyApp::MyClass;
	
	use Moose;
	use MooseX::Types::Moose qw(Str Int);
	use MooseX::Types::Structured qw(Dict Tuple);
	
	has name => (isa=>Dict[first_name=>Str, last_name=>Str]);
	
Then you can instantiate this class with something like:

	my $instance = MyApp::MyClass->new(
		name=>{first_name=>'John', last_name=>'Napiorkowski'},
	);

But all of these would cause an error:

	my $instance = MyApp::MyClass->new(name=>'John');
	my $instance = MyApp::MyClass->new(name=>{first_name=>'John'});
	my $instance = MyApp::MyClass->new(name=>{first_name=>'John', age=>39});

Please see the test cases for more examples.

=head1 DESCRIPTION

This type library enables structured type constraints. Basically, this is very
similar to parameterized constraints that are built into the core Moose types,
except that you are allowed to define the container's entire structure.  For
example, you could define a parameterized constraint like so:

	subtype HashOfInts, as Hashref[Int];

which would constraint a value to something like [1,2,3,...] and so one.  A
structured constraint like so:

	subtype StringFollowedByInt, as Tuple[Str,Int];
	
would constrain it's value to something like ['hello', 111];

These structures can be as simple or elaborate as you wish.  You can even
combine various structured, parameterized and simple constraints all together:

	subtype crazy, as Tuple[Int, Dict[name=>Str, age=>Int], ArrayRef[Int]];
	
Which would match "[1, {name=>'John', age=>25},[10,11,12]]".

You should exercise some care as to whether or not your complex structured
constraints would be better off contained by a real object as in the following
example:

	{
		package MyApp::MyStruct;
		use Moose;
		
			has $_ for qw(name age);
		
		package MyApp::MyClass;
		use Moose;
		
			has person => (isa=>'MyApp::MyStruct');		
	}

	my $instance = MyApp::MyClass
		->new( person=>MyApp::MyStruct->new(name=>'John', age=>39) );
	
This method may take some additional time to setup but will give you more
flexibility.  However, structured constraints are highly compatible with this
method, granting some interesting possibilities for coercion.  Try:

	subtype 'MyStruct',
	 as 'MyApp::MyStruct';
	 
	coerce 'MyStruct',
	 from (Dict[name=>Str, age=>Int]),
	 via {
		MyApp::MyStruct->new(%$_);
	 },
	 from (Dict[last_name=>Str, first_name=>Str, dob=>DateTime]),
	 via {
		my $name = $_->{first_name} .' '. $_->{last_name};
		my $age = DateTime->now - $_->{dob};
		MyApp::MyStruct->new(
			name=>$name,
			age=>$age->years );
	 };
	 
=head2 Subtyping a structured subtype

You need to exercise some care when you try to subtype a structured type
as in this example:

	subtype Person,
	 as Dict[name=>Str, age=>iIt];
	 
	subtype FriendlyPerson,
	 as Person[name=>Str, age=>Int, totalFriends=>Int];
	 
This will actually work BUT you have to take care that the subtype has a
structure that does not contradict the structure of it's parent.  For now the
above works, but I will probably clarify how this works at a future point, so
it's recommended to avoid (should not realy be needed so much anyway).  For
now this is supported in an EXPERIMENTAL way.  In the future we will probably
clarify how to augment existing structured types.

=head2 Coercions

Coercions currently work for 'one level' deep.  That is you can do:

	subtype Person,
     as Dict[name=>Str, age=>Int];

    subtype Fullname,
     as Dict[first=>Str, last=>Str];
	 
	coerce Person,
	 from BlessedPersonObject,
	 via { +{name=>$_->name, age=>$_->age} },
	 from ArrayRef,
	 via { +{name=>$_->[0], age=>$_->[1] },
     from Dict[fullname=>Fullname, dob=>DateTime],
     via {
		my $age = $_->dob - DateTime->now;
		+{
			name=> $_->{fullname}->{first} .' '. $_->{fullname}->{last},
			age=>$age->years
		}
     };
	 
And that should just work as expected.  However, if there are any 'inner'
coercions, such as a coercion on 'Fullname' or on 'DateTime', that coercion
won't currently get activated.

Please see the test '07-coerce.t' for a more detailed example.

=head1 TYPE CONSTRAINTS

This type library defines the following constraints.

=head2 Tuple[@constraints]

This defines an arrayref based constraint which allows you to validate a specific
list of constraints.  For example:

	Tuple[Int,Str]; ## Validates [1,'hello']
	Tuple[Str|Object, Int]; ##Validates ['hello', 1] or [$object, 2]

=head2 Dict [%constraints]

This defines a hashref based constraint which allowed you to validate a specific
hashref.  For example:

	Dict[name=>Str, age=>Int]; ## Validates {name=>'John', age=>39}

=cut

Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint(
	MooseX::Meta::TypeConstraint::Structured->new(
		name => "MooseX::Types::Structured::Tuple" ,
		parent => find_type_constraint('ArrayRef'),
		constraint_generator=> sub {
			## Get the constraints and values to check
			my @type_constraints = @{shift @_};            
			my @values = @{shift @_};
			## Perform the checking
			while(@type_constraints) {
				my $type_constraint = shift @type_constraints;
				if(@values) {
					my $value = shift @values;
					unless($type_constraint->check($value)) {
						return;
					}				
				} else {
					return;
				}
			}
			## Make sure there are no leftovers.
			if(@values) {
				return;
			} elsif(@type_constraints) {
				return;
			}else {
				return 1;
			}
		}
	)
);
	
Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint(
	MooseX::Meta::TypeConstraint::Structured->new(
		name => "MooseX::Types::Structured::Dict",
		parent => find_type_constraint('HashRef'),
		constraint_generator=> sub {
			## Get the constraints and values to check
			my %type_constraints = @{shift @_};            
			my %values = %{shift @_};
			## Perform the checking
			while(%type_constraints) {
				my($key, $type_constraint) = each %type_constraints;
				delete $type_constraints{$key};
				if(exists $values{$key}) {
					my $value = $values{$key};
					delete $values{$key};
					unless($type_constraint->check($value)) {
						return;
						#if ($type_constraint->has_coercion) {    
						#	my $temp = $type_constraint->coerce($value);
						#	use Data::Dump qw/dump/; warn dump $value, $temp; 
						#	unless($type_constraint->check($temp)) {
						#		return;
						#	}
						#} else {
						#	return;
						#}
					}
				} else {
					return;
				}
			}
			## Make sure there are no leftovers.
			if(%values) {
				return;
			} elsif(%type_constraints) {
				return;
			}else {
				return 1;
			}
		},
	)
);

=head1 SEE ALSO

The following modules or resources may be of interest.

L<Moose>, L<MooseX::TypeLibrary>, L<Moose::Meta::TypeConstraint>,
L<MooseX::Meta::TypeConstraint::Structured>

=head1 TODO

Need to clarify deep coercions, need to clarify subtypes of subtypes.

=head1 AUTHOR

John Napiorkowski, C<< <jjnapiork@cpan.org> >>

=head1 COPYRIGHT & LICENSE

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

=cut
	
1;
Commit	Line	Data
d24da8ec	1	package MooseX::Types::Structured;
d24da8ec	2
6c2f284c	3	use Moose;
6c2f284c	4	use Moose::Util::TypeConstraints;
a30fa891	5	use MooseX::Meta::TypeConstraint::Structured;
a30fa891	6	use MooseX::Types -declare => [qw(Dict Tuple)];
011bacc6	7
6c2f284c	8
d24da8ec	9	our $VERSION = '0.01';
	10	our $AUTHORITY = 'cpan:JJNAPIORK';
	11
	12	=head1 NAME
	13
	14	MooseX::Types::Structured; Structured Type Constraints for Moose
	15
	16	=head1 SYNOPSIS
	17
6c2f284c	18	The following is example usage for this module. You can define a class that has
	19	an attribute with a structured type like so:
	20
	21	package MyApp::MyClass;
	22
	23	use Moose;
	24	use MooseX::Types::Moose qw(Str Int);
	25	use MooseX::Types::Structured qw(Dict Tuple);
	26
	27	has name => (isa=>Dict[first_name=>Str, last_name=>Str]);
	28
	29	Then you can instantiate this class with something like:
	30
	31	my $instance = MyApp::MyClass->new(
	32	name=>{first_name=>'John', last_name=>'Napiorkowski'},
	33	);
d24da8ec	34
6c2f284c	35	But all of these would cause an error:
	36
	37	my $instance = MyApp::MyClass->new(name=>'John');
	38	my $instance = MyApp::MyClass->new(name=>{first_name=>'John'});
	39	my $instance = MyApp::MyClass->new(name=>{first_name=>'John', age=>39});
	40
	41	Please see the test cases for more examples.
d24da8ec	42
	43	=head1 DESCRIPTION
	44
6c2f284c	45	This type library enables structured type constraints. Basically, this is very
	46	similar to parameterized constraints that are built into the core Moose types,
	47	except that you are allowed to define the container's entire structure. For
	48	example, you could define a parameterized constraint like so:
	49
	50	subtype HashOfInts, as Hashref[Int];
	51
	52	which would constraint a value to something like [1,2,3,...] and so one. A
	53	structured constraint like so:
	54
	55	subtype StringFollowedByInt, as Tuple[Str,Int];
	56
	57	would constrain it's value to something like ['hello', 111];
	58
	59	These structures can be as simple or elaborate as you wish. You can even
	60	combine various structured, parameterized and simple constraints all together:
	61
	62	subtype crazy, as Tuple[Int, Dict[name=>Str, age=>Int], ArrayRef[Int]];
	63
	64	Which would match "[1, {name=>'John', age=>25},[10,11,12]]".
	65
	66	You should exercise some care as to whether or not your complex structured
	67	constraints would be better off contained by a real object as in the following
	68	example:
	69
	70	{
	71	package MyApp::MyStruct;
	72	use Moose;
	73
	74	has $_ for qw(name age);
	75
	76	package MyApp::MyClass;
	77	use Moose;
	78
	79	has person => (isa=>'MyApp::MyStruct');
	80	}
	81
	82	my $instance = MyApp::MyClass
	83	->new( person=>MyApp::MyStruct->new(name=>'John', age=>39) );
	84
	85	This method may take some additional time to setup but will give you more
	86	flexibility. However, structured constraints are highly compatible with this
	87	method, granting some interesting possibilities for coercion. Try:
	88
	89	subtype 'MyStruct',
	90	as 'MyApp::MyStruct';
	91
	92	coerce 'MyStruct',
	93	from (Dict[name=>Str, age=>Int]),
	94	via {
	95	MyApp::MyStruct->new(%$_);
	96	},
	97	from (Dict[last_name=>Str, first_name=>Str, dob=>DateTime]),
	98	via {
f9468aac	99	my $name = $_->{first_name} .' '. $_->{last_name};
f9468aac	100	my $age = DateTime->now - $_->{dob};
6c2f284c	101	MyApp::MyStruct->new(
	102	name=>$name,
	103	age=>$age->years );
	104	};
a4a88fef	105
16aea7bf	106	=head2 Subtyping a structured subtype
	107
	108	You need to exercise some care when you try to subtype a structured type
a4a88fef	109	as in this example:
d24da8ec	110
a4a88fef	111	subtype Person,
	112	as Dict[name=>Str, age=>iIt];
	113
	114	subtype FriendlyPerson,
	115	as Person[name=>Str, age=>Int, totalFriends=>Int];
	116
16aea7bf	117	This will actually work BUT you have to take care that the subtype has a
a4a88fef	118	structure that does not contradict the structure of it's parent. For now the
	119	above works, but I will probably clarify how this works at a future point, so
	120	it's recommended to avoid (should not realy be needed so much anyway). For
16aea7bf	121	now this is supported in an EXPERIMENTAL way. In the future we will probably
	122	clarify how to augment existing structured types.
	123
	124	=head2 Coercions
	125
	126	Coercions currently work for 'one level' deep. That is you can do:
	127
	128	subtype Person,
	129	as Dict[name=>Str, age=>Int];
	130
	131	subtype Fullname,
	132	as Dict[first=>Str, last=>Str];
	133
	134	coerce Person,
	135	from BlessedPersonObject,
	136	via { +{name=>$_->name, age=>$_->age} },
	137	from ArrayRef,
	138	via { +{name=>$_->[0], age=>$_->[1] },
	139	from Dict[fullname=>Fullname, dob=>DateTime],
	140	via {
	141	my $age = $_->dob - DateTime->now;
	142	+{
	143	name=> $_->{fullname}->{first} .' '. $_->{fullname}->{last},
	144	age=>$age->years
	145	}
	146	};
	147
	148	And that should just work as expected. However, if there are any 'inner'
	149	coercions, such as a coercion on 'Fullname' or on 'DateTime', that coercion
	150	won't currently get activated.
	151
	152	Please see the test '07-coerce.t' for a more detailed example.
	153
	154	=head1 TYPE CONSTRAINTS
	155
	156	This type library defines the following constraints.
	157
	158	=head2 Tuple[@constraints]
	159
	160	This defines an arrayref based constraint which allows you to validate a specific
	161	list of constraints. For example:
	162
	163	Tuple[Int,Str]; ## Validates [1,'hello']
	164	Tuple[Str\|Object, Int]; ##Validates ['hello', 1] or [$object, 2]
	165
	166	=head2 Dict [%constraints]
	167
	168	This defines a hashref based constraint which allowed you to validate a specific
	169	hashref. For example:
	170
	171	Dict[name=>Str, age=>Int]; ## Validates {name=>'John', age=>39}
d24da8ec	172
a30fa891	173	=cut
a30fa891	174
67a8bc04	175	Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint(
	176	MooseX::Meta::TypeConstraint::Structured->new(
	177	name => "MooseX::Types::Structured::Tuple" ,
	178	parent => find_type_constraint('ArrayRef'),
	179	constraint_generator=> sub {
	180	## Get the constraints and values to check
	181	my @type_constraints = @{shift @_};
	182	my @values = @{shift @_};
	183	## Perform the checking
	184	while(@type_constraints) {
	185	my $type_constraint = shift @type_constraints;
a30fa891	186	if(@values) {
67a8bc04	187	my $value = shift @values;
	188	unless($type_constraint->check($value)) {
	189	return;
	190	}
	191	} else {
a30fa891	192	return;
a30fa891	193	}
a30fa891	194	}
67a8bc04	195	## Make sure there are no leftovers.
	196	if(@values) {
	197	return;
	198	} elsif(@type_constraints) {
	199	return;
	200	}else {
	201	return 1;
	202	}
	203	}
	204	)
	205	);
	206
	207	Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint(
	208	MooseX::Meta::TypeConstraint::Structured->new(
	209	name => "MooseX::Types::Structured::Dict",
	210	parent => find_type_constraint('HashRef'),
	211	constraint_generator=> sub {
	212	## Get the constraints and values to check
	213	my %type_constraints = @{shift @_};
	214	my %values = %{shift @_};
	215	## Perform the checking
	216	while(%type_constraints) {
	217	my($key, $type_constraint) = each %type_constraints;
	218	delete $type_constraints{$key};
	219	if(exists $values{$key}) {
	220	my $value = $values{$key};
	221	delete $values{$key};
	222	unless($type_constraint->check($value)) {
a30fa891	223	return;
16aea7bf	224	#if ($type_constraint->has_coercion) {
	225	# my $temp = $type_constraint->coerce($value);
	226	# use Data::Dump qw/dump/; warn dump $value, $temp;
	227	# unless($type_constraint->check($temp)) {
	228	# return;
	229	# }
	230	#} else {
	231	# return;
	232	#}
a30fa891	233	}
67a8bc04	234	} else {
a30fa891	235	return;
a30fa891	236	}
67a8bc04	237	}
	238	## Make sure there are no leftovers.
	239	if(%values) {
	240	return;
	241	} elsif(%type_constraints) {
	242	return;
	243	}else {
	244	return 1;
	245	}
	246	},
	247	)
	248	);
d24da8ec	249
	250	=head1 SEE ALSO
	251
	252	The following modules or resources may be of interest.
	253
a30fa891	254	L<Moose>, L<MooseX::TypeLibrary>, L<Moose::Meta::TypeConstraint>,
a30fa891	255	L<MooseX::Meta::TypeConstraint::Structured>
d24da8ec	256
16aea7bf	257	=head1 TODO
	258
	259	Need to clarify deep coercions, need to clarify subtypes of subtypes.
	260
d24da8ec	261	=head1 AUTHOR
	262
	263	John Napiorkowski, C<< <jjnapiork@cpan.org> >>
	264
	265	=head1 COPYRIGHT & LICENSE
	266
	267	This program is free software; you can redistribute it and/or modify
	268	it under the same terms as Perl itself.
	269
	270	=cut
67a8bc04	271
67a8bc04	272	1;