From: Stevan Little Date: Sat, 19 Sep 2009 18:51:37 +0000 (-0400) Subject: adding the match_on_type function to Moose::Util::TypeConstraints X-Git-Tag: 0.92~10 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0d29b77265a9c26a152cc0d9628d5b1101ceb32a;p=gitmo%2FMoose.git adding the match_on_type function to Moose::Util::TypeConstraints --- diff --git a/Changes b/Changes index 7097888..7066ca4 100644 --- a/Changes +++ b/Changes @@ -1,6 +1,11 @@ Also see Moose::Manual::Delta for more details of, and workarounds for, noteworthy changes. +0.92 + * Moose::Util::TypeConstraints + - added the match_on_type operator (Stevan) + - added tests and docs for this (Stevan) + * Moose::Meta::Class - Metaclass compat fixing should already happen recursively, there's no need to explicitly walk up the inheritance tree. (doy) diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index b0ecf5c..ac9b560 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -46,7 +46,8 @@ Moose::Exporter->setup_import_methods( coerce from via enum find_type_constraint - register_type_constraint ) + register_type_constraint + match_on_type ) ], _export_to_main => 1, ); @@ -442,6 +443,37 @@ sub create_duck_type_constraint { ); } +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); + } + } + { + local $_ = $to_match; + return $default->($to_match) if $default; + } +} + + ## -------------------------------------------------------- ## desugaring functions ... ## -------------------------------------------------------- @@ -1081,6 +1113,49 @@ The valid hashref keys are C, C, and C. =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" }; + } + +Based on a mapping of C<$type> to C<\&action>, where C<$type> can be +either a string type or a L 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 diff --git a/t/040_type_constraints/036_match_type_operator.t b/t/040_type_constraints/036_match_type_operator.t new file mode 100644 index 0000000..6656651 --- /dev/null +++ b/t/040_type_constraints/036_match_type_operator.t @@ -0,0 +1,180 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 22; +use Test::Exception; + +use Moose::Util::TypeConstraints; + +# some simple type dispatching ... + +subtype 'Null' + => as 'ArrayRef' + => where { scalar @{$_} == 0 }; + +sub head { + match_on_type @_ => + Null => sub { die "Cannot get the head of Null" }, + ArrayRef => sub { $_->[0] }; +} + +sub tail { + match_on_type @_ => + Null => sub { die "Cannot get the tail of Null" }, + ArrayRef => sub { [ @{ $_ }[ 1 .. $#{ $_ } ] ] }; +} + +sub len { + match_on_type @_ => + Null => sub { 0 }, + ArrayRef => sub { len( tail( $_ ) ) + 1 }; +} + +sub rev { + match_on_type @_ => + Null => sub { [] }, + ArrayRef => sub { [ @{ rev( tail( $_ ) ) }, head( $_ ) ] }; +} + +is( len( [] ), 0, '... got the right length'); +is( len( [ 1 ] ), 1, '... got the right length'); +is( len( [ 1 .. 5 ] ), 5, '... got the right length'); +is( len( [ 1 .. 50 ] ), 50, '... got the right length'); + +is_deeply( + rev( [ 1 .. 5 ] ), + [ reverse 1 .. 5 ], + '... got the right reversed value' +); + +# break down a Maybe Type ... + +sub break_it_down { + match_on_type shift, + 'Maybe[Str]' => sub { + match_on_type $_ => + 'Undef' => sub { 'undef' }, + 'Str' => sub { $_ } + }, + sub { 'default' } +} + + +is( break_it_down( 'FOO' ), 'FOO', '... got the right value'); +is( break_it_down( [] ), 'default', '... got the right value'); +is( break_it_down( undef ), 'undef', '... got the right value'); +is( break_it_down(), 'undef', '... got the right value'); + +# checking against enum types + +enum RGB => qw[ red green blue ]; +enum CMYK => qw[ cyan magenta yellow black ]; + +sub is_acceptable_color { + match_on_type shift, + 'RGB' => sub { 'RGB' }, + 'CMYK' => sub { 'CMYK' }, + sub { die "bad color $_" }; +} + +is( is_acceptable_color( 'blue' ), 'RGB', '... got the right value'); +is( is_acceptable_color( 'green' ), 'RGB', '... got the right value'); +is( is_acceptable_color( 'red' ), 'RGB', '... got the right value'); +is( is_acceptable_color( 'cyan' ), 'CMYK', '... got the right value'); +is( is_acceptable_color( 'magenta' ), 'CMYK', '... got the right value'); +is( is_acceptable_color( 'yellow' ), 'CMYK', '... got the right value'); +is( is_acceptable_color( 'black' ), 'CMYK', '... got the right value'); + +dies_ok { + is_acceptable_color( 'orange' ) +} '... got the exception'; + +## using it in an OO context + +{ + package LinkedList; + use Moose; + use Moose::Util::TypeConstraints; + + has 'next' => ( + is => 'ro', + isa => __PACKAGE__, + lazy => 1, + default => sub { __PACKAGE__->new }, + predicate => 'has_next' + ); + + sub pprint { + my $list = shift; + match_on_type $list => + subtype( + as 'LinkedList', + where { ! $_->has_next } + ) => sub { '[]' }, + 'LinkedList' => sub { '[' . $_->next->pprint . ']' }; + } +} + +my $l = LinkedList->new; +is($l->pprint, '[]', '... got the right pprint'); +$l->next; +is($l->pprint, '[[]]', '... got the right pprint'); +$l->next->next; +is($l->pprint, '[[[]]]', '... got the right pprint'); +$l->next->next->next; +is($l->pprint, '[[[[]]]]', '... got the right pprint'); + +# basic data dumper + +{ + package Foo; + use Moose; + + sub to_string { 'Foo()' } +} + +use B; + +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" }; +} + +is( + ppprint( + { + one => [ 1, 2, "three", 4, "five", \(my $x = "six") ], + two => undef, + three => sub { "OH HAI" }, + four => qr/.*?/, + five => \*ppprint, + six => Foo->new, + } + ), + '{ five => *ppprint, four => qr/(?-xism:.*?)/, one => [ 1, 2, "three", 4, "five", \"six" ], six => Foo(), three => sub { ... }, two => undef }', + '... got the right pretty printed values' +); + + + + +