/
jsParse.ml
699 lines (660 loc) · 24.5 KB
/
jsParse.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
(*
Copyright © 2011, 2012 MLstate
This file is part of Opa.
Opa is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
Opa is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with Opa. If not, see <http://www.gnu.org/licenses/>.
*)
module J = JsAst
module List = BaseList
open JsLex (* bringing token in the scope *)
(* right now, the parser doesn't insert any positions in the ast *)
let dummy_pos = FilePos.nopos "jsParse"
let nl = Annot.next_label
let merge_pos = FilePos.merge_pos_for_parser
let label () = Annot.next_label dummy_pos
let native_ident = JsCons.Ident.native
(* Redefining the module Stream allows us to 'override' the syntax of
* streams. The new peek, junk and empty functions look at the first
* non-newline token (which allows us to write almost the whole parser
* while implicitely discarding newlines).
*
* The new module also ignores comments by default. Since some
* lookahead is needed when parsing JS, these ignored comments are put
* in a queue to be fetched later if necessary.
*
* The parser relies on the lexer invariant: a LT never occurs right
* after a comment. *)
module OriginalStream = Stream
module Stream =
struct
type 'a t = {
stream: 'a Stream.t;
waiting_comments: 'a Queue.t;
mutable waiting_newline: JsLex.token option;
}
exception Failure = Stream.Failure
exception Error = Stream.Error
let from f = {
stream = Stream.from f;
waiting_comments = Queue.create ();
waiting_newline = None;
}
let wrap stream = {
stream;
waiting_comments = Queue.create ();
waiting_newline = None;
}
(* The *no_*_ignore variants do not skip newlines or comments *)
let peek_no_newline_ignore stream =
match stream.waiting_newline with
| Some _ as token -> token
| None ->
let rec loop () =
match Stream.peek stream.stream with
| Some (DocComment _ as token) ->
Queue.add token stream.waiting_comments;
Stream.junk stream.stream;
loop ()
| o -> o
in loop ()
let peek_no_comment_ignore stream =
if Queue.is_empty stream.waiting_comments then
let rec loop () =
match Stream.peek stream.stream with
| Some (LT _) as o ->
stream.waiting_newline <- o;
Stream.junk stream.stream;
Stream.peek stream.stream (* Using the invariant *)
| o -> o
in loop ()
else
Some (Queue.peek stream.waiting_comments)
let peek stream =
let rec loop () =
match Stream.peek stream.stream with
| Some (LT _ as token) ->
stream.waiting_newline <- Some token;
Stream.junk stream.stream;
loop ()
| Some (DocComment _ as token) ->
Queue.add token stream.waiting_comments;
Stream.junk stream.stream;
loop ()
| o -> o
in loop ()
let junk_no_newline_ignore stream =
match stream.waiting_newline with
| Some _ -> stream.waiting_newline <- None
| None ->
Queue.clear stream.waiting_comments;
let rec loop () =
match Stream.peek stream.stream with
| Some (DocComment _) ->
Stream.junk stream.stream;
loop ()
| _ ->
Stream.junk stream.stream
in loop ()
let junk_no_comment_ignore stream =
begin match stream.waiting_newline with
| Some _ -> stream.waiting_newline <- None
| None -> ()
end;
if Queue.is_empty stream.waiting_comments then
Stream.junk stream.stream
else
ignore (Queue.take stream.waiting_comments)
let junk stream =
(* At junk, we assume that all tokens that have been ignored and
held can be discarded *)
stream.waiting_newline <- None;
Queue.clear stream.waiting_comments;
let rec loop () =
match Stream.peek stream.stream with
| Some (LT _ | DocComment _) ->
Stream.junk stream.stream;
loop ()
| _ -> Stream.junk stream.stream
in loop ()
(* redefining empty because a stream with only a newline must be considered
* as empty *)
let empty s =
match peek_no_comment_ignore s with
| None -> ()
| Some _ -> raise Stream.Failure
end
type tok_stream = JsLex.token Stream.t
type pos = FilePos.pos
type statement = J.statement
type expr = J.expr
(* a handful of parser combinators *)
let rev_list0_aux acc parser_ stream =
let rec aux acc = parser
| [< e = parser_; stream >] -> aux (e :: acc) stream
| [< >] -> acc in
aux acc stream
let rev_list0 parser_ stream =
rev_list0_aux [] parser_ stream
let list0 parser_ stream =
List.rev (rev_list0 parser_ stream)
let rev_list1 parser_ = parser
| [< v = parser_; r = rev_list0_aux [v] parser_ >] -> r
let list1 parser_ = parser
| [< v = parser_; l = list0 parser_ >] -> v :: l
let rev_list1_sep parser_ sep stream =
let rec aux acc = parser
| [< _op = sep; e = parser_; stream >] -> aux (e :: acc) stream
| [< >] -> acc in
match stream with parser
| [< e = parser_; stream >] -> aux [e] stream
let list1_sep_left_assoc parser_ sep stream =
let rec aux pos acc = parser
| [< op = sep; e = parser_; stream >] ->
let pos' = J.JPos.expr e in
let pos = merge_pos pos pos' in
aux pos (J.Je_binop (nl pos,op,acc,e)) stream
| [< >] -> acc in
match stream with parser
| [< e = parser_; stream >] ->
let pos = J.JPos.expr e in
aux pos e stream
let list1_sep_right_assoc parser_ sep stream =
let rec aux pos acc = parser
| [< op = sep; e = parser_; stream >] ->
let pos' = J.JPos.expr e in
let pos = merge_pos pos pos' in
aux pos ((pos, op, e) :: acc) stream
| [< >] -> acc in
match stream with parser
| [< r = parser_; stream >] ->
let pos = J.JPos.expr r in
match aux pos [] stream with
| [] -> r
| (pos, op, e) :: t ->
let pos, op, e =
List.fold_left (fun (pos1, op1, e1) (pos2, op2, e2) ->
let pos = merge_pos pos1 pos2 in
(pos, op2, J.Je_binop (nl pos,op1,e2,e1))
) (pos,op,e) t in
J.Je_binop(nl pos, op, r, e)
let rev_list0_sep parser_ sep stream =
let rec aux acc = parser
| [< _ = sep; v = parser_; stream >] -> aux (v :: acc) stream
| [< >] -> acc in
match stream with parser
| [< r = parser_; stream >] -> aux [r] stream
| [< >] -> []
let list1_sep parser_ sep stream = List.rev (rev_list1_sep parser_ sep stream)
let list0_sep parser_ sep stream = List.rev (rev_list0_sep parser_ sep stream)
let option parser_ = parser
| [< r = parser_ >] -> Some r
| [< >] -> None
let option_default default parser_ = parser
| [< r = parser_ >] -> r
| [< >] -> default
(* tries to parse using [parser_] but only when there is no newline
* in the input stream
* for cases such as [return
* 2]
* which is parsed as [return; 2] and not [return 2] *)
let option_no_newline parser_ stream =
match Stream.peek_no_newline_ignore stream with
| Some (LT _)-> None
| _ -> option parser_ stream
let doc_comment stream =
match Stream.peek_no_comment_ignore stream with
| Some (DocComment (pos, lines, _)) ->
Stream.junk_no_comment_ignore stream;
(pos, lines)
| _ -> raise Stream.Failure
let semic stream =
match Stream.peek_no_newline_ignore stream with
| None -> ()
| Some (Semic _ | LT _) ->
Stream.junk_no_newline_ignore stream
| Some (Rcurly _) -> () (* do not discard the bracket! *)
| _ -> raise Stream.Failure
let ident = parser
| [< 'Ident (pos, i) >] -> (pos, i)
let native = parser
| [< 'Ident (pos, i) >] -> (pos, native_ident i)
let comma = parser
| [< 'Comma _ >] -> ()
let barbar = parser
| [< 'BarBar _ >] -> J.Jb_lor
let amperamper = parser
| [< 'AmperAmper _ >] -> J.Jb_land
let bar = parser
| [< 'Bar _ >] -> J.Jb_or
let chapeau = parser
| [< 'Chapeau _ >] -> J.Jb_xor
let amper = parser
| [< 'Amper _ >] -> J.Jb_and
let assignmentoperator = parser
| [< 'TimesEqual _ >] -> J.Jb_mul_assign
| [< 'PlusEqual _ >] -> J.Jb_add_assign
| [< 'PercentEqual _ >] -> J.Jb_mod_assign
| [< 'MinusEqual _ >] -> J.Jb_sub_assign
| [< 'LtLtEqual _ >] -> J.Jb_lsl_assign
| [< 'GtGtGtEqual _ >] -> J.Jb_asr_assign
| [< 'GtGtEqual _ >] -> J.Jb_lsr_assign
| [< 'Equal _ >] -> J.Jb_assign
| [< 'DivEqual _ >] -> J.Jb_div_assign
| [< 'ChapeauEqual _ >] -> J.Jb_xor_assign
| [< 'BarEqual _ >] -> J.Jb_or_assign
| [< 'AmperEqual _ >] -> J.Jb_and_assign
let equalityoperator = parser
| [< 'EqualEqual _ >] -> J.Jb_eq
| [< 'EqualEqualEqual _ >] -> J.Jb_seq
| [< 'BangEqual _ >] -> J.Jb_neq
| [< 'BangEqualEqual _ >] -> J.Jb_sneq
let relationaloperator = parser
| [< 'Lt _ >] -> J.Jb_lt
| [< 'Gt _ >] -> J.Jb_gt
| [< 'Le _ >] -> J.Jb_leq
| [< 'Ge _ >] -> J.Jb_geq
| [< 'Instanceof _ >] -> J.Jb_instanceof
| [< 'In _ >] -> J.Jb_in
let shiftoperator = parser
| [< 'LtLt _ >] -> J.Jb_lsl
| [< 'GtGt _ >] -> J.Jb_lsr
| [< 'GtGtGt _ >] -> J.Jb_asr
let additiveoperator = parser
| [< 'Plus _ >] -> J.Jb_add
| [< 'Minus _ >] -> J.Jb_sub
let multiplicativeoperator = parser
| [< 'Times _ >] -> J.Jb_mul
| [< 'Div _ >] -> J.Jb_div
| [< 'Percent _ >] -> J.Jb_mod
let unaryoperator = parser
| [< 'PlusPlus pos >] -> (pos, J.Ju_add2_pre)
| [< 'Delete pos >] -> (pos, J.Ju_delete)
| [< 'Typeof pos >] -> (pos, J.Ju_typeof)
| [< 'Void pos >] -> (pos, J.Ju_void)
| [< 'MinusMinus pos >] -> (pos, J.Ju_sub2_pre)
| [< 'Plus pos >] -> (pos, J.Ju_add_pre)
| [< 'Minus pos >] -> (pos, J.Ju_sub_pre)
| [< 'Tilda pos >] -> (pos, J.Ju_tilde)
| [< 'Bang pos >] -> (pos, J.Ju_not)
let postfixoperator = parser
| [< 'PlusPlus pos >] -> (pos, J.Ju_add2_post)
| [< 'MinusMinus pos >] -> (pos, J.Ju_sub2_post)
let rec statement stream =
match stream with parser
| [< (pos, lines) = doc_comment >] ->
J.Js_comment (nl pos, J.Jc_doc (nl pos, lines))
| [< 'Function pos1;
'Ident (_, name) ?? "expected an identifier after 'function' in a statement";
'Lparen _; params = list0_sep native comma; 'Rparen _;
'Lcurly _; body = statements; 'Rcurly pos2 >] ->
let pos = merge_pos pos1 pos2 in
let params = List.map snd params in
J.Js_function (nl pos, native_ident name, params, body)
| [< 'Lcurly pos1; block = statements;
'Rcurly pos2 ?? "expected a closing curly brace" >] ->
let pos = merge_pos pos1 pos2 in
J.Js_block (nl pos, block)
| [< 'Semic pos >] -> J.Js_empty (nl pos)
| [< 'Var pos1; l = list1_sep vardeclaration comma; _ = semic >] -> (
let (pos2, _, _) = List.last l in
let pos = merge_pos pos1 pos2 in
match l with
| [(_,i,o)] -> J.Js_var (nl pos, i, o)
| _ ->
let pos = merge_pos pos1 pos2 in
let decls = List.map (fun (p,i,o) -> J.Js_var (nl p, i, o)) l in
J.Js_block (nl pos, decls)
)
| [< 'If pos1; 'Lparen _; e = expr; 'Rparen _; s1 = statement; stream >] ->
let o, pos =
match stream with parser
| [< 'Else _; s2 = statement >] ->
Some s2, merge_pos pos1 (J.JPos.stm s2)
| [< >] -> None, merge_pos pos1 (J.JPos.stm s1) in
J.Js_if (nl pos,e,s1,o)
| [< 'Do pos1; s = statement; 'While _; 'Lparen _; e = expr; 'Rparen pos2; _ = semic >] ->
let pos = merge_pos pos1 pos2 in
J.Js_dowhile (nl pos, s, e)
| [< 'While pos1; 'Lparen _; e = expr; 'Rparen _; s = statement >] ->
let pos = merge_pos pos1 (J.JPos.stm s) in
J.Js_while (nl pos, e, s)
| [< 'For pos1; 'Lparen _; stream >] -> (
match stream with parser
| [< 'Var pos1'; (pos2',i,o) = vardeclaration; stream >] -> (
let pos_var = merge_pos pos1' pos2' in
match o with
| Some (J.Je_binop (_,J.Jb_in,e1,e2)) -> (
match stream with parser
| [< 'Rparen _; s = statement >] ->
let s1 = J.Js_var (nl pos_var, i, Some e1) in
let pos_for = merge_pos pos1 (J.JPos.stm s) in
let s2 =
J.Js_forin (nl pos_for, J.Je_ident (nl pos_var,i), e2, s) in
J.Js_block (nl pos_for, [s1; s2])
)
| _ ->
match stream with parser
| [< 'In _; e2 = expr; 'Rparen _; s = statement >] ->
let s1 = J.Js_var (nl pos_var, i, o) in
let pos_for = merge_pos pos1 (J.JPos.stm s) in
let s2 =
J.Js_forin (nl pos_for, J.Je_ident (nl pos_var, i), e2, s) in
J.Js_block (nl pos_for, [s1; s2])
| [< 'Comma _; l = list1_sep vardeclaration comma; 'Semic _;
e2 = option expr; 'Semic _; e3 = option expr; 'Rparen _;
s = statement >] ->
let s1 = J.Js_var (nl pos2', i, o) in
let s1_more = List.map (fun (p,i,o) ->
J.Js_var (nl p,i,o)
) l in
let pos_for = merge_pos pos1 (J.JPos.stm s) in
let s2 = J.Js_for (nl pos_for, None, e2, e3, s) in
J.Js_block (nl pos_for, s1 :: s1_more @ [s2])
| [< 'Semic _; e2 = option expr; 'Semic _; e3 = option expr;
'Rparen _; s = statement >] ->
let s1 = J.Js_var (nl pos_var, i, o) in
let pos_for = merge_pos pos1 (J.JPos.stm s) in
let s2 = J.Js_for (nl pos_for, None, e2, e3, s) in
J.Js_block (nl pos_for, [s1;s2])
)
| [< o1 = option expr; stream >] -> (
match o1 with
| Some J.Je_binop (_,J.Jb_in,e1,e2) -> (
match stream with parser
| [< 'Rparen _; s = statement >] ->
let pos_for = merge_pos pos1 (J.JPos.stm s) in
J.Js_forin (nl pos_for, e1, e2, s)
)
| _ ->
match stream with parser
| [< 'Semic _; e2 = option expr; 'Semic _; e3 = option expr;
'Rparen _; s = statement >] ->
let pos_for = merge_pos pos1 (J.JPos.stm s) in
J.Js_for (nl pos_for, o1, e2, e3, s)
)
)
| [< 'Continue pos1; o = option_no_newline ident; _ = semic >] ->
let pos2 =
match o with
| Some (pos2, _) -> pos2
| None -> pos1 in
let pos = merge_pos pos1 pos2 in
J.Js_continue (nl pos, Option.map snd o)
| [< 'Break pos1; o = option_no_newline ident; _ = semic >] ->
let pos2 =
match o with
| Some (pos2, _) -> pos2
| None -> pos1 in
let pos = merge_pos pos1 pos2 in
J.Js_break (nl pos, Option.map snd o)
| [< 'Return pos1; o = option_no_newline expr; _ = semic >] ->
let pos2 =
match o with
| Some expr -> J.JPos.expr expr
| None -> pos1 in
let pos = merge_pos pos1 pos2 in
J.Js_return (nl pos, o)
| [< 'With pos1; 'Lparen _; e = expr; 'Rparen _; s = statement >] ->
let pos = merge_pos pos1 (J.JPos.stm s) in
J.Js_with (nl pos,e,s)
| [< 'Switch pos1; 'Lparen _; e = expr; 'Rparen _;
'Lcurly _; clauses = list0 caseclause; default = option defaultclause;
'Rcurly pos2 >] ->
let pos = merge_pos pos1 pos2 in
J.Js_switch (nl pos,e,clauses,default)
| [< 'Throw pos1; e = expr; _ = semic >] ->
let pos2 = J.JPos.expr e in
let pos = merge_pos pos1 pos2 in
J.Js_throw (nl pos,e)
(* the specification seems crazy, where is the problem with a newline here? *)
| [< 'Debugger _ >] -> (*SDebugger*) failwith "No ast node for \"debugger\""
| [< 'Try pos1; b = block_stm; stream >] -> (
let pos2 = J.JPos.stm b in
let pos = merge_pos pos1 pos2 in
match stream with parser
| [< (i,s) = catch_block; o = option finally >] ->
J.Js_trycatch (nl pos, b, [(i,None,s)], o)
| [< c = finally >] ->
J.Js_trycatch (nl pos, b, [], Some c)
)
| [< e = expr; stream >] ->
match stream with parser
| [< 'Colon _; s = statement >] -> (
match e with
| J.Je_ident (label,i) -> (
match i with
| J.Native (_, i) -> J.Js_label (label,i,s)
| _ -> assert false
)
| _ -> raise (Stream.Error "Invalid label")
)
| [< _ = semic >] -> J.Js_expr (nl (J.JPos.expr e), e)
and block = parser
| [< 'Lcurly pos1; l = statements; 'Rcurly pos2 >] ->
(merge_pos pos1 pos2, l)
and block_stm stream =
let (pos, b) = block stream in
J.Js_block (nl pos, b)
and vardeclaration = parser
| [< 'Ident (pos1, i); stream >] ->
match stream with parser
| [< 'Equal _; e = assignmentexpr >] ->
let pos2 = J.JPos.expr e in
let pos = FilePos.merge_pos_for_parser pos1 pos2 in
(pos, native_ident i, Some e)
| [< >] -> (pos1, native_ident i, None)
and caseclause = parser
| [< 'Case _; e = expr; 'Colon _; l = statements_stm >] -> (e, l)
and defaultclause = parser
| [< 'Default _; 'Colon _; l = statements_stm >] -> l
and catch_block = parser
| [< 'Catch _; 'Lparen _; 'Ident (_, i); 'Rparen _; b = block_stm >] -> (native_ident i,b)
and finally = parser
| [< 'Finally _; b = block_stm >] -> b
and expr stream : expr =
match rev_list1_sep assignmentexpr comma stream with
| [] -> assert false
| [e] -> e
| e :: l ->
let pos1 = J.JPos.expr (List.last l) in
let pos = merge_pos pos1 (J.JPos.expr e) in
J.Je_comma (nl pos, List.rev l, e)
and assignmentexpr stream : expr =
list1_sep_right_assoc conditionalexpr assignmentoperator stream
and conditionalexpr : tok_stream -> expr = parser
| [< e = logicalorexpr; stream >] ->
match stream with parser
| [< 'Question _; e2 = assignmentexpr; 'Colon _; e3 = conditionalexpr >] ->
let pos1 = J.JPos.expr e in
let pos2 = J.JPos.expr e3 in
let pos = merge_pos pos1 pos2 in
J.Je_cond (nl pos, e, e2, e3)
| [< >] -> e
and logicalorexpr stream : expr =
list1_sep_left_assoc logicalandexpr barbar stream
and logicalandexpr stream : expr =
list1_sep_left_assoc bitwiseorexpr amperamper stream
and bitwiseorexpr stream : expr =
list1_sep_left_assoc bitwisexorexpr bar stream
and bitwisexorexpr stream : expr =
list1_sep_left_assoc bitwiseandexpr chapeau stream
and bitwiseandexpr stream : expr =
list1_sep_left_assoc equalityexpr amper stream
and equalityexpr stream : expr =
list1_sep_left_assoc relationalexpr equalityoperator stream
and relationalexpr stream : expr =
list1_sep_left_assoc shiftexpr relationaloperator stream
and shiftexpr stream : expr =
list1_sep_left_assoc additiveexpr shiftoperator stream
and additiveexpr stream : expr =
list1_sep_left_assoc multiplicativeexpr additiveoperator stream
and multiplicativeexpr stream : expr =
list1_sep_left_assoc unaryexpr multiplicativeoperator stream
and unaryexpr : tok_stream -> expr = parser
| [< l = rev_list1 unaryoperator;
e = postfixexpr ?? "expected an expression after a postfix operator" >] ->
List.fold_left (fun e (pos2, op) ->
let pos1 = J.JPos.expr e in
let pos = merge_pos pos1 pos2 in
J.Je_unop (nl pos,op,e)
) e l
| [< e = postfixexpr >] -> e
and postfixexpr : tok_stream -> expr = parser
| [< e = lefthandsideexpr false; o = option_no_newline postfixoperator >] ->
match o with
| None -> e
| Some (pos1, op) ->
let pos2 = J.JPos.expr e in
let pos = merge_pos pos1 pos2 in
J.Je_unop (nl pos, op, e)
and lefthandsideexpr new_ : tok_stream -> expr = parser
| [< 'New pos1; e = lefthandsideexpr true; stream >] -> (
let pos2 = J.JPos.expr e in
match stream with parser
| [< (pos2, el) = option_default (pos2, []) arguments; stream >] ->
let pos = merge_pos pos1 pos2 in
let e = J.Je_new (nl pos, e, el) in
dot_hashref_call true e stream
)
| [< 'Function pos1; name = option native; 'Lparen _;
params = list0_sep native comma; 'Rparen _; 'Lcurly _;
body = statements; 'Rcurly pos2; stream >] ->
let name = Option.map snd name in
let params = List.map snd params in
let pos = merge_pos pos1 pos2 in
(* put the this rule into primaryexpr instead? *)
let e = J.Je_function (nl pos, name, params, body) in
dot_hashref_call (not new_) e stream
| [< e = primaryexpr; r = dot_hashref_call (not new_) e >] -> r
and dot_hashref_call can_call (e : expr) stream : expr =
let pos1 = J.JPos.expr e in
match stream with parser
| [< 'Dot _; 'Ident (pos2, i); stream >] ->
let pos = merge_pos pos1 pos2 in
dot_hashref_call can_call (J.Je_dot (nl pos, e, i)) stream
| [< 'Lbracket _; i = expr; 'Rbracket pos2; stream >] ->
let pos = merge_pos pos1 pos2 in
dot_hashref_call can_call (J.Je_binop (nl pos,J.Jb_hashref,e,i)) stream
| [< 'Lparen _ when can_call; l = list0_sep assignmentexpr comma; 'Rparen pos2; stream >] ->
(* refusing to parse arguments when under a new because in [new f()], the arguments are given to new_
* not to f *)
let pos = merge_pos pos1 pos2 in
dot_hashref_call can_call (J.Je_call (nl pos,e,l,false)) stream
| [< >] -> e
and arguments : tok_stream -> pos * expr list = parser
| [< 'Lparen pos1; l = list0_sep assignmentexpr comma; 'Rparen pos2 >] ->
(merge_pos pos1 pos2, l)
and primaryexpr : tok_stream -> expr = parser
| [< 'Null pos >] -> J.Je_null (nl pos)
| [< 'This pos >] -> J.Je_this (nl pos)
| [< 'Ident (pos, i) >] -> J.Je_ident (nl pos, native_ident i)
| [< 'Integer (pos, i) >] -> J.Je_num (nl pos, i)
| [< 'True pos >] -> J.Je_bool (nl pos, true)
| [< 'False pos >] -> J.Je_bool (nl pos, false)
| [< 'String (pos, s) >] -> J.Je_string (nl pos, s, true)
| [< 'Lbracket pos1; l = list0_sep assignmentexpr comma; 'Rbracket pos2 >] ->
let pos = merge_pos pos1 pos2 in
J.Je_array (nl pos, l)
| [< 'Lcurly pos1; l = list0_sep property_assignment comma; _ = option comma;
'Rcurly pos2 >] ->
let pos = merge_pos pos1 pos2 in
J.Je_object(nl pos, l)
| [< 'Lparen _; e = expr; 'Rparen _ >] -> e
| [< 'Regexp (pos,s1,s2) >] -> J.Je_regexp (nl pos,s1,s2)
and statements (stream : tok_stream) : statement list =
list0 statement stream
and statements_stm (stream : tok_stream) : statement =
J.Js_block (label(),statements stream)
and property_name : tok_stream -> string = parser
| [< 'Ident (_, i) >] -> i
| [< 'String (_, s) >] -> s
| [< 'Integer (_, i) >] -> i
and property_assignment : tok_stream -> string * expr = parser
| [< p = property_name; 'Colon _; e = assignmentexpr >] ->
(p,e)
let code stream =
let stream = Stream.wrap stream in
match stream with parser
| [< r = statements; _ = Stream.empty >] -> r
let expr stream =
let stream = Stream.wrap stream in
match stream with parser
| [< e = expr; _ = Stream.empty >] -> e
let stm stream =
let stream = Stream.wrap stream in
match stream with parser
| [< s = statement; _ = Stream.empty >] -> s
type error =
(** Error while actually trying to parse file *)
| ParseError of int * int * string * string
(** IO error (i.e. couldn't open file) *)
| FileError of string
exception Exception of error
let pp f = function
| ParseError (start, end_, lexem, s) ->
Format.fprintf f "Parse error at %d-%d on %S%s"
start
end_
lexem
(if s = "" then s else ": " ^ s)
| FileError filename ->
Format.fprintf f "Could not open file %s" filename
let build_parser ?(throw_exn=false) ?(globalize=fun x -> x)
(parser_ : JsLex.token OriginalStream.t -> 'a) (stream,lexbuf) : 'a =
try
let code = parser_ stream in
globalize code
with Stream.Error s ->
let error = ParseError
(Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf,
Lexing.lexeme lexbuf, s) in
if throw_exn then
raise (Exception error)
else (
Format.eprintf "%a@." pp error;
exit 1
)
let global_expr ?(globalize=false) expr =
if globalize then
JsWalk.Expr.map (
function
| J.Je_ident (loc, J.Native (`local, id)) ->
J.Je_ident (loc, J.Native (`global false, id))
| e -> e
) expr
else
expr
let stream_of_file ?comments file =
try
JsLex.stream_of_file ?comments file
with
| Unix.Unix_error _ -> raise (Exception (FileError file))
module String =
struct
let code ?comments ?filename ?throw_exn str =
build_parser ?throw_exn code
(JsLex.stream_of_string ?filename ?comments str)
let expr ?comments ?filename ?throw_exn ?globalize str =
build_parser ?throw_exn ~globalize:(global_expr ?globalize)
expr (JsLex.stream_of_string ?filename ?comments str)
let stm ?comments ?filename ?throw_exn str =
build_parser ?throw_exn stm
(JsLex.stream_of_string ?filename ?comments str)
end
module File =
struct
let code ?comments ?throw_exn file =
build_parser ?throw_exn code (stream_of_file ?comments file)
let expr ?comments ?throw_exn ?globalize file =
build_parser ?throw_exn ~globalize:(global_expr ?globalize) expr
(stream_of_file ?comments file)
let stm ?comments ?throw_exn file =
build_parser ?throw_exn stm (stream_of_file ?comments file)
end