%PDF-
%PDF-
Mini Shell
Mini Shell
package Type::Parser;
use strict;
use warnings;
sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak }
our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION = '1.004002';
# Token types
#
sub TYPE () { "TYPE" };
sub QUOTELIKE () { "QUOTELIKE" };
sub STRING () { "STRING" };
sub CLASS () { "CLASS" };
sub L_BRACKET () { "L_BRACKET" };
sub R_BRACKET () { "R_BRACKET" };
sub COMMA () { "COMMA" };
sub SLURPY () { "SLURPY" };
sub UNION () { "UNION" };
sub INTERSECT () { "INTERSECT" };
sub NOT () { "NOT" };
sub L_PAREN () { "L_PAREN" };
sub R_PAREN () { "R_PAREN" };
sub MYSTERY () { "MYSTERY" };
our @EXPORT_OK = qw( eval_type _std_eval parse extract_type );
require Exporter::Tiny;
our @ISA = 'Exporter::Tiny';
Evaluate: {
sub parse
{
my $str = $_[0];
my $parser = "Type::Parser::AstBuilder"->new(input => $str);
$parser->build;
wantarray ? ($parser->ast, $parser->remainder) : $parser->ast;
}
sub extract_type
{
my ($str, $reg) = @_;
my ($parsed, $tail) = parse($str);
wantarray ? (_eval_type($parsed, $reg), $tail) : _eval_type($parsed, $reg);
}
sub eval_type
{
my ($str, $reg) = @_;
my ($parsed, $tail) = parse($str);
_croak("Unexpected tail on type expression: $tail") if $tail =~ /\S/sm;
return _eval_type($parsed, $reg);
}
my $std;
sub _std_eval
{
require Type::Registry;
unless ($std)
{
$std = "Type::Registry"->new;
$std->add_types(-Standard);
}
eval_type($_[0], $std);
}
sub _eval_type
{
my ($node, $reg) = @_;
$node = _simplify_expression($node);
if ($node->{type} eq "list")
{
return map _eval_type($_, $reg), @{$node->{list}};
}
if ($node->{type} eq "union")
{
return $reg->make_union(
map _eval_type($_, $reg), @{$node->{union}}
);
}
if ($node->{type} eq "intersect")
{
return $reg->make_intersection(
map _eval_type($_, $reg), @{$node->{intersect}}
);
}
if ($node->{type} eq "slurpy")
{
return +{ slurpy => _eval_type($node->{of}, $reg) };
}
if ($node->{type} eq "complement")
{
return _eval_type($node->{of}, $reg)->complementary_type;
}
if ($node->{type} eq "parameterized")
{
my $base = _eval_type($node->{base}, $reg);
return $base unless $base->is_parameterizable || $node->{params};
return $base->parameterize($node->{params} ? _eval_type($node->{params}, $reg) : ());
}
if ($node->{type} eq "primary" and $node->{token}->type eq CLASS)
{
my $class = substr(
$node->{token}->spelling,
0,
length($node->{token}->spelling) - 2
);
return $reg->make_class_type($class);
}
if ($node->{type} eq "primary" and $node->{token}->type eq QUOTELIKE)
{
return eval($node->{token}->spelling); #ARGH
}
if ($node->{type} eq "primary" and $node->{token}->type eq STRING)
{
return $node->{token}->spelling;
}
if ($node->{type} eq "primary" and $node->{token}->type eq TYPE)
{
my $t = $node->{token}->spelling;
my $r = ($t =~ /^(.+)::(\w+)$/)
? $reg->foreign_lookup($t, 1)
: $reg->simple_lookup($t, 1);
$r or _croak("%s is not a known type constraint", $node->{token}->spelling);
return $r;
}
}
sub _simplify_expression
{
my $expr = shift;
if ($expr->{type} eq "expression" and $expr->{op}[0] eq COMMA)
{
return _simplify("list", COMMA, $expr);
}
if ($expr->{type} eq "expression" and $expr->{op}[0] eq UNION)
{
return _simplify("union", UNION, $expr);
}
if ($expr->{type} eq "expression" and $expr->{op}[0] eq INTERSECT)
{
return _simplify("intersect", INTERSECT, $expr);
}
return $expr;
}
sub _simplify
{
my $type = shift;
my $op = shift;
my @list;
for my $expr ($_[0]{lhs}, $_[0]{rhs})
{
if ($expr->{type} eq "expression" and $expr->{op}[0] eq $op)
{
my $simple = _simplify($type, $op, $expr);
push @list, @{ $simple->{$type} };
}
else
{
push @list, $expr;
}
}
return { type => $type, $type => \@list };
}
}
{
package # hide from CPAN
Type::Parser::AstBuilder;
sub new
{
my $class = shift;
bless { @_ }, $class;
}
our %precedence = (
# Type::Parser::COMMA() , 1 ,
Type::Parser::UNION() , 2 ,
Type::Parser::INTERSECT() , 3 ,
Type::Parser::NOT() , 4 ,
);
sub _parse_primary
{
my $self = shift;
my $tokens = $self->{tokens};
$tokens->assert_not_empty;
if ($tokens->peek(0)->type eq Type::Parser::NOT)
{
$tokens->eat(Type::Parser::NOT);
$tokens->assert_not_empty;
return {
type => "complement",
of => $self->_parse_primary,
};
}
if ($tokens->peek(0)->type eq Type::Parser::SLURPY)
{
$tokens->eat(Type::Parser::SLURPY);
$tokens->assert_not_empty;
return {
type => "slurpy",
of => $self->_parse_primary,
};
}
if ($tokens->peek(0)->type eq Type::Parser::L_PAREN)
{
$tokens->eat(Type::Parser::L_PAREN);
my $r = $self->_parse_expression;
$tokens->eat(Type::Parser::R_PAREN);
return $r;
}
if ($tokens->peek(1)
and $tokens->peek(0)->type eq Type::Parser::TYPE
and $tokens->peek(1)->type eq Type::Parser::L_BRACKET)
{
my $base = { type => "primary", token => $tokens->eat(Type::Parser::TYPE) };
$tokens->eat(Type::Parser::L_BRACKET);
$tokens->assert_not_empty;
local $precedence{ Type::Parser::COMMA() } = 1;
my $params = undef;
if ($tokens->peek(0)->type eq Type::Parser::R_BRACKET)
{
$tokens->eat(Type::Parser::R_BRACKET);
}
else
{
$params = $self->_parse_expression;
$params = { type => "list", list => [$params] } unless $params->{type} eq "list";
$tokens->eat(Type::Parser::R_BRACKET);
}
return {
type => "parameterized",
base => $base,
params => $params,
};
}
my $type = $tokens->peek(0)->type;
if ($type eq Type::Parser::TYPE
or $type eq Type::Parser::QUOTELIKE
or $type eq Type::Parser::STRING
or $type eq Type::Parser::CLASS)
{
return { type => "primary", token => $tokens->eat };
}
Type::Parser::_croak("Unexpected token in primary type expression; got '%s'", $tokens->peek(0)->spelling);
}
sub _parse_expression_1
{
my $self = shift;
my $tokens = $self->{tokens};
my ($lhs, $min_p) = @_;
while (!$tokens->empty and defined($precedence{$tokens->peek(0)->type}) and $precedence{$tokens->peek(0)->type} >= $min_p)
{
my $op = $tokens->eat;
my $rhs = $self->_parse_primary;
while (!$tokens->empty and defined($precedence{$tokens->peek(0)->type}) and $precedence{$tokens->peek(0)->type} > $precedence{$op->type})
{
my $lookahead = $tokens->peek(0);
$rhs = $self->_parse_expression_1($rhs, $precedence{$lookahead->type});
}
$lhs = {
type => "expression",
op => $op,
lhs => $lhs,
rhs => $rhs,
};
}
return $lhs;
}
sub _parse_expression
{
my $self = shift;
my $tokens = $self->{tokens};
return $self->_parse_expression_1($self->_parse_primary, 0);
}
sub build
{
my $self = shift;
$self->{tokens} = "Type::Parser::TokenStream"->new(remaining => $self->{input});
$self->{ast} = $self->_parse_expression;
}
sub ast
{
$_[0]{ast};
}
sub remainder
{
$_[0]{tokens}->remainder;
}
}
{
package # hide from CPAN
Type::Parser::Token;
sub type { $_[0][0] }
sub spelling { $_[0][1] }
}
{
package # hide from CPAN
Type::Parser::TokenStream;
use Scalar::Util qw(looks_like_number);
sub new
{
my $class = shift;
bless { stack => [], done => [], @_ }, $class;
}
sub peek
{
my $self = shift;
my $ahead = $_[0];
while ($self->_stack_size <= $ahead and length $self->{remaining})
{
$self->_stack_extend;
}
my @tokens = grep ref, @{ $self->{stack} };
return $tokens[$ahead];
}
sub empty
{
my $self = shift;
not $self->peek(0);
}
sub eat
{
my $self = shift;
$self->_stack_extend unless $self->_stack_size;
my $r;
while (defined(my $item = shift @{$self->{stack}}))
{
push @{ $self->{done} }, $item;
if (ref $item)
{
$r = $item;
last;
}
}
if (@_ and $_[0] ne $r->type)
{
unshift @{$self->{stack}}, pop @{$self->{done}};
Type::Parser::_croak("Expected $_[0]; got ".$r->type);
}
return $r;
}
sub assert_not_empty
{
my $self = shift;
Type::Parser::_croak("Expected token; got empty string") if $self->empty;
}
sub _stack_size
{
my $self = shift;
scalar grep ref, @{ $self->{stack} };
}
sub _stack_extend
{
my $self = shift;
push @{ $self->{stack} }, $self->_read_token;
my ($space) = ($self->{remaining} =~ m/^([\s\n\r]*)/sm);
return unless length $space;
push @{ $self->{stack} }, $space;
substr($self->{remaining}, 0, length $space) = "";
}
sub remainder
{
my $self = shift;
return join "",
map { ref($_) ? $_->spelling : $_ }
(@{$self->{stack}}, $self->{remaining})
}
my %punctuation = (
'[' => bless([ Type::Parser::L_BRACKET, "[" ], "Type::Parser::Token"),
']' => bless([ Type::Parser::R_BRACKET, "]" ], "Type::Parser::Token"),
'(' => bless([ Type::Parser::L_PAREN, "[" ], "Type::Parser::Token"),
')' => bless([ Type::Parser::R_PAREN, "]" ], "Type::Parser::Token"),
',' => bless([ Type::Parser::COMMA, "," ], "Type::Parser::Token"),
'=>' => bless([ Type::Parser::COMMA, "=>" ], "Type::Parser::Token"),
'slurpy' => bless([ Type::Parser::SLURPY, "slurpy" ], "Type::Parser::Token"),
'|' => bless([ Type::Parser::UNION, "|" ], "Type::Parser::Token"),
'&' => bless([ Type::Parser::INTERSECT, "&" ], "Type::Parser::Token"),
'~' => bless([ Type::Parser::NOT, "~" ], "Type::Parser::Token"),
);
sub _read_token
{
my $self = shift;
return if $self->{remaining} eq "";
# Punctuation
#
if ($self->{remaining} =~ /^( => | [()\]\[|&~,] )/xsm)
{
my $spelling = $1;
substr($self->{remaining}, 0, length $spelling) = "";
return $punctuation{$spelling};
}
if ($self->{remaining} =~ /\A\s*[q'"]/sm)
{
require Text::Balanced;
if (my $quotelike = Text::Balanced::extract_quotelike($self->{remaining}))
{
return bless([ Type::Parser::QUOTELIKE, $quotelike ], "Type::Parser::Token"),;
}
}
if ($self->{remaining} =~ /^([+-]?[\w:.+]+)/sm)
{
my $spelling = $1;
substr($self->{remaining}, 0, length $spelling) = "";
if ($spelling =~ /::$/sm)
{
return bless([ Type::Parser::CLASS, $spelling ], "Type::Parser::Token"),;
}
elsif (looks_like_number($spelling))
{
return bless([ Type::Parser::STRING, $spelling ], "Type::Parser::Token"),;
}
elsif ($self->{remaining} =~ /^\s*=>/sm) # peek ahead
{
return bless([ Type::Parser::STRING, $spelling ], "Type::Parser::Token"),;
}
elsif ($spelling eq "slurpy")
{
return $punctuation{$spelling};
}
return bless([ Type::Parser::TYPE, $spelling ], "Type::Parser::Token");
}
my $rest = $self->{remaining};
$self->{remaining} = "";
return bless([ Type::Parser::MYSTERY, $rest ], "Type::Parser::Token");
}
}
1;
__END__
=pod
=encoding utf-8
=for stopwords non-whitespace
=head1 NAME
Type::Parser - parse type constraint strings
=head1 SYNOPSIS
use v5.10;
use strict;
use warnings;
use Type::Parser qw( eval_type );
use Type::Registry;
my $reg = Type::Registry->for_me;
$reg->add_types("Types::Standard");
my $type = eval_type("Int | ArrayRef[Int]", $reg);
$type->check(10); # true
$type->check([1..4]); # true
$type->check({foo=>1}); # false
=head1 STATUS
This module is covered by the
L<Type-Tiny stability policy|Type::Tiny::Manual::Policies/"STABILITY">.
=head1 DESCRIPTION
Generally speaking, you probably don't want to be using this module directly.
Instead use the C<< lookup >> method from L<Type::Registry> which wraps it.
=head2 Functions
=over
=item C<< parse($string) >>
Parse the type constraint string into something like an AST.
If called in list context, also returns any "tail" found on the original string.
=item C<< extract_type($string, $registry) >>
Compile a type constraint string into a L<Type::Tiny> object.
If called in list context, also returns any "tail" found on the original string.
=item C<< eval_type($string, $registry) >>
Compile a type constraint string into a L<Type::Tiny> object.
Throws an error if the "tail" contains any non-whitespace character.
=back
=head2 Constants
The following constants correspond to values returned by C<< $token->type >>.
=over
=item C<< TYPE >>
=item C<< QUOTELIKE >>
=item C<< STRING >>
=item C<< CLASS >>
=item C<< L_BRACKET >>
=item C<< R_BRACKET >>
=item C<< COMMA >>
=item C<< SLURPY >>
=item C<< UNION >>
=item C<< INTERSECT >>
=item C<< NOT >>
=item C<< L_PAREN >>
=item C<< R_PAREN >>
=item C<< MYSTERY >>
=back
=head1 BUGS
Please report any bugs to
L<http://rt.cpan.org/Dist/Display.html?Queue=Type-Tiny>.
=head1 SEE ALSO
L<Type::Registry>.
=head1 AUTHOR
Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
=head1 COPYRIGHT AND LICENCE
This software is copyright (c) 2013-2014, 2017-2018 by Toby Inkster.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=head1 DISCLAIMER OF WARRANTIES
THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
Zerion Mini Shell 1.0