-
Notifications
You must be signed in to change notification settings - Fork 482
Expand file tree
/
Copy pathres_core.ml
More file actions
7543 lines (7242 loc) · 251 KB
/
res_core.ml
File metadata and controls
7543 lines (7242 loc) · 251 KB
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
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
module Doc = Res_doc
module Grammar = Res_grammar
module Token = Res_token
module Diagnostics = Res_diagnostics
module CommentTable = Res_comments_table
module ResPrinter = Res_printer
module Scanner = Res_scanner
module Parser = Res_parser
let mk_loc start_loc end_loc =
Location.{loc_start = start_loc; loc_end = end_loc; loc_ghost = false}
let rec skip_doc_comments p =
match p.Parser.token with
| DocComment _ ->
Parser.next p;
skip_doc_comments p
| _ -> ()
type inline_type_definition = {
name: string;
loc: Warnings.loc;
kind: Parsetree.type_kind;
params: (Parsetree.core_type * Asttypes.variance) list;
}
type inline_types_context = {
mutable found_inline_types: inline_type_definition list;
mutable params: (Parsetree.core_type * Asttypes.variance) list;
collect_free_type_vars: bool;
}
let extend_current_type_name_path current_type_name_path field_name =
match current_type_name_path with
| None -> None
| Some path -> Some (path @ [field_name])
let inline_type_name_exists inline_types_context inline_type_name =
inline_types_context.found_inline_types
|> List.exists (fun inline_type -> inline_type.name = inline_type_name)
let inline_type_param_exists params param_name =
params
|> List.exists (fun (param, _) ->
match param.Parsetree.ptyp_desc with
| Ptyp_var existing_name -> existing_name = param_name
| _ -> false)
let maybe_track_inline_type_param inline_types_context name loc =
match inline_types_context with
| Some inline_types_context
when inline_types_context.collect_free_type_vars
&& not (inline_type_param_exists inline_types_context.params name) ->
inline_types_context.params <-
inline_types_context.params
@ [(Ast_helper.Typ.var ~loc name, Asttypes.Invariant)]
| _ -> ()
let make_inline_record_type_name current_type_name_path inline_types_context
~base =
let extend name = extend_current_type_name_path current_type_name_path name in
let rec loop suffix =
let candidate = base ^ suffix in
match (current_type_name_path, inline_types_context) with
| Some prefix, Some inline_types_context ->
let full_name = String.concat "." (prefix @ [candidate]) in
if inline_type_name_exists inline_types_context full_name then
loop (suffix ^ "$")
else extend candidate
| _ -> extend candidate
in
loop ""
let make_inline_record_return_type_name current_type_name_path
inline_types_context =
make_inline_record_type_name current_type_name_path inline_types_context
~base:"return.type"
let make_inline_record_argument_type_name current_type_name_path
inline_types_context index =
make_inline_record_type_name current_type_name_path inline_types_context
~base:("arg" ^ string_of_int index)
module Recover = struct
let default_expr () =
let id = Location.mknoloc "rescript.exprhole" in
Ast_helper.Exp.mk (Pexp_extension (id, PStr []))
let default_type () =
let id = Location.mknoloc "rescript.typehole" in
Ast_helper.Typ.extension (id, PStr [])
let default_pattern () =
let id = Location.mknoloc "rescript.patternhole" in
Ast_helper.Pat.extension (id, PStr [])
let default_module_expr () = Ast_helper.Mod.structure []
let default_module_type () = Ast_helper.Mty.signature []
let default_signature_item =
let id = Location.mknoloc "rescript.sigitemhole" in
Ast_helper.Sig.extension (id, PStr [])
let recover_equal_greater p =
Parser.expect EqualGreater p;
match p.Parser.token with
| MinusGreater -> Parser.next p
| _ -> ()
let should_abort_list_parse p =
let rec check breadcrumbs =
match breadcrumbs with
| [] -> false
| (grammar, _) :: rest ->
if Grammar.is_part_of_list grammar p.Parser.token then true
else check rest
in
check p.breadcrumbs
end
module ErrorMessages = struct
let list_pattern_spread =
"List pattern matches only supports one `...` spread, at the end.\n\
Explanation: a list spread at the tail is efficient, but a spread in the \
middle would create new lists; out of performance concern, our pattern \
matching currently guarantees to never create new intermediate data."
let record_pattern_spread =
"Record spread (`...`) is not supported in pattern matches.\n\
Explanation: you can't collect a subset of a record's field into its own \
record, since a record needs an explicit declaration and that subset \
wouldn't have one.\n\
Solution: you need to pull out each field you want explicitly."
(* let recordPatternUnderscore = "Record patterns only support one `_`, at the end." *)
[@@live]
let array_pattern_spread =
"Array spread (`...`) is not supported in pattern matches.\n\n\
Explanation: Allowing `...` here would require creating a new subarray at \
match time, but for performance reasons pattern matching is guaranteed to \
never create intermediate data.\n\n\
Possible solutions:\n\
- To validate specific elements: Use `if` with length checks and \
`Array.get`\n\
- To extract a subarray: Use `Array.slice`"
let record_expr_spread =
"Records can only have one `...` spread, at the beginning.\n\
Explanation: since records have a known, fixed shape, a spread like `{a, \
...b}` wouldn't make sense, as `b` would override every field of `a` \
anyway."
let dict_expr_spread = "Dict literals do not support spread (`...`) yet."
let record_field_missing_colon =
"Records use `:` when assigning fields. Example: `{field: value}`"
let record_pattern_field_missing_colon =
"Record patterns use `:` when matching fields. Example: `{field: value}`"
let record_type_field_missing_colon =
"Record fields in type declarations use `:`. Example: `{field: string}`"
let dict_field_missing_colon =
"Dict entries use `:` to separate keys from values. Example: `{\"k\": v}`"
let labelled_argument_missing_equal =
"Use `=` to pass a labelled argument. Example: `~label=value`"
let optional_labelled_argument_missing_equal =
"Optional labelled arguments use `=?`. Example: `~label=?value`"
let variant_ident =
"A polymorphic variant (e.g. #id) must start with an alphabetical letter \
or be a number (e.g. #742)"
let experimental_if_let expr =
let switch_expr = {expr with Parsetree.pexp_attributes = []} in
Doc.concat
[
Doc.text "If-let is currently highly experimental.";
Doc.line;
Doc.text "Use a regular `switch` with pattern matching instead:";
Doc.concat
[
Doc.hard_line;
Doc.hard_line;
ResPrinter.print_expression switch_expr CommentTable.empty;
];
]
|> Doc.to_string ~width:80
let experimental_let_unwrap_rec =
"let? is not allowed to be recursive. Use a regular `let` or remove `rec`."
let experimental_let_unwrap_sig =
"let? is not allowed in signatures. Use a regular `let` instead."
let type_param =
"A type param consists of a singlequote followed by a name like `'a` or \
`'A`"
let type_var =
"A type variable consists of a singlequote followed by a name like `'a` or \
`'A`"
let attribute_without_node (attr : Parsetree.attribute) =
let {Asttypes.txt = attr_name}, _ = attr in
"Did you forget to attach `" ^ attr_name
^ "` to an item?\n Standalone attributes start with `@@` like: `@@"
^ attr_name ^ "`"
let type_declaration_name_longident longident =
"A type declaration's name cannot contain a module access. Did you mean `"
^ Longident.last longident ^ "`?"
let tuple_single_element = "A tuple needs at least two elements"
let missing_tilde_labeled_parameter name =
if name = "" then "A labeled parameter starts with a `~`."
else "A labeled parameter starts with a `~`. Did you mean: `~" ^ name ^ "`?"
let string_interpolation_in_pattern =
"String interpolation is not supported in pattern matching."
let object_quoted_field_name name =
"An object type declaration needs quoted field names. Did you mean \""
^ name ^ "\"?"
let forbidden_inline_record_declaration =
"An inline record type declaration is only allowed in a variant \
constructor's declaration or nested inside of a record type declaration"
let poly_var_int_with_suffix number =
"A numeric polymorphic variant cannot be followed by a letter. Did you \
mean `#" ^ number ^ "`?"
let multiple_inline_record_definitions_at_same_path =
"Only one inline record definition is allowed per record field. This \
defines more than one inline record."
let keyword_field_in_expr keyword_txt =
"Cannot use keyword `" ^ keyword_txt
^ "` as a record field name. Suggestion: rename it (e.g. `" ^ keyword_txt
^ "_`)"
let keyword_field_in_pattern keyword_txt =
"Cannot use keyword `" ^ keyword_txt
^ "` here. Keywords are not allowed as record field names."
let keyword_field_in_type keyword_txt =
"Cannot use keyword `" ^ keyword_txt
^ "` as a record field name. Suggestion: rename it (e.g. `" ^ keyword_txt
^ "_`)\n If you need the field to be \"" ^ keyword_txt
^ "\" at runtime, annotate the field: `@as(\"" ^ keyword_txt ^ "\") "
^ keyword_txt ^ "_ : ...`"
let type_definition_in_function =
"Type definitions are not allowed inside functions.\n"
^ " Move this `type` declaration to the top level or into a module."
let spread_children_no_longer_supported =
"Spreading JSX children is no longer supported."
end
module InExternal = struct
let status = ref false
end
let ternary_attr = (Location.mknoloc "res.ternary", Parsetree.PStr [])
let if_let_attr = (Location.mknoloc "res.iflet", Parsetree.PStr [])
let make_await_attr loc = (Location.mkloc "res.await" loc, Parsetree.PStr [])
let suppress_fragile_match_warning_attr =
( Location.mknoloc "warning",
Parsetree.PStr
[
Ast_helper.Str.eval
(Ast_helper.Exp.constant (Pconst_string ("-4", None)));
] )
let make_braces_attr loc = (Location.mkloc "res.braces" loc, Parsetree.PStr [])
let template_literal_attr = (Location.mknoloc "res.template", Parsetree.PStr [])
let make_pat_variant_spread_attr =
(Location.mknoloc "res.patVariantSpread", Parsetree.PStr [])
let tagged_template_literal_attr =
(Location.mknoloc "res.taggedTemplate", Parsetree.PStr [])
let spread_attr = (Location.mknoloc "res.spread", Parsetree.PStr [])
type argument = {label: Asttypes.arg_label; expr: Parsetree.expression}
type type_parameter = {
attrs: Ast_helper.attrs;
label: Asttypes.arg_label;
typ: Parsetree.core_type;
start_pos: Lexing.position;
}
type typ_def_or_ext =
| TypeDef of {
rec_flag: Asttypes.rec_flag;
types: Parsetree.type_declaration list;
}
| TypeExt of Parsetree.type_extension
type fundef_type_param = {
attrs: Parsetree.attributes;
locs: string Location.loc list;
p_pos: Lexing.position;
}
type fundef_term_param = {
attrs: Parsetree.attributes;
p_label: Asttypes.arg_label;
expr: Parsetree.expression option;
pat: Parsetree.pattern;
p_pos: Lexing.position;
}
(* Single parameter of a function definition (type a b, x, ~y) *)
type fundef_parameter =
| TermParameter of fundef_term_param
| TypeParameter of fundef_type_param
type record_pattern_item =
| PatUnderscore
| PatField of Parsetree.pattern Parsetree.record_element
type context = OrdinaryExpr | TernaryTrueBranchExpr | WhenExpr
(* Extracts type and term parameters from a list of function definition parameters, combining all type parameters into one *)
let rec extract_fundef_params ~(type_acc : fundef_type_param option)
~(term_acc : fundef_term_param list) (params : fundef_parameter list) :
fundef_type_param option * fundef_term_param list =
match params with
| TermParameter tp :: rest ->
extract_fundef_params ~type_acc ~term_acc:(tp :: term_acc) rest
| TypeParameter tp :: rest ->
let type_acc =
match type_acc with
| Some tpa ->
Some
{
attrs = tpa.attrs @ tp.attrs;
locs = tpa.locs @ tp.locs;
p_pos = tpa.p_pos;
}
| None -> Some tp
in
extract_fundef_params ~type_acc ~term_acc rest
| [] -> (type_acc, List.rev term_acc)
let get_closing_token = function
| Token.Lparen -> Token.Rparen
| Lbrace -> Rbrace
| Lbracket -> Rbracket
| List -> Rbrace
| Dict -> Rbrace
| LessThan -> GreaterThan
| _ -> assert false
let rec go_to_closing closing_token state =
match (state.Parser.token, closing_token) with
| Rparen, Token.Rparen
| Rbrace, Rbrace
| Rbracket, Rbracket
| GreaterThan, GreaterThan ->
Parser.next state;
()
| ((Token.Lbracket | Lparen | Lbrace | List | Dict | LessThan) as t), _ ->
Parser.next state;
go_to_closing (get_closing_token t) state;
go_to_closing closing_token state
| (Rparen | Token.Rbrace | Rbracket | Eof), _ ->
() (* TODO: how do report errors here? *)
| _ ->
Parser.next state;
go_to_closing closing_token state
(* Madness *)
let is_es6_arrow_expression ~in_ternary p =
Parser.lookahead p (fun state ->
let _async =
match state.Parser.token with
| Lident "async" ->
Parser.next state;
true
| _ -> false
in
match state.Parser.token with
| Lident _ | Underscore -> (
Parser.next state;
match state.Parser.token with
(* Don't think that this valid
* Imagine: let x = (a: int)
* This is a parenthesized expression with a type constraint, wait for
* the arrow *)
(* | Colon when not inTernary -> true *)
| EqualGreater -> true
| _ -> false)
| Lparen -> (
let prev_end_pos = state.prev_end_pos in
Parser.next state;
match state.token with
(* arrived at `()` here *)
| Rparen -> (
Parser.next state;
match state.Parser.token with
(* arrived at `() :` here *)
| Colon when not in_ternary -> (
Parser.next state;
match state.Parser.token with
(* arrived at `() :typ` here *)
| Lident _ -> (
Parser.next state;
(match state.Parser.token with
(* arrived at `() :typ<` here *)
| LessThan ->
Scanner.set_diamond_mode state.scanner;
Parser.next state;
go_to_closing GreaterThan state;
Scanner.pop_mode state.scanner Diamond
| _ -> ());
match state.Parser.token with
(* arrived at `() :typ =>` or `() :typ<'a,'b> =>` here *)
| EqualGreater -> true
| _ -> false)
| _ -> true)
| EqualGreater -> true
| _ -> false)
| Dot (* uncurried *) -> true
| Backtick ->
false
(* (` always indicates the start of an expr, can't be es6 parameter *)
| _ -> (
go_to_closing Rparen state;
match state.Parser.token with
| EqualGreater -> true
(* | Lbrace TODO: detect missing =>, is this possible? *)
| Colon when not in_ternary -> true
| Rparen ->
(* imagine having something as :
* switch colour {
* | Red
* when l == l'
* || (&Clflags.classic && (l == Nolabel && !is_optional(l'))) => (t1, t2)
* We'll arrive at the outer rparen just before the =>.
* This is not an es6 arrow.
*)
false
| _ -> (
Parser.next_unsafe state;
(* error recovery, peek at the next token,
* (elements, providerId] => {
* in the example above, we have an unbalanced ] here
*)
match state.Parser.token with
| EqualGreater
when state.start_pos.pos_lnum == prev_end_pos.pos_lnum ->
true
| _ -> false)))
| _ -> false)
let is_es6_arrow_functor p =
Parser.lookahead p (fun state ->
match state.Parser.token with
(* | Uident _ | Underscore -> *)
(* Parser.next state; *)
(* begin match state.Parser.token with *)
(* | EqualGreater -> true *)
(* | _ -> false *)
(* end *)
| Lparen -> (
Parser.next state;
match state.token with
| Rparen -> (
Parser.next state;
match state.token with
| Colon | EqualGreater -> true
| _ -> false)
| _ -> (
go_to_closing Rparen state;
match state.Parser.token with
| EqualGreater | Lbrace -> true
| Colon -> true
| _ -> false))
| _ -> false)
let is_es6_arrow_type p =
Parser.lookahead p (fun state ->
match state.Parser.token with
| Lparen -> (
Parser.next state;
match state.Parser.token with
| Rparen -> (
Parser.next state;
match state.Parser.token with
| EqualGreater -> true
| _ -> false)
| Tilde | Dot -> true
| _ -> (
go_to_closing Rparen state;
match state.Parser.token with
| EqualGreater -> true
| _ -> false))
| Tilde -> true
| _ -> false)
let build_longident words =
match List.rev words with
| [] -> assert false
| hd :: tl -> List.fold_left (fun p s -> Longident.Ldot (p, s)) (Lident hd) tl
let emit_keyword_field_error (p : Parser.t) ~mk_message =
let keyword_txt = Token.to_string p.token in
let keyword_start = p.Parser.start_pos in
let keyword_end = p.Parser.end_pos in
Parser.err ~start_pos:keyword_start ~end_pos:keyword_end p
(Diagnostics.message (mk_message keyword_txt))
(* Recovers a keyword used as field name if it's probable that it's a full
field name (not punning etc), by checking if there's a colon after it. *)
let recover_keyword_field_name_if_probably_field p ~mk_message :
(string * Location.t) option =
if
Token.is_keyword p.Parser.token
&& Parser.lookahead p (fun st ->
Parser.next st;
st.Parser.token = Colon)
then (
emit_keyword_field_error p ~mk_message;
let loc = mk_loc p.Parser.start_pos p.Parser.end_pos in
let recovered_field_name = Token.to_string p.token ^ "_" in
Parser.next p;
Some (recovered_field_name, loc))
else None
let make_infix_operator (p : Parser.t) token start_pos end_pos =
let stringified_token =
if token = Token.Equal then (
(* TODO: could have a totally different meaning like x->fooSet(y)*)
Parser.err ~start_pos ~end_pos p
(Diagnostics.message "Did you mean `==` here?");
"=")
else Token.to_string token
in
let loc = mk_loc start_pos end_pos in
let operator = Location.mkloc (Longident.Lident stringified_token) loc in
Ast_helper.Exp.ident ~loc operator
let negate_string s =
if String.length s > 0 && (s.[0] [@doesNotRaise]) = '-' then
(String.sub [@doesNotRaise]) s 1 (String.length s - 1)
else "-" ^ s
let make_unary_expr start_pos token_end token operand =
match (token, operand.Parsetree.pexp_desc) with
| (Token.Plus | PlusDot), Pexp_constant (Pconst_integer _ | Pconst_float _) ->
operand
| Minus, Pexp_constant (Pconst_integer (n, m)) ->
{
operand with
pexp_desc = Pexp_constant (Pconst_integer (negate_string n, m));
}
| (Minus | MinusDot), Pexp_constant (Pconst_float (n, m)) ->
{operand with pexp_desc = Pexp_constant (Pconst_float (negate_string n, m))}
| (Token.Plus | PlusDot | Minus | MinusDot | Bnot), _ ->
let token_loc = mk_loc start_pos token_end in
let token_string = Token.to_string token in
let operator =
if token_string.[0] = '~' then token_string else "~" ^ token_string
in
Ast_helper.Exp.apply
~loc:(mk_loc start_pos operand.Parsetree.pexp_loc.loc_end)
(Ast_helper.Exp.ident ~loc:token_loc
(Location.mkloc (Longident.Lident operator) token_loc))
[(Nolabel, operand)]
| Token.Bang, _ ->
let token_loc = mk_loc start_pos token_end in
Ast_helper.Exp.apply
~loc:(mk_loc start_pos operand.Parsetree.pexp_loc.loc_end)
(Ast_helper.Exp.ident ~loc:token_loc
(Location.mkloc (Longident.Lident "not") token_loc))
[(Nolabel, operand)]
| _ -> operand
let make_list_pattern loc seq ext_opt =
let rec handle_seq = function
| [] ->
let base_case =
match ext_opt with
| Some ext -> ext
| None ->
let loc = {loc with Location.loc_ghost = true} in
let nil = {Location.txt = Longident.Lident "[]"; loc} in
Ast_helper.Pat.construct ~loc nil None
in
base_case
| p1 :: pl ->
let pat_pl = handle_seq pl in
let loc =
mk_loc p1.Parsetree.ppat_loc.loc_start pat_pl.ppat_loc.loc_end
in
let arg = Ast_helper.Pat.mk ~loc (Ppat_tuple [p1; pat_pl]) in
Ast_helper.Pat.mk ~loc
(Ppat_construct (Location.mkloc (Longident.Lident "::") loc, Some arg))
in
handle_seq seq
(* TODO: diagnostic reporting *)
let lident_of_path longident =
match Longident.flatten longident |> List.rev with
| [] -> ""
| ident :: _ -> ident
let make_newtypes ~attrs ~loc newtypes exp =
let expr =
List.fold_right
(fun newtype exp -> Ast_helper.Exp.mk ~loc (Pexp_newtype (newtype, exp)))
newtypes exp
in
{expr with pexp_attributes = attrs}
(* locally abstract types syntax sugar
* Transforms
* let f: type t u v. = (foo : list</t, u, v/>) => ...
* into
* let f = (type t u v. foo : list</t, u, v/>) => ...
*)
let wrap_type_annotation ~loc newtypes core_type body =
let exp =
make_newtypes ~attrs:[] ~loc newtypes
(Ast_helper.Exp.constraint_ ~loc body core_type)
in
let typ =
Ast_helper.Typ.poly ~loc newtypes
(Ast_helper.Typ.varify_constructors newtypes core_type)
in
(exp, typ)
(**
* process the occurrence of _ in the arguments of a function application
* replace _ with a new variable, currently __x, in the arguments
* return a wrapping function that wraps ((__x) => ...) around an expression
* e.g. foo(_, 3) becomes (__x) => foo(__x, 3)
*)
let process_underscore_application args =
let exp_question = ref None in
let hidden_var = "__x" in
let check_arg ((lab, exp) as arg) =
match exp.Parsetree.pexp_desc with
| Pexp_ident ({txt = Lident "_"} as id) ->
let new_id = Location.mkloc (Longident.Lident hidden_var) id.loc in
let new_exp = Ast_helper.Exp.mk (Pexp_ident new_id) ~loc:exp.pexp_loc in
exp_question := Some new_exp;
(lab, new_exp)
| _ -> arg
in
let args = List.map check_arg args in
let wrap (exp_apply : Parsetree.expression) =
match !exp_question with
| Some {pexp_loc = loc} ->
let pattern =
Ast_helper.Pat.mk
(Ppat_var (Location.mkloc hidden_var loc))
~loc:Location.none
in
Ast_helper.Exp.fun_ ~loc ~arity:(Some 1) Nolabel None pattern exp_apply
| None -> exp_apply
in
(args, wrap)
(* Transform A.a into a. For use with punned record fields as in {A.a, b}. *)
let remove_module_name_from_punned_field_value exp =
match exp.Parsetree.pexp_desc with
| Pexp_ident path_ident ->
{
exp with
pexp_desc =
Pexp_ident
{path_ident with txt = Lident (Longident.last path_ident.txt)};
}
| _ -> exp
let rec parse_lident p =
let recover_lident p =
if
Token.is_keyword p.Parser.token
&& p.Parser.prev_end_pos.pos_lnum == p.start_pos.pos_lnum
then (
Parser.err p (Diagnostics.lident p.Parser.token);
Parser.next p;
None)
else
let rec loop p =
if (not (Recover.should_abort_list_parse p)) && p.token <> Eof then (
Parser.next p;
loop p)
in
Parser.err p (Diagnostics.lident p.Parser.token);
Parser.next p;
loop p;
match p.Parser.token with
| Lident _ -> Some ()
| _ -> None
in
let start_pos = p.Parser.start_pos in
match p.Parser.token with
| Lident ident ->
Parser.next p;
let loc = mk_loc start_pos p.prev_end_pos in
(ident, loc)
| Eof ->
Parser.err ~start_pos p
(Diagnostics.unexpected p.Parser.token p.breadcrumbs);
("_", mk_loc start_pos p.prev_end_pos)
| _ -> (
match recover_lident p with
| Some () -> parse_lident p
| None -> ("_", mk_loc start_pos p.prev_end_pos))
let parse_ident ~msg ~start_pos p =
match p.Parser.token with
| Lident ident | Uident ident ->
Parser.next p;
let loc = mk_loc start_pos p.prev_end_pos in
(ident, loc)
| token
when Token.is_keyword token
&& p.prev_end_pos.pos_lnum == p.start_pos.pos_lnum ->
let token_txt = Token.to_string token in
let msg =
"`" ^ token_txt
^ "` is a reserved keyword. Keywords need to be escaped: \\\"" ^ token_txt
^ "\""
in
Parser.err ~start_pos p (Diagnostics.message msg);
Parser.next p;
(token_txt, mk_loc start_pos p.prev_end_pos)
| _token ->
Parser.err ~start_pos p (Diagnostics.message msg);
Parser.next p;
("", mk_loc start_pos p.prev_end_pos)
let parse_hash_ident ~start_pos p =
Parser.expect Hash p;
match p.token with
| String text ->
Parser.next p;
(text, mk_loc start_pos p.prev_end_pos)
| Int {i; suffix} ->
let () =
match suffix with
| Some _ ->
Parser.err p
(Diagnostics.message (ErrorMessages.poly_var_int_with_suffix i))
| None -> ()
in
Parser.next p;
(i, mk_loc start_pos p.prev_end_pos)
| Eof ->
Parser.err ~start_pos p (Diagnostics.unexpected p.token p.breadcrumbs);
("", mk_loc start_pos p.prev_end_pos)
| _ -> parse_ident ~start_pos ~msg:ErrorMessages.variant_ident p
(* Ldot (Ldot (Lident "Foo", "Bar"), "baz") *)
let parse_value_path p =
let start_pos = p.Parser.start_pos in
let rec aux p path =
let start_pos = p.Parser.start_pos in
let token = p.token in
Parser.next p;
if p.Parser.token = Dot then (
Parser.expect Dot p;
match p.Parser.token with
| Lident ident -> Longident.Ldot (path, ident)
| Uident uident -> aux p (Ldot (path, uident))
| token ->
Parser.err p (Diagnostics.unexpected token p.breadcrumbs);
Longident.Ldot (path, "_"))
else (
Parser.err p ~start_pos ~end_pos:p.prev_end_pos (Diagnostics.lident token);
path)
in
let ident =
match p.Parser.token with
| Lident ident ->
Parser.next p;
Longident.Lident ident
| Uident ident ->
let res = aux p (Lident ident) in
Parser.next_unsafe p;
res
| token ->
Parser.err p (Diagnostics.unexpected token p.breadcrumbs);
Parser.next_unsafe p;
Longident.Lident "_"
in
Location.mkloc ident (mk_loc start_pos p.prev_end_pos)
let parse_value_path_after_dot p =
let start_pos = p.Parser.start_pos in
match p.Parser.token with
| Lident _ | Uident _ -> parse_value_path p
| token ->
Parser.err p (Diagnostics.unexpected token p.breadcrumbs);
Location.mkloc (Longident.Lident "_") (mk_loc start_pos p.prev_end_pos)
let parse_value_path_tail p start_pos ident =
let rec loop p path =
match p.Parser.token with
| Lident ident ->
Parser.next p;
Location.mkloc
(Longident.Ldot (path, ident))
(mk_loc start_pos p.prev_end_pos)
| Uident ident ->
Parser.next p;
Parser.expect Dot p;
loop p (Longident.Ldot (path, ident))
| token ->
Parser.err p (Diagnostics.unexpected token p.breadcrumbs);
Location.mkloc
(Longident.Ldot (path, "_"))
(mk_loc start_pos p.prev_end_pos)
in
loop p ident
let parse_module_long_ident_tail ~lowercase p start_pos ident =
let rec loop p acc =
match p.Parser.token with
| Lident ident when lowercase ->
Parser.next p;
let lident = Longident.Ldot (acc, ident) in
Location.mkloc lident (mk_loc start_pos p.prev_end_pos)
| Uident ident -> (
Parser.next p;
let end_pos = p.prev_end_pos in
let lident = Longident.Ldot (acc, ident) in
match p.Parser.token with
| Dot ->
Parser.next p;
loop p lident
| _ -> Location.mkloc lident (mk_loc start_pos end_pos))
| t ->
Parser.err p (Diagnostics.uident t);
Location.mkloc
(Longident.Ldot (acc, "_"))
(mk_loc start_pos p.prev_end_pos)
in
loop p ident
(* jsx allows for `-` token in the name, we need to combine some tokens into a single ident *)
(* This function returns Some token when a combined token is created, None when no change is needed.
When it returns Some token:
- All immediately following ("-" IDENT) chunks have been consumed from the scanner
- No hyphen that belongs to the JSX name remains unconsumed
- The returned token is the combined Lident/Uident for the full name *)
(* Non-mutating helpers to parse JSX identifiers with optional hyphen chains *)
type jsx_ident_kind = [`Lower | `Upper]
(* Inspect current token; do not advance *)
let peek_ident (p : Parser.t) : (string * Location.t * jsx_ident_kind) option =
match p.Parser.token with
| Lident txt -> Some (txt, mk_loc p.start_pos p.end_pos, `Lower)
| Uident txt -> Some (txt, mk_loc p.start_pos p.end_pos, `Upper)
| _ -> None
(* Consume one Lident/Uident if present *)
let expect_ident (p : Parser.t) : (string * Location.t * jsx_ident_kind) option
=
match peek_ident p with
| None -> None
| Some (txt, loc, k) ->
Parser.next p;
Some (txt, loc, k)
(* Consume ("-" IDENT)*, appending to buffer; update last_end; diagnose trailing '-' *)
let rec read_hyphen_chain (p : Parser.t) (buf : Buffer.t)
(last_end : Lexing.position ref) : unit =
match p.Parser.token with
| Minus -> (
Parser.next p;
(* after '-' *)
match peek_ident p with
| Some (txt, _loc, _) ->
Buffer.add_char buf '-';
Buffer.add_string buf txt;
(* consume ident *)
Parser.next p;
last_end := p.prev_end_pos;
read_hyphen_chain p buf last_end
| None ->
(* Match previous behavior: rely on parser's current location *)
Parser.err p
(Diagnostics.message "JSX identifier cannot end with a hyphen"))
| _ -> ()
(* Read local jsx name: returns combined name + loc + kind of head ident *)
let read_local_jsx_name (p : Parser.t) :
(string * Location.t * jsx_ident_kind) option =
match expect_ident p with
| None -> None
| Some (head, head_loc, kind) ->
let buf = Buffer.create (String.length head + 8) in
Buffer.add_string buf head;
let start_pos = head_loc.Location.loc_start in
let last_end = ref head_loc.Location.loc_end in
read_hyphen_chain p buf last_end;
let name = Buffer.contents buf in
let loc = mk_loc start_pos !last_end in
Some (name, loc, kind)
(* Build a Longident from a non-empty list of segments *)
let longident_of_segments (segs : string list) : Longident.t =
match segs with
| [] -> invalid_arg "longident_of_segments: empty list"
| hd :: tl ->
List.fold_left
(fun acc s -> Longident.Ldot (acc, s))
(Longident.Lident hd) tl
(* Read a JSX tag name and return a jsx_tag_name; does not mutate tokens beyond what it consumes *)
let read_jsx_tag_name (p : Parser.t) :
(Parsetree.jsx_tag_name Location.loc, string) result =
match peek_ident p with
| None -> Error ""
| Some (_, _, `Lower) ->
read_local_jsx_name p
|> Option.map (fun (name, loc, _) ->
{Location.txt = Parsetree.JsxLowerTag name; loc})
|> Option.to_result ~none:""
| Some (first_seg, first_loc, `Upper) ->
let start_pos = first_loc.Location.loc_start in
(* consume first Uident *)
Parser.next p;
let string_of_rev_segments segs = String.concat "." (List.rev segs) in
let rec loop rev_segs last_end =
match p.Parser.token with
| Dot -> (
Parser.next p;
(* after '.' *)
match peek_ident p with
| None ->
Parser.err p
(Diagnostics.message "expected identifier after '.' in JSX tag name");
Error (string_of_rev_segments rev_segs ^ ".")
| Some (txt, _loc, `Upper) ->
(* another path segment *)
Parser.next p;
loop (txt :: rev_segs) p.prev_end_pos
| Some (_, _, `Lower) -> (
(* final lowercase with optional hyphens *)
match read_local_jsx_name p with
| Some (lname, l_loc, _) -> (
match rev_segs with
| [] -> Error ""
| _ ->
let path = longident_of_segments (List.rev rev_segs) in
let loc = mk_loc start_pos l_loc.Location.loc_end in
Ok
{
Location.txt =
Parsetree.JsxQualifiedLowerTag {path; name = lname};
loc;
})
| None -> Error ""))
| _ -> (
(* pure Upper path *)
match rev_segs with
| [] -> Error ""
| _ ->
let path = longident_of_segments (List.rev rev_segs) in
let loc = mk_loc start_pos last_end in
Ok {txt = Parsetree.JsxUpperTag path; loc})
in
(* seed with the first segment already consumed *)
loop [first_seg] first_loc.Location.loc_end
(* Parses module identifiers:
Foo
Foo.Bar *)
let parse_module_long_ident ~lowercase p =
(* Parser.leaveBreadcrumb p Reporting.ModuleLongIdent; *)
let start_pos = p.Parser.start_pos in
let module_ident =
match p.Parser.token with
| Lident ident when lowercase ->
let loc = mk_loc start_pos p.end_pos in
let lident = Longident.Lident ident in
Parser.next p;
Location.mkloc lident loc
| Uident ident -> (
let lident = Longident.Lident ident in
let end_pos = p.end_pos in
Parser.next p;
match p.Parser.token with
| Dot ->
Parser.next p;