#define HINTK_FLAGS_ MY_PKG "/flags:"
#define HINTK_SHIFT_ MY_PKG "/shift:"
#define HINTK_ATTRS_ MY_PKG "/attrs:"
+#define HINTK_REIFY_ MY_PKG "/reify:"
#define DEFSTRUCT(T) typedef struct T T; struct T
DEFSTRUCT(KWSpec) {
unsigned flags;
+ I32 reify_type;
SV *shift;
SV *attrs;
};
#include "padop_on_crack.c.inc"
-static void my_require(pTHX_ const char *file) {
- SV *err;
- require_pv(file);
- err = ERRSV;
- if (SvTRUE(err)) {
- croak_sv(err);
- }
-}
-
enum {
MY_ATTR_LVALUE = 0x01,
MY_ATTR_METHOD = 0x02,
return t;
}
-static SV *reify_type(pTHX_ Sentinel sen, const SV *declarator, SV *name) {
- SV *t;
+static SV *reify_type(pTHX_ Sentinel sen, const SV *declarator, const KWSpec *spec, SV *name) {
+ AV *type_reifiers;
+ SV *t, *sv, **psv;
int n;
dSP;
- my_require(aTHX_ "Moose/Util/TypeConstraints.pm");
+ type_reifiers = get_av(MY_PKG "::type_reifiers", 0);
+ assert(type_reifiers != NULL);
+
+ if (spec->reify_type < 0 || spec->reify_type > av_len(type_reifiers)) {
+ croak("In %"SVf": internal error: reify_type [%ld] out of range [%ld]", SVfARG(declarator), (long)spec->reify_type, (long)(av_len(type_reifiers) + 1));
+ }
+
+ psv = av_fetch(type_reifiers, spec->reify_type, 0);
+ assert(psv != NULL);
+ sv = *psv;
ENTER;
SAVETMPS;
PUSHMARK(SP);
- EXTEND(SP, 1);
+ EXTEND(SP, 2);
PUSHs(name);
+ PUSHs(PL_curstname);
PUTBACK;
- n = call_pv("Moose::Util::TypeConstraints::find_or_create_isa_type_constraint", G_SCALAR);
+ n = call_sv(sv, G_SCALAR);
SPAGAIN;
assert(n == 1);
}
*ptype = my_eval(aTHX_ sen, floor, expr);
if (!SvROK(*ptype)) {
- *ptype = reify_type(aTHX_ sen, declarator, *ptype);
+ *ptype = reify_type(aTHX_ sen, declarator, spec, *ptype);
}
if (!sv_isobject(*ptype)) {
croak("In %"SVf": (%"SVf") doesn't look like a type object", SVfARG(declarator), SVfARG(*ptype));
c = lex_peek_unichar(0);
} else if (MY_UNI_IDFIRST(c)) {
*ptype = parse_type(aTHX_ sen, declarator);
- *ptype = reify_type(aTHX_ sen, declarator, *ptype);
+ *ptype = reify_type(aTHX_ sen, declarator, spec, *ptype);
c = lex_peek_unichar(0);
}
SAVEDESTRUCTOR_X(sentinel_clear_void, sen);
spec->flags = 0;
+ spec->reify_type = 0;
spec->shift = sentinel_mortalize(sen, newSVpvs(""));
spec->attrs = sentinel_mortalize(sen, newSVpvs(""));
FETCH_HINTK_INTO(FLAGS_, kw_ptr, kw_len, psv);
spec->flags = SvIV(*psv);
+ FETCH_HINTK_INTO(REIFY_, kw_ptr, kw_len, psv);
+ spec->reify_type = SvIV(*psv);
+
FETCH_HINTK_INTO(SHIFT_, kw_ptr, kw_len, psv);
SvSetSV(spec->shift, *psv);
newCONSTSUB(stash, "HINTK_FLAGS_", newSVpvs(HINTK_FLAGS_));
newCONSTSUB(stash, "HINTK_SHIFT_", newSVpvs(HINTK_SHIFT_));
newCONSTSUB(stash, "HINTK_ATTRS_", newSVpvs(HINTK_ATTRS_));
+ newCONSTSUB(stash, "HINTK_REIFY_", newSVpvs(HINTK_REIFY_));
/**/
next_keyword_plugin = PL_keyword_plugin;
PL_keyword_plugin = my_keyword_plugin;
}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 => {
check_argument_count => 0,
named_parameters => 1,
types => 1,
+ reify_type => \&_reify_type_default,
},
method => {
name => 'optional',
check_argument_count => 0,
named_parameters => 1,
types => 1,
+ reify_type => \&_reify_type_default,
attrs => ':method',
shift => '$self',
invocant => 1,
check_argument_count => 0,
named_parameters => 1,
types => 1,
+ reify_type => \&_reify_type_default,
attributes => ':method',
shift => '$class',
invocant => 1,
};
}
+our @type_reifiers = \&_reify_type_default;
+
sub import {
my $class = shift;
$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{types} = !!delete $type{types};
+ $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{check_argument_count} = _delete_default \%type, 'check_argument_count', 0;
+ $clean{invocant} = _delete_default \%type, 'invocant', 0;
+
+ 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]}";
$^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 ";
}
}
excess arguments. If this check fails, an exception will by thrown via
L<C<Carp::croak>|Carp>.
+Currently this flag is overloaded to also enable type checks (see
+L</Experimental feature: Types> below).
+
+=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:
=head2 Experimental feature: Types
An experimental feature is now available: You can annotate parameters with
-L<Moose types|Moose::Manual::Types>. That is, before each parameter you can put
-a type specification consisting of identifiers (C<Foo>), unions (C<... | ...>),
-and parametric types (C<...[...]>). Example:
+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[String | CodeRef] $cb) { ... }
-If you do this, L<Moose> will be loaded automatically (if that hasn't happened
-yet). These specifications are parsed and validated using
-L<C<Moose::Util::TypeConstraints::find_or_parse_type_constraint>|Moose::Util::TypeConstraints/find_or_parse_type_constraint>.
+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
use warnings FATAL => 'all';
use strict;
-use Test::More tests => 4;
+use Test::More tests => 8;
use Test::Fatal;
use Function::Parameters qw(:strict);
+use Function::Parameters {
+ def => { check_argument_count => 1 },
+};
{
package MyTC;
like exception { foo 41, "hello" }, qr{\bValidation failed for constraint 'even number' with value '41'};
like exception { foo 42, "1234567890~" }, qr{\bValidation failed for constraint 'short string' with value '1234567890~'};
like exception { foo 41, "1234567890~" }, qr{\bValidation failed for constraint 'even number' with value '41'};
+
+def foo2((TEvenNum) $x, (TShortStr) $y) {
+ "$x/$y"
+}
+
+is foo2(42, "hello"), "42/hello";
+like exception { foo2 41, "hello" }, qr{\bValidation failed for constraint 'even number' with value '41'};
+like exception { foo2 42, "1234567890~" }, qr{\bValidation failed for constraint 'short string' with value '1234567890~'};
+like exception { foo2 41, "1234567890~" }, qr{\bValidation failed for constraint 'even number' with value '41'};
--- /dev/null
+#!perl
+use warnings FATAL => 'all';
+use strict;
+
+use Test::More tests => 4;
+use Test::Fatal;
+
+{
+ package MyTC;
+
+ use Function::Parameters qw(:strict);
+
+ method new(
+ $class:
+ $name,
+ $check,
+ $get_message = fun ($value) {
+ "Validation failed for constraint '$name' with value '$value'"
+ },
+ ) {
+ bless {
+ name => $name,
+ check => $check,
+ get_message => $get_message,
+ }, $class
+ }
+
+ method check($value) {
+ $self->{check}($value)
+ }
+
+ method get_message($value) {
+ $self->{get_message}($value)
+ }
+}
+
+use Function::Parameters do {
+ use Function::Parameters qw(:strict);
+
+ my %Types = (
+ TEvenNum => MyTC->new('even number' => fun ($n) { $n =~ /^[0-9]+\z/ && $n % 2 == 0 }),
+ TShortStr => MyTC->new('short string' => fun ($s) { length($s) < 10 }),
+ Any => MyTC->new('any value' => fun ($a) { 1 }),
+ );
+ +{
+ fun => {
+ check_argument_count => 1,
+ reify_type => sub { $Types{ $_[0] } || $Types{Any} },
+ },
+ }
+};
+
+fun foo(TEvenNum $x, TShortStr $y) {
+ "$x/$y"
+}
+
+is foo(42, "hello"), "42/hello";
+like exception { foo 41, "hello" }, qr{\bValidation failed for constraint 'even number' with value '41'};
+like exception { foo 42, "1234567890~" }, qr{\bValidation failed for constraint 'short string' with value '1234567890~'};
+like exception { foo 41, "1234567890~" }, qr{\bValidation failed for constraint 'even number' with value '41'};
--- /dev/null
+#!perl
+use warnings FATAL => 'all';
+use strict;
+
+use Test::More tests => 8;
+
+{
+ package TX;
+
+ sub check { 1 }
+
+ our $obj;
+ BEGIN { $obj = bless {}, 'TX'; }
+}
+
+use Function::Parameters {
+ fun => {
+ check_argument_count => 1,
+ reify_type => sub {
+ my ($type, $package) = @_;
+ if ($package ne $type) {
+ my (undef, $file, $line) = @_;
+ diag "";
+ diag "! $file : $line";
+ }
+ is $package, $type;
+ $TX::obj
+ },
+ },
+};
+
+fun f1(main $x) {}
+fun Asdf::f1(main $x) {}
+
+{
+ package Foo::Bar::Baz;
+
+ fun f1(Foo::Bar::Baz $x) {}
+ fun Ghjk::f1(Foo::Bar::Baz $x) {}
+
+ package AAA;
+ fun f1(AAA $x) {}
+ fun main::f2(AAA $x) {}
+}
+
+fun f3(main $x) {}
+fun Ghjk::f2(main $x) {}
--- /dev/null
+#!perl
+use warnings FATAL => 'all';
+use strict;
+
+use Test::More
+ eval { require Moose; 1 }
+ ? (tests => 49)
+ : (skip_all => "Moose required for testing types")
+;
+use Test::Fatal;
+
+use Function::Parameters {
+ def => { check_argument_count => 1 },
+};
+
+def foo(Int $n, CodeRef $f, $x) {
+ $x = $f->($x) for 1 .. $n;
+ $x
+}
+
+is foo(0, def {}, undef), undef;
+is foo(0, def {}, "o hai"), "o hai";
+is foo(3, def ($x) { "($x)" }, 1.5), "(((1.5)))";
+is foo(3, def (Str $x) { "($x)" }, 1.5), "(((1.5)))";
+
+{
+ my $info = Function::Parameters::info \&foo;
+ is $info->invocant, undef;
+ is $info->slurpy, undef;
+ is $info->positional_optional, 0;
+ is $info->named_required, 0;
+ is $info->named_optional, 0;
+ my @req = $info->positional_required;
+ is @req, 3;
+ is $req[0]->name, '$n';
+ ok $req[0]->type->equals('Int');
+ is $req[1]->name, '$f';
+ ok $req[1]->type->equals('CodeRef');
+ is $req[2]->name, '$x';
+ is $req[2]->type, undef;
+}
+
+like exception { foo("ermagerd", def {}, undef) }, qr/\bparameter 1.+\$n\b.+\bValidation failed\b.+\bInt\b.+ermagerd/;
+like exception { foo(0, {}, undef) }, qr/\bparameter 2.+\$f\b.+\bValidation failed\b.+\bCodeRef\b/;
+
+def bar(((Function::Parameters::info(\&foo)->positional_required)[0]->type) $whoa) { $whoa * 2 }
+
+is bar(21), 42;
+{
+ my $info = Function::Parameters::info \&bar;
+ is $info->invocant, undef;
+ is $info->slurpy, undef;
+ is $info->positional_optional, 0;
+ is $info->named_required, 0;
+ is $info->named_optional, 0;
+ my @req = $info->positional_required;
+ is @req, 1;
+ is $req[0]->name, '$whoa';
+ ok $req[0]->type->equals('Int');
+}
+
+{
+ my $info = Function::Parameters::info(def ( ArrayRef [ Int | CodeRef ]@nom) {});
+ is $info->invocant, undef;
+ is $info->positional_required, 0;
+ is $info->positional_optional, 0;
+ is $info->named_required, 0;
+ is $info->named_optional, 0;
+ my $slurpy = $info->slurpy;
+ is $slurpy->name, '@nom';
+ ok $slurpy->type->equals(Moose::Util::TypeConstraints::find_or_parse_type_constraint('ArrayRef[Int|CodeRef]'));
+}
+
+{
+ my $phase = 'runtime';
+ BEGIN { $phase = 'A'; }
+ def
+ baz
+ (
+ (
+ is
+ (
+ $phase
+ ++
+ ,
+ 'A'
+ )
+ ,
+ 'Int'
+ )
+ :
+ $marco
+ ,
+ (
+ is
+ (
+ $phase
+ ++
+ ,
+ 'B'
+ )
+ ,
+ q
+ $ArrayRef[Str]$
+ )
+ :
+ $polo
+ )
+ {
+ [
+ $marco
+ ,
+ $polo
+ ]
+ }
+ BEGIN { is $phase, 'C'; }
+ is $phase, 'runtime';
+
+ is_deeply baz(polo => [qw(foo bar baz)], marco => 11), [11, [qw(foo bar baz)]];
+
+ my $info = Function::Parameters::info \&baz;
+ is $info->invocant, undef;
+ is $info->slurpy, undef;
+ is $info->positional_required, 0;
+ is $info->positional_optional, 0;
+ is $info->named_optional, 0;
+ my @req = $info->named_required;
+ is @req, 2;
+ is $req[0]->name, '$marco';
+ ok $req[0]->type->equals('Int');
+ is $req[1]->name, '$polo';
+ ok $req[1]->type->equals('ArrayRef[Str]');
+}
projects / p5sagit/Function-Parameters.git / commitdiff