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 7d7da3a..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.83';
+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 ...
 ## --------------------------------------------------------
@@ -657,6 +691,7 @@ subtype 'Object' => as 'Ref' =>
     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;
 
@@ -848,10 +883,10 @@ that hierarchy represented visually.
       Defined
           Value
               Num
-                Int
+                  Int
               Str
-                ClassName
-                RoleName
+                  ClassName
+                  RoleName
           Ref
               ScalarRef
               ArrayRef[`a]
@@ -859,9 +894,8 @@ that hierarchy represented visually.
               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:
@@ -887,8 +921,7 @@ existence check. This means that your class B<must> be loaded for this
 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
 
@@ -1068,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.
 
@@ -1082,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