Skip to content

Commit

Permalink
extended signature definitions implemented
Browse files Browse the repository at this point in the history
  • Loading branch information
@phaylon
phaylon committed Jan 24, 2009
1 parent 17460b8 commit 8ec39ac
Show file tree
Hide file tree
Showing 4 changed files with 569 additions and 95 deletions.
1 change: 1 addition & 0 deletions lib/Script/SXC/Script/Command/repl.pm
View file
Expand Up @@ -211,6 +211,7 @@ method run {
}

# normal error
warn "\n# compiled result:\n$body\n";
warn "An error occured during $stage:\n\t$e\n";
do { chomp(my $l = $line); $self->add_to_history($l) };
#$self->print_info($body, no_prefix => 1, filter => sub { "# $_" });
Expand Down
91 changes: 77 additions & 14 deletions lib/Script/SXC/Signature.pm
View file
@@ -1,4 +1,5 @@
package Script::SXC::Signature;
use 5.010;
use Moose;
use MooseX::Method::Signatures;
use MooseX::AttributeHelpers;
Expand All @@ -7,11 +8,15 @@ use MooseX::Types::Moose qw( Str Object ArrayRef );
use Script::SXC::lazyload
'Script::SXC::Exception::ParseError',
'Script::SXC::Signature::Parameter',
'Script::SXC::Compiler::Environment::Variable',
['Script::SXC::Compiled::Value', 'CompiledValue' ],
['Script::SXC::Compiled::Validation::Count', 'CompiledArgCountCheck'];

use Data::Dump qw( pp );

use constant ListClass => 'Script::SXC::Tree::List';
use constant VariableClass => 'Script::SXC::Compiler::Environment::Variable';
use constant ArgumentError => 'Script::SXC::Exception::ArgumentError';

use namespace::clean -except => 'meta';

Expand Down Expand Up @@ -55,24 +60,63 @@ method all_parameters {
}

method required_parameter_count {
return scalar grep { not $_->is_optional } @{ $self->fixed_parameters }, @{ $self->named_parameters };
return scalar grep { $_->is_required } @{ $self->fixed_parameters }, @{ $self->named_parameters };
}

method compile_validations (Object $compiler!, Object $env!) {
my @validations;

# calculate argument count boundaries
my $min = $self->required_parameter_count;
my $min = (grep { $_->is_required } @{ $self->fixed_parameters }) + (2 * grep { $_->is_required } @{ $self->named_parameters });
# my $min = grep { $_->is_required } @{ $self->fixed_parameters };
my $max = $self->rest_parameter ? undef : $self->fixed_parameter_count + ($self->named_parameter_count * 2);

# argument count
push @validations, CompiledArgCountCheck->new(min => $min)
if $min;
# maximum argument count
push @validations, CompiledArgCountCheck->new(max => $max)
if defined $max;

# general validations
push @validations, map { @{ $_->compile_validations($compiler, $env) } } $self->all_parameters;
# extract named arguments
my $named_var;
if ($self->named_parameter_count or ($self->rest_parameter and $self->rest_parameter->is_named)) {

$named_var = Variable->new_anonymous('named_args');
push @validations, CompiledValue->new(content => sprintf
'my %s = +{ @_[%s .. $#_] }',
$named_var->render,
$self->fixed_parameter_count,
);
}

# fixed and named validations
push @validations, map { @{ $_->compile_validations($compiler, $env, named_var => $named_var) } }
@{ $self->fixed_parameters }, @{ $self->named_parameters };

# minimum argument count, comes later so that named params can do their error reporting first
push @validations, CompiledArgCountCheck->new(min => $min)
if $min;

# rest parameter validations
if ($self->rest_parameter) {
push @validations,
@{ $self->rest_parameter->compile_validations($compiler, $env, named_var => $named_var, rest_container => 1) };
}
else {
if ($named_var) {
$compiler->add_required_package(ArgumentError);
push @validations, CompiledValue->new(content => sprintf
'if (keys(%%{( %s )})) { %s->throw_to_caller(message => %s, %s) }',
$named_var->render,
ArgumentError,
sprintf(
'join(q(), q(Unknown arguments: ), join(q(, ), keys(%%{( %s )})))',
$named_var->render,
),
pp(type => 'invalid_arguments'),
);
}
}

return \@validations;
}

method D___compile_validations (Object $compiler!, Object $env!) {
Expand All @@ -99,10 +143,17 @@ method as_definition_map {
CompiledValue->new(content => sprintf('$_[%d]', $arg_index++)),
] } @{ $self->fixed_parameters } ),

# named parameters
( map { [
$_->symbol,
CompiledValue->new(content => 'undef'),
] } @{ $self->named_parameters } ),

# a rest parameter, if present
( $self->rest_parameter ? [
$self->rest_parameter_symbol,
CompiledValue->new(content => sprintf('[@_[%d .. $#_]]', $arg_index)),
CompiledValue->new(content => 'undef'),
# CompiledValue->new(content => sprintf('[@_[%d .. $#_]]', $arg_index)),
] : () ),
];
};
Expand All @@ -123,7 +174,7 @@ method new_from_tree ($class: Object $item!, Object $compiler!, Object $env!) {

# grab-all when symbol is given
if ($item->isa('Script::SXC::Tree::Symbol') or $item->isa(VariableClass)) {
return $class->new(rest_parameter => Parameter->new_from_tree($item, $compiler, $env));
return $class->new(rest_parameter => Parameter->new_from_tree($item, $compiler, $env, position => 0));
}

# otherwise it has to be a list
Expand All @@ -134,7 +185,9 @@ method new_from_tree ($class: Object $item!, Object $compiler!, Object $env!) {
my @sig_parts = @{ $item->contents };

# walk the items and collect parameters
my (@fixed_params, $rest, $is_optional, $is_named);
my (@fixed_params, @named_params, $rest, $is_optional, $is_named);
my $target_list = \@fixed_params;
my $position = -1;
SIGPART:
while (my $sig_part = shift @sig_parts) {

Expand All @@ -149,9 +202,12 @@ method new_from_tree ($class: Object $item!, Object $compiler!, Object $env!) {
if ($class->_is_named_indicator($sig_part)) {

$is_named = 1;
$target_list = \@named_params;
next SIGPART;
}

$position++;

# if we encounter a dot, we found the rest specification
if ($class->_is_rest_indicator($sig_part)) {

Expand All @@ -164,18 +220,25 @@ method new_from_tree ($class: Object $item!, Object $compiler!, Object $env!) {
if @sig_parts < 1;

# store rest and end cycle
$rest = Parameter->new_from_tree(shift(@sig_parts), $compiler, $env);
$rest = Parameter->new_from_tree(shift(@sig_parts), $compiler, $env, is_named => $is_named, position => $position);

# not needed, since list now empty, but it documents in-flow rather nicely
last SIGPART;
}

# this is a fixed parameter
push @fixed_params, Parameter->new_from_tree($sig_part, $compiler, $env);
# fixed or named parameter
push @$target_list, Parameter->new_from_tree(
$sig_part,
$compiler,
$env,
is_named => $is_named,
is_optional => $is_optional,
position => $position,
);
}

# construct object from found parameters
my $self = $class->new(fixed_parameters => \@fixed_params);
my $self = $class->new(fixed_parameters => \@fixed_params, named_parameters => \@named_params);
$self->rest_parameter($rest) if $rest;

# construction finished
Expand Down
94 changes: 83 additions & 11 deletions lib/Script/SXC/Signature/Parameter.pm
View file
Expand Up @@ -2,16 +2,20 @@ package Script::SXC::Signature::Parameter;
use 5.010;
use Moose;
use MooseX::Method::Signatures;
use MooseX::Types::Moose qw( Bool Str Object );
use MooseX::Types::Moose qw( Bool Str Object Int );

use Perl6::Junction qw( any );
use Perl6::Gather;

use Script::SXC::lazyload
'Script::SXC::Exception::ParseError',
['Script::SXC::Compiled::Value', 'CompiledValue'],
['Script::SXC::Compiled::Validation::Where', 'WhereClause'];

use Data::Dump qw( pp );

use constant VariableClass => 'Script::SXC::Compiler::Environment::Variable';
use constant ArgumentError => 'Script::SXC::Exception::ArgumentError';

use namespace::clean -except => 'meta';

Expand All @@ -28,7 +32,7 @@ has symbol => (
isa => Object,
required => 1,
handles => {
'name' => 'value',
'name' => 'value',
},
);

Expand All @@ -42,31 +46,99 @@ has is_named => (
isa => Bool,
);

method compile_validations (Object $compiler!, Object $env!, Bool :$rest_container?) {
has position => (
is => 'rw',
isa => Int,
required => 1
);

method is_required () { not $self->is_optional }

method compile_validations (Object $compiler!, Object $env!, Bool :$rest_container?, Object|Undef :$named_var?) {
my @validations;

#warn "PARAM " . $self->name . "\n";
my $optional_check = sprintf 'defined(%s)', $self->symbol->compile($compiler, $env)->render;
my $value = $self->symbol;

# check named arguments
if ($self->is_named) {
die "We should have a named argument variable at this point"
unless $named_var;

# render access to value in named arg hash
my $access = sprintf '%s->{ %s }', $named_var->render, pp($self->name);

# named arguments need different behaviours
$optional_check = sprintf 'exists(%s)', $access;
$value = CompiledValue->new(content => $access);

# update variable
if ($rest_container) {

push @validations, CompiledValue->new(content => sprintf
'%s = ( +{( %%{( %s )} )} )',
$self->symbol->compile($compiler, $env)->render,
$named_var->render,
);
}
else {

$compiler->add_required_package(ArgumentError);

# check for existance
push @validations, CompiledValue->new(content => sprintf
'%s->throw_to_caller(%s) unless exists(%s)',
ArgumentError,
pp(type => 'missing_argument', message => sprintf('Missing named argument: %s', $self->name)),
$access,
);

push @validations, CompiledValue->new(content => sprintf
'%s = delete(%s)',
$self->symbol->compile($compiler, $env)->render,
$access,
);
}
}
elsif ($rest_container) {
push @validations, CompiledValue->new(content => sprintf
'%s = [( @_[ %s .. $#_ ] )]',
$self->symbol->compile($compiler, $env)->render,
$self->position,
);
}

# compile possible where clause
if ($self->where_clause) {
#warn "WHERE\n";
push @validations, WhereClause->new(
expression => $self->compile_where_clause($compiler, $env),
symbol => $self->symbol,
symbol => $value,
);
}

#use Data::Dump qw(dump); warn dump \@validations;
return \@validations;
# validations for optinoal parameters will be wrapped
if ($self->is_optional) {
return [ CompiledValue->new(content => sprintf
'(do { if (%s) { %s } })',
$optional_check,
join '; ', map { $_->render } @validations,
) ];
}

# required parameter must meet the constraints
else {
return \@validations;
}
}

method new_from_tree ($class: Object $item!, Object $compiler!, Object $env!, Bool :$is_named, Bool :$is_optional) {
method new_from_tree ($class: Object $item!, Object $compiler!, Object $env!, Bool :$is_named, Bool :$is_optional, Int :$position!) {
my %flags = (is_named => $is_named, is_optional => $is_optional);

# we have been given just a symbol
if ($item->isa('Script::SXC::Tree::Symbol') or $item->isa(VariableClass)) {

# we just have the name
return $class->new(symbol => $item, %flags);
return $class->new(symbol => $item, position => $position, %flags);
}

# it must be a list if it's not a symbol
Expand Down Expand Up @@ -105,7 +177,7 @@ method new_from_tree ($class: Object $item!, Object $compiler!, Object $env!, Bo
}

# finished parameter
return $class->new(%flags, %attrs);
return $class->new(%flags, position => $position, %attrs);
}

method prepare_where_clause_expression (Str $class: Object $key!, ArrayRef $args!, Object $compiler!, Object $env!, Object :$symbol!) {
Expand Down

0 comments on commit 8ec39ac

Please sign in to comment.