Tidy
[gitmo/Mouse.git] / lib / Mouse / Util / TypeConstraints.pm
index 6672030..808bb6b 100644 (file)
 package Mouse::Util::TypeConstraints;
-use Mouse::Util qw(does_role not_supported); # enables strict and warnings
-
-use Carp qw(confess);
-use Scalar::Util ();
+use Mouse::Util; # enables strict and warnings
 
 use Mouse::Meta::TypeConstraint;
 use Mouse::Exporter;
 
+use Carp         ();
+use Scalar::Util ();
+
 Mouse::Exporter->setup_import_methods(
     as_is => [qw(
         as where message optimize_as
         from via
-        type subtype coerce class_type role_type enum
+
+        type subtype class_type role_type duck_type
+        enum
+        coerce
+
         find_type_constraint
+        register_type_constraint
     )],
 );
 
+our @CARP_NOT = qw(Mouse::Meta::Attribute);
+
 my %TYPE;
 
-sub as          ($) { (as          => $_[0]) }
-sub where       (&) { (where       => $_[0]) }
-sub message     (&) { (message     => $_[0]) }
-sub optimize_as (&) { (optimize_as => $_[0]) }
+# The root type
+$TYPE{Any} = Mouse::Meta::TypeConstraint->new(
+    name => 'Any',
+);
 
-sub from    { @_ }
-sub via (&) { $_[0] }
-
-BEGIN {
-    my %builtins = (
-        Any        => undef, # null check
-        Item       => undef, # null check
-        Maybe      => undef, # null check
-
-        Bool       => \&Bool,
-        Undef      => \&Undef,
-        Defined    => \&Defined,
-        Value      => \&Value,
-        Num        => \&Num,
-        Int        => \&Int,
-        Str        => \&Str,
-        Ref        => \&Ref,
-
-        ScalarRef  => \&ScalarRef,
-        ArrayRef   => \&ArrayRef,
-        HashRef    => \&HashRef,
-        CodeRef    => \&CodeRef,
-        RegexpRef  => \&RegexpRef,
-        GlobRef    => \&GlobRef,
-
-        FileHandle => \&FileHandle,
-
-        Object     => \&Object,
-
-        ClassName  => \&ClassName,
-        RoleName   => \&RoleName,
+my @builtins = (
+    # $name    => $parent,   $code,
+
+    # the base type
+    Item       => 'Any',     undef,
+
+    # the maybe[] type
+    Maybe      => 'Item',    undef,
+
+    # value types
+    Undef      => 'Item',    \&Undef,
+    Defined    => 'Item',    \&Defined,
+    Bool       => 'Item',    \&Bool,
+    Value      => 'Defined', \&Value,
+    Str        => 'Value',   \&Str,
+    Num        => 'Str',     \&Num,
+    Int        => 'Num',     \&Int,
+
+    # ref types
+    Ref        => 'Defined', \&Ref,
+    ScalarRef  => 'Ref',     \&ScalarRef,
+    ArrayRef   => 'Ref',     \&ArrayRef,
+    HashRef    => 'Ref',     \&HashRef,
+    CodeRef    => 'Ref',     \&CodeRef,
+    RegexpRef  => 'Ref',     \&RegexpRef,
+    GlobRef    => 'Ref',     \&GlobRef,
+
+    # object types
+    FileHandle => 'GlobRef', \&FileHandle,
+    Object     => 'Ref',     \&Object,
+
+    # special string types
+    ClassName  => 'Str',       \&ClassName,
+    RoleName   => 'ClassName', \&RoleName,
+);
+
+while (my ($name, $parent, $code) = splice @builtins, 0, 3) {
+    $TYPE{$name} = Mouse::Meta::TypeConstraint->new(
+        name      => $name,
+        parent    => $TYPE{$parent},
+        optimized => $code,
     );
+}
 
-    while (my ($name, $code) = each %builtins) {
-        $TYPE{$name} = Mouse::Meta::TypeConstraint->new(
-            name      => $name,
-            optimized => $code,
-        );
-    }
+# parametarizable types
+$TYPE{Maybe}   {constraint_generator} = \&_parameterize_Maybe_for;
+$TYPE{ArrayRef}{constraint_generator} = \&_parameterize_ArrayRef_for;
+$TYPE{HashRef} {constraint_generator} = \&_parameterize_HashRef_for;
 
-    sub optimized_constraints { # DEPRECATED
-        Carp::cluck('optimized_constraints() has been deprecated');
-        return \%TYPE;
-    }
+# sugars
+sub as          ($) { (as          => $_[0]) } ## no critic
+sub where       (&) { (where       => $_[0]) } ## no critic
+sub message     (&) { (message     => $_[0]) } ## no critic
+sub optimize_as (&) { (optimize_as => $_[0]) } ## no critic
 
-    my @builtins = keys %TYPE;
-    sub list_all_builtin_type_constraints { @builtins }
+sub from    { @_ }
+sub via (&) { $_[0] } ## no critic
+
+# type utilities
 
-    sub list_all_type_constraints         { keys %TYPE }
+sub optimized_constraints { # DEPRECATED
+    Carp::cluck('optimized_constraints() has been deprecated');
+    return \%TYPE;
 }
 
-sub _create_type{
-    my $mode = shift;
+undef @builtins;        # free the allocated memory
+@builtins = keys %TYPE; # reuse it
+sub list_all_builtin_type_constraints { @builtins }
+sub list_all_type_constraints         { keys %TYPE }
 
+sub _define_type {
+    my $is_subtype = shift;
     my $name;
     my %args;
 
-    if(@_ == 1 && ref $_[0]){   # @_ : { name => $name, where => ... }
+    if(@_ == 1 && ref $_[0] ){    # @_ : { name => $name, where => ... }
         %args = %{$_[0]};
     }
-    elsif(@_ == 2 && ref $_[1]){ # @_ : $name => { where => ... }
+    elsif(@_ == 2 && ref $_[1]) { # @_ : $name => { where => ... }
         $name = $_[0];
         %args = %{$_[1]};
     }
-    elsif(@_ % 2){               # @_ : $name => ( where => ... )
+    elsif(@_ % 2) {               # @_ : $name => ( where => ... )
         ($name, %args) = @_;
     }
-    else{                        # @_ : (name => $name, where => ...)
+    else{                         # @_ : (name => $name, where => ...)
         %args = @_;
     }
 
     if(!defined $name){
-        if(!defined($name = $args{name})){
-            $name = '__ANON__';
-        }
+        $name = $args{name};
     }
 
     $args{name} = $name;
-    my $parent;
-    if($mode eq 'subtype'){
-        $parent = delete $args{as};
-        if(!$parent){
-            $parent = delete $args{name};
-            $name   = '__ANON__';
-        }
+
+    my $parent = delete $args{as};
+    if($is_subtype && !$parent){
+        $parent = delete $args{name};
+        $name   = undef;
     }
 
-    my $package_defined_in = $args{package_defined_in} ||= caller(1);
+    if(defined $parent) {
+        $args{parent} = find_or_create_isa_type_constraint($parent);
+    }
 
-    my $existing = $TYPE{$name};
-    if($existing && $existing->{package_defined_in} ne $package_defined_in){
-        confess("The type constraint '$name' has already been created in "
-              . "$existing->{package_defined_in} and cannot be created again in $package_defined_in");
+    if(defined $name){
+        # set 'package_defined_in' only if it is not a core package
+        my $this = $args{package_defined_in};
+        if(!$this){
+            $this = caller(1);
+            if($this !~ /\A Mouse \b/xms){
+                $args{package_defined_in} = $this;
+            }
+        }
+
+        if(defined $TYPE{$name}){
+            my $that = $TYPE{$name}->{package_defined_in} || __PACKAGE__;
+            if($this ne $that) {
+                my $note = '';
+                if($that eq __PACKAGE__) {
+                    $note = sprintf " ('%s' is %s type constraint)",
+                        $name,
+                        scalar(grep { $name eq $_ } list_all_builtin_type_constraints())
+                            ? 'a builtin'
+                            : 'an implicitly created';
+                }
+                Carp::croak("The type constraint '$name' has already been created in $that"
+                          . " and cannot be created again in $this" . $note);
+            }
+        }
     }
 
     $args{constraint} = delete $args{where}        if exists $args{where};
     $args{optimized}  = delete $args{optimized_as} if exists $args{optimized_as};
 
-    my $constraint;
-    if($mode eq 'subtype'){
-        $constraint = find_or_create_isa_type_constraint($parent)->create_child_type(%args);
+    my $constraint = Mouse::Meta::TypeConstraint->new(%args);
+
+    if(defined $name){
+        return $TYPE{$name} = $constraint;
     }
     else{
-        $constraint = Mouse::Meta::TypeConstraint->new(%args);
+        return $constraint;
     }
-
-    return $TYPE{$name} = $constraint;
 }
 
 sub type {
-    return _create_type('type', @_);
+    return _define_type 0, @_;
 }
 
 sub subtype {
-    return _create_type('subtype', @_);
+    return _define_type 1, @_;
 }
 
-sub coerce {
+sub coerce { # coerce $type, from $from, via { ... }, ...
     my $type_name = shift;
-
     my $type = find_type_constraint($type_name)
-        or confess("Cannot find type '$type_name', perhaps you forgot to load it.");
+        or Carp::croak("Cannot find type '$type_name', perhaps you forgot to load it.");
 
     $type->_add_type_coercions(@_);
     return;
@@ -153,61 +195,83 @@ sub coerce {
 sub class_type {
     my($name, $options) = @_;
     my $class = $options->{class} || $name;
-    return _create_type 'subtype', $name => (
+
+    # ClassType
+    return subtype $name => (
         as           => 'Object',
         optimized_as => Mouse::Util::generate_isa_predicate_for($class),
-
-        type => 'Class',
+        class        => $class,
     );
 }
 
 sub role_type {
     my($name, $options) = @_;
     my $role = $options->{role} || $name;
-    return _create_type 'subtype', $name => (
-        as           => 'Object',
-        optimized_as => sub { Scalar::Util::blessed($_[0]) && does_role($_[0], $role) },
 
-        type => 'Role',
+    # RoleType
+    return subtype $name => (
+        as           => 'Object',
+        optimized_as => sub {
+            return Scalar::Util::blessed($_[0])
+                && Mouse::Util::does_role($_[0], $role);
+        },
+        role         => $role,
     );
 }
 
-sub typecast_constraints { # DEPRECATED
-    my($class, $pkg, $type, $value) = @_;
-    Carp::croak("wrong arguments count") unless @_ == 4;
+sub duck_type {
+    my($name, @methods);
 
-    Carp::cluck("typecast_constraints() has been deprecated, which was an internal utility anyway");
+    if(ref($_[0]) ne 'ARRAY'){
+        $name = shift;
+    }
 
-    return $type->coerce($value);
+    @methods = (@_ == 1 && ref($_[0]) eq 'ARRAY') ? @{$_[0]} : @_;
+
+    # DuckType
+    return _define_type 1, $name => (
+        as           => 'Object',
+        optimized_as => Mouse::Util::generate_can_predicate_for(\@methods),
+        message      => sub {
+            my($object) = @_;
+            my @missing = grep { !$object->can($_) } @methods;
+            return ref($object)
+                . ' is missing methods '
+                . Mouse::Util::quoted_english_list(@missing);
+        },
+        methods      => \@methods,
+    );
 }
 
 sub enum {
     my($name, %valid);
 
-    # enum ['small', 'medium', 'large']
-    if (ref($_[0]) eq 'ARRAY') {
-        %valid = map{ $_ => undef } @{ $_[0] };
-        $name  = sprintf '(%s)', join '|', sort @{$_[0]};
+    if(!(@_ == 1 && ref($_[0]) eq 'ARRAY')){
+        $name = shift;
     }
-    # enum size => 'small', 'medium', 'large'
-    else{
-        $name  = shift;
-        %valid = map{ $_ => undef } @_;
-    }
-    return _create_type 'type', $name => (
-        optimized_as  => sub{ defined($_[0]) && !ref($_[0]) && exists $valid{$_[0]} },
 
-        type => 'Enum',
+    %valid = map{ $_ => undef }
+        (@_ == 1 && ref($_[0]) eq 'ARRAY' ? @{$_[0]} : @_);
+
+    # EnumType
+    return _define_type 1, $name => (
+        as            => 'Str',
+        optimized_as  => sub{
+            return defined($_[0]) && !ref($_[0]) && exists $valid{$_[0]};
+        },
     );
 }
 
 sub _find_or_create_regular_type{
-    my($spec)  = @_;
+    my($spec, $create)  = @_;
 
     return $TYPE{$spec} if exists $TYPE{$spec};
 
-    my $meta = Mouse::Util::get_metaclass_by_name($spec)
-        or return undef;
+    my $meta = Mouse::Util::get_metaclass_by_name($spec);
+
+    if(!defined $meta){
+        return $create ? class_type($spec) : undef;
+    }
 
     if(Mouse::Util::is_a_metarole($meta)){
         return role_type($spec);
@@ -217,10 +281,6 @@ sub _find_or_create_regular_type{
     }
 }
 
-$TYPE{ArrayRef}{constraint_generator} = \&_parameterize_ArrayRef_for;
-$TYPE{HashRef}{constraint_generator}  = \&_parameterize_HashRef_for;
-$TYPE{Maybe}{constraint_generator}    = \&_parameterize_Maybe_for;
-
 sub _find_or_create_parameterized_type{
     my($base, $param) = @_;
 
@@ -230,103 +290,120 @@ sub _find_or_create_parameterized_type{
 }
 
 sub _find_or_create_union_type{
+    return if grep{ not defined } @_;
     my @types = sort map{ $_->{type_constraints} ? @{$_->{type_constraints}} : $_ } @_;
 
     my $name = join '|', @types;
 
+    # UnionType
     $TYPE{$name} ||= Mouse::Meta::TypeConstraint->new(
         name              => $name,
         type_constraints  => \@types,
-
-        type              => 'Union',
     );
 }
 
 # The type parser
-sub _parse_type{
-    my($spec, $start) = @_;
-
-    my @list;
-    my $subtype;
-
-    my $len = length $spec;
-    my $i;
-
-    for($i = $start; $i < $len; $i++){
-        my $char = substr($spec, $i, 1);
 
-        if($char eq '['){
-            my $base = _find_or_create_regular_type( substr($spec, $start, $i - $start) )
-                or return;
+# param : '[' type ']' | NOTHING
+sub _parse_param {
+    my($c) = @_;
 
-            ($i, $subtype) = _parse_type($spec, $i+1)
-                or return;
-            $start = $i+1; # reset
+    if($c->{spec} =~ s/^\[//){
+        my $type = _parse_type($c, 1);
 
-            push @list, _find_or_create_parameterized_type($base => $subtype);
+        if($c->{spec} =~ s/^\]//){
+            return $type;
         }
-        elsif($char eq ']'){
-            $len = $i+1;
-            last;
-        }
-        elsif($char eq '|'){
-            my $type = _find_or_create_regular_type( substr($spec, $start, $i - $start) );
+        Carp::croak("Syntax error in type: missing right square bracket in '$c->{orig}'");
+    }
 
-            if(!defined $type){
-                # XXX: Mouse creates a new class type, but Moose does not.
-                $type = class_type( substr($spec, $start, $i - $start) );
-            }
+    return undef;
+}
 
-            push @list, $type;
+# name : [\w.:]+
+sub _parse_name {
+    my($c, $create) = @_;
 
-            ($i, $subtype) = _parse_type($spec, $i+1)
-                or return;
+    if($c->{spec} =~ s/\A ([\w.:]+) //xms){
+        return _find_or_create_regular_type($1, $create);
+    }
+    Carp::croak("Syntax error in type: expect type name near '$c->{spec}' in '$c->{orig}'");
+}
 
-            $start = $i+1; # reset
+# single_type : name param
+sub _parse_single_type {
+    my($c, $create) = @_;
 
-            push @list, $subtype;
-        }
-    }
-    if($i - $start){
-        my $type = _find_or_create_regular_type( substr $spec, $start, $i - $start );
+    my $type  = _parse_name($c, $create);
+    my $param = _parse_param($c);
 
-        if(defined $type){
-            push @list, $type;
+    if(defined $type){
+        if(defined $param){
+            return _find_or_create_parameterized_type($type, $param);
         }
-        elsif($start != 0) {
-            # RT #50421
-            # create a new class type
-            push @list, class_type( substr $spec, $start, $i - $start );
+        else {
+            return $type;
         }
     }
-
-    if(@list == 0){
-       return;
-    }
-    elsif(@list == 1){
-        return ($len, $list[0]);
+    elsif(defined $param){
+        Carp::croak("Undefined type with parameter [$param] in '$c->{orig}'");
     }
     else{
-        return ($len, _find_or_create_union_type(@list));
+        return undef;
+    }
+}
+
+# type : single_type  ('|' single_type)*
+sub _parse_type {
+    my($c, $create) = @_;
+
+    my $type = _parse_single_type($c, $create);
+    if($c->{spec}){ # can be an union type
+        my @types;
+        while($c->{spec} =~ s/^\|//){
+            push @types, _parse_single_type($c, $create);
+        }
+        if(@types){
+            return _find_or_create_union_type($type, @types);
+        }
     }
+    return $type;
 }
 
 
 sub find_type_constraint {
     my($spec) = @_;
-    return $spec if Mouse::Util::is_a_type_constraint($spec);
+    return $spec if Mouse::Util::is_a_type_constraint($spec) or not defined $spec;
 
     $spec =~ s/\s+//g;
     return $TYPE{$spec};
 }
 
+sub register_type_constraint {
+    my($constraint) = @_;
+    Carp::croak("No type supplied / type is not a valid type constraint")
+        unless Mouse::Util::is_a_type_constraint($constraint);
+    my $name = $constraint->name;
+    Carp::croak("Can't register an unnamed type constraint")
+        unless defined $name;
+    return $TYPE{$name} = $constraint;
+}
+
 sub find_or_parse_type_constraint {
     my($spec) = @_;
-    return $spec if Mouse::Util::is_a_type_constraint($spec);
+    return $spec if Mouse::Util::is_a_type_constraint($spec) or not defined $spec;
 
     $spec =~ s/\s+//g;
     return $TYPE{$spec} || do{
-        my($pos, $type) = _parse_type($spec, 0);
+        my $context = {
+            spec => $spec,
+            orig => $spec,
+        };
+        my $type = _parse_type($context);
+
+        if($context->{spec}){
+            Carp::croak("Syntax error: extra elements '$context->{spec}' in '$context->{orig}'");
+        }
         $type;
     };
 }
@@ -350,7 +427,7 @@ Mouse::Util::TypeConstraints - Type constraint system for Mouse
 
 =head1 VERSION
 
-This document describes Mouse version 0.43
+This document describes Mouse version 0.76
 
 =head2 SYNOPSIS
 
@@ -451,10 +528,6 @@ If Mouse finds a name in brackets that it does not recognize as an
 existing type, it assumes that this is a class name, for example
 C<ArrayRef[DateTime]>.
 
-B<NOTE:> Unless you parameterize a type, then it is invalid to include
-the square brackets. I.e. C<ArrayRef[]> will be treated as a new type
-name, I<not> as a parameterization of C<ArrayRef>.
-
 B<NOTE:> The C<Undef> type constraint for the most part works
 correctly now, but edge cases may still exist, please use it
 sparingly.
@@ -523,16 +596,26 @@ Returns the names of all the type constraints.
 
 =over 4
 
-=item C<< subtype 'Name' => as 'Parent' => where { } ... -> Mouse::Meta::TypeConstraint >>
+=item C<< type $name => where { } ... -> Mouse::Meta::TypeConstraint >>
+
+=item C<< subtype $name => as $parent => where { } ... -> Mouse::Meta::TypeConstraint >>
 
-=item C<< subtype as 'Parent' => where { } ...  -> Mouse::Meta::TypeConstraint >>
+=item C<< subtype as $parent => where { } ...  -> Mouse::Meta::TypeConstraint >>
 
 =item C<< class_type ($class, ?$options) -> Mouse::Meta::TypeConstraint >>
 
 =item C<< role_type ($role, ?$options) -> Mouse::Meta::TypeConstraint >>
 
+=item C<< duck_type($name, @methods | \@methods) -> Mouse::Meta::TypeConstraint >>
+
+=item C<< duck_type(\@methods) -> Mouse::Meta::TypeConstraint >>
+
+=item C<< enum($name, @values | \@values) -> Mouse::Meta::TypeConstraint >>
+
 =item C<< enum (\@values) -> Mouse::Meta::TypeConstraint >>
 
+=item C<< coerce $type => from $another_type, via { }, ... >>
+
 =back
 
 =over 4