line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Type::Parser; |
2
|
|
|
|
|
|
|
|
3
|
64
|
|
|
64
|
|
26341
|
use 5.008001; |
|
64
|
|
|
|
|
278
|
|
4
|
64
|
|
|
64
|
|
428
|
use strict; |
|
64
|
|
|
|
|
133
|
|
|
64
|
|
|
|
|
1487
|
|
5
|
64
|
|
|
64
|
|
322
|
use warnings; |
|
64
|
|
|
|
|
140
|
|
|
64
|
|
|
|
|
92227
|
|
6
|
|
|
|
|
|
|
|
7
|
9
|
|
|
9
|
|
51
|
sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak } |
|
9
|
|
|
|
|
55
|
|
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
our $AUTHORITY = 'cpan:TOBYINK'; |
10
|
|
|
|
|
|
|
our $VERSION = '2.004000'; |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
$VERSION =~ tr/_//d; |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
# Token types |
15
|
|
|
|
|
|
|
# |
16
|
|
|
|
|
|
|
sub TYPE () { "TYPE" } |
17
|
|
|
|
|
|
|
sub QUOTELIKE () { "QUOTELIKE" } |
18
|
|
|
|
|
|
|
sub STRING () { "STRING" } |
19
|
|
|
|
|
|
|
sub HEXNUM () { "HEXNUM" } |
20
|
|
|
|
|
|
|
sub CLASS () { "CLASS" } |
21
|
|
|
|
|
|
|
sub L_BRACKET () { "L_BRACKET" } |
22
|
|
|
|
|
|
|
sub R_BRACKET () { "R_BRACKET" } |
23
|
|
|
|
|
|
|
sub COMMA () { "COMMA" } |
24
|
|
|
|
|
|
|
sub SLURPY () { "SLURPY" } |
25
|
|
|
|
|
|
|
sub UNION () { "UNION" } |
26
|
|
|
|
|
|
|
sub INTERSECT () { "INTERSECT" } |
27
|
|
|
|
|
|
|
sub SLASH () { "SLASH" } |
28
|
|
|
|
|
|
|
sub NOT () { "NOT" } |
29
|
|
|
|
|
|
|
sub L_PAREN () { "L_PAREN" } |
30
|
|
|
|
|
|
|
sub R_PAREN () { "R_PAREN" } |
31
|
|
|
|
|
|
|
sub MYSTERY () { "MYSTERY" } |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
our @EXPORT_OK = qw( eval_type _std_eval parse extract_type ); |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
require Exporter::Tiny; |
36
|
|
|
|
|
|
|
our @ISA = 'Exporter::Tiny'; |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
Evaluate: { |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
sub parse { |
41
|
184
|
|
|
184
|
1
|
5098
|
my $str = $_[0]; |
42
|
184
|
|
|
|
|
760
|
my $parser = "Type::Parser::AstBuilder"->new( input => $str ); |
43
|
184
|
|
|
|
|
545
|
$parser->build; |
44
|
181
|
100
|
|
|
|
727
|
wantarray ? ( $parser->ast, $parser->remainder ) : $parser->ast; |
45
|
|
|
|
|
|
|
} |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
sub extract_type { |
48
|
1
|
|
|
1
|
1
|
8
|
my ( $str, $reg ) = @_; |
49
|
1
|
|
|
|
|
4
|
my ( $parsed, $tail ) = parse( $str ); |
50
|
|
|
|
|
|
|
wantarray |
51
|
1
|
50
|
|
|
|
7
|
? ( _eval_type( $parsed, $reg ), $tail ) |
52
|
|
|
|
|
|
|
: _eval_type( $parsed, $reg ); |
53
|
|
|
|
|
|
|
} |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
sub eval_type { |
56
|
69
|
|
|
69
|
1
|
168
|
my ( $str, $reg ) = @_; |
57
|
69
|
|
|
|
|
154
|
my ( $parsed, $tail ) = parse( $str ); |
58
|
66
|
100
|
|
|
|
190
|
_croak( "Unexpected tail on type expression: $tail" ) if $tail =~ /\S/sm; |
59
|
64
|
|
|
|
|
129
|
return _eval_type( $parsed, $reg ); |
60
|
|
|
|
|
|
|
} |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
my $std; |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
sub _std_eval { |
65
|
52
|
|
|
52
|
|
4437
|
require Type::Registry; |
66
|
52
|
100
|
|
|
|
129
|
unless ( $std ) { |
67
|
1
|
|
|
|
|
4
|
$std = "Type::Registry"->new; |
68
|
1
|
|
|
|
|
4
|
$std->add_types( -Standard ); |
69
|
|
|
|
|
|
|
} |
70
|
52
|
|
|
|
|
109
|
eval_type( $_[0], $std ); |
71
|
|
|
|
|
|
|
} |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
sub _eval_type { |
74
|
312
|
|
|
312
|
|
532
|
my ( $node, $reg ) = @_; |
75
|
|
|
|
|
|
|
|
76
|
312
|
|
|
|
|
444
|
$node = _simplify_expression( $node ); |
77
|
|
|
|
|
|
|
|
78
|
312
|
100
|
|
|
|
566
|
if ( $node->{type} eq "list" ) { |
79
|
59
|
|
|
|
|
70
|
return map _eval_type( $_, $reg ), @{ $node->{list} }; |
|
59
|
|
|
|
|
227
|
|
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
|
82
|
253
|
100
|
|
|
|
395
|
if ( $node->{type} eq "union" ) { |
83
|
18
|
|
|
|
|
22
|
return $reg->_make_union_by_overload( map _eval_type( $_, $reg ), @{ $node->{union} } ); |
|
18
|
|
|
|
|
50
|
|
84
|
|
|
|
|
|
|
} |
85
|
|
|
|
|
|
|
|
86
|
235
|
100
|
|
|
|
377
|
if ( $node->{type} eq "intersect" ) { |
87
|
|
|
|
|
|
|
return $reg->_make_intersection_by_overload( |
88
|
|
|
|
|
|
|
map _eval_type( $_, $reg ), |
89
|
8
|
|
|
|
|
10
|
@{ $node->{intersect} } |
|
8
|
|
|
|
|
19
|
|
90
|
|
|
|
|
|
|
); |
91
|
|
|
|
|
|
|
} |
92
|
|
|
|
|
|
|
|
93
|
227
|
100
|
|
|
|
336
|
if ( $node->{type} eq "slash" ) { |
94
|
2
|
|
|
|
|
5
|
my @types = map _eval_type( $_, $reg ), @{ $node->{slash} }; |
|
2
|
|
|
|
|
26
|
|
95
|
2
|
50
|
|
|
|
11
|
_croak( "Expected exactly two types joined with slash operator" ) |
96
|
|
|
|
|
|
|
unless @types == 2; |
97
|
2
|
|
|
|
|
13
|
return $types[0] / $types[1]; |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
|
100
|
225
|
100
|
|
|
|
362
|
if ( $node->{type} eq "slurpy" ) { |
101
|
2
|
|
|
|
|
11
|
require Types::Standard; |
102
|
2
|
|
|
|
|
9
|
return Types::Standard::Slurpy()->of( _eval_type( $node->{of}, $reg ) ); |
103
|
|
|
|
|
|
|
} |
104
|
|
|
|
|
|
|
|
105
|
223
|
100
|
|
|
|
350
|
if ( $node->{type} eq "complement" ) { |
106
|
4
|
|
|
|
|
10
|
return _eval_type( $node->{of}, $reg )->complementary_type; |
107
|
|
|
|
|
|
|
} |
108
|
|
|
|
|
|
|
|
109
|
219
|
100
|
|
|
|
341
|
if ( $node->{type} eq "parameterized" ) { |
110
|
53
|
|
|
|
|
140
|
my $base = _eval_type( $node->{base}, $reg ); |
111
|
|
|
|
|
|
|
|
112
|
53
|
50
|
66
|
|
|
133
|
return $base unless $base->is_parameterizable || $node->{params}; |
113
|
|
|
|
|
|
|
return $base->parameterize( |
114
|
51
|
100
|
|
|
|
175
|
$node->{params} ? _eval_type( $node->{params}, $reg ) : () ); |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
|
117
|
166
|
100
|
66
|
|
|
475
|
if ( $node->{type} eq "primary" and $node->{token}->type eq CLASS ) { |
118
|
|
|
|
|
|
|
my $class = substr( |
119
|
|
|
|
|
|
|
$node->{token}->spelling, |
120
|
|
|
|
|
|
|
0, |
121
|
8
|
|
|
|
|
19
|
length( $node->{token}->spelling ) - 2 |
122
|
|
|
|
|
|
|
); |
123
|
8
|
|
|
|
|
28
|
return $reg->make_class_type( $class ); |
124
|
|
|
|
|
|
|
} |
125
|
|
|
|
|
|
|
|
126
|
158
|
100
|
66
|
|
|
394
|
if ( $node->{type} eq "primary" and $node->{token}->type eq QUOTELIKE ) { |
127
|
12
|
|
|
|
|
34
|
return eval( $node->{token}->spelling ); #ARGH |
128
|
|
|
|
|
|
|
} |
129
|
|
|
|
|
|
|
|
130
|
146
|
100
|
66
|
|
|
362
|
if ( $node->{type} eq "primary" and $node->{token}->type eq STRING ) { |
131
|
6
|
|
|
|
|
13
|
return $node->{token}->spelling; |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
|
134
|
140
|
100
|
66
|
|
|
342
|
if ( $node->{type} eq "primary" and $node->{token}->type eq HEXNUM ) { |
135
|
3
|
|
|
|
|
6
|
my $sign = '+'; |
136
|
3
|
|
|
|
|
6
|
my $spelling = $node->{token}->spelling; |
137
|
3
|
100
|
|
|
|
11
|
if ( $spelling =~ /^[+-]/ ) { |
138
|
1
|
|
|
|
|
4
|
$sign = substr( $spelling, 0, 1); |
139
|
1
|
|
|
|
|
3
|
$spelling = substr( $spelling, 1 ); |
140
|
|
|
|
|
|
|
} |
141
|
|
|
|
|
|
|
return ( |
142
|
3
|
100
|
|
|
|
22
|
( $sign eq '-' ) ? ( 0 - hex($spelling) ) : hex($spelling) |
143
|
|
|
|
|
|
|
); |
144
|
|
|
|
|
|
|
} |
145
|
|
|
|
|
|
|
|
146
|
137
|
50
|
33
|
|
|
369
|
if ( $node->{type} eq "primary" and $node->{token}->type eq TYPE ) { |
147
|
137
|
|
|
|
|
212
|
my $t = $node->{token}->spelling; |
148
|
137
|
50
|
|
|
|
472
|
my $r = |
149
|
|
|
|
|
|
|
( $t =~ /^(.+)::(\w+)$/ ) |
150
|
|
|
|
|
|
|
? $reg->foreign_lookup( $t, 1 ) |
151
|
|
|
|
|
|
|
: $reg->simple_lookup( $t, 1 ); |
152
|
137
|
100
|
|
|
|
459
|
$r or _croak( "%s is not a known type constraint", $node->{token}->spelling ); |
153
|
133
|
|
|
|
|
410
|
return $r; |
154
|
|
|
|
|
|
|
} |
155
|
|
|
|
|
|
|
} #/ sub _eval_type |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
sub _simplify_expression { |
158
|
312
|
|
|
312
|
|
333
|
my $expr = shift; |
159
|
|
|
|
|
|
|
|
160
|
312
|
100
|
100
|
|
|
736
|
if ( $expr->{type} eq "expression" and $expr->{op}[0] eq COMMA ) { |
161
|
10
|
|
|
|
|
19
|
return _simplify( "list", COMMA, $expr ); |
162
|
|
|
|
|
|
|
} |
163
|
|
|
|
|
|
|
|
164
|
302
|
100
|
100
|
|
|
576
|
if ( $expr->{type} eq "expression" and $expr->{op}[0] eq UNION ) { |
165
|
18
|
|
|
|
|
53
|
return _simplify( "union", UNION, $expr ); |
166
|
|
|
|
|
|
|
} |
167
|
|
|
|
|
|
|
|
168
|
284
|
100
|
100
|
|
|
491
|
if ( $expr->{type} eq "expression" and $expr->{op}[0] eq INTERSECT ) { |
169
|
8
|
|
|
|
|
16
|
return _simplify( "intersect", INTERSECT, $expr ); |
170
|
|
|
|
|
|
|
} |
171
|
|
|
|
|
|
|
|
172
|
276
|
100
|
66
|
|
|
491
|
if ( $expr->{type} eq "expression" and $expr->{op}[0] eq SLASH ) { |
173
|
2
|
|
|
|
|
9
|
return _simplify( "slash", SLASH, $expr ); |
174
|
|
|
|
|
|
|
} |
175
|
|
|
|
|
|
|
|
176
|
274
|
|
|
|
|
342
|
return $expr; |
177
|
|
|
|
|
|
|
} #/ sub _simplify_expression |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
sub _simplify { |
180
|
64
|
|
|
64
|
|
627
|
no warnings 'recursion'; |
|
64
|
|
|
|
|
169
|
|
|
64
|
|
|
|
|
74948
|
|
181
|
52
|
|
|
52
|
|
70
|
my $type = shift; |
182
|
52
|
|
|
|
|
57
|
my $op = shift; |
183
|
|
|
|
|
|
|
|
184
|
52
|
|
|
|
|
58
|
my @list; |
185
|
52
|
|
|
|
|
102
|
for my $expr ( $_[0]{lhs}, $_[0]{rhs} ) { |
186
|
104
|
100
|
100
|
|
|
227
|
if ( $expr->{type} eq "expression" and $expr->{op}[0] eq $op ) { |
187
|
14
|
|
|
|
|
223
|
my $simple = _simplify( $type, $op, $expr ); |
188
|
14
|
|
|
|
|
159
|
push @list, @{ $simple->{$type} }; |
|
14
|
|
|
|
|
49
|
|
189
|
|
|
|
|
|
|
} |
190
|
|
|
|
|
|
|
else { |
191
|
90
|
|
|
|
|
139
|
push @list, $expr; |
192
|
|
|
|
|
|
|
} |
193
|
|
|
|
|
|
|
} |
194
|
|
|
|
|
|
|
|
195
|
52
|
|
|
|
|
174
|
return { type => $type, $type => \@list }; |
196
|
|
|
|
|
|
|
} #/ sub _simplify |
197
|
|
|
|
|
|
|
} #/ Evaluate: |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
{ |
200
|
|
|
|
|
|
|
package Type::Parser::AstBuilder; |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
our $AUTHORITY = 'cpan:TOBYINK'; |
203
|
|
|
|
|
|
|
our $VERSION = '2.004000'; |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
$VERSION =~ tr/_//d; |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
sub new { |
208
|
184
|
|
|
184
|
|
331
|
my $class = shift; |
209
|
184
|
|
|
|
|
605
|
bless {@_}, $class; |
210
|
|
|
|
|
|
|
} |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
our %precedence = ( |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
# Type::Parser::COMMA() , 1 , |
215
|
|
|
|
|
|
|
Type::Parser::SLASH(), 1, |
216
|
|
|
|
|
|
|
Type::Parser::UNION(), 2, |
217
|
|
|
|
|
|
|
Type::Parser::INTERSECT(), 3, |
218
|
|
|
|
|
|
|
Type::Parser::NOT(), 4, |
219
|
|
|
|
|
|
|
); |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
sub _parse_primary { |
222
|
614
|
|
|
614
|
|
779
|
my $self = shift; |
223
|
614
|
|
|
|
|
817
|
my $tokens = $self->{tokens}; |
224
|
|
|
|
|
|
|
|
225
|
614
|
|
|
|
|
1322
|
$tokens->assert_not_empty; |
226
|
|
|
|
|
|
|
|
227
|
614
|
100
|
|
|
|
1559
|
if ( $tokens->peek( 0 )->type eq Type::Parser::NOT ) { |
228
|
4
|
|
|
|
|
11
|
$tokens->eat( Type::Parser::NOT ); |
229
|
4
|
|
|
|
|
7
|
$tokens->assert_not_empty; |
230
|
|
|
|
|
|
|
return { |
231
|
4
|
|
|
|
|
10
|
type => "complement", |
232
|
|
|
|
|
|
|
of => $self->_parse_primary, |
233
|
|
|
|
|
|
|
}; |
234
|
|
|
|
|
|
|
} |
235
|
|
|
|
|
|
|
|
236
|
610
|
100
|
|
|
|
1176
|
if ( $tokens->peek( 0 )->type eq Type::Parser::SLURPY ) { |
237
|
2
|
|
|
|
|
5
|
$tokens->eat( Type::Parser::SLURPY ); |
238
|
2
|
|
|
|
|
5
|
$tokens->assert_not_empty; |
239
|
|
|
|
|
|
|
return { |
240
|
2
|
|
|
|
|
5
|
type => "slurpy", |
241
|
|
|
|
|
|
|
of => $self->_parse_primary, |
242
|
|
|
|
|
|
|
}; |
243
|
|
|
|
|
|
|
} |
244
|
|
|
|
|
|
|
|
245
|
608
|
100
|
|
|
|
1138
|
if ( $tokens->peek( 0 )->type eq Type::Parser::L_PAREN ) { |
246
|
9
|
|
|
|
|
23
|
$tokens->eat( Type::Parser::L_PAREN ); |
247
|
9
|
|
|
|
|
20
|
my $r = $self->_parse_expression; |
248
|
9
|
|
|
|
|
20
|
$tokens->eat( Type::Parser::R_PAREN ); |
249
|
9
|
|
|
|
|
19
|
return $r; |
250
|
|
|
|
|
|
|
} |
251
|
|
|
|
|
|
|
|
252
|
599
|
100
|
100
|
|
|
1127
|
if ( $tokens->peek( 1 ) |
|
|
|
100
|
|
|
|
|
253
|
|
|
|
|
|
|
and $tokens->peek( 0 )->type eq Type::Parser::TYPE |
254
|
|
|
|
|
|
|
and $tokens->peek( 1 )->type eq Type::Parser::L_BRACKET ) |
255
|
|
|
|
|
|
|
{ |
256
|
217
|
|
|
|
|
547
|
my $base = { type => "primary", token => $tokens->eat( Type::Parser::TYPE ) }; |
257
|
217
|
|
|
|
|
581
|
$tokens->eat( Type::Parser::L_BRACKET ); |
258
|
217
|
|
|
|
|
500
|
$tokens->assert_not_empty; |
259
|
|
|
|
|
|
|
|
260
|
217
|
|
|
|
|
620
|
local $precedence{ Type::Parser::COMMA() } = 1; |
261
|
|
|
|
|
|
|
|
262
|
217
|
|
|
|
|
344
|
my $params = undef; |
263
|
217
|
100
|
|
|
|
500
|
if ( $tokens->peek( 0 )->type eq Type::Parser::R_BRACKET ) { |
264
|
4
|
|
|
|
|
11
|
$tokens->eat( Type::Parser::R_BRACKET ); |
265
|
|
|
|
|
|
|
} |
266
|
|
|
|
|
|
|
else { |
267
|
213
|
|
|
|
|
559
|
$params = $self->_parse_expression; |
268
|
|
|
|
|
|
|
$params = { type => "list", list => [$params] } |
269
|
213
|
50
|
|
|
|
1049
|
unless $params->{type} eq "list"; |
270
|
213
|
|
|
|
|
527
|
$tokens->eat( Type::Parser::R_BRACKET ); |
271
|
|
|
|
|
|
|
} |
272
|
|
|
|
|
|
|
return { |
273
|
217
|
|
|
|
|
1169
|
type => "parameterized", |
274
|
|
|
|
|
|
|
base => $base, |
275
|
|
|
|
|
|
|
params => $params, |
276
|
|
|
|
|
|
|
}; |
277
|
|
|
|
|
|
|
} #/ if ( $tokens->peek( 1 ...)) |
278
|
|
|
|
|
|
|
|
279
|
382
|
|
|
|
|
985
|
my $type = $tokens->peek( 0 )->type; |
280
|
382
|
100
|
100
|
|
|
1796
|
if ( $type eq Type::Parser::TYPE |
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
281
|
|
|
|
|
|
|
or $type eq Type::Parser::QUOTELIKE |
282
|
|
|
|
|
|
|
or $type eq Type::Parser::STRING |
283
|
|
|
|
|
|
|
or $type eq Type::Parser::HEXNUM |
284
|
|
|
|
|
|
|
or $type eq Type::Parser::CLASS ) |
285
|
|
|
|
|
|
|
{ |
286
|
379
|
|
|
|
|
771
|
return { type => "primary", token => $tokens->eat }; |
287
|
|
|
|
|
|
|
} |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
Type::Parser::_croak( |
290
|
3
|
|
|
|
|
9
|
"Unexpected token in primary type expression; got '%s'", |
291
|
|
|
|
|
|
|
$tokens->peek( 0 )->spelling |
292
|
|
|
|
|
|
|
); |
293
|
|
|
|
|
|
|
} #/ sub _parse_primary |
294
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
sub _parse_expression_1 { |
296
|
406
|
|
|
406
|
|
585
|
my $self = shift; |
297
|
406
|
|
|
|
|
589
|
my $tokens = $self->{tokens}; |
298
|
|
|
|
|
|
|
|
299
|
406
|
|
|
|
|
746
|
my ( $lhs, $min_p ) = @_; |
300
|
406
|
|
100
|
|
|
786
|
while ( !$tokens->empty |
|
|
|
66
|
|
|
|
|
301
|
|
|
|
|
|
|
and defined( $precedence{ $tokens->peek( 0 )->type } ) |
302
|
|
|
|
|
|
|
and $precedence{ $tokens->peek( 0 )->type } >= $min_p ) |
303
|
|
|
|
|
|
|
{ |
304
|
202
|
|
|
|
|
458
|
my $op = $tokens->eat; |
305
|
202
|
|
|
|
|
417
|
my $rhs = $self->_parse_primary; |
306
|
|
|
|
|
|
|
|
307
|
202
|
|
100
|
|
|
539
|
while ( !$tokens->empty |
|
|
|
100
|
|
|
|
|
308
|
|
|
|
|
|
|
and defined( $precedence{ $tokens->peek( 0 )->type } ) |
309
|
|
|
|
|
|
|
and $precedence{ $tokens->peek( 0 )->type } > $precedence{ $op->type } ) |
310
|
|
|
|
|
|
|
{ |
311
|
3
|
|
|
|
|
11
|
my $lookahead = $tokens->peek( 0 ); |
312
|
3
|
|
|
|
|
7
|
$rhs = $self->_parse_expression_1( $rhs, $precedence{ $lookahead->type } ); |
313
|
|
|
|
|
|
|
} |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
$lhs = { |
316
|
202
|
|
|
|
|
902
|
type => "expression", |
317
|
|
|
|
|
|
|
op => $op, |
318
|
|
|
|
|
|
|
lhs => $lhs, |
319
|
|
|
|
|
|
|
rhs => $rhs, |
320
|
|
|
|
|
|
|
}; |
321
|
|
|
|
|
|
|
} #/ while ( !$tokens->empty and...) |
322
|
406
|
|
|
|
|
1020
|
return $lhs; |
323
|
|
|
|
|
|
|
} #/ sub _parse_expression_1 |
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
sub _parse_expression { |
326
|
406
|
|
|
406
|
|
962
|
my $self = shift; |
327
|
406
|
|
|
|
|
598
|
my $tokens = $self->{tokens}; |
328
|
|
|
|
|
|
|
|
329
|
406
|
|
|
|
|
999
|
return $self->_parse_expression_1( $self->_parse_primary, 0 ); |
330
|
|
|
|
|
|
|
} |
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
sub build { |
333
|
184
|
|
|
184
|
|
277
|
my $self = shift; |
334
|
|
|
|
|
|
|
$self->{tokens} = |
335
|
184
|
|
|
|
|
903
|
"Type::Parser::TokenStream"->new( remaining => $self->{input} ); |
336
|
184
|
|
|
|
|
493
|
$self->{ast} = $self->_parse_expression; |
337
|
|
|
|
|
|
|
} |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
sub ast { |
340
|
181
|
|
|
181
|
|
1184
|
$_[0]{ast}; |
341
|
|
|
|
|
|
|
} |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
sub remainder { |
344
|
69
|
|
|
69
|
|
135
|
$_[0]{tokens}->remainder; |
345
|
|
|
|
|
|
|
} |
346
|
|
|
|
|
|
|
} |
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
{ |
349
|
|
|
|
|
|
|
package Type::Parser::Token; |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
our $AUTHORITY = 'cpan:TOBYINK'; |
352
|
|
|
|
|
|
|
our $VERSION = '2.004000'; |
353
|
|
|
|
|
|
|
|
354
|
|
|
|
|
|
|
$VERSION =~ tr/_//d; |
355
|
|
|
|
|
|
|
|
356
|
6080
|
|
|
6080
|
|
20180
|
sub type { $_[0][0] } |
357
|
490
|
|
|
490
|
|
9542
|
sub spelling { $_[0][1] } |
358
|
|
|
|
|
|
|
} |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
{ |
361
|
|
|
|
|
|
|
package Type::Parser::TokenStream; |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
our $AUTHORITY = 'cpan:TOBYINK'; |
364
|
|
|
|
|
|
|
our $VERSION = '2.004000'; |
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
$VERSION =~ tr/_//d; |
367
|
|
|
|
|
|
|
|
368
|
64
|
|
|
64
|
|
731
|
use Scalar::Util qw(looks_like_number); |
|
64
|
|
|
|
|
173
|
|
|
64
|
|
|
|
|
85721
|
|
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
sub new { |
371
|
184
|
|
|
184
|
|
299
|
my $class = shift; |
372
|
184
|
|
|
|
|
842
|
bless { stack => [], done => [], @_ }, $class; |
373
|
|
|
|
|
|
|
} |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
sub peek { |
376
|
6585
|
|
|
6585
|
|
7742
|
my $self = shift; |
377
|
6585
|
|
|
|
|
7062
|
my $ahead = $_[0]; |
378
|
|
|
|
|
|
|
|
379
|
6585
|
|
100
|
|
|
8666
|
while ( $self->_stack_size <= $ahead and length $self->{remaining} ) { |
380
|
1264
|
|
|
|
|
2191
|
$self->_stack_extend; |
381
|
|
|
|
|
|
|
} |
382
|
|
|
|
|
|
|
|
383
|
6585
|
|
|
|
|
8046
|
my @tokens = grep ref, @{ $self->{stack} }; |
|
6585
|
|
|
|
|
11726
|
|
384
|
6585
|
|
|
|
|
16330
|
return $tokens[$ahead]; |
385
|
|
|
|
|
|
|
} #/ sub peek |
386
|
|
|
|
|
|
|
|
387
|
|
|
|
|
|
|
sub empty { |
388
|
1650
|
|
|
1650
|
|
1863
|
my $self = shift; |
389
|
1650
|
|
|
|
|
2361
|
not $self->peek( 0 ); |
390
|
|
|
|
|
|
|
} |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
sub eat { |
393
|
1256
|
|
|
1256
|
|
2913
|
my $self = shift; |
394
|
1256
|
50
|
|
|
|
1741
|
$self->_stack_extend unless $self->_stack_size; |
395
|
1256
|
|
|
|
|
1558
|
my $r; |
396
|
1256
|
|
|
|
|
2702
|
while ( defined( my $item = shift @{ $self->{stack} } ) ) { |
|
1282
|
|
|
|
|
2642
|
|
397
|
1282
|
|
|
|
|
1446
|
push @{ $self->{done} }, $item; |
|
1282
|
|
|
|
|
2067
|
|
398
|
1282
|
100
|
|
|
|
2486
|
if ( ref $item ) { |
399
|
1256
|
|
|
|
|
1610
|
$r = $item; |
400
|
1256
|
|
|
|
|
1718
|
last; |
401
|
|
|
|
|
|
|
} |
402
|
|
|
|
|
|
|
} |
403
|
|
|
|
|
|
|
|
404
|
1256
|
50
|
66
|
|
|
2806
|
if ( @_ and $_[0] ne $r->type ) { |
405
|
0
|
|
|
|
|
0
|
unshift @{ $self->{stack} }, pop @{ $self->{done} }; # uncoverable statement |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
406
|
0
|
|
|
|
|
0
|
Type::Parser::_croak( "Expected $_[0]; got " . $r->type ); # uncoverable statement |
407
|
|
|
|
|
|
|
} |
408
|
|
|
|
|
|
|
|
409
|
1256
|
|
|
|
|
3032
|
return $r; |
410
|
|
|
|
|
|
|
} #/ sub eat |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
sub assert_not_empty { |
413
|
837
|
|
|
837
|
|
1061
|
my $self = shift; |
414
|
837
|
50
|
|
|
|
1281
|
Type::Parser::_croak( "Expected token; got empty string" ) if $self->empty; |
415
|
|
|
|
|
|
|
} |
416
|
|
|
|
|
|
|
|
417
|
|
|
|
|
|
|
sub _stack_size { |
418
|
9105
|
|
|
9105
|
|
9756
|
my $self = shift; |
419
|
9105
|
|
|
|
|
9324
|
scalar grep ref, @{ $self->{stack} }; |
|
9105
|
|
|
|
|
26296
|
|
420
|
|
|
|
|
|
|
} |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
sub _stack_extend { |
423
|
1264
|
|
|
1264
|
|
1625
|
my $self = shift; |
424
|
1264
|
|
|
|
|
1351
|
push @{ $self->{stack} }, $self->_read_token; |
|
1264
|
|
|
|
|
2256
|
|
425
|
1264
|
|
|
|
|
4252
|
my ( $space ) = ( $self->{remaining} =~ m/^([\s\n\r]*)/sm ); |
426
|
1264
|
100
|
|
|
|
3752
|
return unless length $space; |
427
|
32
|
|
|
|
|
38
|
push @{ $self->{stack} }, $space; |
|
32
|
|
|
|
|
61
|
|
428
|
32
|
|
|
|
|
86
|
substr( $self->{remaining}, 0, length $space ) = ""; |
429
|
|
|
|
|
|
|
} |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
sub remainder { |
432
|
69
|
|
|
69
|
|
100
|
my $self = shift; |
433
|
|
|
|
|
|
|
return join "", |
434
|
80
|
100
|
|
|
|
554
|
map { ref( $_ ) ? $_->spelling : $_ } |
435
|
69
|
|
|
|
|
98
|
( @{ $self->{stack} }, $self->{remaining} ); |
|
69
|
|
|
|
|
129
|
|
436
|
|
|
|
|
|
|
} |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
my %punctuation = ( |
439
|
|
|
|
|
|
|
'[' => bless( [ Type::Parser::L_BRACKET, "[" ], "Type::Parser::Token" ), |
440
|
|
|
|
|
|
|
']' => bless( [ Type::Parser::R_BRACKET, "]" ], "Type::Parser::Token" ), |
441
|
|
|
|
|
|
|
'(' => bless( [ Type::Parser::L_PAREN, "[" ], "Type::Parser::Token" ), |
442
|
|
|
|
|
|
|
')' => bless( [ Type::Parser::R_PAREN, "]" ], "Type::Parser::Token" ), |
443
|
|
|
|
|
|
|
',' => bless( [ Type::Parser::COMMA, "," ], "Type::Parser::Token" ), |
444
|
|
|
|
|
|
|
'=>' => bless( [ Type::Parser::COMMA, "=>" ], "Type::Parser::Token" ), |
445
|
|
|
|
|
|
|
'slurpy' => bless( [ Type::Parser::SLURPY, "slurpy" ], "Type::Parser::Token" ), |
446
|
|
|
|
|
|
|
'|' => bless( [ Type::Parser::UNION, "|" ], "Type::Parser::Token" ), |
447
|
|
|
|
|
|
|
'&' => bless( [ Type::Parser::INTERSECT, "&" ], "Type::Parser::Token" ), |
448
|
|
|
|
|
|
|
'/' => bless( [ Type::Parser::SLASH, "/" ], "Type::Parser::Token" ), |
449
|
|
|
|
|
|
|
'~' => bless( [ Type::Parser::NOT, "~" ], "Type::Parser::Token" ), |
450
|
|
|
|
|
|
|
); |
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
sub _read_token { |
453
|
1264
|
|
|
1264
|
|
1447
|
my $self = shift; |
454
|
|
|
|
|
|
|
|
455
|
1264
|
50
|
|
|
|
2449
|
return if $self->{remaining} eq ""; |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
# Punctuation |
458
|
|
|
|
|
|
|
# |
459
|
|
|
|
|
|
|
|
460
|
1264
|
100
|
|
|
|
4440
|
if ( $self->{remaining} =~ /^( => | [()\]\[|&~,\/] )/xsm ) { |
461
|
660
|
|
|
|
|
1351
|
my $spelling = $1; |
462
|
660
|
|
|
|
|
1265
|
substr( $self->{remaining}, 0, length $spelling ) = ""; |
463
|
660
|
|
|
|
|
1470
|
return $punctuation{$spelling}; |
464
|
|
|
|
|
|
|
} |
465
|
|
|
|
|
|
|
|
466
|
604
|
100
|
|
|
|
1678
|
if ( $self->{remaining} =~ /\A\s*[q'"]/sm ) { |
467
|
130
|
|
|
|
|
17795
|
require Text::Balanced; |
468
|
130
|
50
|
|
|
|
367562
|
if ( my $quotelike = Text::Balanced::extract_quotelike( $self->{remaining} ) ) { |
469
|
130
|
|
|
|
|
10818
|
return bless( [ Type::Parser::QUOTELIKE, $quotelike ], "Type::Parser::Token" ); |
470
|
|
|
|
|
|
|
} |
471
|
|
|
|
|
|
|
} |
472
|
|
|
|
|
|
|
|
473
|
474
|
100
|
|
|
|
1692
|
if ( $self->{remaining} =~ /^([+-]?[\w:.+]+)/sm ) { |
474
|
471
|
|
|
|
|
1131
|
my $spelling = $1; |
475
|
471
|
|
|
|
|
1102
|
substr( $self->{remaining}, 0, length $spelling ) = ""; |
476
|
|
|
|
|
|
|
|
477
|
471
|
100
|
|
|
|
3232
|
if ( $spelling =~ /::$/sm ) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
478
|
10
|
|
|
|
|
39
|
return bless( [ Type::Parser::CLASS, $spelling ], "Type::Parser::Token" ); |
479
|
|
|
|
|
|
|
} |
480
|
|
|
|
|
|
|
elsif ( $spelling =~ /^[+-]?0x[0-9A-Fa-f]+$/sm ) { |
481
|
3
|
|
|
|
|
10
|
return bless( [ Type::Parser::HEXNUM, $spelling ], "Type::Parser::Token" ); |
482
|
|
|
|
|
|
|
} |
483
|
|
|
|
|
|
|
elsif ( looks_like_number( $spelling ) ) { |
484
|
5
|
|
|
|
|
15
|
return bless( [ Type::Parser::STRING, $spelling ], "Type::Parser::Token" ); |
485
|
|
|
|
|
|
|
} |
486
|
|
|
|
|
|
|
elsif ( $self->{remaining} =~ /^\s*=>/sm ) # peek ahead |
487
|
|
|
|
|
|
|
{ |
488
|
4
|
|
|
|
|
16
|
return bless( [ Type::Parser::STRING, $spelling ], "Type::Parser::Token" ); |
489
|
|
|
|
|
|
|
} |
490
|
|
|
|
|
|
|
elsif ( $spelling eq "slurpy" ) { |
491
|
2
|
|
|
|
|
6
|
return $punctuation{$spelling}; |
492
|
|
|
|
|
|
|
} |
493
|
|
|
|
|
|
|
|
494
|
447
|
|
|
|
|
1723
|
return bless( [ Type::Parser::TYPE, $spelling ], "Type::Parser::Token" ); |
495
|
|
|
|
|
|
|
} #/ if ( $self->{remaining...}) |
496
|
|
|
|
|
|
|
|
497
|
3
|
|
|
|
|
9
|
my $rest = $self->{remaining}; |
498
|
3
|
|
|
|
|
8
|
$self->{remaining} = ""; |
499
|
3
|
|
|
|
|
15
|
return bless( [ Type::Parser::MYSTERY, $rest ], "Type::Parser::Token" ); |
500
|
|
|
|
|
|
|
} #/ sub _read_token |
501
|
|
|
|
|
|
|
} |
502
|
|
|
|
|
|
|
|
503
|
|
|
|
|
|
|
1; |
504
|
|
|
|
|
|
|
|
505
|
|
|
|
|
|
|
__END__ |