1 /**************************************************************************/
2 /* */
3 /* OCaml */
4 /* */
5 /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
6 /* */
7 /* Copyright 1996 Institut National de Recherche en Informatique et */
8 /* en Automatique. */
9 /* */
10 /* All rights reserved. This file is distributed under the terms of */
11 /* the GNU Lesser General Public License version 2.1, with the */
12 /* special exception on linking described in the file LICENSE. */
13 /* */
14 /**************************************************************************/
15
16 /* The parser definition */
17
18 %{
19
20 open Asttypes
21 open Longident
22 open Parsetree
23 open Ast_helper
24 open Docstrings
25 open Docstrings.WithMenhir
26
27 let mkloc = Location.mkloc
28 let mknoloc = Location.mknoloc
29
30 let make_loc (startpos, endpos) = {
31 Location.loc_start = startpos;
32 Location.loc_end = endpos;
33 Location.loc_ghost = false;
34 }
35
36 let ghost_loc (startpos, endpos) = {
37 Location.loc_start = startpos;
38 Location.loc_end = endpos;
39 Location.loc_ghost = true;
40 }
41
42 let mktyp ~loc d = Typ.mk ~loc:(make_loc loc) d
43 let mkpat ~loc d = Pat.mk ~loc:(make_loc loc) d
44 let mkexp ~loc d = Exp.mk ~loc:(make_loc loc) d
45 let mkmty ~loc ?attrs d = Mty.mk ~loc:(make_loc loc) ?attrs d
46 let mksig ~loc d = Sig.mk ~loc:(make_loc loc) d
47 let mkmod ~loc ?attrs d = Mod.mk ~loc:(make_loc loc) ?attrs d
48 let mkstr ~loc d = Str.mk ~loc:(make_loc loc) d
49 let mkclass ~loc ?attrs d = Cl.mk ~loc:(make_loc loc) ?attrs d
50 let mkcty ~loc ?attrs d = Cty.mk ~loc:(make_loc loc) ?attrs d
51
52 let pstr_typext (te, ext) =
53 (Pstr_typext te, ext)
54 let pstr_primitive (vd, ext) =
55 (Pstr_primitive vd, ext)
56 let pstr_type ((nr, ext), tys) =
57 (Pstr_type (nr, tys), ext)
58 let pstr_exception (te, ext) =
59 (Pstr_exception te, ext)
60 let pstr_include (body, ext) =
61 (Pstr_include body, ext)
62 let pstr_recmodule (ext, bindings) =
63 (Pstr_recmodule bindings, ext)
64
65 let psig_typext (te, ext) =
66 (Psig_typext te, ext)
67 let psig_value (vd, ext) =
68 (Psig_value vd, ext)
69 let psig_type ((nr, ext), tys) =
70 (Psig_type (nr, tys), ext)
71 let psig_typesubst ((nr, ext), tys) =
72 assert (nr = Recursive); (* see [no_nonrec_flag] *)
73 (Psig_typesubst tys, ext)
74 let psig_exception (te, ext) =
75 (Psig_exception te, ext)
76 let psig_include (body, ext) =
77 (Psig_include body, ext)
78
79 let mkctf ~loc ?attrs ?docs d =
80 Ctf.mk ~loc:(make_loc loc) ?attrs ?docs d
81 let mkcf ~loc ?attrs ?docs d =
82 Cf.mk ~loc:(make_loc loc) ?attrs ?docs d
83
84 let mkrhs rhs loc = mkloc rhs (make_loc loc)
85 let ghrhs rhs loc = mkloc rhs (ghost_loc loc)
86
87 let push_loc x acc =
88 if x.Location.loc_ghost
89 then acc
90 else x :: acc
91
92 let reloc_pat ~loc x =
93 { x with ppat_loc = make_loc loc;
94 ppat_loc_stack = push_loc x.ppat_loc x.ppat_loc_stack };;
95 let reloc_exp ~loc x =
96 { x with pexp_loc = make_loc loc;
97 pexp_loc_stack = push_loc x.pexp_loc x.pexp_loc_stack };;
98 let reloc_typ ~loc x =
99 { x with ptyp_loc = make_loc loc;
100 ptyp_loc_stack = push_loc x.ptyp_loc x.ptyp_loc_stack };;
101
102 let mkexpvar ~loc (name : string) =
103 mkexp ~loc (Pexp_ident(mkrhs (Lident name) loc))
104
105 let mkoperator =
106 mkexpvar
107
108 let mkpatvar ~loc name =
109 mkpat ~loc (Ppat_var (mkrhs name loc))
110
111 (*
112 Ghost expressions and patterns:
113 expressions and patterns that do not appear explicitly in the
114 source file they have the loc_ghost flag set to true.
115 Then the profiler will not try to instrument them and the
116 -annot option will not try to display their type.
117
118 Every grammar rule that generates an element with a location must
119 make at most one non-ghost element, the topmost one.
120
121 How to tell whether your location must be ghost:
122 A location corresponds to a range of characters in the source file.
123 If the location contains a piece of code that is syntactically
124 valid (according to the documentation), and corresponds to the
125 AST node, then the location must be real; in all other cases,
126 it must be ghost.
127 *)
128 let ghexp ~loc d = Exp.mk ~loc:(ghost_loc loc) d
129 let ghpat ~loc d = Pat.mk ~loc:(ghost_loc loc) d
130 let ghtyp ~loc d = Typ.mk ~loc:(ghost_loc loc) d
131 let ghloc ~loc d = { txt = d; loc = ghost_loc loc }
132 let ghstr ~loc d = Str.mk ~loc:(ghost_loc loc) d
133 let ghsig ~loc d = Sig.mk ~loc:(ghost_loc loc) d
134
135 let mkinfix arg1 op arg2 =
136 Pexp_apply(op, [Nolabel, arg1; Nolabel, arg2])
137
138 let neg_string f =
139 if String.length f > 0 && f.[0] = '-'
140 then String.sub f 1 (String.length f - 1)
141 else "-" ^ f
142
143 let mkuminus ~oploc name arg =
144 match name, arg.pexp_desc with
145 | "-", Pexp_constant(Pconst_integer (n,m)) ->
146 Pexp_constant(Pconst_integer(neg_string n,m))
147 | ("-" | "-."), Pexp_constant(Pconst_float (f, m)) ->
148 Pexp_constant(Pconst_float(neg_string f, m))
149 | _ ->
150 Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg])
151
152 let mkuplus ~oploc name arg =
153 let desc = arg.pexp_desc in
154 match name, desc with
155 | "+", Pexp_constant(Pconst_integer _)
156 | ("+" | "+."), Pexp_constant(Pconst_float _) -> desc
157 | _ ->
158 Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg])
159
160 (* TODO define an abstraction boundary between locations-as-pairs
161 and locations-as-Location.t; it should be clear when we move from
162 one world to the other *)
163
164 let mkexp_cons_desc consloc args =
165 Pexp_construct(mkrhs (Lident "::") consloc, Some args)
166 let mkexp_cons ~loc consloc args =
167 mkexp ~loc (mkexp_cons_desc consloc args)
168
169 let mkpat_cons_desc consloc args =
170 Ppat_construct(mkrhs (Lident "::") consloc, Some args)
171 let mkpat_cons ~loc consloc args =
172 mkpat ~loc (mkpat_cons_desc consloc args)
173
174 let ghexp_cons_desc consloc args =
175 Pexp_construct(ghrhs (Lident "::") consloc, Some args)
176 let ghpat_cons_desc consloc args =
177 Ppat_construct(ghrhs (Lident "::") consloc, Some args)
178
179 let rec mktailexp nilloc = let open Location in function
180 [] ->
181 let nil = ghloc ~loc:nilloc (Lident "[]") in
182 Pexp_construct (nil, None), nilloc
183 | e1 :: el ->
184 let exp_el, el_loc = mktailexp nilloc el in
185 let loc = (e1.pexp_loc.loc_start, snd el_loc) in
186 let arg = ghexp ~loc (Pexp_tuple [e1; ghexp ~loc:el_loc exp_el]) in
187 ghexp_cons_desc loc arg, loc
188
189 let rec mktailpat nilloc = let open Location in function
190 [] ->
191 let nil = ghloc ~loc:nilloc (Lident "[]") in
192 Ppat_construct (nil, None), nilloc
193 | p1 :: pl ->
194 let pat_pl, el_loc = mktailpat nilloc pl in
195 let loc = (p1.ppat_loc.loc_start, snd el_loc) in
196 let arg = ghpat ~loc (Ppat_tuple [p1; ghpat ~loc:el_loc pat_pl]) in
197 ghpat_cons_desc loc arg, loc
198
199 let mkstrexp e attrs =
200 { pstr_desc = Pstr_eval (e, attrs); pstr_loc = e.pexp_loc }
201
202 let mkexp_constraint ~loc e (t1, t2) =
203 match t1, t2 with
204 | Some t, None -> ghexp ~loc (Pexp_constraint(e, t))
205 | _, Some t -> ghexp ~loc (Pexp_coerce(e, t1, t))
206 | None, None -> assert false
207
208 let mkexp_opt_constraint ~loc e = function
209 | None -> e
210 | Some constraint_ -> mkexp_constraint ~loc e constraint_
211
212 let mkpat_opt_constraint ~loc p = function
213 | None -> p
214 | Some typ -> mkpat ~loc (Ppat_constraint(p, typ))
215
216 let syntax_error () =
217 raise Syntaxerr.Escape_error
218
219 let unclosed opening_name opening_loc closing_name closing_loc =
220 raise(Syntaxerr.Error(Syntaxerr.Unclosed(make_loc opening_loc, opening_name,
221 make_loc closing_loc, closing_name)))
222
223 let expecting loc nonterm =
224 raise Syntaxerr.(Error(Expecting(make_loc loc, nonterm)))
225
226 let not_expecting loc nonterm =
227 raise Syntaxerr.(Error(Not_expecting(make_loc loc, nonterm)))
228
229 let dotop ~left ~right ~assign ~ext ~multi =
230 let assign = if assign then "<-" else "" in
231 let mid = if multi then ";.." else "" in
232 String.concat "" ["."; ext; left; mid; right; assign]
233 let paren = "(",")"
234 let brace = "{", "}"
235 let bracket = "[", "]"
236 let lident x = Lident x
237 let ldot x y = Ldot(x,y)
238 let dotop_fun ~loc dotop =
239 (* We could use ghexp here, but sticking to mkexp for parser.mly
240 compatibility. TODO improve parser.mly *)
241 mkexp ~loc (Pexp_ident (ghloc ~loc dotop))
242
243 let array_function ~loc str name =
244 ghloc ~loc (Ldot(Lident str,
245 (if !Clflags.unsafe then "unsafe_" ^ name else name)))
246
247 let array_get_fun ~loc =
248 ghexp ~loc (Pexp_ident(array_function ~loc "Array" "get"))
249 let string_get_fun ~loc =
250 ghexp ~loc (Pexp_ident(array_function ~loc "String" "get"))
251
252 let array_set_fun ~loc =
253 ghexp ~loc (Pexp_ident(array_function ~loc "Array" "set"))
254 let string_set_fun ~loc =
255 ghexp ~loc (Pexp_ident(array_function ~loc "String" "set"))
256
257 let multi_indices ~loc = function
258 | [a] -> false, a
259 | l -> true, mkexp ~loc (Pexp_array l)
260
261 let index_get ~loc get_fun array index =
262 let args = [Nolabel, array; Nolabel, index] in
263 mkexp ~loc (Pexp_apply(get_fun, args))
264
265 let index_set ~loc set_fun array index value =
266 let args = [Nolabel, array; Nolabel, index; Nolabel, value] in
267 mkexp ~loc (Pexp_apply(set_fun, args))
268
269 let array_get ~loc = index_get ~loc (array_get_fun ~loc)
270 let string_get ~loc = index_get ~loc (string_get_fun ~loc)
271 let dotop_get ~loc path (left,right) ext array index =
272 let multi, index = multi_indices ~loc index in
273 index_get ~loc
274 (dotop_fun ~loc (path @@ dotop ~left ~right ~ext ~multi ~assign:false))
275 array index
276
277 let array_set ~loc = index_set ~loc (array_set_fun ~loc)
278 let string_set ~loc = index_set ~loc (string_set_fun ~loc)
279 let dotop_set ~loc path (left,right) ext array index value=
280 let multi, index = multi_indices ~loc index in
281 index_set ~loc
282 (dotop_fun ~loc (path @@ dotop ~left ~right ~ext ~multi ~assign:true))
283 array index value
284
285
286 let bigarray_function ~loc str name =
287 ghloc ~loc (Ldot(Ldot(Lident "Bigarray", str), name))
288
289 let bigarray_untuplify = function
290 { pexp_desc = Pexp_tuple explist; pexp_loc = _ } -> explist
291 | exp -> [exp]
292
293 let bigarray_get ~loc arr arg =
294 let mkexp, ghexp = mkexp ~loc, ghexp ~loc in
295 let bigarray_function = bigarray_function ~loc in
296 let get = if !Clflags.unsafe then "unsafe_get" else "get" in
297 match bigarray_untuplify arg with
298 [c1] ->
299 mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" get)),
300 [Nolabel, arr; Nolabel, c1]))
301 | [c1;c2] ->
302 mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" get)),
303 [Nolabel, arr; Nolabel, c1; Nolabel, c2]))
304 | [c1;c2;c3] ->
305 mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" get)),
306 [Nolabel, arr; Nolabel, c1; Nolabel, c2; Nolabel, c3]))
307 | coords ->
308 mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "get")),
309 [Nolabel, arr; Nolabel, ghexp(Pexp_array coords)]))
310
311 let bigarray_set ~loc arr arg newval =
312 let mkexp, ghexp = mkexp ~loc, ghexp ~loc in
313 let bigarray_function = bigarray_function ~loc in
314 let set = if !Clflags.unsafe then "unsafe_set" else "set" in
315 match bigarray_untuplify arg with
316 [c1] ->
317 mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" set)),
318 [Nolabel, arr; Nolabel, c1; Nolabel, newval]))
319 | [c1;c2] ->
320 mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" set)),
321 [Nolabel, arr; Nolabel, c1;
322 Nolabel, c2; Nolabel, newval]))
323 | [c1;c2;c3] ->
324 mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" set)),
325 [Nolabel, arr; Nolabel, c1;
326 Nolabel, c2; Nolabel, c3; Nolabel, newval]))
327 | coords ->
328 mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "set")),
329 [Nolabel, arr;
330 Nolabel, ghexp(Pexp_array coords);
331 Nolabel, newval]))
332
333 let lapply ~loc p1 p2 =
334 if !Clflags.applicative_functors
335 then Lapply(p1, p2)
336 else raise (Syntaxerr.Error(
337 Syntaxerr.Applicative_path (make_loc loc)))
338
339 let exp_of_longident ~loc lid =
340 mkexp ~loc (Pexp_ident {lid with txt = Lident(Longident.last lid.txt)})
341
342 (* [loc_map] could be [Location.map]. *)
343 let loc_map (f : 'a -> 'b) (x : 'a Location.loc) : 'b Location.loc =
344 { x with txt = f x.txt }
345
346 let loc_last (id : Longident.t Location.loc) : string Location.loc =
347 loc_map Longident.last id
348
349 let loc_lident (id : string Location.loc) : Longident.t Location.loc =
350 loc_map (fun x -> Lident x) id
351
352 let exp_of_label ~loc lbl =
353 mkexp ~loc (Pexp_ident (loc_lident lbl))
354
355 let pat_of_label ~loc lbl =
356 mkpat ~loc (Ppat_var (loc_last lbl))
357
358 let mk_newtypes ~loc newtypes exp =
359 let mkexp = mkexp ~loc in
360 List.fold_right (fun newtype exp -> mkexp (Pexp_newtype (newtype, exp)))
361 newtypes exp
362
363 let wrap_type_annotation ~loc newtypes core_type body =
364 let mkexp, ghtyp = mkexp ~loc, ghtyp ~loc in
365 let mk_newtypes = mk_newtypes ~loc in
366 let exp = mkexp(Pexp_constraint(body,core_type)) in
367 let exp = mk_newtypes newtypes exp in
368 (exp, ghtyp(Ptyp_poly(newtypes, Typ.varify_constructors newtypes core_type)))
369
370 let wrap_exp_attrs ~loc body (ext, attrs) =
371 let ghexp = ghexp ~loc in
372 (* todo: keep exact location for the entire attribute *)
373 let body = {body with pexp_attributes = attrs @ body.pexp_attributes} in
374 match ext with
375 | None -> body
376 | Some id -> ghexp(Pexp_extension (id, PStr [mkstrexp body []]))
377
378 let mkexp_attrs ~loc d attrs =
379 wrap_exp_attrs ~loc (mkexp ~loc d) attrs
380
381 let wrap_typ_attrs ~loc typ (ext, attrs) =
382 (* todo: keep exact location for the entire attribute *)
383 let typ = {typ with ptyp_attributes = attrs @ typ.ptyp_attributes} in
384 match ext with
385 | None -> typ
386 | Some id -> ghtyp ~loc (Ptyp_extension (id, PTyp typ))
387
388 let wrap_pat_attrs ~loc pat (ext, attrs) =
389 (* todo: keep exact location for the entire attribute *)
390 let pat = {pat with ppat_attributes = attrs @ pat.ppat_attributes} in
391 match ext with
392 | None -> pat
393 | Some id -> ghpat ~loc (Ppat_extension (id, PPat (pat, None)))
394
395 let mkpat_attrs ~loc d attrs =
396 wrap_pat_attrs ~loc (mkpat ~loc d) attrs
397
398 let wrap_class_attrs ~loc:_ body attrs =
399 {body with pcl_attributes = attrs @ body.pcl_attributes}
400 let wrap_mod_attrs ~loc:_ attrs body =
401 {body with pmod_attributes = attrs @ body.pmod_attributes}
402 let wrap_mty_attrs ~loc:_ attrs body =
403 {body with pmty_attributes = attrs @ body.pmty_attributes}
404
405 let wrap_str_ext ~loc body ext =
406 match ext with
407 | None -> body
408 | Some id -> ghstr ~loc (Pstr_extension ((id, PStr [body]), []))
409
410 let wrap_mkstr_ext ~loc (item, ext) =
411 wrap_str_ext ~loc (mkstr ~loc item) ext
412
413 let wrap_sig_ext ~loc body ext =
414 match ext with
415 | None -> body
416 | Some id -> ghsig ~loc (Psig_extension ((id, PSig [body]), []))
417
418 let wrap_mksig_ext ~loc (item, ext) =
419 wrap_sig_ext ~loc (mksig ~loc item) ext
420
421 let text_str pos = Str.text (rhs_text pos)
422 let text_sig pos = Sig.text (rhs_text pos)
423 let text_cstr pos = Cf.text (rhs_text pos)
424 let text_csig pos = Ctf.text (rhs_text pos)
425 let text_def pos = [Ptop_def (Str.text (rhs_text pos))]
426
427 let extra_text startpos endpos text items =
428 match items with
429 | [] ->
430 let post = rhs_post_text endpos in
431 let post_extras = rhs_post_extra_text endpos in
432 text post @ text post_extras
433 | _ :: _ ->
434 let pre_extras = rhs_pre_extra_text startpos in
435 let post_extras = rhs_post_extra_text endpos in
436 text pre_extras @ items @ text post_extras
437
438 let extra_str p1 p2 items = extra_text p1 p2 Str.text items
439 let extra_sig p1 p2 items = extra_text p1 p2 Sig.text items
440 let extra_cstr p1 p2 items = extra_text p1 p2 Cf.text items
441 let extra_csig p1 p2 items = extra_text p1 p2 Ctf.text items
442 let extra_def p1 p2 items =
443 extra_text p1 p2 (fun txt -> [Ptop_def (Str.text txt)]) items
444
445 let extra_rhs_core_type ct ~pos =
446 let docs = rhs_info pos in
447 { ct with ptyp_attributes = add_info_attrs docs ct.ptyp_attributes }
448
449 type let_binding =
450 { lb_pattern: pattern;
451 lb_expression: expression;
452 lb_attributes: attributes;
453 lb_docs: docs Lazy.t;
454 lb_text: text Lazy.t;
455 lb_loc: Location.t; }
456
457 type let_bindings =
458 { lbs_bindings: let_binding list;
459 lbs_rec: rec_flag;
460 lbs_extension: string Asttypes.loc option;
461 lbs_loc: Location.t }
462
463 let mklb first ~loc (p, e) attrs =
464 {
465 lb_pattern = p;
466 lb_expression = e;
467 lb_attributes = attrs;
468 lb_docs = symbol_docs_lazy loc;
469 lb_text = (if first then empty_text_lazy
470 else symbol_text_lazy (fst loc));
471 lb_loc = make_loc loc;
472 }
473
474 let mklbs ~loc ext rf lb =
475 {
476 lbs_bindings = [lb];
477 lbs_rec = rf;
478 lbs_extension = ext ;
479 lbs_loc = make_loc loc;
480 }
481
482 let addlb lbs lb =
483 { lbs with lbs_bindings = lb :: lbs.lbs_bindings }
484
485 let val_of_let_bindings ~loc lbs =
486 let bindings =
487 List.map
488 (fun lb ->
489 Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
490 ~docs:(Lazy.force lb.lb_docs)
491 ~text:(Lazy.force lb.lb_text)
492 lb.lb_pattern lb.lb_expression)
493 lbs.lbs_bindings
494 in
495 let str = mkstr ~loc (Pstr_value(lbs.lbs_rec, List.rev bindings)) in
496 match lbs.lbs_extension with
497 | None -> str
498 | Some id -> ghstr ~loc (Pstr_extension((id, PStr [str]), []))
499
500 let expr_of_let_bindings ~loc lbs body =
501 let bindings =
502 List.map
503 (fun lb ->
504 Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
505 lb.lb_pattern lb.lb_expression)
506 lbs.lbs_bindings
507 in
508 mkexp_attrs ~loc (Pexp_let(lbs.lbs_rec, List.rev bindings, body))
509 (lbs.lbs_extension, [])
510
511 let class_of_let_bindings ~loc lbs body =
512 let bindings =
513 List.map
514 (fun lb ->
515 Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
516 lb.lb_pattern lb.lb_expression)
517 lbs.lbs_bindings
518 in
519 (* Our use of let_bindings(no_ext) guarantees the following: *)
520 assert (lbs.lbs_extension = None);
521 mkclass ~loc (Pcl_let (lbs.lbs_rec, List.rev bindings, body))
522
523 (* Alternatively, we could keep the generic module type in the Parsetree
524 and extract the package type during type-checking. In that case,
525 the assertions below should be turned into explicit checks. *)
526 let package_type_of_module_type pmty =
527 let err loc s =
528 raise (Syntaxerr.Error (Syntaxerr.Invalid_package_type (loc, s)))
529 in
530 let map_cstr = function
531 | Pwith_type (lid, ptyp) ->
532 let loc = ptyp.ptype_loc in
533 if ptyp.ptype_params <> [] then
534 err loc "parametrized types are not supported";
535 if ptyp.ptype_cstrs <> [] then
536 err loc "constrained types are not supported";
537 if ptyp.ptype_private <> Public then
538 err loc "private types are not supported";
539
540 (* restrictions below are checked by the 'with_constraint' rule *)
541 assert (ptyp.ptype_kind = Ptype_abstract);
542 assert (ptyp.ptype_attributes = []);
543 let ty =
544 match ptyp.ptype_manifest with
545 | Some ty -> ty
546 | None -> assert false
547 in
548 (lid, ty)
549 | _ ->
550 err pmty.pmty_loc "only 'with type t =' constraints are supported"
551 in
552 match pmty with
553 | {pmty_desc = Pmty_ident lid} -> (lid, [])
554 | {pmty_desc = Pmty_with({pmty_desc = Pmty_ident lid}, cstrs)} ->
555 (lid, List.map map_cstr cstrs)
556 | _ ->
557 err pmty.pmty_loc
558 "only module type identifier and 'with type' constraints are supported"
559
560 let mk_directive_arg ~loc k =
561 { pdira_desc = k;
562 pdira_loc = make_loc loc;
563 }
564
565 let mk_directive ~loc name arg =
566 Ptop_dir {
567 pdir_name = name;
568 pdir_arg = arg;
569 pdir_loc = make_loc loc;
570 }
571
572 %}
573
574 /* Tokens */
575
576 %token AMPERAMPER
577 %token AMPERSAND
578 %token AND
579 %token AS
580 %token ASSERT
581 %token BACKQUOTE
582 %token BANG
583 %token BAR
584 %token BARBAR
585 %token BARRBRACKET
586 %token BEGIN
587 %token <char> CHAR
588 %token CLASS
589 %token COLON
590 %token COLONCOLON
591 %token COLONEQUAL
592 %token COLONGREATER
593 %token COMMA
594 %token CONSTRAINT
595 %token DO
596 %token DONE
597 %token DOT
598 %token DOTDOT
599 %token DOWNTO
600 %token ELSE
601 %token END
602 %token EOF
603 %token EQUAL
604 %token EXCEPTION
605 %token EXTERNAL
606 %token FALSE
607 %token <string * char option> FLOAT
608 %token FOR
609 %token FUN
610 %token FUNCTION
611 %token FUNCTOR
612 %token GREATER
613 %token GREATERRBRACE
614 %token GREATERRBRACKET
615 %token IF
616 %token IN
617 %token INCLUDE
618 %token <string> INFIXOP0
619 %token <string> INFIXOP1
620 %token <string> INFIXOP2
621 %token <string> INFIXOP3
622 %token <string> INFIXOP4
623 %token <string> DOTOP
624 %token <string> LETOP
625 %token <string> ANDOP
626 %token INHERIT
627 %token INITIALIZER
628 %token <string * char option> INT
629 %token <string> LABEL
630 %token LAZY
631 %token LBRACE
632 %token LBRACELESS
633 %token LBRACKET
634 %token LBRACKETBAR
635 %token LBRACKETLESS
636 %token LBRACKETGREATER
637 %token LBRACKETPERCENT
638 %token LBRACKETPERCENTPERCENT
639 %token LESS
640 %token LESSMINUS
641 %token LET
642 %token <string> LIDENT
643 %token LPAREN
644 %token LBRACKETAT
645 %token LBRACKETATAT
646 %token LBRACKETATATAT
647 %token MATCH
648 %token METHOD
649 %token MINUS
650 %token MINUSDOT
651 %token MINUSGREATER
652 %token MODULE
653 %token MUTABLE
654 %token NEW
655 %token NONREC
656 %token OBJECT
657 %token OF
658 %token OPEN
659 %token <string> OPTLABEL
660 %token OR
661 /* %token PARSER */
662 %token PERCENT
663 %token PLUS
664 %token PLUSDOT
665 %token PLUSEQ
666 %token <string> PREFIXOP
667 %token PRIVATE
668 %token QUESTION
669 %token QUOTE
670 %token RBRACE
671 %token RBRACKET
672 %token REC
673 %token RPAREN
674 %token SEMI
675 %token SEMISEMI
676 %token HASH
677 %token <string> HASHOP
678 %token SIG
679 %token STAR
680 %token <string * string option> STRING
681 %token STRUCT
682 %token THEN
683 %token TILDE
684 %token TO
685 %token TRUE
686 %token TRY
687 %token TYPE
688 %token <string> UIDENT
689 %token UNDERSCORE
690 %token VAL
691 %token VIRTUAL
692 %token WHEN
693 %token WHILE
694 %token WITH
695 %token <string * Location.t> COMMENT
696 %token <Docstrings.docstring> DOCSTRING
697
698 %token EOL
699
700 /* Precedences and associativities.
701
702 Tokens and rules have precedences. A reduce/reduce conflict is resolved
703 in favor of the first rule (in source file order). A shift/reduce conflict
704 is resolved by comparing the precedence and associativity of the token to
705 be shifted with those of the rule to be reduced.
706
707 By default, a rule has the precedence of its rightmost terminal (if any).
708
709 When there is a shift/reduce conflict between a rule and a token that
710 have the same precedence, it is resolved using the associativity:
711 if the token is left-associative, the parser will reduce; if
712 right-associative, the parser will shift; if non-associative,
713 the parser will declare a syntax error.
714
715 We will only use associativities with operators of the kind x * x -> x
716 for example, in the rules of the form expr: expr BINOP expr
717 in all other cases, we define two precedences if needed to resolve
718 conflicts.
719
720 The precedences must be listed from low to high.
721 */
722
723 %nonassoc IN
724 %nonassoc below_SEMI
725 %nonassoc SEMI /* below EQUAL ({lbl=...; lbl=...}) */
726 %nonassoc LET /* above SEMI ( ...; let ... in ...) */
727 %nonassoc below_WITH
728 %nonassoc FUNCTION WITH /* below BAR (match ... with ...) */
729 %nonassoc AND /* above WITH (module rec A: SIG with ... and ...) */
730 %nonassoc THEN /* below ELSE (if ... then ...) */
731 %nonassoc ELSE /* (if ... then ... else ...) */
732 %nonassoc LESSMINUS /* below COLONEQUAL (lbl <- x := e) */
733 %right COLONEQUAL /* expr (e := e := e) */
734 %nonassoc AS
735 %left BAR /* pattern (p|p|p) */
736 %nonassoc below_COMMA
737 %left COMMA /* expr/expr_comma_list (e,e,e) */
738 %right MINUSGREATER /* function_type (t -> t -> t) */
739 %right OR BARBAR /* expr (e || e || e) */
740 %right AMPERSAND AMPERAMPER /* expr (e && e && e) */
741 %nonassoc below_EQUAL
742 %left INFIXOP0 EQUAL LESS GREATER /* expr (e OP e OP e) */
743 %right INFIXOP1 /* expr (e OP e OP e) */
744 %nonassoc below_LBRACKETAT
745 %nonassoc LBRACKETAT
746 %right COLONCOLON /* expr (e :: e :: e) */
747 %left INFIXOP2 PLUS PLUSDOT MINUS MINUSDOT PLUSEQ /* expr (e OP e OP e) */
748 %left PERCENT INFIXOP3 STAR /* expr (e OP e OP e) */
749 %right INFIXOP4 /* expr (e OP e OP e) */
750 %nonassoc prec_unary_minus prec_unary_plus /* unary - */
751 %nonassoc prec_constant_constructor /* cf. simple_expr (C versus C x) */
752 %nonassoc prec_constr_appl /* above AS BAR COLONCOLON COMMA */
753 %nonassoc below_HASH
754 %nonassoc HASH /* simple_expr/toplevel_directive */
755 %left HASHOP
756 %nonassoc below_DOT
757 %nonassoc DOT DOTOP
758 /* Finally, the first tokens of simple_expr are above everything else. */
759 %nonassoc BACKQUOTE BANG BEGIN CHAR FALSE FLOAT INT
760 LBRACE LBRACELESS LBRACKET LBRACKETBAR LIDENT LPAREN
761 NEW PREFIXOP STRING TRUE UIDENT
762 LBRACKETPERCENT
763
764
765 /* Entry points */
766
767 %start implementation /* for implementation files */
768 %type <Parsetree.structure> implementation
769 %start interface /* for interface files */
770 %type <Parsetree.signature> interface
771 %start toplevel_phrase /* for interactive use */
772 %type <Parsetree.toplevel_phrase> toplevel_phrase
773 %start use_file /* for the #use directive */
774 %type <Parsetree.toplevel_phrase list> use_file
775 %start parse_core_type
776 %type <Parsetree.core_type> parse_core_type
777 %start parse_expression
778 %type <Parsetree.expression> parse_expression
779 %start parse_pattern
780 %type <Parsetree.pattern> parse_pattern
781 %%
782
783 /* macros */
784 %inline extra_str(symb): symb { extra_str $startpos $endpos $1 };
785 %inline extra_sig(symb): symb { extra_sig $startpos $endpos $1 };
786 %inline extra_cstr(symb): symb { extra_cstr $startpos $endpos $1 };
787 %inline extra_csig(symb): symb { extra_csig $startpos $endpos $1 };
788 %inline extra_def(symb): symb { extra_def $startpos $endpos $1 };
789 %inline extra_text(symb): symb { extra_text $startpos $endpos $1 };
790 %inline extra_rhs(symb): symb { extra_rhs_core_type $1 ~pos:$endpos($1) };
791 %inline mkrhs(symb): symb
792 { mkrhs $1 $sloc }
793 ;
794
795 %inline text_str(symb): symb
796 { text_str $startpos @ [$1] }
797 %inline text_str_SEMISEMI: SEMISEMI
798 { text_str $startpos }
799 %inline text_sig(symb): symb
800 { text_sig $startpos @ [$1] }
801 %inline text_sig_SEMISEMI: SEMISEMI
802 { text_sig $startpos }
803 %inline text_def(symb): symb
804 { text_def $startpos @ [$1] }
805 %inline top_def(symb): symb
806 { Ptop_def [$1] }
807 %inline text_cstr(symb): symb
808 { text_cstr $startpos @ [$1] }
809 %inline text_csig(symb): symb
810 { text_csig $startpos @ [$1] }
811
812 (* Using this %inline definition means that we do not control precisely
813 when [mark_rhs_docs] is called, but I don't think this matters. *)
814 %inline mark_rhs_docs(symb): symb
815 { mark_rhs_docs $startpos $endpos;
816 $1 }
817
818 %inline op(symb): symb
819 { mkoperator ~loc:$sloc $1 }
820
821 %inline mkloc(symb): symb
822 { mkloc $1 (make_loc $sloc) }
823
824 %inline mkexp(symb): symb
825 { mkexp ~loc:$sloc $1 }
826 %inline mkpat(symb): symb
827 { mkpat ~loc:$sloc $1 }
828 %inline mktyp(symb): symb
829 { mktyp ~loc:$sloc $1 }
830 %inline mkstr(symb): symb
831 { mkstr ~loc:$sloc $1 }
832 %inline mksig(symb): symb
833 { mksig ~loc:$sloc $1 }
834 %inline mkmod(symb): symb
835 { mkmod ~loc:$sloc $1 }
836 %inline mkmty(symb): symb
837 { mkmty ~loc:$sloc $1 }
838 %inline mkcty(symb): symb
839 { mkcty ~loc:$sloc $1 }
840 %inline mkctf(symb): symb
841 { mkctf ~loc:$sloc $1 }
842 %inline mkcf(symb): symb
843 { mkcf ~loc:$sloc $1 }
844 %inline mkclass(symb): symb
845 { mkclass ~loc:$sloc $1 }
846
847 %inline wrap_mkstr_ext(symb): symb
848 { wrap_mkstr_ext ~loc:$sloc $1 }
849 %inline wrap_mksig_ext(symb): symb
850 { wrap_mksig_ext ~loc:$sloc $1 }
851
852 %inline mk_directive_arg(symb): symb
853 { mk_directive_arg ~loc:$sloc $1 }
854
855 /* Generic definitions */
856
857 (* [iloption(X)] recognizes either nothing or [X]. Assuming [X] produces
858 an OCaml list, it produces an OCaml list, too. *)
859
860 %inline iloption(X):
861 /* nothing */
862 { [] }
863 | x = X
864 { x }
865
866 (* [llist(X)] recognizes a possibly empty list of [X]s. It is left-recursive. *)
867
868 reversed_llist(X):
869 /* empty */
870 { [] }
871 | xs = reversed_llist(X) x = X
872 { x :: xs }
873
874 %inline llist(X):
875 xs = rev(reversed_llist(X))
876 { xs }
877
878 (* [reversed_nonempty_llist(X)] recognizes a nonempty list of [X]s, and produces
879 an OCaml list in reverse order -- that is, the last element in the input text
880 appears first in this list. Its definition is left-recursive. *)
881
882 reversed_nonempty_llist(X):
883 x = X
884 { [ x ] }
885 | xs = reversed_nonempty_llist(X) x = X
886 { x :: xs }
887
888 (* [nonempty_llist(X)] recognizes a nonempty list of [X]s, and produces an OCaml
889 list in direct order -- that is, the first element in the input text appears
890 first in this list. *)
891
892 %inline nonempty_llist(X):
893 xs = rev(reversed_nonempty_llist(X))
894 { xs }
895
896 (* [reversed_separated_nonempty_llist(separator, X)] recognizes a nonempty list
897 of [X]s, separated with [separator]s, and produces an OCaml list in reverse
898 order -- that is, the last element in the input text appears first in this
899 list. Its definition is left-recursive. *)
900
901 (* [inline_reversed_separated_nonempty_llist(separator, X)] is semantically
902 equivalent to [reversed_separated_nonempty_llist(separator, X)], but is
903 marked %inline, which means that the case of a list of length one and
904 the case of a list of length more than one will be distinguished at the
905 use site, and will give rise there to two productions. This can be used
906 to avoid certain conflicts. *)
907
908 %inline inline_reversed_separated_nonempty_llist(separator, X):
909 x = X
910 { [ x ] }
911 | xs = reversed_separated_nonempty_llist(separator, X)
912 separator
913 x = X
914 { x :: xs }
915
916 reversed_separated_nonempty_llist(separator, X):
917 xs = inline_reversed_separated_nonempty_llist(separator, X)
918 { xs }
919
920 (* [separated_nonempty_llist(separator, X)] recognizes a nonempty list of [X]s,
921 separated with [separator]s, and produces an OCaml list in direct order --
922 that is, the first element in the input text appears first in this list. *)
923
924 %inline separated_nonempty_llist(separator, X):
925 xs = rev(reversed_separated_nonempty_llist(separator, X))
926 { xs }
927
928 %inline inline_separated_nonempty_llist(separator, X):
929 xs = rev(inline_reversed_separated_nonempty_llist(separator, X))
930 { xs }
931
932 (* [reversed_separated_nontrivial_llist(separator, X)] recognizes a list of at
933 least two [X]s, separated with [separator]s, and produces an OCaml list in
934 reverse order -- that is, the last element in the input text appears first
935 in this list. Its definition is left-recursive. *)
936
937 reversed_separated_nontrivial_llist(separator, X):
938 xs = reversed_separated_nontrivial_llist(separator, X)
939 separator
940 x = X
941 { x :: xs }
942 | x1 = X
943 separator
944 x2 = X
945 { [ x2; x1 ] }
946
947 (* [separated_nontrivial_llist(separator, X)] recognizes a list of at least
948 two [X]s, separated with [separator]s, and produces an OCaml list in direct
949 order -- that is, the first element in the input text appears first in this
950 list. *)
951
952 %inline separated_nontrivial_llist(separator, X):
953 xs = rev(reversed_separated_nontrivial_llist(separator, X))
954 { xs }
955
956 (* [separated_or_terminated_nonempty_list(delimiter, X)] recognizes a nonempty
957 list of [X]s, separated with [delimiter]s, and optionally terminated with a
958 final [delimiter]. Its definition is right-recursive. *)
959
960 separated_or_terminated_nonempty_list(delimiter, X):
961 x = X ioption(delimiter)
962 { [x] }
963 | x = X
964 delimiter
965 xs = separated_or_terminated_nonempty_list(delimiter, X)
966 { x :: xs }
967
968 (* [reversed_preceded_or_separated_nonempty_llist(delimiter, X)] recognizes a
969 nonempty list of [X]s, separated with [delimiter]s, and optionally preceded
970 with a leading [delimiter]. It produces an OCaml list in reverse order. Its
971 definition is left-recursive. *)
972
973 reversed_preceded_or_separated_nonempty_llist(delimiter, X):
974 ioption(delimiter) x = X
975 { [x] }
976 | xs = reversed_preceded_or_separated_nonempty_llist(delimiter, X)
977 delimiter
978 x = X
979 { x :: xs }
980
981 (* [preceded_or_separated_nonempty_llist(delimiter, X)] recognizes a nonempty
982 list of [X]s, separated with [delimiter]s, and optionally preceded with a
983 leading [delimiter]. It produces an OCaml list in direct order. *)
984
985 %inline preceded_or_separated_nonempty_llist(delimiter, X):
986 xs = rev(reversed_preceded_or_separated_nonempty_llist(delimiter, X))
987 { xs }
988
989 (* [bar_llist(X)] recognizes a nonempty list of [X]'s, separated with BARs,
990 with an optional leading BAR. We assume that [X] is itself parameterized
991 with an opening symbol, which can be [epsilon] or [BAR]. *)
992
993 (* This construction may seem needlessly complicated: one might think that
994 using [preceded_or_separated_nonempty_llist(BAR, X)], where [X] is *not*
995 itself parameterized, would be sufficient. Indeed, this simpler approach
996 would recognize the same language. However, the two approaches differ in
997 the footprint of [X]. We want the start location of [X] to include [BAR]
998 when present. In the future, we might consider switching to the simpler
999 definition, at the cost of producing slightly different locations. TODO *)
1000
1001 reversed_bar_llist(X):
1002 (* An [X] without a leading BAR. *)
1003 x = X(epsilon)
1004 { [x] }
1005 | (* An [X] with a leading BAR. *)
1006 x = X(BAR)
1007 { [x] }
1008 | (* An initial list, followed with a BAR and an [X]. *)
1009 xs = reversed_bar_llist(X)
1010 x = X(BAR)
1011 { x :: xs }
1012
1013 %inline bar_llist(X):
1014 xs = reversed_bar_llist(X)
1015 { List.rev xs }
1016
1017 (* [xlist(A, B)] recognizes [AB*]. We assume that the semantic value for [A]
1018 is a pair [x, b], while the semantic value for [B*] is a list [bs].
1019 We return the pair [x, b :: bs]. *)
1020
1021 %inline xlist(A, B):
1022 a = A bs = B*
1023 { let (x, b) = a in x, b :: bs }
1024
1025 (* [listx(delimiter, X, Y)] recognizes a nonempty list of [X]s, optionally
1026 followed with a [Y], separated-or-terminated with [delimiter]s. The
1027 semantic value is a pair of a list of [X]s and an optional [Y]. *)
1028
1029 listx(delimiter, X, Y):
1030 | x = X ioption(delimiter)
1031 { [x], None }
1032 | x = X delimiter y = Y delimiter?
1033 { [x], Some y }
1034 | x = X
1035 delimiter
1036 tail = listx(delimiter, X, Y)
1037 { let xs, y = tail in
1038 x :: xs, y }
1039
1040 (* -------------------------------------------------------------------------- *)
1041
1042 (* Entry points. *)
1043
1044 (* An .ml file. *)
1045 implementation:
1046 structure EOF
1047 { $1 }
1048 ;
1049
1050 (* An .mli file. *)
1051 interface:
1052 signature EOF
1053 { $1 }
1054 ;
1055
1056 (* A toplevel phrase. *)
1057 toplevel_phrase:
1058 (* An expression with attributes, ended by a double semicolon. *)
1059 extra_str(text_str(str_exp))
1060 SEMISEMI
1061 { Ptop_def $1 }
1062 | (* A list of structure items, ended by a double semicolon. *)
1063 extra_str(flatten(text_str(structure_item)*))
1064 SEMISEMI
1065 { Ptop_def $1 }
1066 | (* A directive, ended by a double semicolon. *)
1067 toplevel_directive
1068 SEMISEMI
1069 { $1 }
1070 | (* End of input. *)
1071 EOF
1072 { raise End_of_file }
1073 ;
1074
1075 (* An .ml file that is read by #use. *)
1076 use_file:
1077 (* An optional standalone expression,
1078 followed with a series of elements,
1079 followed with EOF. *)
1080 extra_def(append(
1081 optional_use_file_standalone_expression,
1082 flatten(use_file_element*)
1083 ))
1084 EOF
1085 { $1 }
1086 ;
1087
1088 (* An optional standalone expression is just an expression with attributes
1089 (str_exp), with extra wrapping. *)
1090 %inline optional_use_file_standalone_expression:
1091 iloption(text_def(top_def(str_exp)))
1092 { $1 }
1093 ;
1094
1095 (* An element in a #used file is one of the following:
1096 - a double semicolon followed with an optional standalone expression;
1097 - a structure item;
1098 - a toplevel directive.
1099 *)
1100 %inline use_file_element:
1101 preceded(SEMISEMI, optional_use_file_standalone_expression)
1102 | text_def(top_def(structure_item))
1103 | text_def(mark_rhs_docs(toplevel_directive))
1104 { $1 }
1105 ;
1106
1107 parse_core_type:
1108 core_type EOF
1109 { $1 }
1110 ;
1111
1112 parse_expression:
1113 seq_expr EOF
1114 { $1 }
1115 ;
1116
1117 parse_pattern:
1118 pattern EOF
1119 { $1 }
1120 ;
1121
1122 (* -------------------------------------------------------------------------- *)
1123
1124 (* Functor arguments appear in module expressions and module types. *)
1125
1126 %inline functor_args:
1127 reversed_nonempty_llist(functor_arg)
1128 { $1 }
1129 (* Produce a reversed list on purpose;
1130 later processed using [fold_left]. *)
1131 ;
1132
1133 functor_arg:
1134 (* An anonymous and untyped argument. *)
1135 LPAREN RPAREN
1136 { Unit }
1137 | (* An argument accompanied with an explicit type. *)
1138 LPAREN x = mkrhs(module_name) COLON mty = module_type RPAREN
1139 { Named (x, mty) }
1140 ;
1141
1142 module_name:
1143 (* A named argument. *)
1144 x = UIDENT
1145 { Some x }
1146 | (* An anonymous argument. *)
1147 UNDERSCORE
1148 { None }
1149 ;
1150
1151 (* -------------------------------------------------------------------------- *)
1152
1153 (* Module expressions. *)
1154
1155 (* The syntax of module expressions is not properly stratified. The cases of
1156 functors, functor applications, and attributes interact and cause conflicts,
1157 which are resolved by precedence declarations. This is concise but fragile.
1158 Perhaps in the future an explicit stratification could be used. *)
1159
1160 module_expr:
1161 | STRUCT attrs = attributes s = structure END
1162 { mkmod ~loc:$sloc ~attrs (Pmod_structure s) }
1163 | STRUCT attributes structure error
1164 { unclosed "struct" $loc($1) "end" $loc($4) }
1165 | FUNCTOR attrs = attributes args = functor_args MINUSGREATER me = module_expr
1166 { wrap_mod_attrs ~loc:$sloc attrs (
1167 List.fold_left (fun acc arg ->
1168 mkmod ~loc:$sloc (Pmod_functor (arg, acc))
1169 ) me args
1170 ) }
1171 | me = paren_module_expr
1172 { me }
1173 | me = module_expr attr = attribute
1174 { Mod.attr me attr }
1175 | mkmod(
1176 (* A module identifier. *)
1177 x = mkrhs(mod_longident)
1178 { Pmod_ident x }
1179 | (* In a functor application, the actual argument must be parenthesized. *)
1180 me1 = module_expr me2 = paren_module_expr
1181 { Pmod_apply(me1, me2) }
1182 | (* Application to unit is sugar for application to an empty structure. *)
1183 me1 = module_expr LPAREN RPAREN
1184 { (* TODO review mkmod location *)
1185 Pmod_apply(me1, mkmod ~loc:$sloc (Pmod_structure [])) }
1186 | (* An extension. *)
1187 ex = extension
1188 { Pmod_extension ex }
1189 )
1190 { $1 }
1191 ;
1192
1193 (* A parenthesized module expression is a module expression that begins
1194 and ends with parentheses. *)
1195
1196 paren_module_expr:
1197 (* A module expression annotated with a module type. *)
1198 LPAREN me = module_expr COLON mty = module_type RPAREN
1199 { mkmod ~loc:$sloc (Pmod_constraint(me, mty)) }
1200 | LPAREN module_expr COLON module_type error
1201 { unclosed "(" $loc($1) ")" $loc($5) }
1202 | (* A module expression within parentheses. *)
1203 LPAREN me = module_expr RPAREN
1204 { me (* TODO consider reloc *) }
1205 | LPAREN module_expr error
1206 { unclosed "(" $loc($1) ")" $loc($3) }
1207 | (* A core language expression that produces a first-class module.
1208 This expression can be annotated in various ways. *)
1209 LPAREN VAL attrs = attributes e = expr_colon_package_type RPAREN
1210 { mkmod ~loc:$sloc ~attrs (Pmod_unpack e) }
1211 | LPAREN VAL attributes expr COLON error
1212 { unclosed "(" $loc($1) ")" $loc($6) }
1213 | LPAREN VAL attributes expr COLONGREATER error
1214 { unclosed "(" $loc($1) ")" $loc($6) }
1215 | LPAREN VAL attributes expr error
1216 { unclosed "(" $loc($1) ")" $loc($5) }
1217 ;
1218
1219 (* The various ways of annotating a core language expression that
1220 produces a first-class module that we wish to unpack. *)
1221 %inline expr_colon_package_type:
1222 e = expr
1223 { e }
1224 | e = expr COLON ty = package_type
1225 { ghexp ~loc:$loc (Pexp_constraint (e, ty)) }
1226 | e = expr COLON ty1 = package_type COLONGREATER ty2 = package_type
1227 { ghexp ~loc:$loc (Pexp_coerce (e, Some ty1, ty2)) }
1228 | e = expr COLONGREATER ty2 = package_type
1229 { ghexp ~loc:$loc (Pexp_coerce (e, None, ty2)) }
1230 ;
1231
1232 (* A structure, which appears between STRUCT and END (among other places),
1233 begins with an optional standalone expression, and continues with a list
1234 of structure elements. *)
1235 structure:
1236 extra_str(append(
1237 optional_structure_standalone_expression,
1238 flatten(structure_element*)
1239 ))
1240 { $1 }
1241 ;
1242
1243 (* An optional standalone expression is just an expression with attributes
1244 (str_exp), with extra wrapping. *)
1245 %inline optional_structure_standalone_expression:
1246 items = iloption(mark_rhs_docs(text_str(str_exp)))
1247 { items }
1248 ;
1249
1250 (* An expression with attributes, wrapped as a structure item. *)
1251 %inline str_exp:
1252 e = seq_expr
1253 attrs = post_item_attributes
1254 { mkstrexp e attrs }
1255 ;
1256
1257 (* A structure element is one of the following:
1258 - a double semicolon followed with an optional standalone expression;
1259 - a structure item. *)
1260 %inline structure_element:
1261 append(text_str_SEMISEMI, optional_structure_standalone_expression)
1262 | text_str(structure_item)
1263 { $1 }
1264 ;
1265
1266 (* A structure item. *)
1267 structure_item:
1268 let_bindings(ext)
1269 { val_of_let_bindings ~loc:$sloc $1 }
1270 | mkstr(
1271 item_extension post_item_attributes
1272 { let docs = symbol_docs $sloc in
1273 Pstr_extension ($1, add_docs_attrs docs $2) }
1274 | floating_attribute
1275 { Pstr_attribute $1 }
1276 )
1277 | wrap_mkstr_ext(
1278 primitive_declaration
1279 { pstr_primitive $1 }
1280 | value_description
1281 { pstr_primitive $1 }
1282 | type_declarations
1283 { pstr_type $1 }
1284 | str_type_extension
1285 { pstr_typext $1 }
1286 | str_exception_declaration
1287 { pstr_exception $1 }
1288 | module_binding
1289 { $1 }
1290 | rec_module_bindings
1291 { pstr_recmodule $1 }
1292 | module_type_declaration
1293 { let (body, ext) = $1 in (Pstr_modtype body, ext) }
1294 | open_declaration
1295 { let (body, ext) = $1 in (Pstr_open body, ext) }
1296 | class_declarations
1297 { let (ext, l) = $1 in (Pstr_class l, ext) }
1298 | class_type_declarations
1299 { let (ext, l) = $1 in (Pstr_class_type l, ext) }
1300 | include_statement(module_expr)
1301 { pstr_include $1 }
1302 )
1303 { $1 }
1304 ;
1305
1306 (* A single module binding. *)
1307 %inline module_binding:
1308 MODULE
1309 ext = ext attrs1 = attributes
1310 name = mkrhs(module_name)
1311 body = module_binding_body
1312 attrs2 = post_item_attributes
1313 { let docs = symbol_docs $sloc in
1314 let loc = make_loc $sloc in
1315 let attrs = attrs1 @ attrs2 in
1316 let body = Mb.mk name body ~attrs ~loc ~docs in
1317 Pstr_module body, ext }
1318 ;
1319
1320 (* The body (right-hand side) of a module binding. *)
1321 module_binding_body:
1322 EQUAL me = module_expr
1323 { me }
1324 | mkmod(
1325 COLON mty = module_type EQUAL me = module_expr
1326 { Pmod_constraint(me, mty) }
1327 | arg = functor_arg body = module_binding_body
1328 { Pmod_functor(arg, body) }
1329 ) { $1 }
1330 ;
1331
1332 (* A group of recursive module bindings. *)
1333 %inline rec_module_bindings:
1334 xlist(rec_module_binding, and_module_binding)
1335 { $1 }
1336 ;
1337
1338 (* The first binding in a group of recursive module bindings. *)
1339 %inline rec_module_binding:
1340 MODULE
1341 ext = ext
1342 attrs1 = attributes
1343 REC
1344 name = mkrhs(module_name)
1345 body = module_binding_body
1346 attrs2 = post_item_attributes
1347 {
1348 let loc = make_loc $sloc in
1349 let attrs = attrs1 @ attrs2 in
1350 let docs = symbol_docs $sloc in
1351 ext,
1352 Mb.mk name body ~attrs ~loc ~docs
1353 }
1354 ;
1355
1356 (* The following bindings in a group of recursive module bindings. *)
1357 %inline and_module_binding:
1358 AND
1359 attrs1 = attributes
1360 name = mkrhs(module_name)
1361 body = module_binding_body
1362 attrs2 = post_item_attributes
1363 {
1364 let loc = make_loc $sloc in
1365 let attrs = attrs1 @ attrs2 in
1366 let docs = symbol_docs $sloc in
1367 let text = symbol_text $symbolstartpos in
1368 Mb.mk name body ~attrs ~loc ~text ~docs
1369 }
1370 ;
1371
1372 (* -------------------------------------------------------------------------- *)
1373
1374 (* Shared material between structures and signatures. *)
1375
1376 (* An [include] statement can appear in a structure or in a signature,
1377 which is why this definition is parameterized. *)
1378 %inline include_statement(thing):
1379 INCLUDE
1380 ext = ext
1381 attrs1 = attributes
1382 thing = thing
1383 attrs2 = post_item_attributes
1384 {
1385 let attrs = attrs1 @ attrs2 in
1386 let loc = make_loc $sloc in
1387 let docs = symbol_docs $sloc in
1388 Incl.mk thing ~attrs ~loc ~docs, ext
1389 }
1390 ;
1391
1392 (* A module type declaration. *)
1393 module_type_declaration:
1394 MODULE TYPE
1395 ext = ext
1396 attrs1 = attributes
1397 id = mkrhs(ident)
1398 typ = preceded(EQUAL, module_type)?
1399 attrs2 = post_item_attributes
1400 {
1401 let attrs = attrs1 @ attrs2 in
1402 let loc = make_loc $sloc in
1403 let docs = symbol_docs $sloc in
1404 Mtd.mk id ?typ ~attrs ~loc ~docs, ext
1405 }
1406 ;
1407
1408 (* -------------------------------------------------------------------------- *)
1409
1410 (* Opens. *)
1411
1412 open_declaration:
1413 OPEN
1414 override = override_flag
1415 ext = ext
1416 attrs1 = attributes
1417 me = module_expr
1418 attrs2 = post_item_attributes
1419 {
1420 let attrs = attrs1 @ attrs2 in
1421 let loc = make_loc $sloc in
1422 let docs = symbol_docs $sloc in
1423 Opn.mk me ~override ~attrs ~loc ~docs, ext
1424 }
1425 ;
1426
1427 open_description:
1428 OPEN
1429 override = override_flag
1430 ext = ext
1431 attrs1 = attributes
1432 id = mkrhs(mod_ext_longident)
1433 attrs2 = post_item_attributes
1434 {
1435 let attrs = attrs1 @ attrs2 in
1436 let loc = make_loc $sloc in
1437 let docs = symbol_docs $sloc in
1438 Opn.mk id ~override ~attrs ~loc ~docs, ext
1439 }
1440 ;
1441
1442 %inline open_dot_declaration: mkrhs(mod_longident)
1443 { let loc = make_loc $loc($1) in
1444 let me = Mod.ident ~loc $1 in
1445 Opn.mk ~loc me }
1446 ;
1447
1448 (* -------------------------------------------------------------------------- *)
1449
1450 /* Module types */
1451
1452 module_type:
1453 | SIG attrs = attributes s = signature END
1454 { mkmty ~loc:$sloc ~attrs (Pmty_signature s) }
1455 | SIG attributes signature error
1456 { unclosed "sig" $loc($1) "end" $loc($4) }
1457 | FUNCTOR attrs = attributes args = functor_args
1458 MINUSGREATER mty = module_type
1459 %prec below_WITH
1460 { wrap_mty_attrs ~loc:$sloc attrs (
1461 List.fold_left (fun acc arg ->
1462 mkmty ~loc:$sloc (Pmty_functor (arg, acc))
1463 ) mty args
1464 ) }
1465 | MODULE TYPE OF attributes module_expr %prec below_LBRACKETAT
1466 { mkmty ~loc:$sloc ~attrs:$4 (Pmty_typeof $5) }
1467 | LPAREN module_type RPAREN
1468 { $2 }
1469 | LPAREN module_type error
1470 { unclosed "(" $loc($1) ")" $loc($3) }
1471 | module_type attribute
1472 { Mty.attr $1 $2 }
1473 | mkmty(
1474 mkrhs(mty_longident)
1475 { Pmty_ident $1 }
1476 | module_type MINUSGREATER module_type
1477 %prec below_WITH
1478 { Pmty_functor(Named (mknoloc None, $1), $3) }
1479 | module_type WITH separated_nonempty_llist(AND, with_constraint)
1480 { Pmty_with($1, $3) }
1481 /* | LPAREN MODULE mkrhs(mod_longident) RPAREN
1482 { Pmty_alias $3 } */
1483 | extension
1484 { Pmty_extension $1 }
1485 )
1486 { $1 }
1487 ;
1488 (* A signature, which appears between SIG and END (among other places),
1489 is a list of signature elements. *)
1490 signature:
1491 extra_sig(flatten(signature_element*))
1492 { $1 }
1493 ;
1494
1495 (* A signature element is one of the following:
1496 - a double semicolon;
1497 - a signature item. *)
1498 %inline signature_element:
1499 text_sig_SEMISEMI
1500 | text_sig(signature_item)
1501 { $1 }
1502 ;
1503
1504 (* A signature item. *)
1505 signature_item:
1506 | item_extension post_item_attributes
1507 { let docs = symbol_docs $sloc in
1508 mksig ~loc:$sloc (Psig_extension ($1, (add_docs_attrs docs $2))) }
1509 | mksig(
1510 floating_attribute
1511 { Psig_attribute $1 }
1512 )
1513 { $1 }
1514 | wrap_mksig_ext(
1515 value_description
1516 { psig_value $1 }
1517 | primitive_declaration
1518 { psig_value $1 }
1519 | type_declarations
1520 { psig_type $1 }
1521 | type_subst_declarations
1522 { psig_typesubst $1 }
1523 | sig_type_extension
1524 { psig_typext $1 }
1525 | sig_exception_declaration
1526 { psig_exception $1 }
1527 | module_declaration
1528 { let (body, ext) = $1 in (Psig_module body, ext) }
1529 | module_alias
1530 { let (body, ext) = $1 in (Psig_module body, ext) }
1531 | module_subst
1532 { let (body, ext) = $1 in (Psig_modsubst body, ext) }
1533 | rec_module_declarations
1534 { let (ext, l) = $1 in (Psig_recmodule l, ext) }
1535 | module_type_declaration
1536 { let (body, ext) = $1 in (Psig_modtype body, ext) }
1537 | open_description
1538 { let (body, ext) = $1 in (Psig_open body, ext) }
1539 | include_statement(module_type)
1540 { psig_include $1 }
1541 | class_descriptions
1542 { let (ext, l) = $1 in (Psig_class l, ext) }
1543 | class_type_declarations
1544 { let (ext, l) = $1 in (Psig_class_type l, ext) }
1545 )
1546 { $1 }
1547
1548 (* A module declaration. *)
1549 %inline module_declaration:
1550 MODULE
1551 ext = ext attrs1 = attributes
1552 name = mkrhs(module_name)
1553 body = module_declaration_body
1554 attrs2 = post_item_attributes
1555 {
1556 let attrs = attrs1 @ attrs2 in
1557 let loc = make_loc $sloc in
1558 let docs = symbol_docs $sloc in
1559 Md.mk name body ~attrs ~loc ~docs, ext
1560 }
1561 ;
1562
1563 (* The body (right-hand side) of a module declaration. *)
1564 module_declaration_body:
1565 COLON mty = module_type
1566 { mty }
1567 | mkmty(
1568 arg = functor_arg body = module_declaration_body
1569 { Pmty_functor(arg, body) }
1570 )
1571 { $1 }
1572 ;
1573
1574 (* A module alias declaration (in a signature). *)
1575 %inline module_alias:
1576 MODULE
1577 ext = ext attrs1 = attributes
1578 name = mkrhs(module_name)
1579 EQUAL
1580 body = module_expr_alias
1581 attrs2 = post_item_attributes
1582 {
1583 let attrs = attrs1 @ attrs2 in
1584 let loc = make_loc $sloc in
1585 let docs = symbol_docs $sloc in
1586 Md.mk name body ~attrs ~loc ~docs, ext
1587 }
1588 ;
1589 %inline module_expr_alias:
1590 id = mkrhs(mod_longident)
1591 { Mty.alias ~loc:(make_loc $sloc) id }
1592 ;
1593 (* A module substitution (in a signature). *)
1594 module_subst:
1595 MODULE
1596 ext = ext attrs1 = attributes
1597 uid = mkrhs(UIDENT)
1598 COLONEQUAL
1599 body = mkrhs(mod_ext_longident)
1600 attrs2 = post_item_attributes
1601 {
1602 let attrs = attrs1 @ attrs2 in
1603 let loc = make_loc $sloc in
1604 let docs = symbol_docs $sloc in
1605 Ms.mk uid body ~attrs ~loc ~docs, ext
1606 }
1607 | MODULE ext attributes mkrhs(UIDENT) COLONEQUAL error
1608 { expecting $loc($6) "module path" }
1609 ;
1610
1611 (* A group of recursive module declarations. *)
1612 %inline rec_module_declarations:
1613 xlist(rec_module_declaration, and_module_declaration)
1614 { $1 }
1615 ;
1616 %inline rec_module_declaration:
1617 MODULE
1618 ext = ext
1619 attrs1 = attributes
1620 REC
1621 name = mkrhs(module_name)
1622 COLON
1623 mty = module_type
1624 attrs2 = post_item_attributes
1625 {
1626 let attrs = attrs1 @ attrs2 in
1627 let loc = make_loc $sloc in
1628 let docs = symbol_docs $sloc in
1629 ext, Md.mk name mty ~attrs ~loc ~docs
1630 }
1631 ;
1632 %inline and_module_declaration:
1633 AND
1634 attrs1 = attributes
1635 name = mkrhs(module_name)
1636 COLON
1637 mty = module_type
1638 attrs2 = post_item_attributes
1639 {
1640 let attrs = attrs1 @ attrs2 in
1641 let docs = symbol_docs $sloc in
1642 let loc = make_loc $sloc in
1643 let text = symbol_text $symbolstartpos in
1644 Md.mk name mty ~attrs ~loc ~text ~docs
1645 }
1646 ;
1647
1648 (* -------------------------------------------------------------------------- *)
1649
1650 (* Class declarations. *)
1651
1652 %inline class_declarations:
1653 xlist(class_declaration, and_class_declaration)
1654 { $1 }
1655 ;
1656 %inline class_declaration:
1657 CLASS
1658 ext = ext
1659 attrs1 = attributes
1660 virt = virtual_flag
1661 params = formal_class_parameters
1662 id = mkrhs(LIDENT)
1663 body = class_fun_binding
1664 attrs2 = post_item_attributes
1665 {
1666 let attrs = attrs1 @ attrs2 in
1667 let loc = make_loc $sloc in
1668 let docs = symbol_docs $sloc in
1669 ext,
1670 Ci.mk id body ~virt ~params ~attrs ~loc ~docs
1671 }
1672 ;
1673 %inline and_class_declaration:
1674 AND
1675 attrs1 = attributes
1676 virt = virtual_flag
1677 params = formal_class_parameters
1678 id = mkrhs(LIDENT)
1679 body = class_fun_binding
1680 attrs2 = post_item_attributes
1681 {
1682 let attrs = attrs1 @ attrs2 in
1683 let loc = make_loc $sloc in
1684 let docs = symbol_docs $sloc in
1685 let text = symbol_text $symbolstartpos in
1686 Ci.mk id body ~virt ~params ~attrs ~loc ~text ~docs
1687 }
1688 ;
1689
1690 class_fun_binding:
1691 EQUAL class_expr
1692 { $2 }
1693 | mkclass(
1694 COLON class_type EQUAL class_expr
1695 { Pcl_constraint($4, $2) }
1696 | labeled_simple_pattern class_fun_binding
1697 { let (l,o,p) = $1 in Pcl_fun(l, o, p, $2) }
1698 ) { $1 }
1699 ;
1700
1701 formal_class_parameters:
1702 params = class_parameters(type_parameter)
1703 { params }
1704 ;
1705
1706 (* -------------------------------------------------------------------------- *)
1707
1708 (* Class expressions. *)
1709
1710 class_expr:
1711 class_simple_expr
1712 { $1 }
1713 | FUN attributes class_fun_def
1714 { wrap_class_attrs ~loc:$sloc $3 $2 }
1715 | let_bindings(no_ext) IN class_expr
1716 { class_of_let_bindings ~loc:$sloc $1 $3 }
1717 | LET OPEN override_flag attributes mkrhs(mod_longident) IN class_expr
1718 { let loc = ($startpos($2), $endpos($4)) in
1719 let od = Opn.mk ~override:$3 ~loc:(make_loc loc) $5 in
1720 mkclass ~loc:$sloc ~attrs:$4 (Pcl_open(od, $7)) }
1721 | class_expr attribute
1722 { Cl.attr $1 $2 }
1723 | mkclass(
1724 class_simple_expr nonempty_llist(labeled_simple_expr)
1725 { Pcl_apply($1, $2) }
1726 | extension
1727 { Pcl_extension $1 }
1728 ) { $1 }
1729 ;
1730 class_simple_expr:
1731 | LPAREN class_expr RPAREN
1732 { $2 }
1733 | LPAREN class_expr error
1734 { unclosed "(" $loc($1) ")" $loc($3) }
1735 | mkclass(
1736 tys = actual_class_parameters cid = mkrhs(class_longident)
1737 { Pcl_constr(cid, tys) }
1738 | OBJECT attributes class_structure error
1739 { unclosed "object" $loc($1) "end" $loc($4) }
1740 | LPAREN class_expr COLON class_type RPAREN
1741 { Pcl_constraint($2, $4) }
1742 | LPAREN class_expr COLON class_type error
1743 { unclosed "(" $loc($1) ")" $loc($5) }
1744 ) { $1 }
1745 | OBJECT attributes class_structure END
1746 { mkclass ~loc:$sloc ~attrs:$2 (Pcl_structure $3) }
1747 ;
1748
1749 class_fun_def:
1750 mkclass(
1751 labeled_simple_pattern MINUSGREATER e = class_expr
1752 | labeled_simple_pattern e = class_fun_def
1753 { let (l,o,p) = $1 in Pcl_fun(l, o, p, e) }
1754 ) { $1 }
1755 ;
1756 %inline class_structure:
1757 | class_self_pattern extra_cstr(class_fields)
1758 { Cstr.mk $1 $2 }
1759 ;
1760 class_self_pattern:
1761 LPAREN pattern RPAREN
1762 { reloc_pat ~loc:$sloc $2 }
1763 | mkpat(LPAREN pattern COLON core_type RPAREN
1764 { Ppat_constraint($2, $4) })
1765 { $1 }
1766 | /* empty */
1767 { ghpat ~loc:$sloc Ppat_any }
1768 ;
1769 %inline class_fields:
1770 flatten(text_cstr(class_field)*)
1771 { $1 }
1772 ;
1773 class_field:
1774 | INHERIT override_flag attributes class_expr
1775 self = preceded(AS, mkrhs(LIDENT))?
1776 post_item_attributes
1777 { let docs = symbol_docs $sloc in
1778 mkcf ~loc:$sloc (Pcf_inherit ($2, $4, self)) ~attrs:($3@$6) ~docs }
1779 | VAL value post_item_attributes
1780 { let v, attrs = $2 in
1781 let docs = symbol_docs $sloc in
1782 mkcf ~loc:$sloc (Pcf_val v) ~attrs:(attrs@$3) ~docs }
1783 | METHOD method_ post_item_attributes
1784 { let meth, attrs = $2 in
1785 let docs = symbol_docs $sloc in
1786 mkcf ~loc:$sloc (Pcf_method meth) ~attrs:(attrs@$3) ~docs }
1787 | CONSTRAINT attributes constrain_field post_item_attributes
1788 { let docs = symbol_docs $sloc in
1789 mkcf ~loc:$sloc (Pcf_constraint $3) ~attrs:($2@$4) ~docs }
1790 | INITIALIZER attributes seq_expr post_item_attributes
1791 { let docs = symbol_docs $sloc in
1792 mkcf ~loc:$sloc (Pcf_initializer $3) ~attrs:($2@$4) ~docs }
1793 | item_extension post_item_attributes
1794 { let docs = symbol_docs $sloc in
1795 mkcf ~loc:$sloc (Pcf_extension $1) ~attrs:$2 ~docs }
1796 | mkcf(floating_attribute
1797 { Pcf_attribute $1 })
1798 { $1 }
1799 ;
1800 value:
1801 no_override_flag
1802 attrs = attributes
1803 mutable_ = virtual_with_mutable_flag
1804 label = mkrhs(label) COLON ty = core_type
1805 { (label, mutable_, Cfk_virtual ty), attrs }
1806 | override_flag attributes mutable_flag mkrhs(label) EQUAL seq_expr
1807 { ($4, $3, Cfk_concrete ($1, $6)), $2 }
1808 | override_flag attributes mutable_flag mkrhs(label) type_constraint
1809 EQUAL seq_expr
1810 { let e = mkexp_constraint ~loc:$sloc $7 $5 in
1811 ($4, $3, Cfk_concrete ($1, e)), $2
1812 }
1813 ;
1814 method_:
1815 no_override_flag
1816 attrs = attributes
1817 private_ = virtual_with_private_flag
1818 label = mkrhs(label) COLON ty = poly_type
1819 { (label, private_, Cfk_virtual ty), attrs }
1820 | override_flag attributes private_flag mkrhs(label) strict_binding
1821 { let e = $5 in
1822 let loc = Location.(e.pexp_loc.loc_start, e.pexp_loc.loc_end) in
1823 ($4, $3,
1824 Cfk_concrete ($1, ghexp ~loc (Pexp_poly (e, None)))), $2 }
1825 | override_flag attributes private_flag mkrhs(label)
1826 COLON poly_type EQUAL seq_expr
1827 { let poly_exp =
1828 let loc = ($startpos($6), $endpos($8)) in
1829 ghexp ~loc (Pexp_poly($8, Some $6)) in
1830 ($4, $3, Cfk_concrete ($1, poly_exp)), $2 }
1831 | override_flag attributes private_flag mkrhs(label) COLON TYPE lident_list
1832 DOT core_type EQUAL seq_expr
1833 { let poly_exp_loc = ($startpos($7), $endpos($11)) in
1834 let poly_exp =
1835 let exp, poly =
1836 (* it seems odd to use the global ~loc here while poly_exp_loc
1837 is tighter, but this is what ocamlyacc does;
1838 TODO improve parser.mly *)
1839 wrap_type_annotation ~loc:$sloc $7 $9 $11 in
1840 ghexp ~loc:poly_exp_loc (Pexp_poly(exp, Some poly)) in
1841 ($4, $3,
1842 Cfk_concrete ($1, poly_exp)), $2 }
1843 ;
1844
1845 /* Class types */
1846
1847 class_type:
1848 class_signature
1849 { $1 }
1850 | mkcty(
1851 label = arg_label
1852 domain = tuple_type
1853 MINUSGREATER
1854 codomain = class_type
1855 { Pcty_arrow(label, domain, codomain) }
1856 ) { $1 }
1857 ;
1858 class_signature:
1859 mkcty(
1860 tys = actual_class_parameters cid = mkrhs(clty_longident)
1861 { Pcty_constr (cid, tys) }
1862 | extension
1863 { Pcty_extension $1 }
1864 ) { $1 }
1865 | OBJECT attributes class_sig_body END
1866 { mkcty ~loc:$sloc ~attrs:$2 (Pcty_signature $3) }
1867 | OBJECT attributes class_sig_body error
1868 { unclosed "object" $loc($1) "end" $loc($4) }
1869 | class_signature attribute
1870 { Cty.attr $1 $2 }
1871 | LET OPEN override_flag attributes mkrhs(mod_longident) IN class_signature
1872 { let loc = ($startpos($2), $endpos($4)) in
1873 let od = Opn.mk ~override:$3 ~loc:(make_loc loc) $5 in
1874 mkcty ~loc:$sloc ~attrs:$4 (Pcty_open(od, $7)) }
1875 ;
1876 %inline class_parameters(parameter):
1877 | /* empty */
1878 { [] }
1879 | LBRACKET params = separated_nonempty_llist(COMMA, parameter) RBRACKET
1880 { params }
1881 ;
1882 %inline actual_class_parameters:
1883 tys = class_parameters(core_type)
1884 { tys }
1885 ;
1886 %inline class_sig_body:
1887 class_self_type extra_csig(class_sig_fields)
1888 { Csig.mk $1 $2 }
1889 ;
1890 class_self_type:
1891 LPAREN core_type RPAREN
1892 { $2 }
1893 | mktyp((* empty *) { Ptyp_any })
1894 { $1 }
1895 ;
1896 %inline class_sig_fields:
1897 flatten(text_csig(class_sig_field)*)
1898 { $1 }
1899 ;
1900 class_sig_field:
1901 INHERIT attributes class_signature post_item_attributes
1902 { let docs = symbol_docs $sloc in
1903 mkctf ~loc:$sloc (Pctf_inherit $3) ~attrs:($2@$4) ~docs }
1904 | VAL attributes value_type post_item_attributes
1905 { let docs = symbol_docs $sloc in
1906 mkctf ~loc:$sloc (Pctf_val $3) ~attrs:($2@$4) ~docs }
1907 | METHOD attributes private_virtual_flags mkrhs(label) COLON poly_type
1908 post_item_attributes
1909 { let (p, v) = $3 in
1910 let docs = symbol_docs $sloc in
1911 mkctf ~loc:$sloc (Pctf_method ($4, p, v, $6)) ~attrs:($2@$7) ~docs }
1912 | CONSTRAINT attributes constrain_field post_item_attributes
1913 { let docs = symbol_docs $sloc in
1914 mkctf ~loc:$sloc (Pctf_constraint $3) ~attrs:($2@$4) ~docs }
1915 | item_extension post_item_attributes
1916 { let docs = symbol_docs $sloc in
1917 mkctf ~loc:$sloc (Pctf_extension $1) ~attrs:$2 ~docs }
1918 | mkctf(floating_attribute
1919 { Pctf_attribute $1 })
1920 { $1 }
1921 ;
1922 %inline value_type:
1923 flags = mutable_virtual_flags
1924 label = mkrhs(label)
1925 COLON
1926 ty = core_type
1927 {
1928 let mut, virt = flags in
1929 label, mut, virt, ty
1930 }
1931 ;
1932 %inline constrain:
1933 core_type EQUAL core_type
1934 { $1, $3, make_loc $sloc }
1935 ;
1936 constrain_field:
1937 core_type EQUAL core_type
1938 { $1, $3 }
1939 ;
1940 (* A group of class descriptions. *)
1941 %inline class_descriptions:
1942 xlist(class_description, and_class_description)
1943 { $1 }
1944 ;
1945 %inline class_description:
1946 CLASS
1947 ext = ext
1948 attrs1 = attributes
1949 virt = virtual_flag
1950 params = formal_class_parameters
1951 id = mkrhs(LIDENT)
1952 COLON
1953 cty = class_type
1954 attrs2 = post_item_attributes
1955 {
1956 let attrs = attrs1 @ attrs2 in
1957 let loc = make_loc $sloc in
1958 let docs = symbol_docs $sloc in
1959 ext,
1960 Ci.mk id cty ~virt ~params ~attrs ~loc ~docs
1961 }
1962 ;
1963 %inline and_class_description:
1964 AND
1965 attrs1 = attributes
1966 virt = virtual_flag
1967 params = formal_class_parameters
1968 id = mkrhs(LIDENT)
1969 COLON
1970 cty = class_type
1971 attrs2 = post_item_attributes
1972 {
1973 let attrs = attrs1 @ attrs2 in
1974 let loc = make_loc $sloc in
1975 let docs = symbol_docs $sloc in
1976 let text = symbol_text $symbolstartpos in
1977 Ci.mk id cty ~virt ~params ~attrs ~loc ~text ~docs
1978 }
1979 ;
1980 class_type_declarations:
1981 xlist(class_type_declaration, and_class_type_declaration)
1982 { $1 }
1983 ;
1984 %inline class_type_declaration:
1985 CLASS TYPE
1986 ext = ext
1987 attrs1 = attributes
1988 virt = virtual_flag
1989 params = formal_class_parameters
1990 id = mkrhs(LIDENT)
1991 EQUAL
1992 csig = class_signature
1993 attrs2 = post_item_attributes
1994 {
1995 let attrs = attrs1 @ attrs2 in
1996 let loc = make_loc $sloc in
1997 let docs = symbol_docs $sloc in
1998 ext,
1999 Ci.mk id csig ~virt ~params ~attrs ~loc ~docs
2000 }
2001 ;
2002 %inline and_class_type_declaration:
2003 AND
2004 attrs1 = attributes
2005 virt = virtual_flag
2006 params = formal_class_parameters
2007 id = mkrhs(LIDENT)
2008 EQUAL
2009 csig = class_signature
2010 attrs2 = post_item_attributes
2011 {
2012 let attrs = attrs1 @ attrs2 in
2013 let loc = make_loc $sloc in
2014 let docs = symbol_docs $sloc in
2015 let text = symbol_text $symbolstartpos in
2016 Ci.mk id csig ~virt ~params ~attrs ~loc ~text ~docs
2017 }
2018 ;
2019
2020 /* Core expressions */
2021
2022 seq_expr:
2023 | expr %prec below_SEMI { $1 }
2024 | expr SEMI { $1 }
2025 | mkexp(expr SEMI seq_expr
2026 { Pexp_sequence($1, $3) })
2027 { $1 }
2028 | expr SEMI PERCENT attr_id seq_expr
2029 { let seq = mkexp ~loc:$sloc (Pexp_sequence ($1, $5)) in
2030 let payload = PStr [mkstrexp seq []] in
2031 mkexp ~loc:$sloc (Pexp_extension ($4, payload)) }
2032 ;
2033 labeled_simple_pattern:
2034 QUESTION LPAREN label_let_pattern opt_default RPAREN
2035 { (Optional (fst $3), $4, snd $3) }
2036 | QUESTION label_var
2037 { (Optional (fst $2), None, snd $2) }
2038 | OPTLABEL LPAREN let_pattern opt_default RPAREN
2039 { (Optional $1, $4, $3) }
2040 | OPTLABEL pattern_var
2041 { (Optional $1, None, $2) }
2042 | TILDE LPAREN label_let_pattern RPAREN
2043 { (Labelled (fst $3), None, snd $3) }
2044 | TILDE label_var
2045 { (Labelled (fst $2), None, snd $2) }
2046 | LABEL simple_pattern
2047 { (Labelled $1, None, $2) }
2048 | simple_pattern
2049 { (Nolabel, None, $1) }
2050 ;
2051
2052 pattern_var:
2053 mkpat(
2054 mkrhs(LIDENT) { Ppat_var $1 }
2055 | UNDERSCORE { Ppat_any }
2056 ) { $1 }
2057 ;
2058
2059 %inline opt_default:
2060 preceded(EQUAL, seq_expr)?
2061 { $1 }
2062 ;
2063 label_let_pattern:
2064 x = label_var
2065 { x }
2066 | x = label_var COLON cty = core_type
2067 { let lab, pat = x in
2068 lab,
2069 mkpat ~loc:$sloc (Ppat_constraint (pat, cty)) }
2070 ;
2071 %inline label_var:
2072 mkrhs(LIDENT)
2073 { ($1.Location.txt, mkpat ~loc:$sloc (Ppat_var $1)) }
2074 ;
2075 let_pattern:
2076 pattern
2077 { $1 }
2078 | mkpat(pattern COLON core_type
2079 { Ppat_constraint($1, $3) })
2080 { $1 }
2081 ;
2082
2083 expr:
2084 simple_expr %prec below_HASH
2085 { $1 }
2086 | expr_attrs
2087 { let desc, attrs = $1 in
2088 mkexp_attrs ~loc:$sloc desc attrs }
2089 | mkexp(expr_)
2090 { $1 }
2091 | let_bindings(ext) IN seq_expr
2092 { expr_of_let_bindings ~loc:$sloc $1 $3 }
2093 | pbop_op = mkrhs(LETOP) bindings = letop_bindings IN body = seq_expr
2094 { let (pbop_pat, pbop_exp, rev_ands) = bindings in
2095 let ands = List.rev rev_ands in
2096 let pbop_loc = make_loc $sloc in
2097 let let_ = {pbop_op; pbop_pat; pbop_exp; pbop_loc} in
2098 mkexp ~loc:$sloc (Pexp_letop{ let_; ands; body}) }
2099 | expr COLONCOLON expr
2100 { mkexp_cons ~loc:$sloc $loc($2) (ghexp ~loc:$sloc (Pexp_tuple[$1;$3])) }
2101 | mkrhs(label) LESSMINUS expr
2102 { mkexp ~loc:$sloc (Pexp_setinstvar($1, $3)) }
2103 | simple_expr DOT mkrhs(label_longident) LESSMINUS expr
2104 { mkexp ~loc:$sloc (Pexp_setfield($1, $3, $5)) }
2105 | simple_expr DOT LPAREN seq_expr RPAREN LESSMINUS expr
2106 { array_set ~loc:$sloc $1 $4 $7 }
2107 | simple_expr DOT LBRACKET seq_expr RBRACKET LESSMINUS expr
2108 { string_set ~loc:$sloc $1 $4 $7 }
2109 | simple_expr DOT LBRACE expr RBRACE LESSMINUS expr
2110 { bigarray_set ~loc:$sloc $1 $4 $7 }
2111 | simple_expr DOTOP LBRACKET expr_semi_list RBRACKET LESSMINUS expr
2112 { dotop_set ~loc:$sloc lident bracket $2 $1 $4 $7 }
2113 | simple_expr DOTOP LPAREN expr_semi_list RPAREN LESSMINUS expr
2114 { dotop_set ~loc:$sloc lident paren $2 $1 $4 $7 }
2115 | simple_expr DOTOP LBRACE expr_semi_list RBRACE LESSMINUS expr
2116 { dotop_set ~loc:$sloc lident brace $2 $1 $4 $7 }
2117 | simple_expr DOT mod_longident DOTOP LBRACKET expr_semi_list RBRACKET
2118 LESSMINUS expr
2119 { dotop_set ~loc:$sloc (ldot $3) bracket $4 $1 $6 $9 }
2120 | simple_expr DOT mod_longident DOTOP LPAREN expr_semi_list RPAREN
2121 LESSMINUS expr
2122 { dotop_set ~loc:$sloc (ldot $3) paren $4 $1 $6 $9 }
2123 | simple_expr DOT mod_longident DOTOP LBRACE expr_semi_list RBRACE
2124 LESSMINUS expr
2125 { dotop_set ~loc:$sloc (ldot $3) brace $4 $1 $6 $9 }
2126 | expr attribute
2127 { Exp.attr $1 $2 }
2128 | UNDERSCORE
2129 { not_expecting $loc($1) "wildcard \"_\"" }
2130 ;
2131 %inline expr_attrs:
2132 | LET MODULE ext_attributes mkrhs(module_name) module_binding_body IN seq_expr
2133 { Pexp_letmodule($4, $5, $7), $3 }
2134 | LET EXCEPTION ext_attributes let_exception_declaration IN seq_expr
2135 { Pexp_letexception($4, $6), $3 }
2136 | LET OPEN override_flag ext_attributes module_expr IN seq_expr
2137 { let open_loc = make_loc ($startpos($2), $endpos($5)) in
2138 let od = Opn.mk $5 ~override:$3 ~loc:open_loc in
2139 Pexp_open(od, $7), $4 }
2140 | FUNCTION ext_attributes match_cases
2141 { Pexp_function $3, $2 }
2142 | FUN ext_attributes labeled_simple_pattern fun_def
2143 { let (l,o,p) = $3 in
2144 Pexp_fun(l, o, p, $4), $2 }
2145 | FUN ext_attributes LPAREN TYPE lident_list RPAREN fun_def
2146 { (mk_newtypes ~loc:$sloc $5 $7).pexp_desc, $2 }
2147 | MATCH ext_attributes seq_expr WITH match_cases
2148 { Pexp_match($3, $5), $2 }
2149 | TRY ext_attributes seq_expr WITH match_cases
2150 { Pexp_try($3, $5), $2 }
2151 | TRY ext_attributes seq_expr WITH error
2152 { syntax_error() }
2153 | IF ext_attributes seq_expr THEN expr ELSE expr
2154 { Pexp_ifthenelse($3, $5, Some $7), $2 }
2155 | IF ext_attributes seq_expr THEN expr
2156 { Pexp_ifthenelse($3, $5, None), $2 }
2157 | WHILE ext_attributes seq_expr DO seq_expr DONE
2158 { Pexp_while($3, $5), $2 }
2159 | FOR ext_attributes pattern EQUAL seq_expr direction_flag seq_expr DO
2160 seq_expr DONE
2161 { Pexp_for($3, $5, $7, $6, $9), $2 }
2162 | ASSERT ext_attributes simple_expr %prec below_HASH
2163 { Pexp_assert $3, $2 }
2164 | LAZY ext_attributes simple_expr %prec below_HASH
2165 { Pexp_lazy $3, $2 }
2166 | OBJECT ext_attributes class_structure END
2167 { Pexp_object $3, $2 }
2168 | OBJECT ext_attributes class_structure error
2169 { unclosed "object" $loc($1) "end" $loc($4) }
2170 ;
2171 %inline expr_:
2172 | simple_expr nonempty_llist(labeled_simple_expr)
2173 { Pexp_apply($1, $2) }
2174 | expr_comma_list %prec below_COMMA
2175 { Pexp_tuple($1) }
2176 | mkrhs(constr_longident) simple_expr %prec below_HASH
2177 { Pexp_construct($1, Some $2) }
2178 | name_tag simple_expr %prec below_HASH
2179 { Pexp_variant($1, Some $2) }
2180 | e1 = expr op = op(infix_operator) e2 = expr
2181 { mkinfix e1 op e2 }
2182 | subtractive expr %prec prec_unary_minus
2183 { mkuminus ~oploc:$loc($1) $1 $2 }
2184 | additive expr %prec prec_unary_plus
2185 { mkuplus ~oploc:$loc($1) $1 $2 }
2186 ;
2187
2188 simple_expr:
2189 | LPAREN seq_expr RPAREN
2190 { reloc_exp ~loc:$sloc $2 }
2191 | LPAREN seq_expr error
2192 { unclosed "(" $loc($1) ")" $loc($3) }
2193 | LPAREN seq_expr type_constraint RPAREN
2194 { mkexp_constraint ~loc:$sloc $2 $3 }
2195 | simple_expr DOT LPAREN seq_expr RPAREN
2196 { array_get ~loc:$sloc $1 $4 }
2197 | simple_expr DOT LPAREN seq_expr error
2198 { unclosed "(" $loc($3) ")" $loc($5) }
2199 | simple_expr DOT LBRACKET seq_expr RBRACKET
2200 { string_get ~loc:$sloc $1 $4 }
2201 | simple_expr DOT LBRACKET seq_expr error
2202 { unclosed "[" $loc($3) "]" $loc($5) }
2203 | simple_expr DOTOP LBRACKET expr_semi_list RBRACKET
2204 { dotop_get ~loc:$sloc lident bracket $2 $1 $4 }
2205 | simple_expr DOTOP LBRACKET expr_semi_list error
2206 { unclosed "[" $loc($3) "]" $loc($5) }
2207 | simple_expr DOTOP LPAREN expr_semi_list RPAREN
2208 { dotop_get ~loc:$sloc lident paren $2 $1 $4 }
2209 | simple_expr DOTOP LPAREN expr_semi_list error
2210 { unclosed "(" $loc($3) ")" $loc($5) }
2211 | simple_expr DOTOP LBRACE expr_semi_list RBRACE
2212 { dotop_get ~loc:$sloc lident brace $2 $1 $4 }
2213 | simple_expr DOTOP LBRACE expr error
2214 { unclosed "{" $loc($3) "}" $loc($5) }
2215 | simple_expr DOT mod_longident DOTOP LBRACKET expr_semi_list RBRACKET
2216 { dotop_get ~loc:$sloc (ldot $3) bracket $4 $1 $6 }
2217 | simple_expr DOT
2218 mod_longident DOTOP LBRACKET expr_semi_list error
2219 { unclosed "[" $loc($5) "]" $loc($7) }
2220 | simple_expr DOT mod_longident DOTOP LPAREN expr_semi_list RPAREN
2221 { dotop_get ~loc:$sloc (ldot $3) paren $4 $1 $6 }
2222 | simple_expr DOT
2223 mod_longident DOTOP LPAREN expr_semi_list error
2224 { unclosed "(" $loc($5) ")" $loc($7) }
2225 | simple_expr DOT mod_longident DOTOP LBRACE expr_semi_list RBRACE
2226 { dotop_get ~loc:$sloc (ldot $3) brace $4 $1 $6 }
2227 | simple_expr DOT
2228 mod_longident DOTOP LBRACE expr_semi_list error
2229 { unclosed "{" $loc($5) "}" $loc($7) }
2230 | simple_expr DOT LBRACE expr RBRACE
2231 { bigarray_get ~loc:$sloc $1 $4 }
2232 | simple_expr DOT LBRACE expr error
2233 { unclosed "{" $loc($3) "}" $loc($5) }
2234 | simple_expr_attrs
2235 { let desc, attrs = $1 in
2236 mkexp_attrs ~loc:$sloc desc attrs }
2237 | mkexp(simple_expr_)
2238 { $1 }
2239 ;
2240 %inline simple_expr_attrs:
2241 | BEGIN ext = ext attrs = attributes e = seq_expr END
2242 { e.pexp_desc, (ext, attrs @ e.pexp_attributes) }
2243 | BEGIN ext_attributes END
2244 { Pexp_construct (mkloc (Lident "()") (make_loc $sloc), None), $2 }
2245 | BEGIN ext_attributes seq_expr error
2246 { unclosed "begin" $loc($1) "end" $loc($4) }
2247 | NEW ext_attributes mkrhs(class_longident)
2248 { Pexp_new($3), $2 }
2249 | LPAREN MODULE ext_attributes module_expr RPAREN
2250 { Pexp_pack $4, $3 }
2251 | LPAREN MODULE ext_attributes module_expr COLON package_type RPAREN
2252 { Pexp_constraint (ghexp ~loc:$sloc (Pexp_pack $4), $6), $3 }
2253 | LPAREN MODULE ext_attributes module_expr COLON error
2254 { unclosed "(" $loc($1) ")" $loc($6) }
2255 ;
2256 %inline simple_expr_:
2257 | mkrhs(val_longident)
2258 { Pexp_ident ($1) }
2259 | constant
2260 { Pexp_constant $1 }
2261 | mkrhs(constr_longident) %prec prec_constant_constructor
2262 { Pexp_construct($1, None) }
2263 | name_tag %prec prec_constant_constructor
2264 { Pexp_variant($1, None) }
2265 | op(PREFIXOP) simple_expr
2266 { Pexp_apply($1, [Nolabel,$2]) }
2267 | op(BANG {"!"}) simple_expr
2268 { Pexp_apply($1, [Nolabel,$2]) }
2269 | LBRACELESS object_expr_content GREATERRBRACE
2270 { Pexp_override $2 }
2271 | LBRACELESS object_expr_content error
2272 { unclosed "{<" $loc($1) ">}" $loc($3) }
2273 | LBRACELESS GREATERRBRACE
2274 { Pexp_override [] }
2275 | simple_expr DOT mkrhs(label_longident)
2276 { Pexp_field($1, $3) }
2277 | od=open_dot_declaration DOT LPAREN seq_expr RPAREN
2278 { Pexp_open(od, $4) }
2279 | od=open_dot_declaration DOT LBRACELESS object_expr_content GREATERRBRACE
2280 { (* TODO: review the location of Pexp_override *)
2281 Pexp_open(od, mkexp ~loc:$sloc (Pexp_override $4)) }
2282 | mod_longident DOT LBRACELESS object_expr_content error
2283 { unclosed "{<" $loc($3) ">}" $loc($5) }
2284 | simple_expr HASH mkrhs(label)
2285 { Pexp_send($1, $3) }
2286 | simple_expr op(HASHOP) simple_expr
2287 { mkinfix $1 $2 $3 }
2288 | extension
2289 { Pexp_extension $1 }
2290 | od=open_dot_declaration DOT mkrhs(LPAREN RPAREN {Lident "()"})
2291 { (* TODO: review the location of Pexp_construct *)
2292 Pexp_open(od, mkexp ~loc:$sloc (Pexp_construct($3, None))) }
2293 | mod_longident DOT LPAREN seq_expr error
2294 { unclosed "(" $loc($3) ")" $loc($5) }
2295 | LBRACE record_expr_content RBRACE
2296 { let (exten, fields) = $2 in
2297 Pexp_record(fields, exten) }
2298 | LBRACE record_expr_content error
2299 { unclosed "{" $loc($1) "}" $loc($3) }
2300 | od=open_dot_declaration DOT LBRACE record_expr_content RBRACE
2301 { let (exten, fields) = $4 in
2302 (* TODO: review the location of Pexp_construct *)
2303 Pexp_open(od, mkexp ~loc:$sloc (Pexp_record(fields, exten))) }
2304 | mod_longident DOT LBRACE record_expr_content error
2305 { unclosed "{" $loc($3) "}" $loc($5) }
2306 | LBRACKETBAR expr_semi_list BARRBRACKET
2307 { Pexp_array($2) }
2308 | LBRACKETBAR expr_semi_list error
2309 { unclosed "[|" $loc($1) "|]" $loc($3) }
2310 | LBRACKETBAR BARRBRACKET
2311 { Pexp_array [] }
2312 | od=open_dot_declaration DOT LBRACKETBAR expr_semi_list BARRBRACKET
2313 { (* TODO: review the location of Pexp_array *)
2314 Pexp_open(od, mkexp ~loc:$sloc (Pexp_array($4))) }
2315 | od=open_dot_declaration DOT LBRACKETBAR BARRBRACKET
2316 { (* TODO: review the location of Pexp_array *)
2317 Pexp_open(od, mkexp ~loc:$sloc (Pexp_array [])) }
2318 | mod_longident DOT
2319 LBRACKETBAR expr_semi_list error
2320 { unclosed "[|" $loc($3) "|]" $loc($5) }
2321 | LBRACKET expr_semi_list RBRACKET
2322 { fst (mktailexp $loc($3) $2) }
2323 | LBRACKET expr_semi_list error
2324 { unclosed "[" $loc($1) "]" $loc($3) }
2325 | od=open_dot_declaration DOT LBRACKET expr_semi_list RBRACKET
2326 { let list_exp =
2327 (* TODO: review the location of list_exp *)
2328 let tail_exp, _tail_loc = mktailexp $loc($5) $4 in
2329 mkexp ~loc:$sloc tail_exp in
2330 Pexp_open(od, list_exp) }
2331 | od=open_dot_declaration DOT mkrhs(LBRACKET RBRACKET {Lident "[]"})
2332 { (* TODO: review the location of Pexp_construct *)
2333 Pexp_open(od, mkexp ~loc:$sloc (Pexp_construct($3, None))) }
2334 | mod_longident DOT
2335 LBRACKET expr_semi_list error
2336 { unclosed "[" $loc($3) "]" $loc($5) }
2337 | od=open_dot_declaration DOT LPAREN MODULE ext_attributes module_expr COLON
2338 package_type RPAREN
2339 { (* TODO: review the location of Pexp_constraint *)
2340 let modexp =
2341 mkexp_attrs ~loc:$sloc
2342 (Pexp_constraint (ghexp ~loc:$sloc (Pexp_pack $6), $8)) $5 in
2343 Pexp_open(od, modexp) }
2344 | mod_longident DOT
2345 LPAREN MODULE ext_attributes module_expr COLON error
2346 { unclosed "(" $loc($3) ")" $loc($8) }
2347 ;
2348 labeled_simple_expr:
2349 simple_expr %prec below_HASH
2350 { (Nolabel, $1) }
2351 | LABEL simple_expr %prec below_HASH
2352 { (Labelled $1, $2) }
2353 | TILDE label = LIDENT
2354 { let loc = $loc(label) in
2355 (Labelled label, mkexpvar ~loc label) }
2356 | QUESTION label = LIDENT
2357 { let loc = $loc(label) in
2358 (Optional label, mkexpvar ~loc label) }
2359 | OPTLABEL simple_expr %prec below_HASH
2360 { (Optional $1, $2) }
2361 ;
2362 %inline lident_list:
2363 xs = mkrhs(LIDENT)+
2364 { xs }
2365 ;
2366 %inline let_ident:
2367 val_ident { mkpatvar ~loc:$sloc $1 }
2368 ;
2369 let_binding_body:
2370 let_ident strict_binding
2371 { ($1, $2) }
2372 | let_ident type_constraint EQUAL seq_expr
2373 { let v = $1 in (* PR#7344 *)
2374 let t =
2375 match $2 with
2376 Some t, None -> t
2377 | _, Some t -> t
2378 | _ -> assert false
2379 in
2380 let loc = Location.(t.ptyp_loc.loc_start, t.ptyp_loc.loc_end) in
2381 let typ = ghtyp ~loc (Ptyp_poly([],t)) in
2382 let patloc = ($startpos($1), $endpos($2)) in
2383 (ghpat ~loc:patloc (Ppat_constraint(v, typ)),
2384 mkexp_constraint ~loc:$sloc $4 $2) }
2385 | let_ident COLON typevar_list DOT core_type EQUAL seq_expr
2386 (* TODO: could replace [typevar_list DOT core_type]
2387 with [mktyp(poly(core_type))]
2388 and simplify the semantic action? *)
2389 { let typloc = ($startpos($3), $endpos($5)) in
2390 let patloc = ($startpos($1), $endpos($5)) in
2391 (ghpat ~loc:patloc
2392 (Ppat_constraint($1, ghtyp ~loc:typloc (Ptyp_poly($3,$5)))),
2393 $7) }
2394 | let_ident COLON TYPE lident_list DOT core_type EQUAL seq_expr
2395 { let exp, poly =
2396 wrap_type_annotation ~loc:$sloc $4 $6 $8 in
2397 let loc = ($startpos($1), $endpos($6)) in
2398 (ghpat ~loc (Ppat_constraint($1, poly)), exp) }
2399 | pattern_no_exn EQUAL seq_expr
2400 { ($1, $3) }
2401 | simple_pattern_not_ident COLON core_type EQUAL seq_expr
2402 { let loc = ($startpos($1), $endpos($3)) in
2403 (ghpat ~loc (Ppat_constraint($1, $3)), $5) }
2404 ;
2405 (* The formal parameter EXT can be instantiated with ext or no_ext
2406 so as to indicate whether an extension is allowed or disallowed. *)
2407 let_bindings(EXT):
2408 let_binding(EXT) { $1 }
2409 | let_bindings(EXT) and_let_binding { addlb $1 $2 }
2410 ;
2411 %inline let_binding(EXT):
2412 LET
2413 ext = EXT
2414 attrs1 = attributes
2415 rec_flag = rec_flag
2416 body = let_binding_body
2417 attrs2 = post_item_attributes
2418 {
2419 let attrs = attrs1 @ attrs2 in
2420 mklbs ~loc:$sloc ext rec_flag (mklb ~loc:$sloc true body attrs)
2421 }
2422 ;
2423 and_let_binding:
2424 AND
2425 attrs1 = attributes
2426 body = let_binding_body
2427 attrs2 = post_item_attributes
2428 {
2429 let attrs = attrs1 @ attrs2 in
2430 mklb ~loc:$sloc false body attrs
2431 }
2432 ;
2433 letop_binding_body:
2434 pat = let_ident exp = strict_binding
2435 { (pat, exp) }
2436 | pat = simple_pattern COLON typ = core_type EQUAL exp = seq_expr
2437 { let loc = ($startpos(pat), $endpos(typ)) in
2438 (ghpat ~loc (Ppat_constraint(pat, typ)), exp) }
2439 | pat = pattern_no_exn EQUAL exp = seq_expr
2440 { (pat, exp) }
2441 ;
2442 letop_bindings:
2443 body = letop_binding_body
2444 { let let_pat, let_exp = body in
2445 let_pat, let_exp, [] }
2446 | bindings = letop_bindings pbop_op = mkrhs(ANDOP) body = let_binding_body
2447 { let let_pat, let_exp, rev_ands = bindings in
2448 let pbop_pat, pbop_exp = body in
2449 let pbop_loc = make_loc $sloc in
2450 let and_ = {pbop_op; pbop_pat; pbop_exp; pbop_loc} in
2451 let_pat, let_exp, and_ :: rev_ands }
2452 ;
2453 fun_binding:
2454 strict_binding
2455 { $1 }
2456 | type_constraint EQUAL seq_expr
2457 { mkexp_constraint ~loc:$sloc $3 $1 }
2458 ;
2459 strict_binding:
2460 EQUAL seq_expr
2461 { $2 }
2462 | labeled_simple_pattern fun_binding
2463 { let (l, o, p) = $1 in ghexp ~loc:$sloc (Pexp_fun(l, o, p, $2)) }
2464 | LPAREN TYPE lident_list RPAREN fun_binding
2465 { mk_newtypes ~loc:$sloc $3 $5 }
2466 ;
2467 %inline match_cases:
2468 xs = preceded_or_separated_nonempty_llist(BAR, match_case)
2469 { xs }
2470 ;
2471 match_case:
2472 pattern MINUSGREATER seq_expr
2473 { Exp.case $1 $3 }
2474 | pattern WHEN seq_expr MINUSGREATER seq_expr
2475 { Exp.case $1 ~guard:$3 $5 }
2476 | pattern MINUSGREATER DOT
2477 { Exp.case $1 (Exp.unreachable ~loc:(make_loc $loc($3)) ()) }
2478 ;
2479 fun_def:
2480 MINUSGREATER seq_expr
2481 { $2 }
2482 | mkexp(COLON atomic_type MINUSGREATER seq_expr
2483 { Pexp_constraint ($4, $2) })
2484 { $1 }
2485 /* Cf #5939: we used to accept (fun p when e0 -> e) */
2486 | labeled_simple_pattern fun_def
2487 {
2488 let (l,o,p) = $1 in
2489 ghexp ~loc:$sloc (Pexp_fun(l, o, p, $2))
2490 }
2491 | LPAREN TYPE lident_list RPAREN fun_def
2492 { mk_newtypes ~loc:$sloc $3 $5 }
2493 ;
2494 %inline expr_comma_list:
2495 es = separated_nontrivial_llist(COMMA, expr)
2496 { es }
2497 ;
2498 record_expr_content:
2499 eo = ioption(terminated(simple_expr, WITH))
2500 fields = separated_or_terminated_nonempty_list(SEMI, record_expr_field)
2501 { eo, fields }
2502 ;
2503 %inline record_expr_field:
2504 | label = mkrhs(label_longident)
2505 c = type_constraint?
2506 eo = preceded(EQUAL, expr)?
2507 { let e =
2508 match eo with
2509 | None ->
2510 (* No pattern; this is a pun. Desugar it. *)
2511 exp_of_longident ~loc:$sloc label
2512 | Some e ->
2513 e
2514 in
2515 label, mkexp_opt_constraint ~loc:$sloc e c }
2516 ;
2517 %inline object_expr_content:
2518 xs = separated_or_terminated_nonempty_list(SEMI, object_expr_field)
2519 { xs }
2520 ;
2521 %inline object_expr_field:
2522 label = mkrhs(label)
2523 oe = preceded(EQUAL, expr)?
2524 { let e =
2525 match oe with
2526 | None ->
2527 (* No expression; this is a pun. Desugar it. *)
2528 exp_of_label ~loc:$sloc label
2529 | Some e ->
2530 e
2531 in
2532 label, e }
2533 ;
2534 %inline expr_semi_list:
2535 es = separated_or_terminated_nonempty_list(SEMI, expr)
2536 { es }
2537 ;
2538 type_constraint:
2539 COLON core_type { (Some $2, None) }
2540 | COLON core_type COLONGREATER core_type { (Some $2, Some $4) }
2541 | COLONGREATER core_type { (None, Some $2) }
2542 | COLON error { syntax_error() }
2543 | COLONGREATER error { syntax_error() }
2544 ;
2545
2546 /* Patterns */
2547
2548 (* Whereas [pattern] is an arbitrary pattern, [pattern_no_exn] is a pattern
2549 that does not begin with the [EXCEPTION] keyword. Thus, [pattern_no_exn]
2550 is the intersection of the context-free language [pattern] with the
2551 regular language [^EXCEPTION .*].
2552
2553 Ideally, we would like to use [pattern] everywhere and check in a later
2554 phase that EXCEPTION patterns are used only where they are allowed (there
2555 is code in typing/typecore.ml to this end). Unfortunately, in the
2556 definition of [let_binding_body], we cannot allow [pattern]. That would
2557 create a shift/reduce conflict: upon seeing LET EXCEPTION ..., the parser
2558 wouldn't know whether this is the beginning of a LET EXCEPTION construct or
2559 the beginning of a LET construct whose pattern happens to begin with
2560 EXCEPTION. The conflict is avoided there by using [pattern_no_exn] in the
2561 definition of [let_binding_body].
2562
2563 In order to avoid duplication between the definitions of [pattern] and
2564 [pattern_no_exn], we create a parameterized definition [pattern_(self)]
2565 and instantiate it twice. *)
2566
2567 pattern:
2568 pattern_(pattern)
2569 { $1 }
2570 | EXCEPTION ext_attributes pattern %prec prec_constr_appl
2571 { mkpat_attrs ~loc:$sloc (Ppat_exception $3) $2}
2572 ;
2573
2574 pattern_no_exn:
2575 pattern_(pattern_no_exn)
2576 { $1 }
2577 ;
2578
2579 %inline pattern_(self):
2580 | self COLONCOLON pattern
2581 { mkpat_cons ~loc:$sloc $loc($2) (ghpat ~loc:$sloc (Ppat_tuple[$1;$3])) }
2582 | self attribute
2583 { Pat.attr $1 $2 }
2584 | pattern_gen
2585 { $1 }
2586 | mkpat(
2587 self AS mkrhs(val_ident)
2588 { Ppat_alias($1, $3) }
2589 | self AS error
2590 { expecting $loc($3) "identifier" }
2591 | pattern_comma_list(self) %prec below_COMMA
2592 { Ppat_tuple(List.rev $1) }
2593 | self COLONCOLON error
2594 { expecting $loc($3) "pattern" }
2595 | self BAR pattern
2596 { Ppat_or($1, $3) }
2597 | self BAR error
2598 { expecting $loc($3) "pattern" }
2599 ) { $1 }
2600 ;
2601
2602 pattern_gen:
2603 simple_pattern
2604 { $1 }
2605 | mkpat(
2606 mkrhs(constr_longident) pattern %prec prec_constr_appl
2607 { Ppat_construct($1, Some $2) }
2608 | name_tag pattern %prec prec_constr_appl
2609 { Ppat_variant($1, Some $2) }
2610 ) { $1 }
2611 | LAZY ext_attributes simple_pattern
2612 { mkpat_attrs ~loc:$sloc (Ppat_lazy $3) $2}
2613 ;
2614 simple_pattern:
2615 mkpat(mkrhs(val_ident) %prec below_EQUAL
2616 { Ppat_var ($1) })
2617 { $1 }
2618 | simple_pattern_not_ident { $1 }
2619 ;
2620
2621 simple_pattern_not_ident:
2622 | LPAREN pattern RPAREN
2623 { reloc_pat ~loc:$sloc $2 }
2624 | simple_delimited_pattern
2625 { $1 }
2626 | LPAREN MODULE ext_attributes mkrhs(module_name) RPAREN
2627 { mkpat_attrs ~loc:$sloc (Ppat_unpack $4) $3 }
2628 | LPAREN MODULE ext_attributes mkrhs(module_name) COLON package_type RPAREN
2629 { mkpat_attrs ~loc:$sloc
2630 (Ppat_constraint(mkpat ~loc:$sloc (Ppat_unpack $4), $6))
2631 $3 }
2632 | mkpat(simple_pattern_not_ident_)
2633 { $1 }
2634 ;
2635 %inline simple_pattern_not_ident_:
2636 | UNDERSCORE
2637 { Ppat_any }
2638 | signed_constant
2639 { Ppat_constant $1 }
2640 | signed_constant DOTDOT signed_constant
2641 { Ppat_interval ($1, $3) }
2642 | mkrhs(constr_longident)
2643 { Ppat_construct($1, None) }
2644 | name_tag
2645 { Ppat_variant($1, None) }
2646 | HASH mkrhs(type_longident)
2647 { Ppat_type ($2) }
2648 | mkrhs(mod_longident) DOT simple_delimited_pattern
2649 { Ppat_open($1, $3) }
2650 | mkrhs(mod_longident) DOT mkrhs(LBRACKET RBRACKET {Lident "[]"})
2651 { Ppat_open($1, mkpat ~loc:$sloc (Ppat_construct($3, None))) }
2652 | mkrhs(mod_longident) DOT mkrhs(LPAREN RPAREN {Lident "()"})
2653 { Ppat_open($1, mkpat ~loc:$sloc (Ppat_construct($3, None))) }
2654 | mkrhs(mod_longident) DOT LPAREN pattern RPAREN
2655 { Ppat_open ($1, $4) }
2656 | mod_longident DOT LPAREN pattern error
2657 { unclosed "(" $loc($3) ")" $loc($5) }
2658 | mod_longident DOT LPAREN error
2659 { expecting $loc($4) "pattern" }
2660 | LPAREN pattern error
2661 { unclosed "(" $loc($1) ")" $loc($3) }
2662 | LPAREN pattern COLON core_type RPAREN
2663 { Ppat_constraint($2, $4) }
2664 | LPAREN pattern COLON core_type error
2665 { unclosed "(" $loc($1) ")" $loc($5) }
2666 | LPAREN pattern COLON error
2667 { expecting $loc($4) "type" }
2668 | LPAREN MODULE ext_attributes module_name COLON package_type
2669 error
2670 { unclosed "(" $loc($1) ")" $loc($7) }
2671 | extension
2672 { Ppat_extension $1 }
2673 ;
2674
2675 simple_delimited_pattern:
2676 mkpat(
2677 LBRACE record_pat_content RBRACE
2678 { let (fields, closed) = $2 in
2679 Ppat_record(fields, closed) }
2680 | LBRACE record_pat_content error
2681 { unclosed "{" $loc($1) "}" $loc($3) }
2682 | LBRACKET pattern_semi_list RBRACKET
2683 { fst (mktailpat $loc($3) $2) }
2684 | LBRACKET pattern_semi_list error
2685 { unclosed "[" $loc($1) "]" $loc($3) }
2686 | LBRACKETBAR pattern_semi_list BARRBRACKET
2687 { Ppat_array $2 }
2688 | LBRACKETBAR BARRBRACKET
2689 { Ppat_array [] }
2690 | LBRACKETBAR pattern_semi_list error
2691 { unclosed "[|" $loc($1) "|]" $loc($3) }
2692 ) { $1 }
2693
2694 pattern_comma_list(self):
2695 pattern_comma_list(self) COMMA pattern { $3 :: $1 }
2696 | self COMMA pattern { [$3; $1] }
2697 | self COMMA error { expecting $loc($3) "pattern" }
2698 ;
2699 %inline pattern_semi_list:
2700 ps = separated_or_terminated_nonempty_list(SEMI, pattern)
2701 { ps }
2702 ;
2703 (* A label-pattern list is a nonempty list of label-pattern pairs, optionally
2704 followed with an UNDERSCORE, separated-or-terminated with semicolons. *)
2705 %inline record_pat_content:
2706 listx(SEMI, record_pat_field, UNDERSCORE)
2707 { let fields, closed = $1 in
2708 let closed = match closed with Some () -> Open | None -> Closed in
2709 fields, closed }
2710 ;
2711 %inline record_pat_field:
2712 label = mkrhs(label_longident)
2713 octy = preceded(COLON, core_type)?
2714 opat = preceded(EQUAL, pattern)?
2715 { let pat =
2716 match opat with
2717 | None ->
2718 (* No pattern; this is a pun. Desugar it. *)
2719 pat_of_label ~loc:$sloc label
2720 | Some pat ->
2721 pat
2722 in
2723 label, mkpat_opt_constraint ~loc:$sloc pat octy
2724 }
2725 ;
2726
2727 /* Value descriptions */
2728
2729 value_description:
2730 VAL
2731 ext = ext
2732 attrs1 = attributes
2733 id = mkrhs(val_ident)
2734 COLON
2735 ty = core_type
2736 attrs2 = post_item_attributes
2737 { let attrs = attrs1 @ attrs2 in
2738 let loc = make_loc $sloc in
2739 let docs = symbol_docs $sloc in
2740 Val.mk id ty ~attrs ~loc ~docs,
2741 ext }
2742 ;
2743
2744 /* Primitive declarations */
2745
2746 primitive_declaration:
2747 EXTERNAL
2748 ext = ext
2749 attrs1 = attributes
2750 id = mkrhs(val_ident)
2751 COLON
2752 ty = core_type
2753 EQUAL
2754 prim = raw_string+
2755 attrs2 = post_item_attributes
2756 { let attrs = attrs1 @ attrs2 in
2757 let loc = make_loc $sloc in
2758 let docs = symbol_docs $sloc in
2759 Val.mk id ty ~prim ~attrs ~loc ~docs,
2760 ext }
2761 ;
2762
2763 (* Type declarations and type substitutions. *)
2764
2765 (* Type declarations [type t = u] and type substitutions [type t := u] are very
2766 similar, so we view them as instances of [generic_type_declarations]. In the
2767 case of a type declaration, the use of [nonrec_flag] means that [NONREC] may
2768 be absent or present, whereas in the case of a type substitution, the use of
2769 [no_nonrec_flag] means that [NONREC] must be absent. The use of [type_kind]
2770 versus [type_subst_kind] means that in the first case, we expect an [EQUAL]
2771 sign, whereas in the second case, we expect [COLONEQUAL]. *)
2772
2773 %inline type_declarations:
2774 generic_type_declarations(nonrec_flag, type_kind)
2775 { $1 }
2776 ;
2777
2778 %inline type_subst_declarations:
2779 generic_type_declarations(no_nonrec_flag, type_subst_kind)
2780 { $1 }
2781 ;
2782
2783 (* A set of type declarations or substitutions begins with a
2784 [generic_type_declaration] and continues with a possibly empty list of
2785 [generic_and_type_declaration]s. *)
2786
2787 %inline generic_type_declarations(flag, kind):
2788 xlist(
2789 generic_type_declaration(flag, kind),
2790 generic_and_type_declaration(kind)
2791 )
2792 { $1 }
2793 ;
2794
2795 (* [generic_type_declaration] and [generic_and_type_declaration] look similar,
2796 but are in reality different enough that it is difficult to share anything
2797 between them. *)
2798
2799 generic_type_declaration(flag, kind):
2800 TYPE
2801 ext = ext
2802 attrs1 = attributes
2803 flag = flag
2804 params = type_parameters
2805 id = mkrhs(LIDENT)
2806 kind_priv_manifest = kind
2807 cstrs = constraints
2808 attrs2 = post_item_attributes
2809 {
2810 let (kind, priv, manifest) = kind_priv_manifest in
2811 let docs = symbol_docs $sloc in
2812 let attrs = attrs1 @ attrs2 in
2813 let loc = make_loc $sloc in
2814 (flag, ext),
2815 Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs
2816 }
2817 ;
2818 %inline generic_and_type_declaration(kind):
2819 AND
2820 attrs1 = attributes
2821 params = type_parameters
2822 id = mkrhs(LIDENT)
2823 kind_priv_manifest = kind
2824 cstrs = constraints
2825 attrs2 = post_item_attributes
2826 {
2827 let (kind, priv, manifest) = kind_priv_manifest in
2828 let docs = symbol_docs $sloc in
2829 let attrs = attrs1 @ attrs2 in
2830 let loc = make_loc $sloc in
2831 let text = symbol_text $symbolstartpos in
2832 Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ~text
2833 }
2834 ;
2835 %inline constraints:
2836 llist(preceded(CONSTRAINT, constrain))
2837 { $1 }
2838 ;
2839 (* Lots of %inline expansion are required for [nonempty_type_kind] to be
2840 LR(1). At the cost of some manual expansion, it would be possible to give a
2841 definition that leads to a smaller grammar (after expansion) and therefore
2842 a smaller automaton. *)
2843 nonempty_type_kind:
2844 | priv = inline_private_flag
2845 ty = core_type
2846 { (Ptype_abstract, priv, Some ty) }
2847 | oty = type_synonym
2848 priv = inline_private_flag
2849 cs = constructor_declarations
2850 { (Ptype_variant cs, priv, oty) }
2851 | oty = type_synonym
2852 priv = inline_private_flag
2853 DOTDOT
2854 { (Ptype_open, priv, oty) }
2855 | oty = type_synonym
2856 priv = inline_private_flag
2857 LBRACE ls = label_declarations RBRACE
2858 { (Ptype_record ls, priv, oty) }
2859 ;
2860 %inline type_synonym:
2861 ioption(terminated(core_type, EQUAL))
2862 { $1 }
2863 ;
2864 type_kind:
2865 /*empty*/
2866 { (Ptype_abstract, Public, None) }
2867 | EQUAL nonempty_type_kind
2868 { $2 }
2869 ;
2870 %inline type_subst_kind:
2871 COLONEQUAL nonempty_type_kind
2872 { $2 }
2873 ;
2874 type_parameters:
2875 /* empty */
2876 { [] }
2877 | p = type_parameter
2878 { [p] }
2879 | LPAREN ps = separated_nonempty_llist(COMMA, type_parameter) RPAREN
2880 { ps }
2881 ;
2882 type_parameter:
2883 type_variance type_variable { $2, $1 }
2884 ;
2885 type_variable:
2886 mktyp(
2887 QUOTE tyvar = ident
2888 { Ptyp_var tyvar }
2889 | UNDERSCORE
2890 { Ptyp_any }
2891 ) { $1 }
2892 ;
2893
2894 type_variance:
2895 /* empty */ { Invariant }
2896 | PLUS { Covariant }
2897 | MINUS { Contravariant }
2898 ;
2899
2900 (* A sequence of constructor declarations is either a single BAR, which
2901 means that the list is empty, or a nonempty BAR-separated list of
2902 declarations, with an optional leading BAR. *)
2903 constructor_declarations:
2904 | BAR
2905 { [] }
2906 | cs = bar_llist(constructor_declaration)
2907 { cs }
2908 ;
2909 (* A constructor declaration begins with an opening symbol, which can
2910 be either epsilon or BAR. Note that this opening symbol is included
2911 in the footprint $sloc. *)
2912 (* Because [constructor_declaration] and [extension_constructor_declaration]
2913 are identical except for their semantic actions, we introduce the symbol
2914 [generic_constructor_declaration], whose semantic action is neutral -- it
2915 merely returns a tuple. *)
2916 generic_constructor_declaration(opening):
2917 opening
2918 cid = mkrhs(constr_ident)
2919 args_res = generalized_constructor_arguments
2920 attrs = attributes
2921 {
2922 let args, res = args_res in
2923 let info = symbol_info $endpos in
2924 let loc = make_loc $sloc in
2925 cid, args, res, attrs, loc, info
2926 }
2927 ;
2928 %inline constructor_declaration(opening):
2929 d = generic_constructor_declaration(opening)
2930 {
2931 let cid, args, res, attrs, loc, info = d in
2932 Type.constructor cid ~args ?res ~attrs ~loc ~info
2933 }
2934 ;
2935 str_exception_declaration:
2936 sig_exception_declaration
2937 { $1 }
2938 | EXCEPTION
2939 ext = ext
2940 attrs1 = attributes
2941 id = mkrhs(constr_ident)
2942 EQUAL
2943 lid = mkrhs(constr_longident)
2944 attrs2 = attributes
2945 attrs = post_item_attributes
2946 { let loc = make_loc $sloc in
2947 let docs = symbol_docs $sloc in
2948 Te.mk_exception ~attrs
2949 (Te.rebind id lid ~attrs:(attrs1 @ attrs2) ~loc ~docs)
2950 , ext }
2951 ;
2952 sig_exception_declaration:
2953 EXCEPTION
2954 ext = ext
2955 attrs1 = attributes
2956 id = mkrhs(constr_ident)
2957 args_res = generalized_constructor_arguments
2958 attrs2 = attributes
2959 attrs = post_item_attributes
2960 { let args, res = args_res in
2961 let loc = make_loc $sloc in
2962 let docs = symbol_docs $sloc in
2963 Te.mk_exception ~attrs
2964 (Te.decl id ~args ?res ~attrs:(attrs1 @ attrs2) ~loc ~docs)
2965 , ext }
2966 ;
2967 %inline let_exception_declaration:
2968 mkrhs(constr_ident) generalized_constructor_arguments attributes
2969 { let args, res = $2 in
2970 Te.decl $1 ~args ?res ~attrs:$3 ~loc:(make_loc $sloc) }
2971 ;
2972 generalized_constructor_arguments:
2973 /*empty*/ { (Pcstr_tuple [],None) }
2974 | OF constructor_arguments { ($2,None) }
2975 | COLON constructor_arguments MINUSGREATER atomic_type %prec below_HASH
2976 { ($2,Some $4) }
2977 | COLON atomic_type %prec below_HASH
2978 { (Pcstr_tuple [],Some $2) }
2979 ;
2980
2981 constructor_arguments:
2982 | tys = inline_separated_nonempty_llist(STAR, atomic_type)
2983 %prec below_HASH
2984 { Pcstr_tuple tys }
2985 | LBRACE label_declarations RBRACE
2986 { Pcstr_record $2 }
2987 ;
2988 label_declarations:
2989 label_declaration { [$1] }
2990 | label_declaration_semi { [$1] }
2991 | label_declaration_semi label_declarations { $1 :: $2 }
2992 ;
2993 label_declaration:
2994 mutable_flag mkrhs(label) COLON poly_type_no_attr attributes
2995 { let info = symbol_info $endpos in
2996 Type.field $2 $4 ~mut:$1 ~attrs:$5 ~loc:(make_loc $sloc) ~info }
2997 ;
2998 label_declaration_semi:
2999 mutable_flag mkrhs(label) COLON poly_type_no_attr attributes SEMI attributes
3000 { let info =
3001 match rhs_info $endpos($5) with
3002 | Some _ as info_before_semi -> info_before_semi
3003 | None -> symbol_info $endpos
3004 in
3005 Type.field $2 $4 ~mut:$1 ~attrs:($5 @ $7) ~loc:(make_loc $sloc) ~info }
3006 ;
3007
3008 /* Type Extensions */
3009
3010 %inline str_type_extension:
3011 type_extension(extension_constructor)
3012 { $1 }
3013 ;
3014 %inline sig_type_extension:
3015 type_extension(extension_constructor_declaration)
3016 { $1 }
3017 ;
3018 %inline type_extension(declaration):
3019 TYPE
3020 ext = ext
3021 attrs1 = attributes
3022 no_nonrec_flag
3023 params = type_parameters
3024 tid = mkrhs(type_longident)
3025 PLUSEQ
3026 priv = private_flag
3027 cs = bar_llist(declaration)
3028 attrs2 = post_item_attributes
3029 { let docs = symbol_docs $sloc in
3030 let attrs = attrs1 @ attrs2 in
3031 Te.mk tid cs ~params ~priv ~attrs ~docs,
3032 ext }
3033 ;
3034 %inline extension_constructor(opening):
3035 extension_constructor_declaration(opening)
3036 { $1 }
3037 | extension_constructor_rebind(opening)
3038 { $1 }
3039 ;
3040 %inline extension_constructor_declaration(opening):
3041 d = generic_constructor_declaration(opening)
3042 {
3043 let cid, args, res, attrs, loc, info = d in
3044 Te.decl cid ~args ?res ~attrs ~loc ~info
3045 }
3046 ;
3047 extension_constructor_rebind(opening):
3048 opening
3049 cid = mkrhs(constr_ident)
3050 EQUAL
3051 lid = mkrhs(constr_longident)
3052 attrs = attributes
3053 { let info = symbol_info $endpos in
3054 Te.rebind cid lid ~attrs ~loc:(make_loc $sloc) ~info }
3055 ;
3056
3057 /* "with" constraints (additional type equations over signature components) */
3058
3059 with_constraint:
3060 TYPE type_parameters mkrhs(label_longident) with_type_binder
3061 core_type_no_attr constraints
3062 { let lident = loc_last $3 in
3063 Pwith_type
3064 ($3,
3065 (Type.mk lident
3066 ~params:$2
3067 ~cstrs:$6
3068 ~manifest:$5
3069 ~priv:$4
3070 ~loc:(make_loc $sloc))) }
3071 /* used label_longident instead of type_longident to disallow
3072 functor applications in type path */
3073 | TYPE type_parameters mkrhs(label_longident)
3074 COLONEQUAL core_type_no_attr
3075 { let lident = loc_last $3 in
3076 Pwith_typesubst
3077 ($3,
3078 (Type.mk lident
3079 ~params:$2
3080 ~manifest:$5
3081 ~loc:(make_loc $sloc))) }
3082 | MODULE mkrhs(mod_longident) EQUAL mkrhs(mod_ext_longident)
3083 { Pwith_module ($2, $4) }
3084 | MODULE mkrhs(mod_longident) COLONEQUAL mkrhs(mod_ext_longident)
3085 { Pwith_modsubst ($2, $4) }
3086 ;
3087 with_type_binder:
3088 EQUAL { Public }
3089 | EQUAL PRIVATE { Private }
3090 ;
3091
3092 /* Polymorphic types */
3093
3094 %inline typevar:
3095 QUOTE mkrhs(ident)
3096 { $2 }
3097 ;
3098 %inline typevar_list:
3099 nonempty_llist(typevar)
3100 { $1 }
3101 ;
3102 %inline poly(X):
3103 typevar_list DOT X
3104 { Ptyp_poly($1, $3) }
3105 ;
3106 possibly_poly(X):
3107 X
3108 { $1 }
3109 | mktyp(poly(X))
3110 { $1 }
3111 ;
3112 %inline poly_type:
3113 possibly_poly(core_type)
3114 { $1 }
3115 ;
3116 %inline poly_type_no_attr:
3117 possibly_poly(core_type_no_attr)
3118 { $1 }
3119 ;
3120
3121 (* -------------------------------------------------------------------------- *)
3122
3123 (* Core language types. *)
3124
3125 (* A core type (core_type) is a core type without attributes (core_type_no_attr)
3126 followed with a list of attributes. *)
3127 core_type:
3128 core_type_no_attr
3129 { $1 }
3130 | core_type attribute
3131 { Typ.attr $1 $2 }
3132 ;
3133
3134 (* A core type without attributes is currently defined as an alias type, but
3135 this could change in the future if new forms of types are introduced. From
3136 the outside, one should use core_type_no_attr. *)
3137 %inline core_type_no_attr:
3138 alias_type
3139 { $1 }
3140 ;
3141
3142 (* Alias types include:
3143 - function types (see below);
3144 - proper alias types: 'a -> int as 'a
3145 *)
3146 alias_type:
3147 function_type
3148 { $1 }
3149 | mktyp(
3150 ty = alias_type AS QUOTE tyvar = ident
3151 { Ptyp_alias(ty, tyvar) }
3152 )
3153 { $1 }
3154 ;
3155
3156 (* Function types include:
3157 - tuple types (see below);
3158 - proper function types: int -> int
3159 foo: int -> int
3160 ?foo: int -> int
3161 *)
3162 function_type:
3163 | ty = tuple_type
3164 %prec MINUSGREATER
3165 { ty }
3166 | mktyp(
3167 label = arg_label
3168 domain = extra_rhs(tuple_type)
3169 MINUSGREATER
3170 codomain = function_type
3171 { Ptyp_arrow(label, domain, codomain) }
3172 )
3173 { $1 }
3174 ;
3175 %inline arg_label:
3176 | label = optlabel
3177 { Optional label }
3178 | label = LIDENT COLON
3179 { Labelled label }
3180 | /* empty */
3181 { Nolabel }
3182 ;
3183 (* Tuple types include:
3184 - atomic types (see below);
3185 - proper tuple types: int * int * int list
3186 A proper tuple type is a star-separated list of at least two atomic types.
3187 *)
3188 tuple_type:
3189 | ty = atomic_type
3190 %prec below_HASH
3191 { ty }
3192 | mktyp(
3193 tys = separated_nontrivial_llist(STAR, atomic_type)
3194 { Ptyp_tuple tys }
3195 )
3196 { $1 }
3197 ;
3198
3199 (* Atomic types are the most basic level in the syntax of types.
3200 Atomic types include:
3201 - types between parentheses: (int -> int)
3202 - first-class module types: (module S)
3203 - type variables: 'a
3204 - applications of type constructors: int, int list, int option list
3205 - variant types: [`A]
3206 *)
3207 atomic_type:
3208 | LPAREN core_type RPAREN
3209 { $2 }
3210 | LPAREN MODULE ext_attributes package_type RPAREN
3211 { wrap_typ_attrs ~loc:$sloc (reloc_typ ~loc:$sloc $4) $3 }
3212 | mktyp( /* begin mktyp group */
3213 QUOTE ident
3214 { Ptyp_var $2 }
3215 | UNDERSCORE
3216 { Ptyp_any }
3217 | tys = actual_type_parameters
3218 tid = mkrhs(type_longident)
3219 { Ptyp_constr(tid, tys) }
3220 | LESS meth_list GREATER
3221 { let (f, c) = $2 in Ptyp_object (f, c) }
3222 | LESS GREATER
3223 { Ptyp_object ([], Closed) }
3224 | tys = actual_type_parameters
3225 HASH
3226 cid = mkrhs(class_longident)
3227 { Ptyp_class(cid, tys) }
3228 | LBRACKET tag_field RBRACKET
3229 (* not row_field; see CONFLICTS *)
3230 { Ptyp_variant([$2], Closed, None) }
3231 | LBRACKET BAR row_field_list RBRACKET
3232 { Ptyp_variant($3, Closed, None) }
3233 | LBRACKET row_field BAR row_field_list RBRACKET
3234 { Ptyp_variant($2 :: $4, Closed, None) }
3235 | LBRACKETGREATER BAR? row_field_list RBRACKET
3236 { Ptyp_variant($3, Open, None) }
3237 | LBRACKETGREATER RBRACKET
3238 { Ptyp_variant([], Open, None) }
3239 | LBRACKETLESS BAR? row_field_list RBRACKET
3240 { Ptyp_variant($3, Closed, Some []) }
3241 | LBRACKETLESS BAR? row_field_list GREATER name_tag_list RBRACKET
3242 { Ptyp_variant($3, Closed, Some $5) }
3243 | extension
3244 { Ptyp_extension $1 }
3245 )
3246 { $1 } /* end mktyp group */
3247 ;
3248
3249 (* This is the syntax of the actual type parameters in an application of
3250 a type constructor, such as int, int list, or (int, bool) Hashtbl.t.
3251 We allow one of the following:
3252 - zero parameters;
3253 - one parameter:
3254 an atomic type;
3255 among other things, this can be an arbitrary type between parentheses;
3256 - two or more parameters:
3257 arbitrary types, between parentheses, separated with commas.
3258 *)
3259 %inline actual_type_parameters:
3260 | /* empty */
3261 { [] }
3262 | ty = atomic_type
3263 { [ty] }
3264 | LPAREN tys = separated_nontrivial_llist(COMMA, core_type) RPAREN
3265 { tys }
3266 ;
3267
3268 %inline package_type:
3269 mktyp(module_type
3270 { Ptyp_package (package_type_of_module_type $1) })
3271 { $1 }
3272 ;
3273 %inline row_field_list:
3274 separated_nonempty_llist(BAR, row_field)
3275 { $1 }
3276 ;
3277 row_field:
3278 tag_field
3279 { $1 }
3280 | core_type
3281 { Rf.inherit_ ~loc:(make_loc $sloc) $1 }
3282 ;
3283 tag_field:
3284 mkrhs(name_tag) OF opt_ampersand amper_type_list attributes
3285 { let info = symbol_info $endpos in
3286 let attrs = add_info_attrs info $5 in
3287 Rf.tag ~loc:(make_loc $sloc) ~attrs $1 $3 $4 }
3288 | mkrhs(name_tag) attributes
3289 { let info = symbol_info $endpos in
3290 let attrs = add_info_attrs info $2 in
3291 Rf.tag ~loc:(make_loc $sloc) ~attrs $1 true [] }
3292 ;
3293 opt_ampersand:
3294 AMPERSAND { true }
3295 | /* empty */ { false }
3296 ;
3297 %inline amper_type_list:
3298 separated_nonempty_llist(AMPERSAND, core_type_no_attr)
3299 { $1 }
3300 ;
3301 %inline name_tag_list:
3302 nonempty_llist(name_tag)
3303 { $1 }
3304 ;
3305 (* A method list (in an object type). *)
3306 meth_list:
3307 head = field_semi tail = meth_list
3308 | head = inherit_field SEMI tail = meth_list
3309 { let (f, c) = tail in (head :: f, c) }
3310 | head = field_semi
3311 | head = inherit_field SEMI
3312 { [head], Closed }
3313 | head = field
3314 | head = inherit_field
3315 { [head], Closed }
3316 | DOTDOT
3317 { [], Open }
3318 ;
3319 %inline field:
3320 mkrhs(label) COLON poly_type_no_attr attributes
3321 { let info = symbol_info $endpos in
3322 let attrs = add_info_attrs info $4 in
3323 Of.tag ~loc:(make_loc $sloc) ~attrs $1 $3 }
3324 ;
3325
3326 %inline field_semi:
3327 mkrhs(label) COLON poly_type_no_attr attributes SEMI attributes
3328 { let info =
3329 match rhs_info $endpos($4) with
3330 | Some _ as info_before_semi -> info_before_semi
3331 | None -> symbol_info $endpos
3332 in
3333 let attrs = add_info_attrs info ($4 @ $6) in
3334 Of.tag ~loc:(make_loc $sloc) ~attrs $1 $3 }
3335 ;
3336
3337 %inline inherit_field:
3338 ty = atomic_type
3339 { Of.inherit_ ~loc:(make_loc $sloc) ty }
3340 ;
3341
3342 %inline label:
3343 LIDENT { $1 }
3344 ;
3345
3346 /* Constants */
3347
3348 constant:
3349 | INT { let (n, m) = $1 in Pconst_integer (n, m) }
3350 | CHAR { Pconst_char $1 }
3351 | STRING { let (s, d) = $1 in Pconst_string (s, d) }
3352 | FLOAT { let (f, m) = $1 in Pconst_float (f, m) }
3353 ;
3354 signed_constant:
3355 constant { $1 }
3356 | MINUS INT { let (n, m) = $2 in Pconst_integer("-" ^ n, m) }
3357 | MINUS FLOAT { let (f, m) = $2 in Pconst_float("-" ^ f, m) }
3358 | PLUS INT { let (n, m) = $2 in Pconst_integer (n, m) }
3359 | PLUS FLOAT { let (f, m) = $2 in Pconst_float(f, m) }
3360 ;
3361
3362 /* Identifiers and long identifiers */
3363
3364 ident:
3365 UIDENT { $1 }
3366 | LIDENT { $1 }
3367 ;
3368 val_ident:
3369 LIDENT { $1 }
3370 | LPAREN operator RPAREN { $2 }
3371 | LPAREN operator error { unclosed "(" $loc($1) ")" $loc($3) }
3372 | LPAREN error { expecting $loc($2) "operator" }
3373 | LPAREN MODULE error { expecting $loc($3) "module-expr" }
3374 ;
3375 operator:
3376 PREFIXOP { $1 }
3377 | LETOP { $1 }
3378 | ANDOP { $1 }
3379 | DOTOP LPAREN index_mod RPAREN { "."^ $1 ^"(" ^ $3 ^ ")" }
3380 | DOTOP LPAREN index_mod RPAREN LESSMINUS { "."^ $1 ^ "(" ^ $3 ^ ")<-" }
3381 | DOTOP LBRACKET index_mod RBRACKET { "."^ $1 ^"[" ^ $3 ^ "]" }
3382 | DOTOP LBRACKET index_mod RBRACKET LESSMINUS { "."^ $1 ^ "[" ^ $3 ^ "]<-" }
3383 | DOTOP LBRACE index_mod RBRACE { "."^ $1 ^"{" ^ $3 ^ "}" }
3384 | DOTOP LBRACE index_mod RBRACE LESSMINUS { "."^ $1 ^ "{" ^ $3 ^ "}<-" }
3385 | HASHOP { $1 }
3386 | BANG { "!" }
3387 | infix_operator { $1 }
3388 ;
3389 %inline infix_operator:
3390 | op = INFIXOP0 { op }
3391 | op = INFIXOP1 { op }
3392 | op = INFIXOP2 { op }
3393 | op = INFIXOP3 { op }
3394 | op = INFIXOP4 { op }
3395 | PLUS {"+"}
3396 | PLUSDOT {"+."}
3397 | PLUSEQ {"+="}
3398 | MINUS {"-"}
3399 | MINUSDOT {"-."}
3400 | STAR {"*"}
3401 | PERCENT {"%"}
3402 | EQUAL {"="}
3403 | LESS {"<"}
3404 | GREATER {">"}
3405 | OR {"or"}
3406 | BARBAR {"||"}
3407 | AMPERSAND {"&"}
3408 | AMPERAMPER {"&&"}
3409 | COLONEQUAL {":="}
3410 ;
3411 index_mod:
3412 | { "" }
3413 | SEMI DOTDOT { ";.." }
3414 ;
3415 constr_ident:
3416 UIDENT { $1 }
3417 | LBRACKET RBRACKET { "[]" }
3418 | LPAREN RPAREN { "()" }
3419 | LPAREN COLONCOLON RPAREN { "::" }
3420 | FALSE { "false" }
3421 | TRUE { "true" }
3422 ;
3423
3424 val_longident:
3425 val_ident { Lident $1 }
3426 | mod_longident DOT val_ident { Ldot($1, $3) }
3427 ;
3428 constr_longident:
3429 mod_longident %prec below_DOT { $1 }
3430 | mod_longident DOT LPAREN COLONCOLON RPAREN { Ldot($1,"::") }
3431 | LBRACKET RBRACKET { Lident "[]" }
3432 | LPAREN RPAREN { Lident "()" }
3433 | LPAREN COLONCOLON RPAREN { Lident "::" }
3434 | FALSE { Lident "false" }
3435 | TRUE { Lident "true" }
3436 ;
3437 label_longident:
3438 LIDENT { Lident $1 }
3439 | mod_longident DOT LIDENT { Ldot($1, $3) }
3440 ;
3441 type_longident:
3442 LIDENT { Lident $1 }
3443 | mod_ext_longident DOT LIDENT { Ldot($1, $3) }
3444 ;
3445 mod_longident:
3446 UIDENT { Lident $1 }
3447 | mod_longident DOT UIDENT { Ldot($1, $3) }
3448 ;
3449 mod_ext_longident:
3450 UIDENT { Lident $1 }
3451 | mod_ext_longident DOT UIDENT { Ldot($1, $3) }
3452 | mod_ext_longident LPAREN mod_ext_longident RPAREN
3453 { lapply ~loc:$sloc $1 $3 }
3454 | mod_ext_longident LPAREN error
3455 { expecting $loc($3) "module path" }
3456 ;
3457 mty_longident:
3458 ident { Lident $1 }
3459 | mod_ext_longident DOT ident { Ldot($1, $3) }
3460 ;
3461 clty_longident:
3462 LIDENT { Lident $1 }
3463 | mod_ext_longident DOT LIDENT { Ldot($1, $3) }
3464 ;
3465 class_longident:
3466 LIDENT { Lident $1 }
3467 | mod_longident DOT LIDENT { Ldot($1, $3) }
3468 ;
3469
3470 /* Toplevel directives */
3471
3472 toplevel_directive:
3473 HASH dir = mkrhs(ident)
3474 arg = ioption(mk_directive_arg(toplevel_directive_argument))
3475 { mk_directive ~loc:$sloc dir arg }
3476 ;
3477
3478 %inline toplevel_directive_argument:
3479 | STRING { let (s, _) = $1 in Pdir_string s }
3480 | INT { let (n, m) = $1 in Pdir_int (n ,m) }
3481 | val_longident { Pdir_ident $1 }
3482 | mod_longident { Pdir_ident $1 }
3483 | FALSE { Pdir_bool false }
3484 | TRUE { Pdir_bool true }
3485 ;
3486
3487 /* Miscellaneous */
3488
3489 (* The symbol epsilon can be used instead of an /* empty */ comment. *)
3490 %inline epsilon:
3491 /* empty */
3492 { () }
3493 ;
3494
3495 %inline raw_string:
3496 s = STRING
3497 { fst s }
3498 ;
3499
3500 name_tag:
3501 BACKQUOTE ident { $2 }
3502 ;
3503 rec_flag:
3504 /* empty */ { Nonrecursive }
3505 | REC { Recursive }
3506 ;
3507 %inline nonrec_flag:
3508 /* empty */ { Recursive }
3509 | NONREC { Nonrecursive }
3510 ;
3511 %inline no_nonrec_flag:
3512 /* empty */ { Recursive }
3513 | NONREC { not_expecting $loc "nonrec flag" }
3514 ;
3515 direction_flag:
3516 TO { Upto }
3517 | DOWNTO { Downto }
3518 ;
3519 private_flag:
3520 inline_private_flag
3521 { $1 }
3522 ;
3523 %inline inline_private_flag:
3524 /* empty */ { Public }
3525 | PRIVATE { Private }
3526 ;
3527 mutable_flag:
3528 /* empty */ { Immutable }
3529 | MUTABLE { Mutable }
3530 ;
3531 virtual_flag:
3532 /* empty */ { Concrete }
3533 | VIRTUAL { Virtual }
3534 ;
3535 mutable_virtual_flags:
3536 /* empty */
3537 { Immutable, Concrete }
3538 | MUTABLE
3539 { Mutable, Concrete }
3540 | VIRTUAL
3541 { Immutable, Virtual }
3542 | MUTABLE VIRTUAL
3543 | VIRTUAL MUTABLE
3544 { Mutable, Virtual }
3545 ;
3546 private_virtual_flags:
3547 /* empty */ { Public, Concrete }
3548 | PRIVATE { Private, Concrete }
3549 | VIRTUAL { Public, Virtual }
3550 | PRIVATE VIRTUAL { Private, Virtual }
3551 | VIRTUAL PRIVATE { Private, Virtual }
3552 ;
3553 (* This nonterminal symbol indicates the definite presence of a VIRTUAL
3554 keyword and the possible presence of a MUTABLE keyword. *)
3555 virtual_with_mutable_flag:
3556 | VIRTUAL { Immutable }
3557 | MUTABLE VIRTUAL { Mutable }
3558 | VIRTUAL MUTABLE { Mutable }
3559 ;
3560 (* This nonterminal symbol indicates the definite presence of a VIRTUAL
3561 keyword and the possible presence of a PRIVATE keyword. *)
3562 virtual_with_private_flag:
3563 | VIRTUAL { Public }
3564 | PRIVATE VIRTUAL { Private }
3565 | VIRTUAL PRIVATE { Private }
3566 ;
3567 %inline no_override_flag:
3568 /* empty */ { Fresh }
3569 ;
3570 %inline override_flag:
3571 /* empty */ { Fresh }
3572 | BANG { Override }
3573 ;
3574 subtractive:
3575 | MINUS { "-" }
3576 | MINUSDOT { "-." }
3577 ;
3578 additive:
3579 | PLUS { "+" }
3580 | PLUSDOT { "+." }
3581 ;
3582 optlabel:
3583 | OPTLABEL { $1 }
3584 | QUESTION LIDENT COLON { $2 }
3585 ;
3586
3587 /* Attributes and extensions */
3588
3589 single_attr_id:
3590 LIDENT { $1 }
3591 | UIDENT { $1 }
3592 | AND { "and" }
3593 | AS { "as" }
3594 | ASSERT { "assert" }
3595 | BEGIN { "begin" }
3596 | CLASS { "class" }
3597 | CONSTRAINT { "constraint" }
3598 | DO { "do" }
3599 | DONE { "done" }
3600 | DOWNTO { "downto" }
3601 | ELSE { "else" }
3602 | END { "end" }
3603 | EXCEPTION { "exception" }
3604 | EXTERNAL { "external" }
3605 | FALSE { "false" }
3606 | FOR { "for" }
3607 | FUN { "fun" }
3608 | FUNCTION { "function" }
3609 | FUNCTOR { "functor" }
3610 | IF { "if" }
3611 | IN { "in" }
3612 | INCLUDE { "include" }
3613 | INHERIT { "inherit" }
3614 | INITIALIZER { "initializer" }
3615 | LAZY { "lazy" }
3616 | LET { "let" }
3617 | MATCH { "match" }
3618 | METHOD { "method" }
3619 | MODULE { "module" }
3620 | MUTABLE { "mutable" }
3621 | NEW { "new" }
3622 | NONREC { "nonrec" }
3623 | OBJECT { "object" }
3624 | OF { "of" }
3625 | OPEN { "open" }
3626 | OR { "or" }
3627 | PRIVATE { "private" }
3628 | REC { "rec" }
3629 | SIG { "sig" }
3630 | STRUCT { "struct" }
3631 | THEN { "then" }
3632 | TO { "to" }
3633 | TRUE { "true" }
3634 | TRY { "try" }
3635 | TYPE { "type" }
3636 | VAL { "val" }
3637 | VIRTUAL { "virtual" }
3638 | WHEN { "when" }
3639 | WHILE { "while" }
3640 | WITH { "with" }
3641 /* mod/land/lor/lxor/lsl/lsr/asr are not supported for now */
3642 ;
3643
3644 attr_id:
3645 mkloc(
3646 single_attr_id { $1 }
3647 | single_attr_id DOT attr_id { $1 ^ "." ^ $3.txt }
3648 ) { $1 }
3649 ;
3650 attribute:
3651 LBRACKETAT attr_id payload RBRACKET
3652 { Attr.mk ~loc:(make_loc $sloc) $2 $3 }
3653 ;
3654 post_item_attribute:
3655 LBRACKETATAT attr_id payload RBRACKET
3656 { Attr.mk ~loc:(make_loc $sloc) $2 $3 }
3657 ;
3658 floating_attribute:
3659 LBRACKETATATAT attr_id payload RBRACKET
3660 { mark_symbol_docs $sloc;
3661 Attr.mk ~loc:(make_loc $sloc) $2 $3 }
3662 ;
3663 %inline post_item_attributes:
3664 post_item_attribute*
3665 { $1 }
3666 ;
3667 %inline attributes:
3668 attribute*
3669 { $1 }
3670 ;
3671 ext:
3672 | /* empty */ { None }
3673 | PERCENT attr_id { Some $2 }
3674 ;
3675 %inline no_ext:
3676 | /* empty */ { None }
3677 | PERCENT attr_id { not_expecting $loc "extension" }
3678 ;
3679 %inline ext_attributes:
3680 ext attributes { $1, $2 }
3681 ;
3682 extension:
3683 LBRACKETPERCENT attr_id payload RBRACKET { ($2, $3) }
3684 ;
3685 item_extension:
3686 LBRACKETPERCENTPERCENT attr_id payload RBRACKET { ($2, $3) }
3687 ;
3688 payload:
3689 structure { PStr $1 }
3690 | COLON signature { PSig $2 }
3691 | COLON core_type { PTyp $2 }
3692 | QUESTION pattern { PPat ($2, None) }
3693 | QUESTION pattern WHEN seq_expr { PPat ($2, Some $4) }
3694 ;
3695 %%
3696