File Coverage

lib/Type/Parser.pm
Criterion Covered Total %
statement 214 218 99.0
branch 91 102 89.2
condition 59 69 85.5
subroutine 31 31 100.0
pod 3 3 100.0
total 398 423 94.5


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__