From: Stevan Little Date: Sun, 16 Sep 2007 22:16:11 +0000 (+0000) Subject: TypeConstraint::Utils,.. now with find_or_create_type_constraint goodness X-Git-Tag: 0_26~12 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d9b400059075f0cdffc909861da391aff5f7db66;p=gitmo%2FMoose.git TypeConstraint::Utils,.. now with find_or_create_type_constraint goodness --- diff --git a/PLANS b/PLANS index 23ad296..c986a04 100644 --- a/PLANS +++ b/PLANS @@ -9,30 +9,6 @@ This will make it much easier to generate TCs on their own, without having to use the sugar layer. This should also clean up their APIs as well, which will make it easier to subclass them. -- create an official TC registry API - -Right now the registration of the TC is a by-product of creation in the sugar -layer, this is bad and make extension of TCs difficult. I am not sure if this -registry API should exist as part of Moose::Util::TypeConstraints, or of we -should create a complete registry object itself. - -This registry should be a singleton, but M::U::TC should enforce that lifecycle -choice so that you can use your own registry if you really want too. - -I mean parent of the registry. So that I can create my own registry -object for a given class, and any retrieval of a type constraint from -this object would automatically search parent registries as well. - -- refactor the various TC internals to make it more subclassing friendly - -This also includes the coercion stuff as well. This should give you what you -need to make your object/class bound stuff. - -- move the container TCs from MooseX::AttributeHelpers into Moose core - -These have proven so useful for me in the latest $work project that I think -they should really be core. - - allow a switch of some kind to optionally turn TC checking off at runtime The type checks can get expensive and some people have suggested that allowing @@ -87,6 +63,47 @@ subtype Foo => as Bar => where { ... } => in __PACKAGE__ ; my $Foo = subtype Bar => where { ... }; +# ---------- + +[17:10] stevan: it should do it if I pass coerce => 1 as part of the attribute definition +[17:12] autarch: what I am not 100% sure of is how to tell it to deep coerce and when to not +[17:13] cause a basic coerce is from A to B +[17:13] hmm +[17:13] which is valid for collection types too +[17:13] deep coercion is what you are asking for +[17:13] yeah +[17:13] so perhaps we add deep_coerce => 1 +[17:13] which will do it +[17:13] that's fine for me +[17:13] k + +----------------------------------------------------------- +- TC stuff DONE +----------------------------------------------------------- + +- create an official TC registry API (DONE) + +Right now the registration of the TC is a by-product of creation in the sugar +layer, this is bad and make extension of TCs difficult. I am not sure if this +registry API should exist as part of Moose::Util::TypeConstraints, or of we +should create a complete registry object itself. + +This registry should be a singleton, but M::U::TC should enforce that lifecycle +choice so that you can use your own registry if you really want too. + +I mean parent of the registry. So that I can create my own registry +object for a given class, and any retrieval of a type constraint from +this object would automatically search parent registries as well. + +- refactor the various TC internals to make it more subclassing friendly (DONE) + +This also includes the coercion stuff as well. This should give you what you +need to make your object/class bound stuff. + +- move the container TCs from MooseX::AttributeHelpers into Moose core (DONE) + +These have proven so useful for me in the latest $work project that I think +they should really be core. ----------------------------------------------------------- -- Roles refactor diff --git a/TODO b/TODO index 38386c1..7e66a51 100644 --- a/TODO +++ b/TODO @@ -1,8 +1,6 @@ ------------------------------------------------------------------------------- BUGS ------------------------------------------------------------------------------- - -mst: if I do "subtype 'Foo' => as 'Bar';" I get an empty condition and it dies ------------------------------------------------------------------------------- TODO @@ -50,26 +48,6 @@ over there.. in that other object (... probably be a custom metaclass) -- compile time extends - -[00:39] sri but maybe a better syntax for compile time extends -[00:39] stevan I have been pondering that actually -[00:39] sri use Moose extends => Foo::Bar -[00:40] stevan I think now that we have the Sub::Exporter stuff - in, that kinda thing should be pretty easy - -nothingmuch notes that all the constructs should be supported in the entirety of the use clause: - - use Moose ( - has => foo ( - .... - ), - ); - -and that if this usage style is used nothing is exported to the namespace. - -- default should dclone() - - subtype $anon_subtype => where { ... } [22:56] stevan sub mst_doesnt_like_to_type { (shift)->meta->attr->type_contstraint } @@ -100,20 +78,6 @@ and that if this usage style is used nothing is exported to the namespace. [23:01] mst right [23:01] stevan ok -- method keyword - -[23:37] mst more seriously, I'd still like a "method" keyword or something -[23:37] mst method 'foo' => sub { ... }; -[23:38] stevan what would it do more than sub foo { ... }? -[23:39] stevan I would like multimethods actually -[23:39] mst almost exactly nothing, to begin with -[23:39] stevan but thats just cause I love CLOS and am reading a book on Dylan now -[23:40] stevan keyword squating :) -[23:40] mst but if we need to hook stuff later it's bloody handy to already have people writing it that way -[23:40] mst right -... -[23:49] mst oh, also: method 'has' => sub { ... } could squelch the redefine warning - - local coerce [13:16] mst stevan: slight problem with coerce diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index f51788d..57f2aff 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -135,27 +135,13 @@ sub _process_options { $options->{type_constraint} = $options->{isa}; } else { - - if ($options->{isa} =~ /\|/) { - my @type_constraints = split /\s*\|\s*/ => $options->{isa}; - $options->{type_constraint} = Moose::Util::TypeConstraints::create_type_constraint_union( - @type_constraints - ); - } - else { - # otherwise assume it is a constraint - my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{isa}); - # if the constraing it not found .... - unless (defined $constraint) { - # assume it is a foreign class, and make - # an anon constraint for it - $constraint = Moose::Util::TypeConstraints::subtype( - 'Object', - Moose::Util::TypeConstraints::where { $_->isa($options->{isa}) } - ); - } - $options->{type_constraint} = $constraint; - } + $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint( + $options->{isa}, + { + parent => Moose::Util::TypeConstraints::find_type_constraint('Object'), + constraint => sub { $_[0]->isa($options->{isa}) } + } + ); } } elsif (exists $options->{does}) { @@ -164,18 +150,13 @@ sub _process_options { $options->{type_constraint} = $options->{isa}; } else { - # otherwise assume it is a constraint - my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{does}); - # if the constraing it not found .... - unless (defined $constraint) { - # assume it is a foreign class, and make - # an anon constraint for it - $constraint = Moose::Util::TypeConstraints::subtype( - 'Role', - Moose::Util::TypeConstraints::where { $_->does($options->{does}) } - ); - } - $options->{type_constraint} = $constraint; + $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint( + $options->{does}, + { + parent => Moose::Util::TypeConstraints::find_type_constraint('Role'), + constraint => sub { $_[0]->does($options->{does}) } + } + ); } } diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index 9420e55..da0da30 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -12,25 +12,36 @@ use Sub::Exporter; our $VERSION = '0.14'; our $AUTHORITY = 'cpan:STEVAN'; -# Prototyped subs must be predeclared because we have a circular dependency -# with Moose::Meta::Attribute et. al. so in case of us being use'd first the -# predeclaration ensures the prototypes are in scope when consumers are -# compiled - -sub find_type_constraint ($); -sub _create_type_constraint ($$$;$$); -sub _install_type_coercions ($$); -sub create_type_constraint_union (@); -sub type ($$;$$); -sub subtype ($$;$$$); -sub coerce ($@); -sub as ($); -sub from ($); -sub where (&); -sub via (&); -sub message (&); -sub optimize_as (&); -sub enum ($;@); +## -------------------------------------------------------- +# Prototyped subs must be predeclared because we have a +# circular dependency with Moose::Meta::Attribute et. al. +# so in case of us being use'd first the predeclaration +# ensures the prototypes are in scope when consumers are +# compiled. + +# creation and location +sub find_type_constraint ($); +sub find_or_create_type_constraint ($;$); +sub create_type_constraint_union (@); +sub create_container_type_constraint ($); + +# dah sugah! +sub type ($$;$$); +sub subtype ($$;$$$); +sub coerce ($@); +sub as ($); +sub from ($); +sub where (&); +sub via (&); +sub message (&); +sub optimize_as (&); +sub enum ($;@); + +## private stuff ... +sub _create_type_constraint ($$$;$$); +sub _install_type_coercions ($$); + +## -------------------------------------------------------- use Moose::Meta::TypeConstraint; use Moose::Meta::TypeConstraint::Union; @@ -71,70 +82,40 @@ sub unimport { } } +## -------------------------------------------------------- +## type registry and some useful functions for it +## -------------------------------------------------------- + my $REGISTRY = Moose::Meta::TypeConstraint::Registry->new; -sub _get_type_constraint_registry { $REGISTRY } -sub _dump_type_constraints { $REGISTRY->dump } +sub get_type_constraint_registry { $REGISTRY } +sub list_all_type_constraints { keys %{$REGISTRY->type_constraints} } +sub export_type_constraints_as_functions { + my $pkg = caller(); + no strict 'refs'; + foreach my $constraint (keys %{$REGISTRY->type_constraints}) { + *{"${pkg}::${constraint}"} = $REGISTRY->get_type_constraint($constraint) + ->_compiled_type_constraint; + } +} -# NOTE: -# this method breaks down the sugar -# from the functions below. -sub _create_type_constraint ($$$;$$) { - my $name = shift; - my $parent = shift; - my $check = shift || sub { 1 }; +sub create_type_constraint_union (@) { + my @type_constraint_names; - my ($message, $optimized); - for (@_) { - $message = $_->{message} if exists $_->{message}; - $optimized = $_->{optimized} if exists $_->{optimized}; + if (scalar @_ == 1 && $_[0] =~ /\|/) { + @type_constraint_names = (split /\s*\|\s*/ => $_[0]); + } + else { + @type_constraint_names = @_; } - - my $pkg_defined_in = scalar(caller(0)); - - if (defined $name) { - my $type = $REGISTRY->get_type_constraint($name); - - ($type->_package_defined_in eq $pkg_defined_in) - || confess ("The type constraint '$name' has already been created in " - . $type->_package_defined_in . " and cannot be created again in " - . $pkg_defined_in) - if defined $type; - } - - $parent = $REGISTRY->get_type_constraint($parent) if defined $parent; - my $constraint = Moose::Meta::TypeConstraint->new( - name => $name || '__ANON__', - parent => $parent, - constraint => $check, - message => $message, - optimized => $optimized, - package_defined_in => $pkg_defined_in, - ); - - $REGISTRY->add_type_constraint($constraint) - if defined $name; - - return $constraint; -} - -sub _install_type_coercions ($$) { - my ($type_name, $coercion_map) = @_; - my $type = $REGISTRY->get_type_constraint($type_name); - (!$type->has_coercion) - || confess "The type coercion for '$type_name' has already been registered"; - my $type_coercion = Moose::Meta::TypeCoercion->new( - type_coercion_map => $coercion_map, - type_constraint => $type - ); - $type->coercion($type_coercion); -} - -sub create_type_constraint_union (@) { - my (@type_constraint_names) = @_; (scalar @type_constraint_names >= 2) - || confess "You must pass in at least 2 type names to make a union"; + || confess "You must pass in at least 2 type names to make a union"; + + ($REGISTRY->has_type_constraint($_)) + || confess "Could not locate type constraint ($_) for the union" + foreach @type_constraint_names; + return Moose::Meta::TypeConstraint::Union->new( type_constraints => [ map { @@ -144,18 +125,58 @@ sub create_type_constraint_union (@) { ); } -sub export_type_constraints_as_functions { - my $pkg = caller(); - no strict 'refs'; - foreach my $constraint (keys %{$REGISTRY->type_constraints}) { - *{"${pkg}::${constraint}"} = $REGISTRY->get_type_constraint($constraint) - ->_compiled_type_constraint; - } +sub create_container_type_constraint ($) { + my $type_constraint_name = shift; + + my ($base_type, $container_type) = ($type_constraint_name =~ /^(.*)\[(.*)\]$/); + + (defined $base_type && defined $container_type) + || confess "Could not parse type name ($type_constraint_name) correctly"; + + ($REGISTRY->has_type_constraint($base_type)) + || confess "Could not locate the base type ($base_type)"; + + ($REGISTRY->has_type_constraint($container_type)) + || confess "Could not locate the container type ($container_type)"; + + return Moose::Meta::TypeConstraint::Container->new( + name => $type_constraint_name, + parent => $REGISTRY->get_type_constraint($base_type), + container_type => $REGISTRY->get_type_constraint($container_type), + ); } -*Moose::Util::TypeConstraints::export_type_contstraints_as_functions = \&export_type_constraints_as_functions; - -sub list_all_type_constraints { keys %{$REGISTRY->type_constraints} } +sub find_or_create_type_constraint ($;$) { + my ($type_constraint_name, $options_for_anon_type) = @_; + + return $REGISTRY->get_type_constraint($type_constraint_name) + if $REGISTRY->has_type_constraint($type_constraint_name); + + my $constraint; + + if ($type_constraint_name =~ /\|/) { + $constraint = create_type_constraint_union($type_constraint_name); + } + elsif ($type_constraint_name =~ /^.*?\[.*?\]$/) { + $constraint = create_container_type_constraint($type_constraint_name); + } + else { + # NOTE: + # otherwise assume that we should create + # an ANON type with the $options_for_anon_type + # options which can be passed in. It should + # be noted that these don't get registered + # so we need to return it. + # - SL + return Moose::Meta::TypeConstraint->new( + name => '__ANON__', + %{$options_for_anon_type} + ); + } + + $REGISTRY->add_type_constraint($constraint); + return $constraint; +} ## -------------------------------------------------------- ## exported functions ... @@ -209,7 +230,65 @@ sub enum ($;@) { ); } -# define some basic types +## -------------------------------------------------------- +## desugaring functions ... +## -------------------------------------------------------- + +sub _create_type_constraint ($$$;$$) { + my $name = shift; + my $parent = shift; + my $check = shift || sub { 1 }; + + my ($message, $optimized); + for (@_) { + $message = $_->{message} if exists $_->{message}; + $optimized = $_->{optimized} if exists $_->{optimized}; + } + + my $pkg_defined_in = scalar(caller(0)); + + if (defined $name) { + my $type = $REGISTRY->get_type_constraint($name); + + ($type->_package_defined_in eq $pkg_defined_in) + || confess ("The type constraint '$name' has already been created in " + . $type->_package_defined_in . " and cannot be created again in " + . $pkg_defined_in) + if defined $type; + } + + $parent = $REGISTRY->get_type_constraint($parent) if defined $parent; + + my $constraint = Moose::Meta::TypeConstraint->new( + name => $name || '__ANON__', + parent => $parent, + constraint => $check, + message => $message, + optimized => $optimized, + package_defined_in => $pkg_defined_in, + ); + + $REGISTRY->add_type_constraint($constraint) + if defined $name; + + return $constraint; +} + +sub _install_type_coercions ($$) { + my ($type_name, $coercion_map) = @_; + my $type = $REGISTRY->get_type_constraint($type_name); + (!$type->has_coercion) + || confess "The type coercion for '$type_name' has already been registered"; + my $type_coercion = Moose::Meta::TypeCoercion->new( + type_coercion_map => $coercion_map, + type_constraint => $type + ); + $type->coercion($type_coercion); +} + +## -------------------------------------------------------- +# define some basic built-in types +## -------------------------------------------------------- type 'Any' => where { 1 }; # meta-type including all type 'Item' => where { 1 }; # base-type @@ -278,6 +357,10 @@ subtype 'ClassName' => where { eval { $_->isa('UNIVERSAL') } } => optimize_as { !ref($_[0]) && eval { $_[0]->isa('UNIVERSAL') } }; +## -------------------------------------------------------- +# end of built-in types ... +## -------------------------------------------------------- + { my @BUILTINS = list_all_type_constraints(); sub list_all_builtin_type_constraints { @BUILTINS } @@ -425,30 +508,42 @@ test file. =head1 FUNCTIONS -=head2 Type Constraint Registry +=head2 Type Constraint Construction & Locating =over 4 -=item B +=item B -This function can be used to locate a specific type constraint -meta-object, of the class L or a -derivative. What you do with it from there is up to you :) +Given string with C<$pipe_seperated_types> or a list of C<@type_constraint_names>, +this will return a L instance. -=item B +=item B -Given a list of C<@type_constraint_names>, this will return a -B instance. +Given a C<$type_name> in the form of: -=item B + BaseType[ContainerType] -This will export all the current type constraints as functions -into the caller's namespace. Right now, this is mostly used for -testing, but it might prove useful to others. +this will extract the base type and container type and build an instance of +L for it. + +=item B -=item B +This will attempt to find or create a type constraint given the a C<$type_name>. +If it cannot find it in the registry, it will see if it should be a union or +container type an create one if appropriate, and lastly if nothing can be +found or created that way, it will create an anon-type using the +C<$options_for_anon_type> HASH ref to populate it. -Alias for the above function. +=item B + +This function can be used to locate a specific type constraint +meta-object, of the class L or a +derivative. What you do with it from there is up to you :) + +=item B + +Fetch the L object which +keeps track of all type constraints. =item B @@ -462,6 +557,12 @@ This will return a list of builtin type constraints, meaning, those which are defined in this module. See the section labeled L for a complete list. +=item B + +This will export all the current type constraints as functions +into the caller's namespace. Right now, this is mostly used for +testing, but it might prove useful to others. + =back =head2 Type Constraint Constructors diff --git a/t/040_type_constraints/001_util_type_constraints.t b/t/040_type_constraints/001_util_type_constraints.t index 2252957..353a344 100644 --- a/t/040_type_constraints/001_util_type_constraints.t +++ b/t/040_type_constraints/001_util_type_constraints.t @@ -26,7 +26,7 @@ subtype NaturalLessThanTen => where { $_ < 10 } => message { "The number '$_' is not less than 10" }; -Moose::Util::TypeConstraints->export_type_contstraints_as_functions(); +Moose::Util::TypeConstraints->export_type_constraints_as_functions(); ok(Number(5), '... this is a Num'); ok(!defined(Number('Foo')), '... this is not a Num'); diff --git a/t/040_type_constraints/002_util_type_constraints_export.t b/t/040_type_constraints/002_util_type_constraints_export.t index 70c4a09..cbab89c 100644 --- a/t/040_type_constraints/002_util_type_constraints_export.t +++ b/t/040_type_constraints/002_util_type_constraints_export.t @@ -25,7 +25,7 @@ BEGIN { }; ::ok(!$@, '... successfully exported &subtype to Foo package'); - Moose::Util::TypeConstraints->export_type_contstraints_as_functions(); + Moose::Util::TypeConstraints->export_type_constraints_as_functions(); ::ok(MyRef({}), '... Ref worked correctly'); ::ok(MyArrayRef([]), '... ArrayRef worked correctly'); diff --git a/t/040_type_constraints/003_util_std_type_constraints.t b/t/040_type_constraints/003_util_std_type_constraints.t index d4cdb5e..780405d 100644 --- a/t/040_type_constraints/003_util_std_type_constraints.t +++ b/t/040_type_constraints/003_util_std_type_constraints.t @@ -20,7 +20,7 @@ my $GLOB_REF = \*GLOB_REF; my $fh; open($fh, '<', $0) || die "Could not open $0 for the test"; -Moose::Util::TypeConstraints->export_type_contstraints_as_functions(); +Moose::Util::TypeConstraints->export_type_constraints_as_functions(); ok(defined Any(0), '... Any accepts anything'); ok(defined Any(100), '... Any accepts anything'); diff --git a/t/040_type_constraints/005_util_type_coercion.t b/t/040_type_constraints/005_util_type_coercion.t index c483323..4fb8c55 100644 --- a/t/040_type_constraints/005_util_type_coercion.t +++ b/t/040_type_constraints/005_util_type_coercion.t @@ -43,7 +43,7 @@ coerce "Math::BigFloat" => via { Math::BigFloat->new( $_ ) }; -Moose::Util::TypeConstraints->export_type_contstraints_as_functions(); +Moose::Util::TypeConstraints->export_type_constraints_as_functions(); my $header = HTTPHeader->new(); isa_ok($header, 'HTTPHeader'); diff --git a/t/040_type_constraints/012_container_type_coercion.t b/t/040_type_constraints/012_container_type_coercion.t index a1324a7..8ca24b7 100644 --- a/t/040_type_constraints/012_container_type_coercion.t +++ b/t/040_type_constraints/012_container_type_coercion.t @@ -11,7 +11,7 @@ BEGIN { use_ok('Moose::Meta::TypeConstraint::Container'); } -my $r = Moose::Util::TypeConstraints->_get_type_constraint_registry; +my $r = Moose::Util::TypeConstraints->get_type_constraint_registry; # Array of Ints