use Scalar::Util qw( blessed reftype );
use Moose::Exporter;
-our $VERSION = '0.77';
+our $VERSION = '0.91';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Moose::Meta::TypeConstraint::Class;
use Moose::Meta::TypeConstraint::Role;
use Moose::Meta::TypeConstraint::Enum;
+use Moose::Meta::TypeConstraint::DuckType;
use Moose::Meta::TypeCoercion;
use Moose::Meta::TypeCoercion::Union;
use Moose::Meta::TypeConstraint::Registry;
coerce from via
enum
find_type_constraint
- register_type_constraint )
+ register_type_constraint
+ match_on_type )
],
_export_to_main => 1,
);
}
register_type_constraint(
- _create_type_constraint(
+ create_duck_type_constraint(
$type_name,
- 'Object',
- sub {
- my $obj = $_;
- return 0 unless all { $obj->can($_) } @methods;
- return 1;
- },
- sub {
- my $obj = $_;
- my @missing_methods = grep { !$obj->can($_) } @methods;
- return
- "${\blessed($obj)} is missing methods '@missing_methods'";
- },
+ \@methods,
)
);
}
);
}
+sub create_duck_type_constraint {
+ my ( $type_name, $methods ) = @_;
+
+ Moose::Meta::TypeConstraint::DuckType->new(
+ name => $type_name || '__ANON__',
+ methods => $methods,
+ );
+}
+
+sub match_on_type {
+ my ($to_match, @cases) = @_;
+ my $default;
+ if (@cases % 2 != 0) {
+ $default = pop @cases;
+ (ref $default eq 'CODE')
+ || __PACKAGE__->_throw_error("Default case must be a CODE ref, not $default");
+ }
+ while (@cases) {
+ my ($type, $action) = splice @cases, 0, 2;
+
+ unless (blessed $type && $type->isa('Moose::Meta::TypeConstraint')) {
+ $type = find_or_parse_type_constraint($type)
+ || __PACKAGE__->_throw_error("Cannot find or parse the type '$type'")
+ }
+
+ (ref $action eq 'CODE')
+ || __PACKAGE__->_throw_error("Match action must be a CODE ref, not $action");
+
+ if ($type->check($to_match)) {
+ local $_ = $to_match;
+ return $action->($to_match);
+ }
+ }
+ (defined $default)
+ || __PACKAGE__->_throw_error("No cases matched for $to_match");
+ {
+ local $_ = $to_match;
+ return $default->($to_match);
+ }
+}
+
+
## --------------------------------------------------------
## desugaring functions ...
## --------------------------------------------------------
my $type = find_type_constraint($type_name);
( defined $type )
|| __PACKAGE__->_throw_error(
- "Cannot find type '$type_name', perhaps you forgot to load it.");
+ "Cannot find type '$type_name', perhaps you forgot to load it");
if ( $type->has_coercion ) {
$type->coercion->add_type_coercions(@$coercion_map);
}
Moose::Meta::TypeConstraint::Class
Moose::Meta::TypeConstraint::Role
Moose::Meta::TypeConstraint::Enum
+ Moose::Meta::TypeConstraint::DuckType
Moose::Meta::TypeConstraint::Registry
);
where { blessed($_) && blessed($_) ne 'Regexp' } =>
optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Object;
+# This type is deprecated.
subtype 'Role' => as 'Object' => where { $_->can('does') } =>
optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Role;
Defined
Value
Num
- Int
+ Int
Str
- ClassName
- RoleName
+ ClassName
+ RoleName
Ref
ScalarRef
ArrayRef[`a]
CodeRef
RegexpRef
GlobRef
- FileHandle
+ FileHandle
Object
- Role
B<NOTE:> Any type followed by a type parameter C<[`a]> can be
parameterized, this means you can say:
type constraint to pass.
B<NOTE:> The C<RoleName> constraint checks a string is a I<package
-name> which is a role, like C<'MyApp::Role::Comparable'>. The C<Role>
-constraint checks that an I<object does> the named role.
+name> which is a role, like C<'MyApp::Role::Comparable'>.
=head2 Type Constraint Naming
all the built in types use this, so your subtypes (assuming they
are shallow) will not likely need to use this.
-=item B<type 'Name' => where { } ... >
+=item B<< type 'Name' => where { } ... >>
This creates a base type, which has no parent.
=back
+=head2 Type Constraint Utilities
+
+=over 4
+
+=item B<< match_on_type $value => ( $type => \&action, ... ?\&default ) >>
+
+This is a utility function for doing simple type based dispatching
+similar to match/case in O'Caml and case/of in Haskell. It does not
+claim to be as featureful as either of those and does not support any
+kind of automatic destructuring bind. However it is suitable for a fair
+amount of your dispatching needs, for instance, here is a simple
+Perl pretty printer dispatching over the core Moose types.
+
+ sub ppprint {
+ my $x = shift;
+ match_on_type $x =>
+ HashRef => sub {
+ my $hash = shift;
+ '{ ' . (join ", " => map {
+ $_ . ' => ' . ppprint( $hash->{ $_ } )
+ } sort keys %$hash ) . ' }' },
+ ArrayRef => sub {
+ my $array = shift;
+ '[ '.(join ", " => map { ppprint( $_ ) } @$array ).' ]' },
+ CodeRef => sub { 'sub { ... }' },
+ RegexpRef => sub { 'qr/' . $_ . '/' },
+ GlobRef => sub { '*' . B::svref_2object($_)->NAME },
+ Object => sub { $_->can('to_string') ? $_->to_string : $_ },
+ ScalarRef => sub { '\\' . ppprint( ${$_} ) },
+ Num => sub { $_ },
+ Str => sub { '"'. $_ . '"' },
+ Undef => sub { 'undef' },
+ => sub { die "I don't know what $_ is" };
+ }
+
+Or a simple JSON serializer:
+
+ sub to_json {
+ my $x = shift;
+ match_on_type $x =>
+ HashRef => sub {
+ my $hash = shift;
+ '{ ' . (join ", " => map {
+ '"' . $_ . '" : ' . to_json( $hash->{ $_ } )
+ } sort keys %$hash ) . ' }' },
+ ArrayRef => sub {
+ my $array = shift;
+ '[ ' . (join ", " => map { to_json( $_ ) } @$array ) . ' ]' },
+ Num => sub { $_ },
+ Str => sub { '"'. $_ . '"' },
+ Undef => sub { 'null' },
+ => sub { die "$_ is not acceptable json type" };
+ }
+
+Based on a mapping of C<$type> to C<\&action>, where C<$type> can be
+either a string type or a L<Moose::Meta::TypeConstraint> object, and
+C<\&action> is a CODE ref, this function will dispatch on the first
+match for C<$value>. It is possible to have a catch-all at the end
+in the form of a C<\&default> CODE ref.
+
+=back
+
=head2 Type Coercion Constructors
You can define coercions for type constraints, which allow you to
Given a enum name this function will create a new
L<Moose::Meta::TypeConstraint::Enum> object for that enum name.
+=item B<create_duck_type_constraint($name, $methods)>
+
+Given a duck type name this function will create a new
+L<Moose::Meta::TypeConstraint::DuckType> object for that enum name.
+
=item B<find_or_parse_type_constraint($type_name)>
Given a type name, this first attempts to find a matching constraint