From: Lukas Mai Date: Thu, 18 Jul 2013 22:51:32 +0000 (+0200) Subject: implement custom per-keyword type reification X-Git-Tag: v1.0201~3^2~2 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7193dffba45795c249b405f8636d644261380ff0;hp=d72d56ce74efe8558da8154d85aea834ff87dfc6;p=p5sagit%2FFunction-Parameters.git implement custom per-keyword type reification --- diff --git a/Parameters.xs b/Parameters.xs index 3ca4d40..c999c9b 100644 --- a/Parameters.xs +++ b/Parameters.xs @@ -85,6 +85,7 @@ WARNINGS_ENABLE #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 @@ -103,6 +104,7 @@ enum { DEFSTRUCT(KWSpec) { unsigned flags; + I32 reify_type; SV *shift; SV *attrs; }; @@ -220,15 +222,6 @@ static int my_sv_eq_pvn(pTHX_ SV *sv, const char *p, STRLEN n) { #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, @@ -506,12 +499,22 @@ static SV *parse_type(pTHX_ Sentinel sen, const SV *declarator) { 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; @@ -521,7 +524,7 @@ static SV *reify_type(pTHX_ Sentinel sen, const SV *declarator, SV *name) { PUSHs(name); 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); @@ -801,7 +804,7 @@ static PADOFFSET parse_param( } *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)); @@ -810,7 +813,7 @@ static PADOFFSET parse_param( 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); } @@ -1987,6 +1990,7 @@ static int kw_flags_enter(pTHX_ Sentinel sen, const char *kw_ptr, STRLEN kw_len, 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("")); @@ -2010,6 +2014,9 @@ static int kw_flags_enter(pTHX_ Sentinel sen, const char *kw_ptr, STRLEN kw_len, 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); @@ -2075,6 +2082,7 @@ WARNINGS_ENABLE { 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; diff --git a/lib/Function/Parameters.pm b/lib/Function/Parameters.pm index 101a34f..8720269 100644 --- a/lib/Function/Parameters.pm +++ b/lib/Function/Parameters.pm @@ -52,6 +52,11 @@ sub _assert_valid_attributes { }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]) +} + my @bare_arms = qw(function method); my %type_map = ( function => { @@ -60,6 +65,7 @@ my %type_map = ( check_argument_count => 0, named_parameters => 1, types => 1, + reify_type => \&_reify_type_default, }, method => { name => 'optional', @@ -67,6 +73,7 @@ my %type_map = ( check_argument_count => 0, named_parameters => 1, types => 1, + reify_type => \&_reify_type_default, attrs => ':method', shift => '$self', invocant => 1, @@ -77,6 +84,7 @@ my %type_map = ( check_argument_count => 0, named_parameters => 1, types => 1, + reify_type => \&_reify_type_default, attributes => ':method', shift => '$class', invocant => 1, @@ -89,6 +97,8 @@ for my $k (keys %type_map) { }; } +our @type_reifiers = \&_reify_type_default; + sub import { my $class = shift; @@ -143,11 +153,30 @@ sub import { ? !!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}; + 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]}"; $spec{$name} = \%clean; @@ -169,6 +198,7 @@ sub import { $^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 "; } } @@ -615,6 +645,22 @@ 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|Carp>. +Currently this flag is overloaded to also enable type checks (see +L below). + +=item C + +Valid values: code references. The function specified here will be called to +turn type annotations into constraint objects (see +L below). + +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 is equivalent to: @@ -694,15 +740,17 @@ affects the file that is currently being compiled. =head2 Experimental feature: Types An experimental feature is now available: You can annotate parameters with -L. That is, before each parameter you can put -a type specification consisting of identifiers (C), unions (C<... | ...>), -and parametric types (C<...[...]>). Example: +types. That is, before each parameter you can put a type specification +consisting of identifiers (C), unions (C<... | ...>), and parametric types +(C<...[...]>). Example: fun foo(Int $n, ArrayRef[String | CodeRef] $cb) { ... } -If you do this, L will be loaded automatically (if that hasn't happened -yet). These specifications are parsed and validated using -L|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 and forwards to +L|Moose::Util::TypeConstraints/find_or_parse_type_constraint>, +which creates L. If you are in "lax" mode, nothing further happens and the types are ignored. If you are in "strict" mode, C generates code to make sure diff --git a/t/types_custom_2.t b/t/types_custom_2.t new file mode 100644 index 0000000..f22ae0e --- /dev/null +++ b/t/types_custom_2.t @@ -0,0 +1,61 @@ +#!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, + types => 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'};