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

[gitmo/Moose.git] / lib / Moose / Util / TypeConstraints.pm

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