adding another example and some docs

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

diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm
index 2ee25fc..2341102 100644 (file)
--- a/lib/Moose/Util/TypeConstraints.pm
+++ b/lib/Moose/Util/TypeConstraints.pm
@@ -6,7 +6,7 @@ use List::MoreUtils qw( all any );
 use Scalar::Util qw( blessed reftype );
 use Moose::Exporter;
 
-our $VERSION = '0.85';
+our $VERSION = '0.91';
 $VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
 
@@ -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,39 @@ 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);
+        }
+    }
+    (defined $default)
+        || __PACKAGE__->_throw_error("No cases matched for $to_match");
+    {
+        local $_ = $to_match;
+        return $default->($to_match);
+    }
+}
+
+
 ## --------------------------------------------------------
 ## desugaring functions ...
 ## --------------------------------------------------------
@@ -1067,7 +1101,7 @@ B<NOTE:> You should only use this if you know what you are doing,
 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.
 
@@ -1081,6 +1115,68 @@ 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"             };
+  }
+
+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