1package GraphQL::Language::Receiver;
2
3use 5.014;
4use strict;
5use warnings;
6use base 'Pegex::Receiver';
7use Types::Standard -all;
8use GraphQL::MaybeTypeCheck;
9use JSON::MaybeXS;
10use Carp;
11
12my $JSON = JSON::MaybeXS->new->allow_nonref->canonical;
13
14my @KINDHASH = qw(
15  scalar
16  union
17  field
18  inline_fragment
19  fragment_spread
20  fragment
21  directive
22);
23my %KINDHASH21 = map { ($_ => 1) } @KINDHASH;
24
25my @KINDFIELDS = qw(
26  type
27  input
28  interface
29);
30my %KINDFIELDS21 = map { ($_ => 1) } @KINDFIELDS;
31
32=head1 NAME
33
34GraphQL::Language::Receiver - GraphQL Pegex AST constructor
35
36=head1 VERSION
37
38Version 0.02
39
40=cut
41
42our $VERSION = '0.02';
43
44=head1 SYNOPSIS
45
46  # this class used internally by:
47  use GraphQL::Language::Parser qw(parse);
48  my $parsed = parse($source);
49
50=head1 DESCRIPTION
51
52Subclass of L<Pegex::Receiver> to turn Pegex parsing events into data
53usable by GraphQL.
54
55=cut
56
57method gotrule (Any $param = undef) {
58  return unless defined $param;
59  if ($KINDHASH21{$self->{parser}{rule}}) {
60    return {kind => $self->{parser}{rule}, %{$self->_locate_hash(_merge_hash($param))}};
61  } elsif ($KINDFIELDS21{$self->{parser}{rule}}) {
62    return {kind => $self->{parser}{rule}, %{$self->_locate_hash(_merge_hash($param, 'fields'))}};
63  }
64  return {$self->{parser}{rule} => $param};
65}
66
67method _locate_hash(HashRef $hash) {
68  my ($line, $column) = @{$self->{parser}->line_column($self->{parser}{farthest})};
69  +{ %$hash, location => { line => $line, column => $column } };
70}
71
72fun _merge_hash (Any $param = undef, Any $arraykey = undef) {
73  my %def = map %$_, grep ref eq 'HASH', @$param;
74  if ($arraykey) {
75    my @arrays = grep ref eq 'ARRAY', @$param;
76    Carp::confess "More than one array found\n" if @arrays > 1;
77    Carp::confess "No arrays found but \$arraykey given\n" if !@arrays;
78    my %fields = map %$_, @{$arrays[0]};
79    $def{$arraykey} = \%fields;
80  }
81  \%def;
82}
83
84fun _unescape (Str $str) {
85  # https://facebook.github.io/graphql/June2018/#EscapedCharacter
86  $str =~ s|\\(["\\/bfnrt])|"qq!\\$1!"|gee;
87  return $str;
88}
89
90fun _blockstring_value (Str $str) {
91  # https://facebook.github.io/graphql/June2018/#BlockStringValue()
92  my @lines = split(/(?:\n|\r(?!\r)|\r\n)/s, $str);
93  if (1 < @lines) {
94    my $common_indent;
95    for my $line (@lines[1..$#lines]) {
96      my $length = length($line);
97      my $indent = length(($line =~ /^([\t ]*)/)[0] || '');
98      if ($indent < $length && (!defined($common_indent) || $indent < $common_indent)) {
99        $common_indent = $indent;
100      }
101    }
102    if (defined $common_indent) {
103      for my $line (@lines[1..$#lines]) {
104        $line =~ s/^[\t ]{$common_indent}//;
105      }
106    }
107  }
108  my ($start, $end);
109  for ($start = 0; $start < @lines && $lines[$start] =~ /^[\t ]*$/; ++$start) {}
110  for ($end = $#lines; $end >= 0 && $lines[$end] =~ /^[\t ]*$/; --$end) {}
111  @lines = @lines[$start..$end];
112  my $formatted = join("\n", @lines);
113  $formatted =~ s/\\"""/"""/g;
114  return $formatted;
115}
116
117method got_arguments (Any $param = undef) {
118  return unless defined $param;
119  my %args = map { ($_->[0]{name} => $_->[1]) } @$param;
120  return {$self->{parser}{rule} => \%args};
121}
122
123method got_argument (Any $param = undef) {
124  return unless defined $param;
125  $param;
126}
127
128method got_objectField (Any $param = undef) {
129  return unless defined $param;
130  return {$param->[0]{name} => $param->[1]};
131}
132
133method got_objectValue (Any $param = undef) {
134  return unless defined $param;
135  _merge_hash($param);
136}
137
138method got_objectField_const (Any $param = undef) {
139  unshift @_, $self; goto &got_objectField;
140}
141
142method got_objectValue_const (Any $param = undef) {
143  unshift @_, $self; goto &got_objectValue;
144}
145
146method got_listValue (Any $param = undef) {
147  return unless defined $param;
148  return $param;
149}
150
151method got_listValue_const (Any $param = undef) {
152  unshift @_, $self; goto &got_listValue;
153}
154
155method got_directiveactual (Any $param = undef) {
156  return unless defined $param;
157  _merge_hash($param);
158}
159
160method got_inputValueDefinition (Any $param = undef) {
161  return unless defined $param;
162  my $def = _merge_hash($param);
163  my $name = delete $def->{name};
164  return { $name => $def };
165}
166
167method got_directiveLocations (Any $param = undef) {
168  return unless defined $param;
169  return {locations => [ map $_->{name}, @$param ]};
170}
171
172method got_namedType (Any $param = undef) {
173  return unless defined $param;
174  return $param->{name};
175}
176
177method got_enumValueDefinition (Any $param = undef) {
178  return unless defined $param;
179  my @copy = @$param;
180  my $rest = pop @copy;
181  my $value = pop @copy;
182  my $description = $copy[0] // {};
183  $rest = ref $rest eq 'HASH' ? [ $rest ] : $rest;
184  my %def = (%$description, value => $value, map %$_, @$rest);
185  return \%def;
186}
187
188method got_defaultValue (Any $param = undef) {
189  # the value can be undef
190  return { default_value => $param };
191}
192
193method got_implementsInterfaces (Any $param = undef) {
194  return unless defined $param;
195  return { interfaces => $param };
196}
197
198method got_argumentsDefinition (Any $param = undef) {
199  return unless defined $param;
200  return { args => _merge_hash($param) };
201}
202
203method got_fieldDefinition (Any $param = undef) {
204  return unless defined $param;
205  my $def = _merge_hash($param);
206  my $name = delete $def->{name};
207  return { $name => $def };
208}
209
210method got_typeExtensionDefinition (Any $param = undef) {
211  return unless defined $param;
212  return {kind => 'extend', %{$self->_locate_hash($param)}};
213}
214
215method got_enumTypeDefinition (Any $param = undef) {
216  return unless defined $param;
217  my $def = _merge_hash($param);
218  my %values;
219  map {
220    my $name = ${${delete $_->{value}}};
221    $values{$name} = $_;
222  } @{(grep ref eq 'ARRAY', @$param)[0]};
223  $def->{values} = \%values;
224  return {kind => 'enum', %{$self->_locate_hash($def)}};
225}
226
227method got_unionMembers (Any $param = undef) {
228  return unless defined $param;
229  return { types => $param };
230}
231
232method got_boolean (Any $param = undef) {
233  return unless defined $param;
234  return $param eq 'true' ? JSON->true : JSON->false;
235}
236
237method got_null (Any $param = undef) {
238  return unless defined $param;
239  return undef;
240}
241
242method got_string (Any $param = undef) {
243  return unless defined $param;
244  return $param;
245}
246
247method got_stringValue (Any $param = undef) {
248  return unless defined $param;
249  return _unescape($param);
250}
251
252method got_blockStringValue (Any $param = undef) {
253  return unless defined $param;
254  return _blockstring_value($param);
255}
256
257method got_int (Any $param = undef) {
258  $param+0;
259}
260
261method got_float (Any $param = undef) {
262  $param+0;
263}
264
265method got_enumValue (Any $param = undef) {
266  return unless defined $param;
267  my $varname = $param->{name};
268  return \\$varname;
269}
270
271# not returning empty list if undef
272method got_value_const (Any $param = undef) {
273  return $param;
274}
275
276method got_value (Any $param = undef) {
277  unshift @_, $self; goto &got_value_const;
278}
279
280method got_variableDefinitions (Any $param = undef) {
281  return unless defined $param;
282  my %def;
283  map {
284    my $name = ${ shift @$_ };
285    $def{$name} = { map %$_, @$_ }; # merge
286  } @$param;
287  return {variables => \%def};
288}
289
290method got_variableDefinition (Any $param = undef) {
291  return unless defined $param;
292  return $param;
293}
294
295method got_selection (Any $param = undef) {
296  unshift @_, $self; goto &got_value_const;
297}
298
299method got_typedef (Any $param = undef) {
300  return unless defined $param;
301  $param = $param->{name} if ref($param) eq 'HASH';
302  return {type => $param};
303}
304
305method got_alias (Any $param = undef) {
306  return unless defined $param;
307  return {$self->{parser}{rule} => $param->{name}};
308}
309
310method got_typeCondition (Any $param = undef) {
311  return unless defined $param;
312  return {on => $param};
313}
314
315method got_fragmentName (Any $param = undef) {
316  return unless defined $param;
317  return $param;
318}
319
320method got_selectionSet (Any $param = undef) {
321  return unless defined $param;
322  return {selections => $param};
323}
324
325method got_operationDefinition (Any $param = undef) {
326  return unless defined $param;
327  $param = [ $param ] unless ref $param eq 'ARRAY'; # bare selectionSet
328  return {kind => 'operation', %{$self->_locate_hash(_merge_hash($param))}};
329}
330
331method got_directives (Any $param = undef) {
332  return unless defined $param;
333  return {$self->{parser}{rule} => $param};
334}
335
336method got_graphql (Any $param = undef) {
337  return unless defined $param;
338  return $param;
339}
340
341method got_definition (Any $param = undef) {
342  return unless defined $param;
343  return $param;
344}
345
346method got_operationTypeDefinition (Any $param = undef) {
347  return unless defined $param;
348  return { map { ref($_) ? values %$_ : $_ } @$param };
349}
350
351method got_comment (Any $param = undef) {
352  return unless defined $param;
353  return $param;
354}
355
356method got_description (Any $param = undef) {
357  return unless defined $param;
358  my $string = ref($param) eq 'ARRAY' ? join("\n", @$param) : $param;
359  return $string ? {$self->{parser}{rule} => $string} : {};
360}
361
362method got_schema (Any $param = undef) {
363  return unless defined $param;
364  my $directives = {};
365  if (ref $param->[1] eq 'ARRAY') {
366    # got directives
367    $directives = shift @$param;
368  }
369  my %type2count;
370  $type2count{(keys %$_)[0]}++ for @{$param->[0]};
371  $type2count{$_} > 1 and die "Must provide only one $_ type in schema.\n"
372    for keys %type2count;
373  return {kind => $self->{parser}{rule}, %{$self->_locate_hash(_merge_hash($param->[0]))}, %$directives};
374}
375
376method got_typeSystemDefinition (Any $param = undef) {
377  return unless defined $param;
378  my @copy = @$param;
379  my $node = pop @copy;
380  my $description = $copy[0] // {};
381  +{ %$node, %$description };
382}
383
384method got_typeDefinition (Any $param = undef) {
385  return unless defined $param;
386  return $param;
387}
388
389method got_variable (Any $param = undef) {
390  return unless defined $param;
391  my $varname = $param->{name};
392  return \$varname;
393}
394
395method got_nonNullType (Any $param = undef) {
396  return unless defined $param;
397  $param = $param->[0]; # zap first useless layer
398  $param = { type => $param } if ref $param ne 'HASH';
399  return [ 'non_null', $param ];
400}
401
402method got_listType (Any $param = undef) {
403  return unless defined $param;
404  $param = $param->[0]; # zap first useless layer
405  $param = { type => $param } if ref $param ne 'HASH';
406  return [ 'list', $param ];
407}
408
4091;
410