implement 'runtime' keyword attribute
[p5sagit/Function-Parameters.git] / lib / Function / Parameters.pm
index 4bcec7e..a39f93b 100644 (file)
@@ -1,14 +1,13 @@
 package Function::Parameters;
 
 use v5.14.0;
-
 use warnings;
 
 use Carp qw(confess);
 
 use XSLoader;
 BEGIN {
-       our $VERSION = '1.0003';
+       our $VERSION = '1.0202';
        XSLoader::load;
 }
 
@@ -21,43 +20,76 @@ sub _assert_valid_identifier {
 
 sub _assert_valid_attributes {
        my ($attrs) = @_;
-       $attrs =~ /^\s*:\s*[^\W\d]\w*\s*(?:(?:\s|:\s*)[^\W\d]\w*\s*)*(?:\(|\z)/
-               or confess qq{"$attrs" doesn't look like valid attributes};
+       $attrs =~ m{
+               ^ \s*+
+               : \s*+
+               (?&ident) (?! [^\s:(] ) (?&param)?+ \s*+
+               (?:
+                       (?: : \s*+ )?
+                       (?&ident) (?! [^\s:(] ) (?&param)?+ \s*+
+               )*+
+               \z
+
+               (?(DEFINE)
+                       (?<ident>
+                               [^\W\d]
+                               \w*+
+                       )
+                       (?<param>
+                               \(
+                               [^()\\]*+
+                               (?:
+                                       (?:
+                                               \\ .
+                                       |
+                                               (?&param)
+                                       )
+                                       [^()\\]*+
+                               )*+
+                               \)
+                       )
+               )
+       }sx or confess qq{"$attrs" doesn't look like valid attributes};
+}
+
+sub _reify_type_default {
+       require Moose::Util::TypeConstraints;
+       Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($_[0])
+}
+
+sub _delete_default {
+       my ($href, $key, $default) = @_;
+       exists $href->{$key} ? delete $href->{$key} : $default
 }
 
 my @bare_arms = qw(function method);
 my %type_map = (
-       function => {
-               name => 'optional',
-               default_arguments => 1,
-               check_argument_count => 0,
-               named_parameters => 1,
-       },
-       method   => {
-               name => 'optional',
-               default_arguments => 1,
-               check_argument_count => 0,
-               named_parameters => 1,
-               attrs => ':method',
-               shift => '$self',
-               invocant => 1,
+       function           => {},  # all default settings
+       function_strict    => {
+               defaults   => 'function',
+               strict     => 1,
        },
-       classmethod   => {
-               name => 'optional',
-               default_arguments => 1,
-               check_argument_count => 0,
-               named_parameters => 1,
+       method             => {
+               defaults   => 'function',
                attributes => ':method',
-               shift => '$class',
-               invocant => 1,
+               shift      => '$self',
+               invocant   => 1,
+       },
+       method_strict      => {
+               defaults   => 'method',
+               strict     => 1,
+       },
+       classmethod        => {
+               defaults   => 'method',
+               shift      => '$class',
+       },
+       classmethod_strict => {
+               defaults   => 'classmethod',
+               strict     => 1,
        },
 );
-for my $k (keys %type_map) {
-       $type_map{$k . '_strict'} = {
-               %{$type_map{$k}},
-               check_argument_count => 1,
-       };
-}
+
+our @type_reifiers = \&_reify_type_default;
 
 sub import {
        my $class = shift;
@@ -89,33 +121,54 @@ sub import {
                my ($name, $proto_type) = @$item;
                _assert_valid_identifier $name;
 
-               unless (ref $proto_type) {
-                       # use '||' instead of 'or' to preserve $proto_type in the error message
-                       $proto_type = $type_map{$proto_type}
-                               || confess qq["$proto_type" doesn't look like a valid type (one of ${\join ', ', sort keys %type_map})];
-               }
+               $proto_type = {defaults => $proto_type} unless ref $proto_type;
 
                my %type = %$proto_type;
+               while (my $defaults = delete $type{defaults}) {
+                       my $base = $type_map{$defaults}
+                               or confess qq["$defaults" doesn't look like a valid type (one of ${\join ', ', sort keys %type_map})];
+                       %type = (%$base, %type);
+               }
+
                my %clean;
 
-               $clean{name} = delete $type{name} || 'optional';
+               $clean{name} = delete $type{name} // 'optional';
                $clean{name} =~ /^(?:optional|required|prohibited)\z/
                        or confess qq["$clean{name}" doesn't look like a valid name attribute (one of optional, required, prohibited)];
 
-               $clean{shift} = delete $type{shift} || '';
+               $clean{shift} = delete $type{shift} // '';
                _assert_valid_identifier $clean{shift}, 1 if $clean{shift};
 
-               $clean{attrs} = join ' ', map delete $type{$_} || (), qw(attributes attrs);
+               $clean{attrs} = join ' ', map delete $type{$_} // (), qw(attributes attrs);
                _assert_valid_attributes $clean{attrs} if $clean{attrs};
                
-               $clean{default_arguments} =
-                       exists $type{default_arguments}
-                       ? !!delete $type{default_arguments}
-                       : 1
-               ;
-               $clean{check_argument_count} = !!delete $type{check_argument_count};
-               $clean{invocant} = !!delete $type{invocant};
-               $clean{named_parameters} = !!delete $type{named_parameters};
+               $clean{default_arguments} = _delete_default \%type, 'default_arguments', 1;
+               $clean{named_parameters}  = _delete_default \%type, 'named_parameters',  1;
+               $clean{types}             = _delete_default \%type, 'types',             1;
+
+               $clean{invocant}             = _delete_default \%type, 'invocant',             0;
+               $clean{runtime}              = _delete_default \%type, 'runtime',              0;
+               $clean{check_argument_count} = _delete_default \%type, 'check_argument_count', 0;
+               $clean{check_argument_types} = _delete_default \%type, 'check_argument_types', 0;
+               $clean{check_argument_count} = $clean{check_argument_types} = 1 if delete $type{strict};
+
+               if (my $rt = delete $type{reify_type}) {
+                       ref $rt eq 'CODE' or confess qq{"$rt" doesn't look like a type reifier};
+
+                       my $index;
+                       for my $i (0 .. $#type_reifiers) {
+                               if ($type_reifiers[$i] == $rt) {
+                                       $index = $i;
+                                       last;
+                               }
+                       }
+                       unless (defined $index) {
+                               $index = @type_reifiers;
+                               push @type_reifiers, $rt;
+                       }
+
+                       $clean{reify_type} = $index;
+               }
 
                %type and confess "Invalid keyword property: @{[keys %type]}";
 
@@ -126,17 +179,21 @@ sub import {
                my $type = $spec{$kw};
 
                my $flags =
-                       $type->{name} eq 'prohibited' ? FLAG_ANON_OK :
-                       $type->{name} eq 'required' ? FLAG_NAME_OK :
-                       FLAG_ANON_OK | FLAG_NAME_OK
+                       $type->{name} eq 'prohibited' ? FLAG_ANON_OK                :
+                       $type->{name} eq 'required'   ? FLAG_NAME_OK                :
+                                                       FLAG_ANON_OK | FLAG_NAME_OK
                ;
                $flags |= FLAG_DEFAULT_ARGS if $type->{default_arguments};
-               $flags |= FLAG_CHECK_NARGS if $type->{check_argument_count};
-               $flags |= FLAG_INVOCANT if $type->{invocant};
+               $flags |= FLAG_CHECK_NARGS  if $type->{check_argument_count};
+               $flags |= FLAG_CHECK_TARGS  if $type->{check_argument_types};
+               $flags |= FLAG_INVOCANT     if $type->{invocant};
                $flags |= FLAG_NAMED_PARAMS if $type->{named_parameters};
+               $flags |= FLAG_TYPES_OK     if $type->{types};
+               $flags |= FLAG_RUNTIME      if $type->{runtime};
                $^H{HINTK_FLAGS_ . $kw} = $flags;
                $^H{HINTK_SHIFT_ . $kw} = $type->{shift};
                $^H{HINTK_ATTRS_ . $kw} = $type->{attrs};
+               $^H{HINTK_REIFY_ . $kw} = $type->{reify_type} // 0;
                $^H{+HINTK_KEYWORDS} .= "$kw ";
        }
 }
@@ -155,6 +212,68 @@ sub unimport {
 }
 
 
+our %metadata;
+
+sub _register_info {
+       my (
+               $key,
+               $declarator,
+               $invocant,
+               $invocant_type,
+               $positional_required,
+               $positional_optional,
+               $named_required,
+               $named_optional,
+               $slurpy,
+               $slurpy_type,
+       ) = @_;
+
+       my $info = {
+               declarator => $declarator,
+               invocant => defined $invocant ? [$invocant, $invocant_type] : undef,
+               slurpy   => defined $slurpy   ? [$slurpy  , $slurpy_type  ] : undef,
+               positional_required => $positional_required,
+               positional_optional => $positional_optional,
+               named_required => $named_required,
+               named_optional => $named_optional,
+       };
+
+       $metadata{$key} = $info;
+}
+
+sub _mkparam1 {
+       my ($pair) = @_;
+       my ($v, $t) = @{$pair || []} or return undef;
+       Function::Parameters::Param->new(
+               name => $v,
+               type => $t,
+       )
+}
+
+sub _mkparams {
+       my @r;
+       while (my ($v, $t) = splice @_, 0, 2) {
+               push @r, Function::Parameters::Param->new(
+                       name => $v,
+                       type => $t,
+               );
+       }
+       \@r
+}
+
+sub info {
+       my ($func) = @_;
+       my $key = _cv_root $func or return undef;
+       my $info = $metadata{$key} or return undef;
+       require Function::Parameters::Info;
+       Function::Parameters::Info->new(
+               keyword  => $info->{declarator},
+               invocant => _mkparam1($info->{invocant}),
+               slurpy   => _mkparam1($info->{slurpy}),
+               (map +("_$_" => _mkparams @{$info->{$_}}), glob '{positional,named}_{required,optional}')
+       )
+}
+
 'ok'
 
 __END__
@@ -272,11 +391,12 @@ This is just a normal block of statements, as with L<C<sub>|perlsub>. No surpris
 =head3 Name
 
 If present, it specifies the name of the function being defined. As with
-L<C<sub>|perlsub>, if a name is present, the whole declaration is syntactically
-a statement and its effects are performed at compile time (i.e. at runtime you
-can call functions whose definitions only occur later in the file). If no name
-is present, the declaration is an expression that evaluates to a reference to
-the function in question. No surprises here either.
+L<C<sub>|perlsub>, if a name is present, by default the whole declaration is
+syntactically a statement and its effects are performed at compile time (i.e.
+at runtime you can call functions whose definitions only occur later in the
+file - but see the C<runtime> flag below). If no name is present, the
+declaration is an expression that evaluates to a reference to the function in
+question.
 
 =head3 Attributes
 
@@ -390,7 +510,7 @@ exchange the order of the arguments doesn't matter anymore. As with hash
 initialization, you can specify the same key multiple times and the last
 occurrence wins:
 
-  rectangle(height => 1, width => 2, height => 2, height => 5;
+  rectangle(height => 1, width => 2, height => 2, height => 5);
   # same as: rectangle(width => 2, height => 5);
 
 You can combine positional and named parameters as long as the positional
@@ -481,12 +601,49 @@ a reference to a hash with the following keys:
 
 =over
 
+=item C<defaults>
+
+Valid values: One of the predefined types C<function>, C<method>,
+C<classmethod>, C<function_strict>, C<method_strict>, C<classmethod_strict>.
+This will set the defaults for all other keys from the specified type, which is
+useful if you only want to override some properties:
+
+  use Function::Parameters { defmethod => { defaults => 'method', shift => '$this' } };
+
+This example defines a keyword called C<defmethod> that works like the standard
+C<method> keyword, but the implicit object variable is called C<$this> instead
+of C<$self>.
+
+Using the string types directly is equivalent to C<defaults> with no further
+customization:
+
+  use Function::Parameters {
+      foo => 'function',         # like: foo => { defaults => 'function' },
+      bar => 'function_strict',  # like: bar => { defaults => 'function_strict' },
+      baz => 'method_strict',    # like: baz => { defaults => 'method_strict' },
+  };
+
 =item C<name>
 
 Valid values: C<optional> (default), C<required> (all functions defined with
 this keyword must have a name), and C<prohibited> (functions defined with this
 keyword must be anonymous).
 
+=item C<runtime>
+
+Valid values: booleans. If enabled, this keyword takes effect at runtime, not
+compile time:
+
+  use Function::Parameters { fun => { defaults => 'function_strict', runtime => 1 } };
+  say defined &foo ? "defined" : "not defined";  # not defined
+  fun foo() {}
+  say defined &foo ? "defined" : "not defined";  # defined
+
+C<&foo> is only defined after C<fun foo() {}> has been reached at runtime.
+
+B<CAVEAT:> A future version of this module may enable C<< runtime => 1 >> by
+default for methods.
+
 =item C<shift>
 
 Valid values: strings that look like scalar variables. This lets you specify a
@@ -521,15 +678,41 @@ automatically check that they have been passed all required arguments and no
 excess arguments. If this check fails, an exception will by thrown via
 L<C<Carp::croak>|Carp>.
 
+=item C<check_argument_types>
+
+Valid values: booleans. If turned on, functions defined with this keyword will
+automatically check that the arguments they are passed pass the declared type
+constraints (if any). See L</Experimental feature: Types> below.
+
+=item C<strict>
+
+Valid values: booleans. This turns on both C<check_argument_count> and
+C<check_argument_types>.
+
+=item C<reify_type>
+
+Valid values: code references. The function specified here will be called to
+turn type annotations into constraint objects (see
+L</Experimental feature: Types> below). It will receive two arguments: a string
+containing the type description, and the name of the current package.
+
+The default type reifier is equivalent to:
+
+ sub {
+     require Moose::Util::TypeConstraints;
+     Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($_[0])
+ }
+
 =back
 
 The predefined type C<function> is equivalent to:
 
  {
-   name => 'optional',
-   invocant => 0,
+   name              => 'optional',
    default_arguments => 1,
-   check_argument_count => 0,
+   strict            => 0,
+   invocant          => 0,
+   runtime           => 0,
  }
 
 These are all default values, so C<function> is also equivalent to C<{}>.
@@ -537,29 +720,24 @@ These are all default values, so C<function> is also equivalent to C<{}>.
 C<method> is equivalent to:
 
  {
-   name => 'optional',
-   shift => '$self',
-   invocant => 1,
-   attributes => ':method',
-   default_arguments => 1,
-   check_argument_count => 0,
+   defaults          => 'function',
+   attributes        => ':method',
+   shift             => '$self',
+   invocant          => 1,
+   # runtime         => 1,  ## possibly in a future version of this module
  }
 
 
 C<classmethod> is equivalent to:
 
  {
-   name => 'optional',
-   shift => '$class',
-   invocant => 1,
-   attributes => ':method',
-   default_arguments => 1,
-   check_argument_count => 0,
+   defaults          => 'method',
+   shift             => '$class',
  }
 
 C<function_strict>, C<method_strict>, and
 C<classmethod_strict> are like C<function>, C<method>, and
-C<classmethod>, respectively, but with C<< check_argument_count => 1 >>.
+C<classmethod>, respectively, but with C<< strict => 1 >>.
 
 =back
 
@@ -569,6 +747,21 @@ C<< use Function::Parameters { fun => 'function', method => 'method' } >>.
 C<use Function::Parameters qw(:strict)> is equivalent to
 C<< use Function::Parameters { fun => 'function_strict', method => 'method_strict' } >>.
 
+=head2 Introspection
+
+You can ask a function at runtime what parameters it has. This functionality is
+available through the function C<Function::Parameters::info> (which is not
+exported, so you have to call it by its full name). It takes a reference to a
+function, and returns either C<undef> (if it knows nothing about the function)
+or a L<Function::Parameters::Info> object describing the parameter list.
+
+Note: This feature is implemented using L<Moo>, so you'll need to have L<Moo>
+installed if you want to call C<Function::Parameters::info> (alternatively, if
+L<Moose> is already loaded by the time C<Function::Parameters::info> is first
+called, it will use that instead).
+
+See L<Function::Parameters::Info> for examples.
+
 =head2 Wrapping C<Function::Parameters>
 
 If you want to write a wrapper around C<Function::Parameters>, you only have to
@@ -582,6 +775,46 @@ affects the file that is currently being compiled.
    # or Function::Parameters->import(@custom_import_args);
  }
 
+=head2 Experimental feature: Types
+
+An experimental feature is now available: You can annotate parameters with
+types. That is, before each parameter you can put a type specification
+consisting of identifiers (C<Foo>), unions (C<... | ...>), and parametric types
+(C<...[...]>). Example:
+
+  fun foo(Int $n, ArrayRef[Str | CodeRef] $cb) { ... }
+
+If you do this, the type reification function corresponding to the keyword will
+be called to turn the type (a string) into a constraint object. The default
+type reifier simply loads L<Moose> and forwards to
+L<C<Moose::Util::TypeConstraints::find_or_parse_type_constraint>|Moose::Util::TypeConstraints/find_or_parse_type_constraint>,
+which creates L<Moose types|Moose::Manual::Types>.
+
+If you are in "lax" mode, nothing further happens and the types are ignored. If
+you are in "strict" mode, C<Function::Parameters> generates code to make sure
+any values passed in conform to the type (via
+L<< C<< $constraint->check($value) >>|Moose::Meta::TypeConstraint/$constraint->check($value) >>).
+
+In addition, these type constraints are inspectable through the
+L<Function::Parameters::Info> object returned by
+L<C<Function::Parameters::info>|/Introspection>.
+
+=head2 Experimental experimental feature: Type expressions
+
+An even more experimental feature is the ability to specify arbitrary
+expressions as types. The syntax for this is like the literal types described
+above, but with an expression wrapped in parentheses (C<( EXPR )>). Example:
+
+  fun foo(('Int') $n, ($othertype) $x) { ... }
+
+Every type expression must return either a string (which is resolved as for
+literal types), or a L<type constraint object|Moose::Meta::TypeConstraint>
+(providing C<check> and C<get_message> methods).
+
+Note that these expressions are evaluated (once) at parse time (similar to
+C<BEGIN> blocks), so make sure that any variables you use are set and any
+functions you call are defined at parse time.
+
 =head2 How it works
 
 The module is actually written in L<C|perlxs> and uses
@@ -599,13 +832,56 @@ generated code corresponds to:
   # ... turns into ...
   sub bar :method { my $self = shift; my ($x, $y, @z) = @_; sub bar; ... }
 
+=head1 BUGS AND INCOMPATIBILITIES
+
+A future version of this module may enable C<< runtime => 1 >> by default for
+methods. If this would break your code, please send me a note or file a bug on
+RT.
+
+=head1 SUPPORT AND DOCUMENTATION
+
+After installing, you can find documentation for this module with the
+perldoc command.
+
+    perldoc Function::Parameters
+
+You can also look for information at:
+
+=over
+
+=item MetaCPAN
+
+L<https://metacpan.org/module/Function%3A%3AParameters>
+
+=item RT, CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Function-Parameters>
+
+=item AnnoCPAN, Annotated CPAN documentation
+
+L<http://annocpan.org/dist/Function-Parameters>
+
+=item CPAN Ratings
+
+L<http://cpanratings.perl.org/d/Function-Parameters>
+
+=item Search CPAN
+
+L<http://search.cpan.org/dist/Function-Parameters/>
+
+=back
+
+=head1 SEE ALSO
+
+L<Function::Parameters::Info>
+
 =head1 AUTHOR
 
 Lukas Mai, C<< <l.mai at web.de> >>
 
 =head1 COPYRIGHT & LICENSE
 
-Copyright 2010, 2011, 2012 Lukas Mai.
+Copyright 2010-2013 Lukas Mai.
 
 This program is free software; you can redistribute it and/or modify it
 under the terms of either: the GNU General Public License as published