adding the match_on_type function to Moose::Util::TypeConstraints

diff --git a/Changes b/Changes
index 7097888..7066ca4 100644 (file)
--- 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 (file)
--- 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<where>, C<message>, and C<optimize_as>.
 
 =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<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

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 (file)
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'
+);
+
+
+
+
+