diff --git a/CHANGES.md b/CHANGES.md index e6d50e1da..fb20f846f 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -21,6 +21,10 @@ details. a `ppxlib-pp-ast` executable in a new separate `ppxlib-tools` package (#517, @NathanReb) +- Change `-dparsetree` from a sexp output to a pretty printed AST, closer + to what the compiler's `-dparsetree` is. + (#530, @NathanReb) + 0.33.0 (2024-07-22) ------------------- diff --git a/ast/ast.ml b/ast/ast.ml index 992874a37..2c13355f8 100644 --- a/ast/ast.ml +++ b/ast/ast.ml @@ -13,9 +13,8 @@ (* *) (**************************************************************************) -(** Definition of the OCaml AST *) - open Import +(** Definition of the OCaml AST *) (* This file is obtained by: @@ -28,13 +27,13 @@ open Import - - Location.t -> location - - Longident.t -> longident - adding a type longident_loc = longident loc and replacing all the occurrences of the - latter by the former. This is so that we can override iteration an the level of a + latter by the former. This is so that we can override iteration at the level of a longident loc - adding a type cases = case list - - replacing all occurences of "case list" by "cases" + - replacing all occurrences of "case list" by "cases" - replacing all the (*IF_CURRENT = Foo.bar*) by: = Foo.bar - removing the extra values at the end of the file - - replacing app [type ...] by [and ...] to make everything one recursive block + - replacing all [type ...] by [and ...] to make everything one recursive block - adding [@@deriving_inline traverse][@@@end] at the end To update it to a newer OCaml version, create a new module with the above from the @@ -135,7 +134,7 @@ and attribute = Parsetree.attribute = { attr_payload : payload; attr_loc : location; } -(** Attributes such as [[@id ARG]] and [[@@id ARG]]. +(** Attributes such as [[\@id ARG]] and [[\@\@id ARG]]. Metadata containers passed around within the AST. The compiler ignores unknown attributes. *) @@ -161,7 +160,7 @@ and core_type = Parsetree.core_type = { ptyp_desc : core_type_desc; ptyp_loc : location; ptyp_loc_stack : location_stack; - ptyp_attributes : attributes; (** [... [@id1] [@id2]] *) + ptyp_attributes : attributes; (** [... [\@id1] [\@id2]] *) } and core_type_desc = Parsetree.core_type_desc = @@ -169,7 +168,6 @@ and core_type_desc = Parsetree.core_type_desc = | Ptyp_var of string (** A type variable such as ['a] *) | Ptyp_arrow of arg_label * core_type * core_type (** [Ptyp_arrow(lbl, T1, T2)] represents: - - [T1 -> T2] when [lbl] is {{!Asttypes.arg_label.Nolabel} [Nolabel]}, - [~l:T1 -> T2] when [lbl] is {{!Asttypes.arg_label.Labelled} [Labelled]}, @@ -180,29 +178,25 @@ and core_type_desc = Parsetree.core_type_desc = [T1 * ... * Tn]. Invariant: [n >= 2]. *) - | Ptyp_constr of longident_loc * core_type list + | Ptyp_constr of longident loc * core_type list (** [Ptyp_constr(lident, l)] represents: - - [tconstr] when [l=[]], - [T tconstr] when [l=[T]], - [(T1, ..., Tn) tconstr] when [l=[T1 ; ... ; Tn]]. *) | Ptyp_object of object_field list * closed_flag (** [Ptyp_object([ l1:T1; ...; ln:Tn ], flag)] represents: - - [< l1:T1; ...; ln:Tn >] when [flag] is {{!Asttypes.closed_flag.Closed} [Closed]}, - [< l1:T1; ...; ln:Tn; .. >] when [flag] is {{!Asttypes.closed_flag.Open} [Open]}. *) - | Ptyp_class of longident_loc * core_type list + | Ptyp_class of longident loc * core_type list (** [Ptyp_class(tconstr, l)] represents: - - [#tconstr] when [l=[]], - [T #tconstr] when [l=[T]], - [(T1, ..., Tn) #tconstr] when [l=[T1 ; ... ; Tn]]. *) - | Ptyp_alias of core_type * string (** [T as 'a]. *) + | Ptyp_alias of core_type * string loc (** [T as 'a]. *) | Ptyp_variant of row_field list * closed_flag * label list option (** [Ptyp_variant([`A;`B], flag, labels)] represents: - - [[ `A|`B ]] when [flag] is {{!Asttypes.closed_flag.Closed} [Closed]}, and [labels] is [None], - [[> `A|`B ]] when [flag] is {{!Asttypes.closed_flag.Open} [Open]}, @@ -241,11 +235,11 @@ and core_type_desc = Parsetree.core_type_desc = - As the {{!value_description.pval_type} [pval_type]} field of a {!value_description}. *) | Ptyp_package of package_type (** [(module S)]. *) + | Ptyp_open of longident loc * core_type (** [M.(T)] *) | Ptyp_extension of extension (** [[%id]]. *) -and package_type = longident_loc * (longident_loc * core_type) list +and package_type = longident loc * (longident loc * core_type) list (** As {!package_type} typed values: - - [(S, [])] represents [(module S)], - [(S, [(t1, T1) ; ... ; (tn, Tn)])] represents [(module S with type t1 = T1 and ... and tn = Tn)]. *) @@ -259,7 +253,6 @@ and row_field = Parsetree.row_field = { and row_field_desc = Parsetree.row_field_desc = | Rtag of label loc * bool * core_type list (** [Rtag(`A, b, l)] represents: - - [`A] when [b] is [true] and [l] is [[]], - [`A of T] when [b] is [false] and [l] is [[T]], - [`A of T1 & .. & Tn] when [b] is [false] and [l] is [[T1;...Tn]], @@ -287,7 +280,7 @@ and pattern = Parsetree.pattern = { ppat_desc : pattern_desc; ppat_loc : location; ppat_loc_stack : location_stack; - ppat_attributes : attributes; (** [... [@id1] [@id2]] *) + ppat_attributes : attributes; (** [... [\@id1] [\@id2]] *) } and pattern_desc = Parsetree.pattern_desc = @@ -306,9 +299,8 @@ and pattern_desc = Parsetree.pattern_desc = (** Patterns [(P1, ..., Pn)]. Invariant: [n >= 2] *) - | Ppat_construct of longident_loc * (string loc list * pattern) option + | Ppat_construct of longident loc * (string loc list * pattern) option (** [Ppat_construct(C, args)] represents: - - [C] when [args] is [None], - [C P] when [args] is [Some ([], P)] - [C (P1, ..., Pn)] when [args] is @@ -316,12 +308,10 @@ and pattern_desc = Parsetree.pattern_desc = - [C (type a b) P] when [args] is [Some ([a; b], P)] *) | Ppat_variant of label * pattern option (** [Ppat_variant(`A, pat)] represents: - - [`A] when [pat] is [None], - [`A P] when [pat] is [Some P] *) - | Ppat_record of (longident_loc * pattern) list * closed_flag + | Ppat_record of (longident loc * pattern) list * closed_flag (** [Ppat_record([(l1, P1) ; ... ; (ln, Pn)], flag)] represents: - - [{ l1=P1; ...; ln=Pn }] when [flag] is {{!Asttypes.closed_flag.Closed} [Closed]} - [{ l1=P1; ...; ln=Pn; _}] when [flag] is @@ -331,11 +321,10 @@ and pattern_desc = Parsetree.pattern_desc = | Ppat_array of pattern list (** Pattern [[| P1; ...; Pn |]] *) | Ppat_or of pattern * pattern (** Pattern [P1 | P2] *) | Ppat_constraint of pattern * core_type (** Pattern [(P : T)] *) - | Ppat_type of longident_loc (** Pattern [#tconst] *) + | Ppat_type of longident loc (** Pattern [#tconst] *) | Ppat_lazy of pattern (** Pattern [lazy P] *) | Ppat_unpack of string option loc (** [Ppat_unpack(s)] represents: - - [(module P)] when [s] is [Some "P"] - [(module _)] when [s] is [None] @@ -343,7 +332,7 @@ and pattern_desc = Parsetree.pattern_desc = [Ppat_constraint(Ppat_unpack(Some "P"), Ptyp_package S)] *) | Ppat_exception of pattern (** Pattern [exception P] *) | Ppat_extension of extension (** Pattern [[%id]] *) - | Ppat_open of longident_loc * pattern (** Pattern [M.(P)] *) + | Ppat_open of longident loc * pattern (** Pattern [M.(P)] *) (** {2 Value expressions} *) @@ -351,43 +340,31 @@ and expression = Parsetree.expression = { pexp_desc : expression_desc; pexp_loc : location; pexp_loc_stack : location_stack; - pexp_attributes : attributes; (** [... [@id1] [@id2]] *) + pexp_attributes : attributes; (** [... [\@id1] [\@id2]] *) } and expression_desc = Parsetree.expression_desc = - | Pexp_ident of longident_loc (** Identifiers such as [x] and [M.x] *) + | Pexp_ident of longident loc (** Identifiers such as [x] and [M.x] *) | Pexp_constant of constant (** Expressions constant such as [1], ['a'], ["true"], [1.0], [1l], [1L], [1n] *) | Pexp_let of rec_flag * value_binding list * expression (** [Pexp_let(flag, [(P1,E1) ; ... ; (Pn,En)], E)] represents: - - [let P1 = E1 and ... and Pn = EN in E] when [flag] is {{!Asttypes.rec_flag.Nonrecursive} [Nonrecursive]}, - [let rec P1 = E1 and ... and Pn = EN in E] when [flag] is {{!Asttypes.rec_flag.Recursive} [Recursive]}. *) - | Pexp_function of cases (** [function P1 -> E1 | ... | Pn -> En] *) - | Pexp_fun of arg_label * expression option * pattern * expression - (** [Pexp_fun(lbl, exp0, P, E1)] represents: - - - [fun P -> E1] when [lbl] is {{!Asttypes.arg_label.Nolabel} - [Nolabel]} and [exp0] is [None] - - [fun ~l:P -> E1] when [lbl] is {{!Asttypes.arg_label.Labelled} - [Labelled l]} and [exp0] is [None] - - [fun ?l:P -> E1] when [lbl] is {{!Asttypes.arg_label.Optional} - [Optional l]} and [exp0] is [None] - - [fun ?l:(P = E0) -> E1] when [lbl] is - {{!Asttypes.arg_label.Optional} [Optional l]} and [exp0] is - [Some E0] - - Notes: - - - If [E0] is provided, only {{!Asttypes.arg_label.Optional} - [Optional]} is allowed. - - [fun P1 P2 .. Pn -> E1] is represented as nested - {{!expression_desc.Pexp_fun} [Pexp_fun]}. - - [let f P = E] is represented using {{!expression_desc.Pexp_fun} - [Pexp_fun]}. *) + | Pexp_function of + function_param list * type_constraint option * function_body + (** [Pexp_function ([P1; ...; Pn], C, body)] represents any construct + involving [fun] or [function], including: + - [fun P1 ... Pn -> E] when [body = Pfunction_body E] + - [fun P1 ... Pn -> function p1 -> e1 | ... | pm -> em] when + [body = Pfunction_cases [ p1 -> e1; ...; pm -> em ]] [C] represents + a type constraint or coercion placed immediately before the arrow, + e.g. [fun P1 ... Pn : ty -> ...] when [C = Some (Pconstraint ty)]. A + function must have parameters. [Pexp_function (params, _, body)] + must have non-empty [params] or a [Pfunction_cases _] body. *) | Pexp_apply of expression * (arg_label * expression) list (** [Pexp_apply(E0, [(l1, E1) ; ... ; (ln, En)])] represents [E0 ~l1:E1 ... ~ln:En] @@ -406,26 +383,23 @@ and expression_desc = Parsetree.expression_desc = (** Expressions [(E1, ..., En)] Invariant: [n >= 2] *) - | Pexp_construct of longident_loc * expression option + | Pexp_construct of longident loc * expression option (** [Pexp_construct(C, exp)] represents: - - [C] when [exp] is [None], - [C E] when [exp] is [Some E], - [C (E1, ..., En)] when [exp] is [Some (Pexp_tuple[E1;...;En])] *) | Pexp_variant of label * expression option (** [Pexp_variant(`A, exp)] represents - - [`A] when [exp] is [None] - [`A E] when [exp] is [Some E] *) - | Pexp_record of (longident_loc * expression) list * expression option + | Pexp_record of (longident loc * expression) list * expression option (** [Pexp_record([(l1,P1) ; ... ; (ln,Pn)], exp0)] represents - - [{ l1=P1; ...; ln=Pn }] when [exp0] is [None] - [{ E0 with l1=P1; ...; ln=Pn }] when [exp0] is [Some E0] Invariant: [n > 0] *) - | Pexp_field of expression * longident_loc (** [E.l] *) - | Pexp_setfield of expression * longident_loc * expression + | Pexp_field of expression * longident loc (** [E.l] *) + | Pexp_setfield of expression * longident loc * expression (** [E1.l <- E2] *) | Pexp_array of expression list (** [[| E1; ...; En |]] *) | Pexp_ifthenelse of expression * expression * expression option @@ -434,7 +408,6 @@ and expression_desc = Parsetree.expression_desc = | Pexp_while of expression * expression (** [while E1 do E2 done] *) | Pexp_for of pattern * expression * expression * direction_flag * expression (** [Pexp_for(i, E1, E2, direction, E3)] represents: - - [for i = E1 to E2 do E3 done] when [direction] is {{!Asttypes.direction_flag.Upto} [Upto]} - [for i = E1 downto E2 do E3 done] when [direction] is @@ -442,11 +415,10 @@ and expression_desc = Parsetree.expression_desc = | Pexp_constraint of expression * core_type (** [(E : T)] *) | Pexp_coerce of expression * core_type option * core_type (** [Pexp_coerce(E, from, T)] represents - - [(E :> T)] when [from] is [None], - [(E : T0 :> T)] when [from] is [Some T0]. *) | Pexp_send of expression * label loc (** [E # m] *) - | Pexp_new of longident_loc (** [new M.c] *) + | Pexp_new of longident loc (** [new M.c] *) | Pexp_setinstvar of label loc * expression (** [x <- 2] *) | Pexp_override of (label loc * expression) list (** [{< x1 = E1; ...; xn = En >}] *) @@ -502,17 +474,71 @@ and binding_op = Parsetree.binding_op = { pbop_loc : location; } +and function_param_desc = Parsetree.function_param_desc = + | Pparam_val of arg_label * expression option * pattern + (** [Pparam_val (lbl, exp0, P)] represents the parameter: + - [P] when [lbl] is {{!Asttypes.arg_label.Nolabel} [Nolabel]} and + [exp0] is [None] + - [~l:P] when [lbl] is {{!Asttypes.arg_label.Labelled} [Labelled l]} + and [exp0] is [None] + - [?l:P] when [lbl] is {{!Asttypes.arg_label.Optional} [Optional l]} + and [exp0] is [None] + - [?l:(P = E0)] when [lbl] is {{!Asttypes.arg_label.Optional} + [Optional l]} and [exp0] is [Some E0] + + Note: If [E0] is provided, only {{!Asttypes.arg_label.Optional} + [Optional]} is allowed. *) + | Pparam_newtype of string loc + (** [Pparam_newtype x] represents the parameter [(type x)]. [x] carries + the location of the identifier, whereas the [pparam_loc] on the + enclosing [function_param] node is the location of the [(type x)] as a + whole. + + Multiple parameters [(type a b c)] are represented as multiple + [Pparam_newtype] nodes, let's say: + + {[ + [ + { pparam_kind = Pparam_newtype a; pparam_loc = loc1 }; + { pparam_kind = Pparam_newtype b; pparam_loc = loc2 }; + { pparam_kind = Pparam_newtype c; pparam_loc = loc3 }; + ] + ]} + + Here, the first loc [loc1] is the location of [(type a b c)], and the + subsequent locs [loc2] and [loc3] are the same as [loc1], except + marked as ghost locations. The locations on [a], [b], [c], correspond + to the variables [a], [b], and [c] in the source code. *) + +and function_param = Parsetree.function_param = { + pparam_loc : location; + pparam_desc : function_param_desc; +} + +(** See the comment on {{!expression_desc.Pexp_function} [Pexp_function]}. *) +and function_body = Parsetree.function_body = + | Pfunction_body of expression + | Pfunction_cases of cases * location * attributes + (** In [Pfunction_cases (_, loc, attrs)], the location extends from the + start of the [function] keyword to the end of the last case. The + compiler will only use typechecking-related attributes from [attrs], + e.g. enabling or disabling a warning. *) + +and type_constraint = Parsetree.type_constraint = + | Pconstraint of core_type + | Pcoerce of core_type option * core_type + (** See the comment on {{!expression_desc.Pexp_function} [Pexp_function]}. *) + (** {2 Value descriptions} *) and value_description = Parsetree.value_description = { pval_name : string loc; pval_type : core_type; pval_prim : string list; - pval_attributes : attributes; (** [... [@@id1] [@@id2]] *) + pval_attributes : attributes; (** [... [\@\@id1] [\@\@id2]] *) pval_loc : location; } (** Values of type {!value_description} represents: - - [val x: T], when {{!value_description.pval_prim} [pval_prim]} is [[]] - [external x: T = "s1" ... "sn"] when {{!value_description.pval_prim} [pval_prim]} is [["s1";..."sn"]] *) @@ -528,13 +554,12 @@ and type_declaration = Parsetree.type_declaration = { ptype_kind : type_kind; ptype_private : private_flag; (** for [= private ...] *) ptype_manifest : core_type option; (** represents [= T] *) - ptype_attributes : attributes; (** [... [@@id1] [@@id2]] *) + ptype_attributes : attributes; (** [... [\@\@id1] [\@\@id2]] *) ptype_loc : location; } (** Here are type declarations and their representation, for various {{!type_declaration.ptype_kind} [ptype_kind]} and {{!type_declaration.ptype_manifest} [ptype_manifest]} values: - - [type t] when [type_kind] is {{!type_kind.Ptype_abstract} [Ptype_abstract]}, and [manifest] is [None], - [type t = T0] when [type_kind] is {{!type_kind.Ptype_abstract} @@ -561,7 +586,7 @@ and label_declaration = Parsetree.label_declaration = { pld_mutable : mutable_flag; pld_type : core_type; pld_loc : location; - pld_attributes : attributes; (** [l : T [@id1] [@id2]] *) + pld_attributes : attributes; (** [l : T [\@id1] [\@id2]] *) } (** - [{ ...; l: T; ... }] when {{!label_declaration.pld_mutable} [pld_mutable]} is {{!Asttypes.mutable_flag.Immutable} [Immutable]}, @@ -576,7 +601,7 @@ and constructor_declaration = Parsetree.constructor_declaration = { pcd_args : constructor_arguments; pcd_res : core_type option; pcd_loc : location; - pcd_attributes : attributes; (** [C of ... [@id1] [@id2]] *) + pcd_attributes : attributes; (** [C of ... [\@id1] [\@id2]] *) } and constructor_arguments = Parsetree.constructor_arguments = @@ -584,7 +609,6 @@ and constructor_arguments = Parsetree.constructor_arguments = | Pcstr_record of label_declaration list (** Values of type {!constructor_declaration} represents the constructor arguments of: - - [C of T1 * ... * Tn] when [res = None], and [args = Pcstr_tuple [T1; ... ; Tn]], - [C: T0] when [res = Some T0], and [args = Pcstr_tuple []], @@ -595,12 +619,12 @@ and constructor_arguments = Parsetree.constructor_arguments = [args = Pcstr_record [...]]. *) and type_extension = Parsetree.type_extension = { - ptyext_path : longident_loc; + ptyext_path : longident loc; ptyext_params : (core_type * (variance * injectivity)) list; ptyext_constructors : extension_constructor list; ptyext_private : private_flag; ptyext_loc : location; - ptyext_attributes : attributes; (** ... [@@id1] [@@id2] *) + ptyext_attributes : attributes; (** ... [\@\@id1] [\@\@id2] *) } (** Definition of new extensions constructors for the extensive sum type [t] ([type t += ...]). *) @@ -609,13 +633,13 @@ and extension_constructor = Parsetree.extension_constructor = { pext_name : string loc; pext_kind : extension_constructor_kind; pext_loc : location; - pext_attributes : attributes; (** [C of ... [@id1] [@id2]] *) + pext_attributes : attributes; (** [C of ... [\@id1] [\@id2]] *) } and type_exception = Parsetree.type_exception = { ptyexn_constructor : extension_constructor; ptyexn_loc : location; - ptyexn_attributes : attributes; (** [... [@@id1] [@@id2]] *) + ptyexn_attributes : attributes; (** [... [\@\@id1] [\@\@id2]] *) } (** Definition of a new exception ([exception E]). *) @@ -623,38 +647,33 @@ and extension_constructor_kind = Parsetree.extension_constructor_kind = | Pext_decl of string loc list * constructor_arguments * core_type option (** [Pext_decl(existentials, c_args, t_opt)] describes a new extension constructor. It can be: - {ul {- [C of T1 * ... * Tn] when: - - [existentials] is [[]], - [c_args] is [[T1; ...; Tn]], - [t_opt] is [None]. } {- [C: T0] when - - [existentials] is [[]], - [c_args] is [[]], - [t_opt] is [Some T0]. } {- [C: T1 * ... * Tn -> T0] when - - [existentials] is [[]], - [c_args] is [[T1; ...; Tn]], - [t_opt] is [Some T0]. } {- [C: 'a... . T1 * ... * Tn -> T0] when - - [existentials] is [['a;...]], - [c_args] is [[T1; ... ; Tn]], - [t_opt] is [Some T0]. } } *) - | Pext_rebind of longident_loc + | Pext_rebind of longident loc (** [Pext_rebind(D)] re-export the constructor [D] with the new name [C] *) (** {1 Class language} *) @@ -663,17 +682,16 @@ and extension_constructor_kind = Parsetree.extension_constructor_kind = and class_type = Parsetree.class_type = { pcty_desc : class_type_desc; pcty_loc : location; - pcty_attributes : attributes; (** [... [@id1] [@id2]] *) + pcty_attributes : attributes; (** [... [\@id1] [\@id2]] *) } and class_type_desc = Parsetree.class_type_desc = - | Pcty_constr of longident_loc * core_type list + | Pcty_constr of longident loc * core_type list (** - [c] - [['a1, ..., 'an] c] *) | Pcty_signature of class_signature (** [object ... end] *) | Pcty_arrow of arg_label * core_type * class_type (** [Pcty_arrow(lbl, T, CT)] represents: - - [T -> CT] when [lbl] is {{!Asttypes.arg_label.Nolabel} [Nolabel]}, - [~l:T -> CT] when [lbl] is {{!Asttypes.arg_label.Labelled} [Labelled l]}, @@ -687,7 +705,6 @@ and class_signature = Parsetree.class_signature = { pcsig_fields : class_type_field list; } (** Values of type [class_signature] represents: - - [object('selfpat) ... end] - [object ... end] when {{!class_signature.pcsig_self} [pcsig_self]} is {{!core_type_desc.Ptyp_any} [Ptyp_any]} *) @@ -695,7 +712,7 @@ and class_signature = Parsetree.class_signature = { and class_type_field = Parsetree.class_type_field = { pctf_desc : class_type_field_desc; pctf_loc : location; - pctf_attributes : attributes; (** [... [@@id1] [@@id2]] *) + pctf_attributes : attributes; (** [... [\@\@id1] [\@\@id2]] *) } and class_type_field_desc = Parsetree.class_type_field_desc = @@ -707,7 +724,7 @@ and class_type_field_desc = Parsetree.class_type_field_desc = Note: [T] can be a {{!core_type_desc.Ptyp_poly} [Ptyp_poly]}. *) | Pctf_constraint of (core_type * core_type) (** [constraint T1 = T2] *) - | Pctf_attribute of attribute (** [[@@@id]] *) + | Pctf_attribute of attribute (** [[\@\@\@id]] *) | Pctf_extension of extension (** [[%%id]] *) and 'a class_infos = 'a Parsetree.class_infos = { @@ -716,10 +733,9 @@ and 'a class_infos = 'a Parsetree.class_infos = { pci_name : string loc; pci_expr : 'a; pci_loc : location; - pci_attributes : attributes; (** [... [@@id1] [@@id2]] *) + pci_attributes : attributes; (** [... [\@\@id1] [\@\@id2]] *) } (** Values of type [class_expr class_infos] represents: - - [class c = ...] - [class ['a1,...,'an] c = ...] - [class virtual c = ...] @@ -734,16 +750,15 @@ and class_type_declaration = class_type class_infos and class_expr = Parsetree.class_expr = { pcl_desc : class_expr_desc; pcl_loc : location; - pcl_attributes : attributes; (** [... [@id1] [@id2]] *) + pcl_attributes : attributes; (** [... [\@id1] [\@id2]] *) } and class_expr_desc = Parsetree.class_expr_desc = - | Pcl_constr of longident_loc * core_type list + | Pcl_constr of longident loc * core_type list (** [c] and [['a1, ..., 'an] c] *) | Pcl_structure of class_structure (** [object ... end] *) | Pcl_fun of arg_label * expression option * pattern * class_expr (** [Pcl_fun(lbl, exp0, P, CE)] represents: - - [fun P -> CE] when [lbl] is {{!Asttypes.arg_label.Nolabel} [Nolabel]} and [exp0] is [None], - [fun ~l:P -> CE] when [lbl] is {{!Asttypes.arg_label.Labelled} @@ -761,7 +776,6 @@ and class_expr_desc = Parsetree.class_expr_desc = Invariant: [n > 0] *) | Pcl_let of rec_flag * value_binding list * class_expr (** [Pcl_let(rec, [(P1, E1); ... ; (Pn, En)], CE)] represents: - - [let P1 = E1 and ... and Pn = EN in CE] when [rec] is {{!Asttypes.rec_flag.Nonrecursive} [Nonrecursive]}, - [let rec P1 = E1 and ... and Pn = EN in CE] when [rec] is @@ -775,7 +789,6 @@ and class_structure = Parsetree.class_structure = { pcstr_fields : class_field list; } (** Values of type {!class_structure} represents: - - [object(selfpat) ... end] - [object ... end] when {{!class_structure.pcstr_self} [pcstr_self]} is {{!pattern_desc.Ppat_any} [Ppat_any]} *) @@ -783,13 +796,12 @@ and class_structure = Parsetree.class_structure = { and class_field = Parsetree.class_field = { pcf_desc : class_field_desc; pcf_loc : location; - pcf_attributes : attributes; (** [... [@@id1] [@@id2]] *) + pcf_attributes : attributes; (** [... [\@\@id1] [\@\@id2]] *) } and class_field_desc = Parsetree.class_field_desc = | Pcf_inherit of override_flag * class_expr * string loc option (** [Pcf_inherit(flag, CE, s)] represents: - - [inherit CE] when [flag] is {{!Asttypes.override_flag.Fresh} [Fresh]} and [s] is [None], - [inherit CE as x] when [flag] is {{!Asttypes.override_flag.Fresh} @@ -800,7 +812,6 @@ and class_field_desc = Parsetree.class_field_desc = {{!Asttypes.override_flag.Override} [Override]} and [s] is [Some x] *) | Pcf_val of (label loc * mutable_flag * class_field_kind) (** [Pcf_val(x,flag, kind)] represents: - - [val x = E] when [flag] is {{!Asttypes.mutable_flag.Immutable} [Immutable]} and [kind] is {{!class_field_kind.Cfk_concrete} [Cfk_concrete(Fresh, E)]} @@ -820,7 +831,7 @@ and class_field_desc = Parsetree.class_field_desc = [Ptyp_poly]}) *) | Pcf_constraint of (core_type * core_type) (** [constraint T1 = T2] *) | Pcf_initializer of expression (** [initializer E] *) - | Pcf_attribute of attribute (** [[@@@id]] *) + | Pcf_attribute of attribute (** [[\@\@\@id]] *) | Pcf_extension of extension (** [[%%id]] *) and class_field_kind = Parsetree.class_field_kind = @@ -835,24 +846,23 @@ and class_declaration = class_expr class_infos and module_type = Parsetree.module_type = { pmty_desc : module_type_desc; pmty_loc : location; - pmty_attributes : attributes; (** [... [@id1] [@id2]] *) + pmty_attributes : attributes; (** [... [\@id1] [\@id2]] *) } and module_type_desc = Parsetree.module_type_desc = - | Pmty_ident of longident_loc (** [Pmty_ident(S)] represents [S] *) + | Pmty_ident of longident loc (** [Pmty_ident(S)] represents [S] *) | Pmty_signature of signature (** [sig ... end] *) | Pmty_functor of functor_parameter * module_type (** [functor(X : MT1) -> MT2] *) | Pmty_with of module_type * with_constraint list (** [MT with ...] *) | Pmty_typeof of module_expr (** [module type of ME] *) | Pmty_extension of extension (** [[%id]] *) - | Pmty_alias of longident_loc (** [(module M)] *) + | Pmty_alias of longident loc (** [(module M)] *) and functor_parameter = Parsetree.functor_parameter = | Unit (** [()] *) | Named of string option loc * module_type (** [Named(name, MT)] represents: - - [(X : MT)] when [name] is [Some X], - [(_ : MT)] when [name] is [None] *) @@ -886,21 +896,21 @@ and signature_item_desc = Parsetree.signature_item_desc = (** [class c1 : ... and ... and cn : ...] *) | Psig_class_type of class_type_declaration list (** [class type ct1 = ... and ... and ctn = ...] *) - | Psig_attribute of attribute (** [[@@@id]] *) + | Psig_attribute of attribute (** [[\@\@\@id]] *) | Psig_extension of extension * attributes (** [[%%id]] *) and module_declaration = Parsetree.module_declaration = { pmd_name : string option loc; pmd_type : module_type; - pmd_attributes : attributes; (** [... [@@id1] [@@id2]] *) + pmd_attributes : attributes; (** [... [\@\@id1] [\@\@id2]] *) pmd_loc : location; } (** Values of type [module_declaration] represents [S : MT] *) and module_substitution = Parsetree.module_substitution = { pms_name : string loc; - pms_manifest : longident_loc; - pms_attributes : attributes; (** [... [@@id1] [@@id2]] *) + pms_manifest : longident loc; + pms_attributes : attributes; (** [... [\@\@id1] [\@\@id2]] *) pms_loc : location; } (** Values of type [module_substitution] represents [S := M] *) @@ -908,11 +918,10 @@ and module_substitution = Parsetree.module_substitution = { and module_type_declaration = Parsetree.module_type_declaration = { pmtd_name : string loc; pmtd_type : module_type option; - pmtd_attributes : attributes; (** [... [@@id1] [@@id2]] *) + pmtd_attributes : attributes; (** [... [\@\@id1] [\@\@id2]] *) pmtd_loc : location; } (** Values of type [module_type_declaration] represents: - - [S = MT], - [S] for abstract module type declaration, when {{!module_type_declaration.pmtd_type} [pmtd_type]} is [None]. *) @@ -924,22 +933,19 @@ and 'a open_infos = 'a Parsetree.open_infos = { popen_attributes : attributes; } (** Values of type ['a open_infos] represents: - - [open! X] when {{!open_infos.popen_override} [popen_override]} is {{!Asttypes.override_flag.Override} [Override]} (silences the "used identifier shadowing" warning) - [open X] when {{!open_infos.popen_override} [popen_override]} is {{!Asttypes.override_flag.Fresh} [Fresh]} *) -and open_description = longident_loc open_infos +and open_description = longident loc open_infos (** Values of type [open_description] represents: - - [open M.N] - [open M(N).O] *) and open_declaration = module_expr open_infos (** Values of type [open_declaration] represents: - - [open M.N] - [open M(N).O] - [open struct ... end] *) @@ -957,19 +963,19 @@ and include_declaration = module_expr include_infos (** Values of type [include_declaration] represents [include ME] *) and with_constraint = Parsetree.with_constraint = - | Pwith_type of longident_loc * type_declaration + | Pwith_type of longident loc * type_declaration (** [with type X.t = ...] Note: the last component of the longident must match the name of the type_declaration. *) - | Pwith_module of longident_loc * longident_loc (** [with module X.Y = Z] *) - | Pwith_modtype of longident_loc * module_type + | Pwith_module of longident loc * longident loc (** [with module X.Y = Z] *) + | Pwith_modtype of longident loc * module_type (** [with module type X.Y = Z] *) - | Pwith_modtypesubst of longident_loc * module_type + | Pwith_modtypesubst of longident loc * module_type (** [with module type X.Y := sig end] *) - | Pwith_typesubst of longident_loc * type_declaration + | Pwith_typesubst of longident loc * type_declaration (** [with type X.t := ..., same format as [Pwith_type]] *) - | Pwith_modsubst of longident_loc * longident_loc + | Pwith_modsubst of longident loc * longident loc (** [with module X.Y := Z] *) (** {2 Value expressions for the module language} *) @@ -977,15 +983,16 @@ and with_constraint = Parsetree.with_constraint = and module_expr = Parsetree.module_expr = { pmod_desc : module_expr_desc; pmod_loc : location; - pmod_attributes : attributes; (** [... [@id1] [@id2]] *) + pmod_attributes : attributes; (** [... [\@id1] [\@id2]] *) } and module_expr_desc = Parsetree.module_expr_desc = - | Pmod_ident of longident_loc (** [X] *) + | Pmod_ident of longident loc (** [X] *) | Pmod_structure of structure (** [struct ... end] *) | Pmod_functor of functor_parameter * module_expr (** [functor(X : MT1) -> ME] *) | Pmod_apply of module_expr * module_expr (** [ME1(ME2)] *) + | Pmod_apply_unit of module_expr (** [ME1()] *) | Pmod_constraint of module_expr * module_type (** [(ME : MT)] *) | Pmod_unpack of expression (** [(val E)] *) | Pmod_extension of extension (** [[%id]] *) @@ -1001,7 +1008,6 @@ and structure_item_desc = Parsetree.structure_item_desc = | Pstr_eval of expression * attributes (** [E] *) | Pstr_value of rec_flag * value_binding list (** [Pstr_value(rec, [(P1, E1 ; ... ; (Pn, En))])] represents: - - [let P1 = E1 and ... and Pn = EN] when [rec] is {{!Asttypes.rec_flag.Nonrecursive} [Nonrecursive]}, - [let rec P1 = E1 and ... and Pn = EN ] when [rec] is @@ -1025,12 +1031,20 @@ and structure_item_desc = Parsetree.structure_item_desc = | Pstr_class_type of class_type_declaration list (** [class type ct1 = ... and ... and ctn = ...] *) | Pstr_include of include_declaration (** [include ME] *) - | Pstr_attribute of attribute (** [[@@@id]] *) + | Pstr_attribute of attribute (** [[\@\@\@id]] *) | Pstr_extension of extension * attributes (** [[%%id]] *) +and value_constraint = Parsetree.value_constraint = + | Pvc_constraint of { + locally_abstract_univars : string loc list; + typ : core_type; + } + | Pvc_coercion of { ground : core_type option; coercion : core_type } + and value_binding = Parsetree.value_binding = { pvb_pat : pattern; pvb_expr : expression; + pvb_constraint : value_constraint option; pvb_attributes : attributes; pvb_loc : location; } @@ -1219,7 +1233,7 @@ class virtual map = let a = self#list self#core_type a in Ptyp_tuple a | Ptyp_constr (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#list self#core_type b in Ptyp_constr (a, b) | Ptyp_object (a, b) -> @@ -1227,12 +1241,12 @@ class virtual map = let b = self#closed_flag b in Ptyp_object (a, b) | Ptyp_class (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#list self#core_type b in Ptyp_class (a, b) | Ptyp_alias (a, b) -> let a = self#core_type a in - let b = self#string b in + let b = self#loc self#string b in Ptyp_alias (a, b) | Ptyp_variant (a, b, c) -> let a = self#list self#row_field a in @@ -1246,17 +1260,21 @@ class virtual map = | Ptyp_package a -> let a = self#package_type a in Ptyp_package a + | Ptyp_open (a, b) -> + let a = self#loc self#longident a in + let b = self#core_type b in + Ptyp_open (a, b) | Ptyp_extension a -> let a = self#extension a in Ptyp_extension a method package_type : package_type -> package_type = fun (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#list (fun (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#core_type b in (a, b)) b @@ -1330,7 +1348,7 @@ class virtual map = let a = self#list self#pattern a in Ppat_tuple a | Ppat_construct (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#option (fun (a, b) -> @@ -1348,7 +1366,7 @@ class virtual map = let a = self#list (fun (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#pattern b in (a, b)) a @@ -1367,7 +1385,7 @@ class virtual map = let b = self#core_type b in Ppat_constraint (a, b) | Ppat_type a -> - let a = self#longident_loc a in + let a = self#loc self#longident a in Ppat_type a | Ppat_lazy a -> let a = self#pattern a in @@ -1382,7 +1400,7 @@ class virtual map = let a = self#extension a in Ppat_extension a | Ppat_open (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#pattern b in Ppat_open (a, b) @@ -1398,7 +1416,7 @@ class virtual map = fun x -> match x with | Pexp_ident a -> - let a = self#longident_loc a in + let a = self#loc self#longident a in Pexp_ident a | Pexp_constant a -> let a = self#constant a in @@ -1408,15 +1426,11 @@ class virtual map = let b = self#list self#value_binding b in let c = self#expression c in Pexp_let (a, b, c) - | Pexp_function a -> - let a = self#cases a in - Pexp_function a - | Pexp_fun (a, b, c, d) -> - let a = self#arg_label a in - let b = self#option self#expression b in - let c = self#pattern c in - let d = self#expression d in - Pexp_fun (a, b, c, d) + | Pexp_function (a, b, c) -> + let a = self#list self#function_param a in + let b = self#option self#type_constraint b in + let c = self#function_body c in + Pexp_function (a, b, c) | Pexp_apply (a, b) -> let a = self#expression a in let b = @@ -1440,7 +1454,7 @@ class virtual map = let a = self#list self#expression a in Pexp_tuple a | Pexp_construct (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#option self#expression b in Pexp_construct (a, b) | Pexp_variant (a, b) -> @@ -1451,7 +1465,7 @@ class virtual map = let a = self#list (fun (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#expression b in (a, b)) a @@ -1460,11 +1474,11 @@ class virtual map = Pexp_record (a, b) | Pexp_field (a, b) -> let a = self#expression a in - let b = self#longident_loc b in + let b = self#loc self#longident b in Pexp_field (a, b) | Pexp_setfield (a, b, c) -> let a = self#expression a in - let b = self#longident_loc b in + let b = self#loc self#longident b in let c = self#expression c in Pexp_setfield (a, b, c) | Pexp_array a -> @@ -1504,7 +1518,7 @@ class virtual map = let b = self#loc self#label b in Pexp_send (a, b) | Pexp_new a -> - let a = self#longident_loc a in + let a = self#loc self#longident a in Pexp_new a | Pexp_setinstvar (a, b) -> let a = self#loc self#label a in @@ -1583,6 +1597,47 @@ class virtual map = let pbop_loc = self#location pbop_loc in { pbop_op; pbop_pat; pbop_exp; pbop_loc } + method function_param_desc : function_param_desc -> function_param_desc = + fun x -> + match x with + | Pparam_val (a, b, c) -> + let a = self#arg_label a in + let b = self#option self#expression b in + let c = self#pattern c in + Pparam_val (a, b, c) + | Pparam_newtype a -> + let a = self#loc self#string a in + Pparam_newtype a + + method function_param : function_param -> function_param = + fun { pparam_loc; pparam_desc } -> + let pparam_loc = self#location pparam_loc in + let pparam_desc = self#function_param_desc pparam_desc in + { pparam_loc; pparam_desc } + + method function_body : function_body -> function_body = + fun x -> + match x with + | Pfunction_body a -> + let a = self#expression a in + Pfunction_body a + | Pfunction_cases (a, b, c) -> + let a = self#cases a in + let b = self#location b in + let c = self#attributes c in + Pfunction_cases (a, b, c) + + method type_constraint : type_constraint -> type_constraint = + fun x -> + match x with + | Pconstraint a -> + let a = self#core_type a in + Pconstraint a + | Pcoerce (a, b) -> + let a = self#option self#core_type a in + let b = self#core_type b in + Pcoerce (a, b) + method value_description : value_description -> value_description = fun { pval_name; pval_type; pval_prim; pval_attributes; pval_loc } -> let pval_name = self#loc self#string pval_name in @@ -1695,7 +1750,7 @@ class virtual map = ptyext_loc; ptyext_attributes; } -> - let ptyext_path = self#longident_loc ptyext_path in + let ptyext_path = self#loc self#longident ptyext_path in let ptyext_params = self#list (fun (a, b) -> @@ -1753,7 +1808,7 @@ class virtual map = let c = self#option self#core_type c in Pext_decl (a, b, c) | Pext_rebind a -> - let a = self#longident_loc a in + let a = self#loc self#longident a in Pext_rebind a method class_type : class_type -> class_type = @@ -1767,7 +1822,7 @@ class virtual map = fun x -> match x with | Pcty_constr (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#list self#core_type b in Pcty_constr (a, b) | Pcty_signature a -> @@ -1886,7 +1941,7 @@ class virtual map = fun x -> match x with | Pcl_constr (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#list self#core_type b in Pcl_constr (a, b) | Pcl_structure a -> @@ -2011,7 +2066,7 @@ class virtual map = fun x -> match x with | Pmty_ident a -> - let a = self#longident_loc a in + let a = self#loc self#longident a in Pmty_ident a | Pmty_signature a -> let a = self#signature a in @@ -2031,7 +2086,7 @@ class virtual map = let a = self#extension a in Pmty_extension a | Pmty_alias a -> - let a = self#longident_loc a in + let a = self#loc self#longident a in Pmty_alias a method functor_parameter : functor_parameter -> functor_parameter = @@ -2116,7 +2171,7 @@ class virtual map = method module_substitution : module_substitution -> module_substitution = fun { pms_name; pms_manifest; pms_attributes; pms_loc } -> let pms_name = self#loc self#string pms_name in - let pms_manifest = self#longident_loc pms_manifest in + let pms_manifest = self#loc self#longident pms_manifest in let pms_attributes = self#attributes pms_attributes in let pms_loc = self#location pms_loc in { pms_name; pms_manifest; pms_attributes; pms_loc } @@ -2139,7 +2194,7 @@ class virtual map = { popen_expr; popen_override; popen_loc; popen_attributes } method open_description : open_description -> open_description = - self#open_infos self#longident_loc + self#open_infos (self#loc self#longident) method open_declaration : open_declaration -> open_declaration = self#open_infos self#module_expr @@ -2162,28 +2217,28 @@ class virtual map = fun x -> match x with | Pwith_type (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#type_declaration b in Pwith_type (a, b) | Pwith_module (a, b) -> - let a = self#longident_loc a in - let b = self#longident_loc b in + let a = self#loc self#longident a in + let b = self#loc self#longident b in Pwith_module (a, b) | Pwith_modtype (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#module_type b in Pwith_modtype (a, b) | Pwith_modtypesubst (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#module_type b in Pwith_modtypesubst (a, b) | Pwith_typesubst (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#type_declaration b in Pwith_typesubst (a, b) | Pwith_modsubst (a, b) -> - let a = self#longident_loc a in - let b = self#longident_loc b in + let a = self#loc self#longident a in + let b = self#loc self#longident b in Pwith_modsubst (a, b) method module_expr : module_expr -> module_expr = @@ -2197,7 +2252,7 @@ class virtual map = fun x -> match x with | Pmod_ident a -> - let a = self#longident_loc a in + let a = self#loc self#longident a in Pmod_ident a | Pmod_structure a -> let a = self#structure a in @@ -2210,6 +2265,9 @@ class virtual map = let a = self#module_expr a in let b = self#module_expr b in Pmod_apply (a, b) + | Pmod_apply_unit a -> + let a = self#module_expr a in + Pmod_apply_unit a | Pmod_constraint (a, b) -> let a = self#module_expr a in let b = self#module_type b in @@ -2282,13 +2340,28 @@ class virtual map = let b = self#attributes b in Pstr_extension (a, b) + method value_constraint : value_constraint -> value_constraint = + fun x -> + match x with + | Pvc_constraint { locally_abstract_univars; typ } -> + let locally_abstract_univars = + self#list (self#loc self#string) locally_abstract_univars + in + let typ = self#core_type typ in + Pvc_constraint { locally_abstract_univars; typ } + | Pvc_coercion { ground; coercion } -> + let ground = self#option self#core_type ground in + let coercion = self#core_type coercion in + Pvc_coercion { ground; coercion } + method value_binding : value_binding -> value_binding = - fun { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } -> + fun { pvb_pat; pvb_expr; pvb_constraint; pvb_attributes; pvb_loc } -> let pvb_pat = self#pattern pvb_pat in let pvb_expr = self#expression pvb_expr in + let pvb_constraint = self#option self#value_constraint pvb_constraint in let pvb_attributes = self#attributes pvb_attributes in let pvb_loc = self#location pvb_loc in - { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } + { pvb_pat; pvb_expr; pvb_constraint; pvb_attributes; pvb_loc } method module_binding : module_binding -> module_binding = fun { pmb_name; pmb_expr; pmb_attributes; pmb_loc } -> @@ -2458,17 +2531,17 @@ class virtual iter = self#core_type c | Ptyp_tuple a -> self#list self#core_type a | Ptyp_constr (a, b) -> - self#longident_loc a; + self#loc self#longident a; self#list self#core_type b | Ptyp_object (a, b) -> self#list self#object_field a; self#closed_flag b | Ptyp_class (a, b) -> - self#longident_loc a; + self#loc self#longident a; self#list self#core_type b | Ptyp_alias (a, b) -> self#core_type a; - self#string b + self#loc self#string b | Ptyp_variant (a, b, c) -> self#list self#row_field a; self#closed_flag b; @@ -2477,14 +2550,17 @@ class virtual iter = self#list (self#loc self#string) a; self#core_type b | Ptyp_package a -> self#package_type a + | Ptyp_open (a, b) -> + self#loc self#longident a; + self#core_type b | Ptyp_extension a -> self#extension a method package_type : package_type -> unit = fun (a, b) -> - self#longident_loc a; + self#loc self#longident a; self#list (fun (a, b) -> - self#longident_loc a; + self#loc self#longident a; self#core_type b) b @@ -2538,7 +2614,7 @@ class virtual iter = self#constant b | Ppat_tuple a -> self#list self#pattern a | Ppat_construct (a, b) -> - self#longident_loc a; + self#loc self#longident a; self#option (fun (a, b) -> self#list (self#loc self#string) a; @@ -2550,7 +2626,7 @@ class virtual iter = | Ppat_record (a, b) -> self#list (fun (a, b) -> - self#longident_loc a; + self#loc self#longident a; self#pattern b) a; self#closed_flag b @@ -2561,13 +2637,13 @@ class virtual iter = | Ppat_constraint (a, b) -> self#pattern a; self#core_type b - | Ppat_type a -> self#longident_loc a + | Ppat_type a -> self#loc self#longident a | Ppat_lazy a -> self#pattern a | Ppat_unpack a -> self#loc (self#option self#string) a | Ppat_exception a -> self#pattern a | Ppat_extension a -> self#extension a | Ppat_open (a, b) -> - self#longident_loc a; + self#loc self#longident a; self#pattern b method expression : expression -> unit = @@ -2580,18 +2656,16 @@ class virtual iter = method expression_desc : expression_desc -> unit = fun x -> match x with - | Pexp_ident a -> self#longident_loc a + | Pexp_ident a -> self#loc self#longident a | Pexp_constant a -> self#constant a | Pexp_let (a, b, c) -> self#rec_flag a; self#list self#value_binding b; self#expression c - | Pexp_function a -> self#cases a - | Pexp_fun (a, b, c, d) -> - self#arg_label a; - self#option self#expression b; - self#pattern c; - self#expression d + | Pexp_function (a, b, c) -> + self#list self#function_param a; + self#option self#type_constraint b; + self#function_body c | Pexp_apply (a, b) -> self#expression a; self#list @@ -2607,7 +2681,7 @@ class virtual iter = self#cases b | Pexp_tuple a -> self#list self#expression a | Pexp_construct (a, b) -> - self#longident_loc a; + self#loc self#longident a; self#option self#expression b | Pexp_variant (a, b) -> self#label a; @@ -2615,16 +2689,16 @@ class virtual iter = | Pexp_record (a, b) -> self#list (fun (a, b) -> - self#longident_loc a; + self#loc self#longident a; self#expression b) a; self#option self#expression b | Pexp_field (a, b) -> self#expression a; - self#longident_loc b + self#loc self#longident b | Pexp_setfield (a, b, c) -> self#expression a; - self#longident_loc b; + self#loc self#longident b; self#expression c | Pexp_array a -> self#list self#expression a | Pexp_ifthenelse (a, b, c) -> @@ -2653,7 +2727,7 @@ class virtual iter = | Pexp_send (a, b) -> self#expression a; self#loc self#label b - | Pexp_new a -> self#longident_loc a + | Pexp_new a -> self#loc self#longident a | Pexp_setinstvar (a, b) -> self#loc self#label a; self#expression b @@ -2706,6 +2780,37 @@ class virtual iter = self#expression pbop_exp; self#location pbop_loc + method function_param_desc : function_param_desc -> unit = + fun x -> + match x with + | Pparam_val (a, b, c) -> + self#arg_label a; + self#option self#expression b; + self#pattern c + | Pparam_newtype a -> self#loc self#string a + + method function_param : function_param -> unit = + fun { pparam_loc; pparam_desc } -> + self#location pparam_loc; + self#function_param_desc pparam_desc + + method function_body : function_body -> unit = + fun x -> + match x with + | Pfunction_body a -> self#expression a + | Pfunction_cases (a, b, c) -> + self#cases a; + self#location b; + self#attributes c + + method type_constraint : type_constraint -> unit = + fun x -> + match x with + | Pconstraint a -> self#core_type a + | Pcoerce (a, b) -> + self#option self#core_type a; + self#core_type b + method value_description : value_description -> unit = fun { pval_name; pval_type; pval_prim; pval_attributes; pval_loc } -> self#loc self#string pval_name; @@ -2786,7 +2891,7 @@ class virtual iter = ptyext_loc; ptyext_attributes; } -> - self#longident_loc ptyext_path; + self#loc self#longident ptyext_path; self#list (fun (a, b) -> self#core_type a; @@ -2820,7 +2925,7 @@ class virtual iter = self#list (self#loc self#string) a; self#constructor_arguments b; self#option self#core_type c - | Pext_rebind a -> self#longident_loc a + | Pext_rebind a -> self#loc self#longident a method class_type : class_type -> unit = fun { pcty_desc; pcty_loc; pcty_attributes } -> @@ -2832,7 +2937,7 @@ class virtual iter = fun x -> match x with | Pcty_constr (a, b) -> - self#longident_loc a; + self#loc self#longident a; self#list self#core_type b | Pcty_signature a -> self#class_signature a | Pcty_arrow (a, b, c) -> @@ -2914,7 +3019,7 @@ class virtual iter = fun x -> match x with | Pcl_constr (a, b) -> - self#longident_loc a; + self#loc self#longident a; self#list self#core_type b | Pcl_structure a -> self#class_structure a | Pcl_fun (a, b, c, d) -> @@ -3000,7 +3105,7 @@ class virtual iter = method module_type_desc : module_type_desc -> unit = fun x -> match x with - | Pmty_ident a -> self#longident_loc a + | Pmty_ident a -> self#loc self#longident a | Pmty_signature a -> self#signature a | Pmty_functor (a, b) -> self#functor_parameter a; @@ -3010,7 +3115,7 @@ class virtual iter = self#list self#with_constraint b | Pmty_typeof a -> self#module_expr a | Pmty_extension a -> self#extension a - | Pmty_alias a -> self#longident_loc a + | Pmty_alias a -> self#loc self#longident a method functor_parameter : functor_parameter -> unit = fun x -> @@ -3061,7 +3166,7 @@ class virtual iter = method module_substitution : module_substitution -> unit = fun { pms_name; pms_manifest; pms_attributes; pms_loc } -> self#loc self#string pms_name; - self#longident_loc pms_manifest; + self#loc self#longident pms_manifest; self#attributes pms_attributes; self#location pms_loc @@ -3080,7 +3185,7 @@ class virtual iter = self#attributes popen_attributes method open_description : open_description -> unit = - self#open_infos self#longident_loc + self#open_infos (self#loc self#longident) method open_declaration : open_declaration -> unit = self#open_infos self#module_expr @@ -3101,23 +3206,23 @@ class virtual iter = fun x -> match x with | Pwith_type (a, b) -> - self#longident_loc a; + self#loc self#longident a; self#type_declaration b | Pwith_module (a, b) -> - self#longident_loc a; - self#longident_loc b + self#loc self#longident a; + self#loc self#longident b | Pwith_modtype (a, b) -> - self#longident_loc a; + self#loc self#longident a; self#module_type b | Pwith_modtypesubst (a, b) -> - self#longident_loc a; + self#loc self#longident a; self#module_type b | Pwith_typesubst (a, b) -> - self#longident_loc a; + self#loc self#longident a; self#type_declaration b | Pwith_modsubst (a, b) -> - self#longident_loc a; - self#longident_loc b + self#loc self#longident a; + self#loc self#longident b method module_expr : module_expr -> unit = fun { pmod_desc; pmod_loc; pmod_attributes } -> @@ -3128,7 +3233,7 @@ class virtual iter = method module_expr_desc : module_expr_desc -> unit = fun x -> match x with - | Pmod_ident a -> self#longident_loc a + | Pmod_ident a -> self#loc self#longident a | Pmod_structure a -> self#structure a | Pmod_functor (a, b) -> self#functor_parameter a; @@ -3136,6 +3241,7 @@ class virtual iter = | Pmod_apply (a, b) -> self#module_expr a; self#module_expr b + | Pmod_apply_unit a -> self#module_expr a | Pmod_constraint (a, b) -> self#module_expr a; self#module_type b @@ -3176,10 +3282,21 @@ class virtual iter = self#extension a; self#attributes b + method value_constraint : value_constraint -> unit = + fun x -> + match x with + | Pvc_constraint { locally_abstract_univars; typ } -> + self#list (self#loc self#string) locally_abstract_univars; + self#core_type typ + | Pvc_coercion { ground; coercion } -> + self#option self#core_type ground; + self#core_type coercion + method value_binding : value_binding -> unit = - fun { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } -> + fun { pvb_pat; pvb_expr; pvb_constraint; pvb_attributes; pvb_loc } -> self#pattern pvb_pat; self#expression pvb_expr; + self#option self#value_constraint pvb_constraint; self#attributes pvb_attributes; self#location pvb_loc @@ -3355,7 +3472,7 @@ class virtual ['acc] fold = acc | Ptyp_tuple a -> self#list self#core_type a acc | Ptyp_constr (a, b) -> - let acc = self#longident_loc a acc in + let acc = self#loc self#longident a acc in let acc = self#list self#core_type b acc in acc | Ptyp_object (a, b) -> @@ -3363,12 +3480,12 @@ class virtual ['acc] fold = let acc = self#closed_flag b acc in acc | Ptyp_class (a, b) -> - let acc = self#longident_loc a acc in + let acc = self#loc self#longident a acc in let acc = self#list self#core_type b acc in acc | Ptyp_alias (a, b) -> let acc = self#core_type a acc in - let acc = self#string b acc in + let acc = self#loc self#string b acc in acc | Ptyp_variant (a, b, c) -> let acc = self#list self#row_field a acc in @@ -3380,15 +3497,19 @@ class virtual ['acc] fold = let acc = self#core_type b acc in acc | Ptyp_package a -> self#package_type a acc + | Ptyp_open (a, b) -> + let acc = self#loc self#longident a acc in + let acc = self#core_type b acc in + acc | Ptyp_extension a -> self#extension a acc method package_type : package_type -> 'acc -> 'acc = fun (a, b) acc -> - let acc = self#longident_loc a acc in + let acc = self#loc self#longident a acc in let acc = self#list (fun (a, b) acc -> - let acc = self#longident_loc a acc in + let acc = self#loc self#longident a acc in let acc = self#core_type b acc in acc) b acc @@ -3452,7 +3573,7 @@ class virtual ['acc] fold = acc | Ppat_tuple a -> self#list self#pattern a acc | Ppat_construct (a, b) -> - let acc = self#longident_loc a acc in + let acc = self#loc self#longident a acc in let acc = self#option (fun (a, b) acc -> @@ -3470,7 +3591,7 @@ class virtual ['acc] fold = let acc = self#list (fun (a, b) acc -> - let acc = self#longident_loc a acc in + let acc = self#loc self#longident a acc in let acc = self#pattern b acc in acc) a acc @@ -3486,13 +3607,13 @@ class virtual ['acc] fold = let acc = self#pattern a acc in let acc = self#core_type b acc in acc - | Ppat_type a -> self#longident_loc a acc + | Ppat_type a -> self#loc self#longident a acc | Ppat_lazy a -> self#pattern a acc | Ppat_unpack a -> self#loc (self#option self#string) a acc | Ppat_exception a -> self#pattern a acc | Ppat_extension a -> self#extension a acc | Ppat_open (a, b) -> - let acc = self#longident_loc a acc in + let acc = self#loc self#longident a acc in let acc = self#pattern b acc in acc @@ -3507,19 +3628,17 @@ class virtual ['acc] fold = method expression_desc : expression_desc -> 'acc -> 'acc = fun x acc -> match x with - | Pexp_ident a -> self#longident_loc a acc + | Pexp_ident a -> self#loc self#longident a acc | Pexp_constant a -> self#constant a acc | Pexp_let (a, b, c) -> let acc = self#rec_flag a acc in let acc = self#list self#value_binding b acc in let acc = self#expression c acc in acc - | Pexp_function a -> self#cases a acc - | Pexp_fun (a, b, c, d) -> - let acc = self#arg_label a acc in - let acc = self#option self#expression b acc in - let acc = self#pattern c acc in - let acc = self#expression d acc in + | Pexp_function (a, b, c) -> + let acc = self#list self#function_param a acc in + let acc = self#option self#type_constraint b acc in + let acc = self#function_body c acc in acc | Pexp_apply (a, b) -> let acc = self#expression a acc in @@ -3542,7 +3661,7 @@ class virtual ['acc] fold = acc | Pexp_tuple a -> self#list self#expression a acc | Pexp_construct (a, b) -> - let acc = self#longident_loc a acc in + let acc = self#loc self#longident a acc in let acc = self#option self#expression b acc in acc | Pexp_variant (a, b) -> @@ -3553,7 +3672,7 @@ class virtual ['acc] fold = let acc = self#list (fun (a, b) acc -> - let acc = self#longident_loc a acc in + let acc = self#loc self#longident a acc in let acc = self#expression b acc in acc) a acc @@ -3562,11 +3681,11 @@ class virtual ['acc] fold = acc | Pexp_field (a, b) -> let acc = self#expression a acc in - let acc = self#longident_loc b acc in + let acc = self#loc self#longident b acc in acc | Pexp_setfield (a, b, c) -> let acc = self#expression a acc in - let acc = self#longident_loc b acc in + let acc = self#loc self#longident b acc in let acc = self#expression c acc in acc | Pexp_array a -> self#list self#expression a acc @@ -3603,7 +3722,7 @@ class virtual ['acc] fold = let acc = self#expression a acc in let acc = self#loc self#label b acc in acc - | Pexp_new a -> self#longident_loc a acc + | Pexp_new a -> self#loc self#longident a acc | Pexp_setinstvar (a, b) -> let acc = self#loc self#label a acc in let acc = self#expression b acc in @@ -3666,6 +3785,41 @@ class virtual ['acc] fold = let acc = self#location pbop_loc acc in acc + method function_param_desc : function_param_desc -> 'acc -> 'acc = + fun x acc -> + match x with + | Pparam_val (a, b, c) -> + let acc = self#arg_label a acc in + let acc = self#option self#expression b acc in + let acc = self#pattern c acc in + acc + | Pparam_newtype a -> self#loc self#string a acc + + method function_param : function_param -> 'acc -> 'acc = + fun { pparam_loc; pparam_desc } acc -> + let acc = self#location pparam_loc acc in + let acc = self#function_param_desc pparam_desc acc in + acc + + method function_body : function_body -> 'acc -> 'acc = + fun x acc -> + match x with + | Pfunction_body a -> self#expression a acc + | Pfunction_cases (a, b, c) -> + let acc = self#cases a acc in + let acc = self#location b acc in + let acc = self#attributes c acc in + acc + + method type_constraint : type_constraint -> 'acc -> 'acc = + fun x acc -> + match x with + | Pconstraint a -> self#core_type a acc + | Pcoerce (a, b) -> + let acc = self#option self#core_type a acc in + let acc = self#core_type b acc in + acc + method value_description : value_description -> 'acc -> 'acc = fun { pval_name; pval_type; pval_prim; pval_attributes; pval_loc } acc -> let acc = self#loc self#string pval_name acc in @@ -3759,7 +3913,7 @@ class virtual ['acc] fold = ptyext_loc; ptyext_attributes; } acc -> - let acc = self#longident_loc ptyext_path acc in + let acc = self#loc self#longident ptyext_path acc in let acc = self#list (fun (a, b) acc -> @@ -3806,7 +3960,7 @@ class virtual ['acc] fold = let acc = self#constructor_arguments b acc in let acc = self#option self#core_type c acc in acc - | Pext_rebind a -> self#longident_loc a acc + | Pext_rebind a -> self#loc self#longident a acc method class_type : class_type -> 'acc -> 'acc = fun { pcty_desc; pcty_loc; pcty_attributes } acc -> @@ -3819,7 +3973,7 @@ class virtual ['acc] fold = fun x acc -> match x with | Pcty_constr (a, b) -> - let acc = self#longident_loc a acc in + let acc = self#loc self#longident a acc in let acc = self#list self#core_type b acc in acc | Pcty_signature a -> self#class_signature a acc @@ -3919,7 +4073,7 @@ class virtual ['acc] fold = fun x acc -> match x with | Pcl_constr (a, b) -> - let acc = self#longident_loc a acc in + let acc = self#loc self#longident a acc in let acc = self#list self#core_type b acc in acc | Pcl_structure a -> self#class_structure a acc @@ -4022,7 +4176,7 @@ class virtual ['acc] fold = method module_type_desc : module_type_desc -> 'acc -> 'acc = fun x acc -> match x with - | Pmty_ident a -> self#longident_loc a acc + | Pmty_ident a -> self#loc self#longident a acc | Pmty_signature a -> self#signature a acc | Pmty_functor (a, b) -> let acc = self#functor_parameter a acc in @@ -4034,7 +4188,7 @@ class virtual ['acc] fold = acc | Pmty_typeof a -> self#module_expr a acc | Pmty_extension a -> self#extension a acc - | Pmty_alias a -> self#longident_loc a acc + | Pmty_alias a -> self#loc self#longident a acc method functor_parameter : functor_parameter -> 'acc -> 'acc = fun x acc -> @@ -4090,7 +4244,7 @@ class virtual ['acc] fold = method module_substitution : module_substitution -> 'acc -> 'acc = fun { pms_name; pms_manifest; pms_attributes; pms_loc } acc -> let acc = self#loc self#string pms_name acc in - let acc = self#longident_loc pms_manifest acc in + let acc = self#loc self#longident pms_manifest acc in let acc = self#attributes pms_attributes acc in let acc = self#location pms_loc acc in acc @@ -4113,7 +4267,7 @@ class virtual ['acc] fold = acc method open_description : open_description -> 'acc -> 'acc = - self#open_infos self#longident_loc + self#open_infos (self#loc self#longident) method open_declaration : open_declaration -> 'acc -> 'acc = self#open_infos self#module_expr @@ -4136,28 +4290,28 @@ class virtual ['acc] fold = fun x acc -> match x with | Pwith_type (a, b) -> - let acc = self#longident_loc a acc in + let acc = self#loc self#longident a acc in let acc = self#type_declaration b acc in acc | Pwith_module (a, b) -> - let acc = self#longident_loc a acc in - let acc = self#longident_loc b acc in + let acc = self#loc self#longident a acc in + let acc = self#loc self#longident b acc in acc | Pwith_modtype (a, b) -> - let acc = self#longident_loc a acc in + let acc = self#loc self#longident a acc in let acc = self#module_type b acc in acc | Pwith_modtypesubst (a, b) -> - let acc = self#longident_loc a acc in + let acc = self#loc self#longident a acc in let acc = self#module_type b acc in acc | Pwith_typesubst (a, b) -> - let acc = self#longident_loc a acc in + let acc = self#loc self#longident a acc in let acc = self#type_declaration b acc in acc | Pwith_modsubst (a, b) -> - let acc = self#longident_loc a acc in - let acc = self#longident_loc b acc in + let acc = self#loc self#longident a acc in + let acc = self#loc self#longident b acc in acc method module_expr : module_expr -> 'acc -> 'acc = @@ -4170,7 +4324,7 @@ class virtual ['acc] fold = method module_expr_desc : module_expr_desc -> 'acc -> 'acc = fun x acc -> match x with - | Pmod_ident a -> self#longident_loc a acc + | Pmod_ident a -> self#loc self#longident a acc | Pmod_structure a -> self#structure a acc | Pmod_functor (a, b) -> let acc = self#functor_parameter a acc in @@ -4180,6 +4334,7 @@ class virtual ['acc] fold = let acc = self#module_expr a acc in let acc = self#module_expr b acc in acc + | Pmod_apply_unit a -> self#module_expr a acc | Pmod_constraint (a, b) -> let acc = self#module_expr a acc in let acc = self#module_type b acc in @@ -4226,10 +4381,25 @@ class virtual ['acc] fold = let acc = self#attributes b acc in acc + method value_constraint : value_constraint -> 'acc -> 'acc = + fun x acc -> + match x with + | Pvc_constraint { locally_abstract_univars; typ } -> + let acc = + self#list (self#loc self#string) locally_abstract_univars acc + in + let acc = self#core_type typ acc in + acc + | Pvc_coercion { ground; coercion } -> + let acc = self#option self#core_type ground acc in + let acc = self#core_type coercion acc in + acc + method value_binding : value_binding -> 'acc -> 'acc = - fun { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } acc -> + fun { pvb_pat; pvb_expr; pvb_constraint; pvb_attributes; pvb_loc } acc -> let acc = self#pattern pvb_pat acc in let acc = self#expression pvb_expr acc in + let acc = self#option self#value_constraint pvb_constraint acc in let acc = self#attributes pvb_attributes acc in let acc = self#location pvb_loc acc in acc @@ -4447,7 +4617,7 @@ class virtual ['acc] fold_map = let a, acc = self#list self#core_type a acc in (Ptyp_tuple a, acc) | Ptyp_constr (a, b) -> - let a, acc = self#longident_loc a acc in + let a, acc = self#loc self#longident a acc in let b, acc = self#list self#core_type b acc in (Ptyp_constr (a, b), acc) | Ptyp_object (a, b) -> @@ -4455,12 +4625,12 @@ class virtual ['acc] fold_map = let b, acc = self#closed_flag b acc in (Ptyp_object (a, b), acc) | Ptyp_class (a, b) -> - let a, acc = self#longident_loc a acc in + let a, acc = self#loc self#longident a acc in let b, acc = self#list self#core_type b acc in (Ptyp_class (a, b), acc) | Ptyp_alias (a, b) -> let a, acc = self#core_type a acc in - let b, acc = self#string b acc in + let b, acc = self#loc self#string b acc in (Ptyp_alias (a, b), acc) | Ptyp_variant (a, b, c) -> let a, acc = self#list self#row_field a acc in @@ -4474,17 +4644,21 @@ class virtual ['acc] fold_map = | Ptyp_package a -> let a, acc = self#package_type a acc in (Ptyp_package a, acc) + | Ptyp_open (a, b) -> + let a, acc = self#loc self#longident a acc in + let b, acc = self#core_type b acc in + (Ptyp_open (a, b), acc) | Ptyp_extension a -> let a, acc = self#extension a acc in (Ptyp_extension a, acc) method package_type : package_type -> 'acc -> package_type * 'acc = fun (a, b) acc -> - let a, acc = self#longident_loc a acc in + let a, acc = self#loc self#longident a acc in let b, acc = self#list (fun (a, b) acc -> - let a, acc = self#longident_loc a acc in + let a, acc = self#loc self#longident a acc in let b, acc = self#core_type b acc in ((a, b), acc)) b acc @@ -4559,7 +4733,7 @@ class virtual ['acc] fold_map = let a, acc = self#list self#pattern a acc in (Ppat_tuple a, acc) | Ppat_construct (a, b) -> - let a, acc = self#longident_loc a acc in + let a, acc = self#loc self#longident a acc in let b, acc = self#option (fun (a, b) acc -> @@ -4577,7 +4751,7 @@ class virtual ['acc] fold_map = let a, acc = self#list (fun (a, b) acc -> - let a, acc = self#longident_loc a acc in + let a, acc = self#loc self#longident a acc in let b, acc = self#pattern b acc in ((a, b), acc)) a acc @@ -4596,7 +4770,7 @@ class virtual ['acc] fold_map = let b, acc = self#core_type b acc in (Ppat_constraint (a, b), acc) | Ppat_type a -> - let a, acc = self#longident_loc a acc in + let a, acc = self#loc self#longident a acc in (Ppat_type a, acc) | Ppat_lazy a -> let a, acc = self#pattern a acc in @@ -4611,7 +4785,7 @@ class virtual ['acc] fold_map = let a, acc = self#extension a acc in (Ppat_extension a, acc) | Ppat_open (a, b) -> - let a, acc = self#longident_loc a acc in + let a, acc = self#loc self#longident a acc in let b, acc = self#pattern b acc in (Ppat_open (a, b), acc) @@ -4627,7 +4801,7 @@ class virtual ['acc] fold_map = fun x acc -> match x with | Pexp_ident a -> - let a, acc = self#longident_loc a acc in + let a, acc = self#loc self#longident a acc in (Pexp_ident a, acc) | Pexp_constant a -> let a, acc = self#constant a acc in @@ -4637,15 +4811,11 @@ class virtual ['acc] fold_map = let b, acc = self#list self#value_binding b acc in let c, acc = self#expression c acc in (Pexp_let (a, b, c), acc) - | Pexp_function a -> - let a, acc = self#cases a acc in - (Pexp_function a, acc) - | Pexp_fun (a, b, c, d) -> - let a, acc = self#arg_label a acc in - let b, acc = self#option self#expression b acc in - let c, acc = self#pattern c acc in - let d, acc = self#expression d acc in - (Pexp_fun (a, b, c, d), acc) + | Pexp_function (a, b, c) -> + let a, acc = self#list self#function_param a acc in + let b, acc = self#option self#type_constraint b acc in + let c, acc = self#function_body c acc in + (Pexp_function (a, b, c), acc) | Pexp_apply (a, b) -> let a, acc = self#expression a acc in let b, acc = @@ -4669,7 +4839,7 @@ class virtual ['acc] fold_map = let a, acc = self#list self#expression a acc in (Pexp_tuple a, acc) | Pexp_construct (a, b) -> - let a, acc = self#longident_loc a acc in + let a, acc = self#loc self#longident a acc in let b, acc = self#option self#expression b acc in (Pexp_construct (a, b), acc) | Pexp_variant (a, b) -> @@ -4680,7 +4850,7 @@ class virtual ['acc] fold_map = let a, acc = self#list (fun (a, b) acc -> - let a, acc = self#longident_loc a acc in + let a, acc = self#loc self#longident a acc in let b, acc = self#expression b acc in ((a, b), acc)) a acc @@ -4689,11 +4859,11 @@ class virtual ['acc] fold_map = (Pexp_record (a, b), acc) | Pexp_field (a, b) -> let a, acc = self#expression a acc in - let b, acc = self#longident_loc b acc in + let b, acc = self#loc self#longident b acc in (Pexp_field (a, b), acc) | Pexp_setfield (a, b, c) -> let a, acc = self#expression a acc in - let b, acc = self#longident_loc b acc in + let b, acc = self#loc self#longident b acc in let c, acc = self#expression c acc in (Pexp_setfield (a, b, c), acc) | Pexp_array a -> @@ -4733,7 +4903,7 @@ class virtual ['acc] fold_map = let b, acc = self#loc self#label b acc in (Pexp_send (a, b), acc) | Pexp_new a -> - let a, acc = self#longident_loc a acc in + let a, acc = self#loc self#longident a acc in (Pexp_new a, acc) | Pexp_setinstvar (a, b) -> let a, acc = self#loc self#label a acc in @@ -4812,6 +4982,48 @@ class virtual ['acc] fold_map = let pbop_loc, acc = self#location pbop_loc acc in ({ pbop_op; pbop_pat; pbop_exp; pbop_loc }, acc) + method function_param_desc + : function_param_desc -> 'acc -> function_param_desc * 'acc = + fun x acc -> + match x with + | Pparam_val (a, b, c) -> + let a, acc = self#arg_label a acc in + let b, acc = self#option self#expression b acc in + let c, acc = self#pattern c acc in + (Pparam_val (a, b, c), acc) + | Pparam_newtype a -> + let a, acc = self#loc self#string a acc in + (Pparam_newtype a, acc) + + method function_param : function_param -> 'acc -> function_param * 'acc = + fun { pparam_loc; pparam_desc } acc -> + let pparam_loc, acc = self#location pparam_loc acc in + let pparam_desc, acc = self#function_param_desc pparam_desc acc in + ({ pparam_loc; pparam_desc }, acc) + + method function_body : function_body -> 'acc -> function_body * 'acc = + fun x acc -> + match x with + | Pfunction_body a -> + let a, acc = self#expression a acc in + (Pfunction_body a, acc) + | Pfunction_cases (a, b, c) -> + let a, acc = self#cases a acc in + let b, acc = self#location b acc in + let c, acc = self#attributes c acc in + (Pfunction_cases (a, b, c), acc) + + method type_constraint : type_constraint -> 'acc -> type_constraint * 'acc = + fun x acc -> + match x with + | Pconstraint a -> + let a, acc = self#core_type a acc in + (Pconstraint a, acc) + | Pcoerce (a, b) -> + let a, acc = self#option self#core_type a acc in + let b, acc = self#core_type b acc in + (Pcoerce (a, b), acc) + method value_description : value_description -> 'acc -> value_description * 'acc = fun { pval_name; pval_type; pval_prim; pval_attributes; pval_loc } acc -> @@ -4930,7 +5142,7 @@ class virtual ['acc] fold_map = ptyext_loc; ptyext_attributes; } acc -> - let ptyext_path, acc = self#longident_loc ptyext_path acc in + let ptyext_path, acc = self#loc self#longident ptyext_path acc in let ptyext_params, acc = self#list (fun (a, b) acc -> @@ -4991,7 +5203,7 @@ class virtual ['acc] fold_map = let c, acc = self#option self#core_type c acc in (Pext_decl (a, b, c), acc) | Pext_rebind a -> - let a, acc = self#longident_loc a acc in + let a, acc = self#loc self#longident a acc in (Pext_rebind a, acc) method class_type : class_type -> 'acc -> class_type * 'acc = @@ -5005,7 +5217,7 @@ class virtual ['acc] fold_map = fun x acc -> match x with | Pcty_constr (a, b) -> - let a, acc = self#longident_loc a acc in + let a, acc = self#loc self#longident a acc in let b, acc = self#list self#core_type b acc in (Pcty_constr (a, b), acc) | Pcty_signature a -> @@ -5135,7 +5347,7 @@ class virtual ['acc] fold_map = fun x acc -> match x with | Pcl_constr (a, b) -> - let a, acc = self#longident_loc a acc in + let a, acc = self#loc self#longident a acc in let b, acc = self#list self#core_type b acc in (Pcl_constr (a, b), acc) | Pcl_structure a -> @@ -5264,7 +5476,7 @@ class virtual ['acc] fold_map = fun x acc -> match x with | Pmty_ident a -> - let a, acc = self#longident_loc a acc in + let a, acc = self#loc self#longident a acc in (Pmty_ident a, acc) | Pmty_signature a -> let a, acc = self#signature a acc in @@ -5284,7 +5496,7 @@ class virtual ['acc] fold_map = let a, acc = self#extension a acc in (Pmty_extension a, acc) | Pmty_alias a -> - let a, acc = self#longident_loc a acc in + let a, acc = self#loc self#longident a acc in (Pmty_alias a, acc) method functor_parameter @@ -5374,7 +5586,7 @@ class virtual ['acc] fold_map = : module_substitution -> 'acc -> module_substitution * 'acc = fun { pms_name; pms_manifest; pms_attributes; pms_loc } acc -> let pms_name, acc = self#loc self#string pms_name acc in - let pms_manifest, acc = self#longident_loc pms_manifest acc in + let pms_manifest, acc = self#loc self#longident pms_manifest acc in let pms_attributes, acc = self#attributes pms_attributes acc in let pms_loc, acc = self#location pms_loc acc in ({ pms_name; pms_manifest; pms_attributes; pms_loc }, acc) @@ -5403,7 +5615,7 @@ class virtual ['acc] fold_map = method open_description : open_description -> 'acc -> open_description * 'acc = - self#open_infos self#longident_loc + self#open_infos (self#loc self#longident) method open_declaration : open_declaration -> 'acc -> open_declaration * 'acc = @@ -5433,28 +5645,28 @@ class virtual ['acc] fold_map = fun x acc -> match x with | Pwith_type (a, b) -> - let a, acc = self#longident_loc a acc in + let a, acc = self#loc self#longident a acc in let b, acc = self#type_declaration b acc in (Pwith_type (a, b), acc) | Pwith_module (a, b) -> - let a, acc = self#longident_loc a acc in - let b, acc = self#longident_loc b acc in + let a, acc = self#loc self#longident a acc in + let b, acc = self#loc self#longident b acc in (Pwith_module (a, b), acc) | Pwith_modtype (a, b) -> - let a, acc = self#longident_loc a acc in + let a, acc = self#loc self#longident a acc in let b, acc = self#module_type b acc in (Pwith_modtype (a, b), acc) | Pwith_modtypesubst (a, b) -> - let a, acc = self#longident_loc a acc in + let a, acc = self#loc self#longident a acc in let b, acc = self#module_type b acc in (Pwith_modtypesubst (a, b), acc) | Pwith_typesubst (a, b) -> - let a, acc = self#longident_loc a acc in + let a, acc = self#loc self#longident a acc in let b, acc = self#type_declaration b acc in (Pwith_typesubst (a, b), acc) | Pwith_modsubst (a, b) -> - let a, acc = self#longident_loc a acc in - let b, acc = self#longident_loc b acc in + let a, acc = self#loc self#longident a acc in + let b, acc = self#loc self#longident b acc in (Pwith_modsubst (a, b), acc) method module_expr : module_expr -> 'acc -> module_expr * 'acc = @@ -5469,7 +5681,7 @@ class virtual ['acc] fold_map = fun x acc -> match x with | Pmod_ident a -> - let a, acc = self#longident_loc a acc in + let a, acc = self#loc self#longident a acc in (Pmod_ident a, acc) | Pmod_structure a -> let a, acc = self#structure a acc in @@ -5482,6 +5694,9 @@ class virtual ['acc] fold_map = let a, acc = self#module_expr a acc in let b, acc = self#module_expr b acc in (Pmod_apply (a, b), acc) + | Pmod_apply_unit a -> + let a, acc = self#module_expr a acc in + (Pmod_apply_unit a, acc) | Pmod_constraint (a, b) -> let a, acc = self#module_expr a acc in let b, acc = self#module_type b acc in @@ -5556,13 +5771,31 @@ class virtual ['acc] fold_map = let b, acc = self#attributes b acc in (Pstr_extension (a, b), acc) + method value_constraint + : value_constraint -> 'acc -> value_constraint * 'acc = + fun x acc -> + match x with + | Pvc_constraint { locally_abstract_univars; typ } -> + let locally_abstract_univars, acc = + self#list (self#loc self#string) locally_abstract_univars acc + in + let typ, acc = self#core_type typ acc in + (Pvc_constraint { locally_abstract_univars; typ }, acc) + | Pvc_coercion { ground; coercion } -> + let ground, acc = self#option self#core_type ground acc in + let coercion, acc = self#core_type coercion acc in + (Pvc_coercion { ground; coercion }, acc) + method value_binding : value_binding -> 'acc -> value_binding * 'acc = - fun { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } acc -> + fun { pvb_pat; pvb_expr; pvb_constraint; pvb_attributes; pvb_loc } acc -> let pvb_pat, acc = self#pattern pvb_pat acc in let pvb_expr, acc = self#expression pvb_expr acc in + let pvb_constraint, acc = + self#option self#value_constraint pvb_constraint acc + in let pvb_attributes, acc = self#attributes pvb_attributes acc in let pvb_loc, acc = self#location pvb_loc acc in - ({ pvb_pat; pvb_expr; pvb_attributes; pvb_loc }, acc) + ({ pvb_pat; pvb_expr; pvb_constraint; pvb_attributes; pvb_loc }, acc) method module_binding : module_binding -> 'acc -> module_binding * 'acc = fun { pmb_name; pmb_expr; pmb_attributes; pmb_loc } acc -> @@ -5778,7 +6011,7 @@ class virtual ['ctx] map_with_context = let a = self#list self#core_type ctx a in Ptyp_tuple a | Ptyp_constr (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#list self#core_type ctx b in Ptyp_constr (a, b) | Ptyp_object (a, b) -> @@ -5786,12 +6019,12 @@ class virtual ['ctx] map_with_context = let b = self#closed_flag ctx b in Ptyp_object (a, b) | Ptyp_class (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#list self#core_type ctx b in Ptyp_class (a, b) | Ptyp_alias (a, b) -> let a = self#core_type ctx a in - let b = self#string ctx b in + let b = self#loc self#string ctx b in Ptyp_alias (a, b) | Ptyp_variant (a, b, c) -> let a = self#list self#row_field ctx a in @@ -5805,17 +6038,21 @@ class virtual ['ctx] map_with_context = | Ptyp_package a -> let a = self#package_type ctx a in Ptyp_package a + | Ptyp_open (a, b) -> + let a = self#loc self#longident ctx a in + let b = self#core_type ctx b in + Ptyp_open (a, b) | Ptyp_extension a -> let a = self#extension ctx a in Ptyp_extension a method package_type : 'ctx -> package_type -> package_type = fun ctx (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#list (fun ctx (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#core_type ctx b in (a, b)) ctx b @@ -5889,7 +6126,7 @@ class virtual ['ctx] map_with_context = let a = self#list self#pattern ctx a in Ppat_tuple a | Ppat_construct (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#option (fun ctx (a, b) -> @@ -5907,7 +6144,7 @@ class virtual ['ctx] map_with_context = let a = self#list (fun ctx (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#pattern ctx b in (a, b)) ctx a @@ -5926,7 +6163,7 @@ class virtual ['ctx] map_with_context = let b = self#core_type ctx b in Ppat_constraint (a, b) | Ppat_type a -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in Ppat_type a | Ppat_lazy a -> let a = self#pattern ctx a in @@ -5941,7 +6178,7 @@ class virtual ['ctx] map_with_context = let a = self#extension ctx a in Ppat_extension a | Ppat_open (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#pattern ctx b in Ppat_open (a, b) @@ -5957,7 +6194,7 @@ class virtual ['ctx] map_with_context = fun ctx x -> match x with | Pexp_ident a -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in Pexp_ident a | Pexp_constant a -> let a = self#constant ctx a in @@ -5967,15 +6204,11 @@ class virtual ['ctx] map_with_context = let b = self#list self#value_binding ctx b in let c = self#expression ctx c in Pexp_let (a, b, c) - | Pexp_function a -> - let a = self#cases ctx a in - Pexp_function a - | Pexp_fun (a, b, c, d) -> - let a = self#arg_label ctx a in - let b = self#option self#expression ctx b in - let c = self#pattern ctx c in - let d = self#expression ctx d in - Pexp_fun (a, b, c, d) + | Pexp_function (a, b, c) -> + let a = self#list self#function_param ctx a in + let b = self#option self#type_constraint ctx b in + let c = self#function_body ctx c in + Pexp_function (a, b, c) | Pexp_apply (a, b) -> let a = self#expression ctx a in let b = @@ -5999,7 +6232,7 @@ class virtual ['ctx] map_with_context = let a = self#list self#expression ctx a in Pexp_tuple a | Pexp_construct (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#option self#expression ctx b in Pexp_construct (a, b) | Pexp_variant (a, b) -> @@ -6010,7 +6243,7 @@ class virtual ['ctx] map_with_context = let a = self#list (fun ctx (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#expression ctx b in (a, b)) ctx a @@ -6019,11 +6252,11 @@ class virtual ['ctx] map_with_context = Pexp_record (a, b) | Pexp_field (a, b) -> let a = self#expression ctx a in - let b = self#longident_loc ctx b in + let b = self#loc self#longident ctx b in Pexp_field (a, b) | Pexp_setfield (a, b, c) -> let a = self#expression ctx a in - let b = self#longident_loc ctx b in + let b = self#loc self#longident ctx b in let c = self#expression ctx c in Pexp_setfield (a, b, c) | Pexp_array a -> @@ -6063,7 +6296,7 @@ class virtual ['ctx] map_with_context = let b = self#loc self#label ctx b in Pexp_send (a, b) | Pexp_new a -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in Pexp_new a | Pexp_setinstvar (a, b) -> let a = self#loc self#label ctx a in @@ -6142,6 +6375,48 @@ class virtual ['ctx] map_with_context = let pbop_loc = self#location ctx pbop_loc in { pbop_op; pbop_pat; pbop_exp; pbop_loc } + method function_param_desc + : 'ctx -> function_param_desc -> function_param_desc = + fun ctx x -> + match x with + | Pparam_val (a, b, c) -> + let a = self#arg_label ctx a in + let b = self#option self#expression ctx b in + let c = self#pattern ctx c in + Pparam_val (a, b, c) + | Pparam_newtype a -> + let a = self#loc self#string ctx a in + Pparam_newtype a + + method function_param : 'ctx -> function_param -> function_param = + fun ctx { pparam_loc; pparam_desc } -> + let pparam_loc = self#location ctx pparam_loc in + let pparam_desc = self#function_param_desc ctx pparam_desc in + { pparam_loc; pparam_desc } + + method function_body : 'ctx -> function_body -> function_body = + fun ctx x -> + match x with + | Pfunction_body a -> + let a = self#expression ctx a in + Pfunction_body a + | Pfunction_cases (a, b, c) -> + let a = self#cases ctx a in + let b = self#location ctx b in + let c = self#attributes ctx c in + Pfunction_cases (a, b, c) + + method type_constraint : 'ctx -> type_constraint -> type_constraint = + fun ctx x -> + match x with + | Pconstraint a -> + let a = self#core_type ctx a in + Pconstraint a + | Pcoerce (a, b) -> + let a = self#option self#core_type ctx a in + let b = self#core_type ctx b in + Pcoerce (a, b) + method value_description : 'ctx -> value_description -> value_description = fun ctx { pval_name; pval_type; pval_prim; pval_attributes; pval_loc } -> let pval_name = self#loc self#string ctx pval_name in @@ -6256,7 +6531,7 @@ class virtual ['ctx] map_with_context = ptyext_loc; ptyext_attributes; } -> - let ptyext_path = self#longident_loc ctx ptyext_path in + let ptyext_path = self#loc self#longident ctx ptyext_path in let ptyext_params = self#list (fun ctx (a, b) -> @@ -6314,7 +6589,7 @@ class virtual ['ctx] map_with_context = let c = self#option self#core_type ctx c in Pext_decl (a, b, c) | Pext_rebind a -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in Pext_rebind a method class_type : 'ctx -> class_type -> class_type = @@ -6328,7 +6603,7 @@ class virtual ['ctx] map_with_context = fun ctx x -> match x with | Pcty_constr (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#list self#core_type ctx b in Pcty_constr (a, b) | Pcty_signature a -> @@ -6448,7 +6723,7 @@ class virtual ['ctx] map_with_context = fun ctx x -> match x with | Pcl_constr (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#list self#core_type ctx b in Pcl_constr (a, b) | Pcl_structure a -> @@ -6573,7 +6848,7 @@ class virtual ['ctx] map_with_context = fun ctx x -> match x with | Pmty_ident a -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in Pmty_ident a | Pmty_signature a -> let a = self#signature ctx a in @@ -6593,7 +6868,7 @@ class virtual ['ctx] map_with_context = let a = self#extension ctx a in Pmty_extension a | Pmty_alias a -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in Pmty_alias a method functor_parameter : 'ctx -> functor_parameter -> functor_parameter = @@ -6682,7 +6957,7 @@ class virtual ['ctx] map_with_context = : 'ctx -> module_substitution -> module_substitution = fun ctx { pms_name; pms_manifest; pms_attributes; pms_loc } -> let pms_name = self#loc self#string ctx pms_name in - let pms_manifest = self#longident_loc ctx pms_manifest in + let pms_manifest = self#loc self#longident ctx pms_manifest in let pms_attributes = self#attributes ctx pms_attributes in let pms_loc = self#location ctx pms_loc in { pms_name; pms_manifest; pms_attributes; pms_loc } @@ -6706,7 +6981,7 @@ class virtual ['ctx] map_with_context = { popen_expr; popen_override; popen_loc; popen_attributes } method open_description : 'ctx -> open_description -> open_description = - self#open_infos self#longident_loc + self#open_infos (self#loc self#longident) method open_declaration : 'ctx -> open_declaration -> open_declaration = self#open_infos self#module_expr @@ -6732,28 +7007,28 @@ class virtual ['ctx] map_with_context = fun ctx x -> match x with | Pwith_type (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#type_declaration ctx b in Pwith_type (a, b) | Pwith_module (a, b) -> - let a = self#longident_loc ctx a in - let b = self#longident_loc ctx b in + let a = self#loc self#longident ctx a in + let b = self#loc self#longident ctx b in Pwith_module (a, b) | Pwith_modtype (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#module_type ctx b in Pwith_modtype (a, b) | Pwith_modtypesubst (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#module_type ctx b in Pwith_modtypesubst (a, b) | Pwith_typesubst (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#type_declaration ctx b in Pwith_typesubst (a, b) | Pwith_modsubst (a, b) -> - let a = self#longident_loc ctx a in - let b = self#longident_loc ctx b in + let a = self#loc self#longident ctx a in + let b = self#loc self#longident ctx b in Pwith_modsubst (a, b) method module_expr : 'ctx -> module_expr -> module_expr = @@ -6767,7 +7042,7 @@ class virtual ['ctx] map_with_context = fun ctx x -> match x with | Pmod_ident a -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in Pmod_ident a | Pmod_structure a -> let a = self#structure ctx a in @@ -6780,6 +7055,9 @@ class virtual ['ctx] map_with_context = let a = self#module_expr ctx a in let b = self#module_expr ctx b in Pmod_apply (a, b) + | Pmod_apply_unit a -> + let a = self#module_expr ctx a in + Pmod_apply_unit a | Pmod_constraint (a, b) -> let a = self#module_expr ctx a in let b = self#module_type ctx b in @@ -6854,13 +7132,30 @@ class virtual ['ctx] map_with_context = let b = self#attributes ctx b in Pstr_extension (a, b) + method value_constraint : 'ctx -> value_constraint -> value_constraint = + fun ctx x -> + match x with + | Pvc_constraint { locally_abstract_univars; typ } -> + let locally_abstract_univars = + self#list (self#loc self#string) ctx locally_abstract_univars + in + let typ = self#core_type ctx typ in + Pvc_constraint { locally_abstract_univars; typ } + | Pvc_coercion { ground; coercion } -> + let ground = self#option self#core_type ctx ground in + let coercion = self#core_type ctx coercion in + Pvc_coercion { ground; coercion } + method value_binding : 'ctx -> value_binding -> value_binding = - fun ctx { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } -> + fun ctx { pvb_pat; pvb_expr; pvb_constraint; pvb_attributes; pvb_loc } -> let pvb_pat = self#pattern ctx pvb_pat in let pvb_expr = self#expression ctx pvb_expr in + let pvb_constraint = + self#option self#value_constraint ctx pvb_constraint + in let pvb_attributes = self#attributes ctx pvb_attributes in let pvb_loc = self#location ctx pvb_loc in - { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } + { pvb_pat; pvb_expr; pvb_constraint; pvb_attributes; pvb_loc } method module_binding : 'ctx -> module_binding -> module_binding = fun ctx { pmb_name; pmb_expr; pmb_attributes; pmb_loc } -> @@ -7134,7 +7429,7 @@ class virtual ['res] lift = let a = self#list self#core_type a in self#constr "Ptyp_tuple" [ a ] | Ptyp_constr (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#list self#core_type b in self#constr "Ptyp_constr" [ a; b ] | Ptyp_object (a, b) -> @@ -7142,12 +7437,12 @@ class virtual ['res] lift = let b = self#closed_flag b in self#constr "Ptyp_object" [ a; b ] | Ptyp_class (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#list self#core_type b in self#constr "Ptyp_class" [ a; b ] | Ptyp_alias (a, b) -> let a = self#core_type a in - let b = self#string b in + let b = self#loc self#string b in self#constr "Ptyp_alias" [ a; b ] | Ptyp_variant (a, b, c) -> let a = self#list self#row_field a in @@ -7161,17 +7456,21 @@ class virtual ['res] lift = | Ptyp_package a -> let a = self#package_type a in self#constr "Ptyp_package" [ a ] + | Ptyp_open (a, b) -> + let a = self#loc self#longident a in + let b = self#core_type b in + self#constr "Ptyp_open" [ a; b ] | Ptyp_extension a -> let a = self#extension a in self#constr "Ptyp_extension" [ a ] method package_type : package_type -> 'res = fun (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#list (fun (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#core_type b in self#tuple [ a; b ]) b @@ -7261,7 +7560,7 @@ class virtual ['res] lift = let a = self#list self#pattern a in self#constr "Ppat_tuple" [ a ] | Ppat_construct (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#option (fun (a, b) -> @@ -7279,7 +7578,7 @@ class virtual ['res] lift = let a = self#list (fun (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#pattern b in self#tuple [ a; b ]) a @@ -7298,7 +7597,7 @@ class virtual ['res] lift = let b = self#core_type b in self#constr "Ppat_constraint" [ a; b ] | Ppat_type a -> - let a = self#longident_loc a in + let a = self#loc self#longident a in self#constr "Ppat_type" [ a ] | Ppat_lazy a -> let a = self#pattern a in @@ -7313,7 +7612,7 @@ class virtual ['res] lift = let a = self#extension a in self#constr "Ppat_extension" [ a ] | Ppat_open (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#pattern b in self#constr "Ppat_open" [ a; b ] @@ -7335,7 +7634,7 @@ class virtual ['res] lift = fun x -> match x with | Pexp_ident a -> - let a = self#longident_loc a in + let a = self#loc self#longident a in self#constr "Pexp_ident" [ a ] | Pexp_constant a -> let a = self#constant a in @@ -7345,15 +7644,11 @@ class virtual ['res] lift = let b = self#list self#value_binding b in let c = self#expression c in self#constr "Pexp_let" [ a; b; c ] - | Pexp_function a -> - let a = self#cases a in - self#constr "Pexp_function" [ a ] - | Pexp_fun (a, b, c, d) -> - let a = self#arg_label a in - let b = self#option self#expression b in - let c = self#pattern c in - let d = self#expression d in - self#constr "Pexp_fun" [ a; b; c; d ] + | Pexp_function (a, b, c) -> + let a = self#list self#function_param a in + let b = self#option self#type_constraint b in + let c = self#function_body c in + self#constr "Pexp_function" [ a; b; c ] | Pexp_apply (a, b) -> let a = self#expression a in let b = @@ -7377,7 +7672,7 @@ class virtual ['res] lift = let a = self#list self#expression a in self#constr "Pexp_tuple" [ a ] | Pexp_construct (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#option self#expression b in self#constr "Pexp_construct" [ a; b ] | Pexp_variant (a, b) -> @@ -7388,7 +7683,7 @@ class virtual ['res] lift = let a = self#list (fun (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#expression b in self#tuple [ a; b ]) a @@ -7397,11 +7692,11 @@ class virtual ['res] lift = self#constr "Pexp_record" [ a; b ] | Pexp_field (a, b) -> let a = self#expression a in - let b = self#longident_loc b in + let b = self#loc self#longident b in self#constr "Pexp_field" [ a; b ] | Pexp_setfield (a, b, c) -> let a = self#expression a in - let b = self#longident_loc b in + let b = self#loc self#longident b in let c = self#expression c in self#constr "Pexp_setfield" [ a; b; c ] | Pexp_array a -> @@ -7441,7 +7736,7 @@ class virtual ['res] lift = let b = self#loc self#label b in self#constr "Pexp_send" [ a; b ] | Pexp_new a -> - let a = self#longident_loc a in + let a = self#loc self#longident a in self#constr "Pexp_new" [ a ] | Pexp_setinstvar (a, b) -> let a = self#loc self#label a in @@ -7527,6 +7822,47 @@ class virtual ['res] lift = ("pbop_loc", pbop_loc); ] + method function_param_desc : function_param_desc -> 'res = + fun x -> + match x with + | Pparam_val (a, b, c) -> + let a = self#arg_label a in + let b = self#option self#expression b in + let c = self#pattern c in + self#constr "Pparam_val" [ a; b; c ] + | Pparam_newtype a -> + let a = self#loc self#string a in + self#constr "Pparam_newtype" [ a ] + + method function_param : function_param -> 'res = + fun { pparam_loc; pparam_desc } -> + let pparam_loc = self#location pparam_loc in + let pparam_desc = self#function_param_desc pparam_desc in + self#record [ ("pparam_loc", pparam_loc); ("pparam_desc", pparam_desc) ] + + method function_body : function_body -> 'res = + fun x -> + match x with + | Pfunction_body a -> + let a = self#expression a in + self#constr "Pfunction_body" [ a ] + | Pfunction_cases (a, b, c) -> + let a = self#cases a in + let b = self#location b in + let c = self#attributes c in + self#constr "Pfunction_cases" [ a; b; c ] + + method type_constraint : type_constraint -> 'res = + fun x -> + match x with + | Pconstraint a -> + let a = self#core_type a in + self#constr "Pconstraint" [ a ] + | Pcoerce (a, b) -> + let a = self#option self#core_type a in + let b = self#core_type b in + self#constr "Pcoerce" [ a; b ] + method value_description : value_description -> 'res = fun { pval_name; pval_type; pval_prim; pval_attributes; pval_loc } -> let pval_name = self#loc self#string pval_name in @@ -7660,7 +7996,7 @@ class virtual ['res] lift = ptyext_loc; ptyext_attributes; } -> - let ptyext_path = self#longident_loc ptyext_path in + let ptyext_path = self#loc self#longident ptyext_path in let ptyext_params = self#list (fun (a, b) -> @@ -7728,7 +8064,7 @@ class virtual ['res] lift = let c = self#option self#core_type c in self#constr "Pext_decl" [ a; b; c ] | Pext_rebind a -> - let a = self#longident_loc a in + let a = self#loc self#longident a in self#constr "Pext_rebind" [ a ] method class_type : class_type -> 'res = @@ -7747,7 +8083,7 @@ class virtual ['res] lift = fun x -> match x with | Pcty_constr (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#list self#core_type b in self#constr "Pcty_constr" [ a; b ] | Pcty_signature a -> @@ -7883,7 +8219,7 @@ class virtual ['res] lift = fun x -> match x with | Pcl_constr (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#list self#core_type b in self#constr "Pcl_constr" [ a; b ] | Pcl_structure a -> @@ -8019,7 +8355,7 @@ class virtual ['res] lift = fun x -> match x with | Pmty_ident a -> - let a = self#longident_loc a in + let a = self#loc self#longident a in self#constr "Pmty_ident" [ a ] | Pmty_signature a -> let a = self#signature a in @@ -8039,7 +8375,7 @@ class virtual ['res] lift = let a = self#extension a in self#constr "Pmty_extension" [ a ] | Pmty_alias a -> - let a = self#longident_loc a in + let a = self#loc self#longident a in self#constr "Pmty_alias" [ a ] method functor_parameter : functor_parameter -> 'res = @@ -8130,7 +8466,7 @@ class virtual ['res] lift = method module_substitution : module_substitution -> 'res = fun { pms_name; pms_manifest; pms_attributes; pms_loc } -> let pms_name = self#loc self#string pms_name in - let pms_manifest = self#longident_loc pms_manifest in + let pms_manifest = self#loc self#longident pms_manifest in let pms_attributes = self#attributes pms_attributes in let pms_loc = self#location pms_loc in self#record @@ -8170,7 +8506,7 @@ class virtual ['res] lift = ] method open_description : open_description -> 'res = - self#open_infos self#longident_loc + self#open_infos (self#loc self#longident) method open_declaration : open_declaration -> 'res = self#open_infos self#module_expr @@ -8197,28 +8533,28 @@ class virtual ['res] lift = fun x -> match x with | Pwith_type (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#type_declaration b in self#constr "Pwith_type" [ a; b ] | Pwith_module (a, b) -> - let a = self#longident_loc a in - let b = self#longident_loc b in + let a = self#loc self#longident a in + let b = self#loc self#longident b in self#constr "Pwith_module" [ a; b ] | Pwith_modtype (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#module_type b in self#constr "Pwith_modtype" [ a; b ] | Pwith_modtypesubst (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#module_type b in self#constr "Pwith_modtypesubst" [ a; b ] | Pwith_typesubst (a, b) -> - let a = self#longident_loc a in + let a = self#loc self#longident a in let b = self#type_declaration b in self#constr "Pwith_typesubst" [ a; b ] | Pwith_modsubst (a, b) -> - let a = self#longident_loc a in - let b = self#longident_loc b in + let a = self#loc self#longident a in + let b = self#loc self#longident b in self#constr "Pwith_modsubst" [ a; b ] method module_expr : module_expr -> 'res = @@ -8237,7 +8573,7 @@ class virtual ['res] lift = fun x -> match x with | Pmod_ident a -> - let a = self#longident_loc a in + let a = self#loc self#longident a in self#constr "Pmod_ident" [ a ] | Pmod_structure a -> let a = self#structure a in @@ -8250,6 +8586,9 @@ class virtual ['res] lift = let a = self#module_expr a in let b = self#module_expr b in self#constr "Pmod_apply" [ a; b ] + | Pmod_apply_unit a -> + let a = self#module_expr a in + self#constr "Pmod_apply_unit" [ a ] | Pmod_constraint (a, b) -> let a = self#module_expr a in let b = self#module_type b in @@ -8322,16 +8661,40 @@ class virtual ['res] lift = let b = self#attributes b in self#constr "Pstr_extension" [ a; b ] + method value_constraint : value_constraint -> 'res = + fun x -> + match x with + | Pvc_constraint { locally_abstract_univars; typ } -> + let locally_abstract_univars = + self#list (self#loc self#string) locally_abstract_univars + in + let typ = self#core_type typ in + self#constr "Pvc_constraint" + [ + self#record + [ + ("locally_abstract_univars", locally_abstract_univars); + ("typ", typ); + ]; + ] + | Pvc_coercion { ground; coercion } -> + let ground = self#option self#core_type ground in + let coercion = self#core_type coercion in + self#constr "Pvc_coercion" + [ self#record [ ("ground", ground); ("coercion", coercion) ] ] + method value_binding : value_binding -> 'res = - fun { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } -> + fun { pvb_pat; pvb_expr; pvb_constraint; pvb_attributes; pvb_loc } -> let pvb_pat = self#pattern pvb_pat in let pvb_expr = self#expression pvb_expr in + let pvb_constraint = self#option self#value_constraint pvb_constraint in let pvb_attributes = self#attributes pvb_attributes in let pvb_loc = self#location pvb_loc in self#record [ ("pvb_pat", pvb_pat); ("pvb_expr", pvb_expr); + ("pvb_constraint", pvb_constraint); ("pvb_attributes", pvb_attributes); ("pvb_loc", pvb_loc); ] @@ -8637,7 +9000,7 @@ class virtual ['ctx, 'res] lift_map_with_context = ( Ptyp_tuple (Stdlib.fst a), self#constr ctx "Ptyp_tuple" [ Stdlib.snd a ] ) | Ptyp_constr (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#list self#core_type ctx b in ( Ptyp_constr (Stdlib.fst a, Stdlib.fst b), self#constr ctx "Ptyp_constr" [ Stdlib.snd a; Stdlib.snd b ] ) @@ -8647,13 +9010,13 @@ class virtual ['ctx, 'res] lift_map_with_context = ( Ptyp_object (Stdlib.fst a, Stdlib.fst b), self#constr ctx "Ptyp_object" [ Stdlib.snd a; Stdlib.snd b ] ) | Ptyp_class (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#list self#core_type ctx b in ( Ptyp_class (Stdlib.fst a, Stdlib.fst b), self#constr ctx "Ptyp_class" [ Stdlib.snd a; Stdlib.snd b ] ) | Ptyp_alias (a, b) -> let a = self#core_type ctx a in - let b = self#string ctx b in + let b = self#loc self#string ctx b in ( Ptyp_alias (Stdlib.fst a, Stdlib.fst b), self#constr ctx "Ptyp_alias" [ Stdlib.snd a; Stdlib.snd b ] ) | Ptyp_variant (a, b, c) -> @@ -8672,6 +9035,11 @@ class virtual ['ctx, 'res] lift_map_with_context = let a = self#package_type ctx a in ( Ptyp_package (Stdlib.fst a), self#constr ctx "Ptyp_package" [ Stdlib.snd a ] ) + | Ptyp_open (a, b) -> + let a = self#loc self#longident ctx a in + let b = self#core_type ctx b in + ( Ptyp_open (Stdlib.fst a, Stdlib.fst b), + self#constr ctx "Ptyp_open" [ Stdlib.snd a; Stdlib.snd b ] ) | Ptyp_extension a -> let a = self#extension ctx a in ( Ptyp_extension (Stdlib.fst a), @@ -8679,11 +9047,11 @@ class virtual ['ctx, 'res] lift_map_with_context = method package_type : 'ctx -> package_type -> package_type * 'res = fun ctx (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#list (fun ctx (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#core_type ctx b in ( (Stdlib.fst a, Stdlib.fst b), self#tuple ctx [ Stdlib.snd a; Stdlib.snd b ] )) @@ -8802,7 +9170,7 @@ class virtual ['ctx, 'res] lift_map_with_context = ( Ppat_tuple (Stdlib.fst a), self#constr ctx "Ppat_tuple" [ Stdlib.snd a ] ) | Ppat_construct (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#option (fun ctx (a, b) -> @@ -8823,7 +9191,7 @@ class virtual ['ctx, 'res] lift_map_with_context = let a = self#list (fun ctx (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#pattern ctx b in ( (Stdlib.fst a, Stdlib.fst b), self#tuple ctx [ Stdlib.snd a; Stdlib.snd b ] )) @@ -8848,7 +9216,7 @@ class virtual ['ctx, 'res] lift_map_with_context = self#constr ctx "Ppat_constraint" [ Stdlib.snd a; Stdlib.snd b ] ) | Ppat_type a -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in ( Ppat_type (Stdlib.fst a), self#constr ctx "Ppat_type" [ Stdlib.snd a ] ) | Ppat_lazy a -> @@ -8868,7 +9236,7 @@ class virtual ['ctx, 'res] lift_map_with_context = ( Ppat_extension (Stdlib.fst a), self#constr ctx "Ppat_extension" [ Stdlib.snd a ] ) | Ppat_open (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#pattern ctx b in ( Ppat_open (Stdlib.fst a, Stdlib.fst b), self#constr ctx "Ppat_open" [ Stdlib.snd a; Stdlib.snd b ] ) @@ -8897,7 +9265,7 @@ class virtual ['ctx, 'res] lift_map_with_context = fun ctx x -> match x with | Pexp_ident a -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in ( Pexp_ident (Stdlib.fst a), self#constr ctx "Pexp_ident" [ Stdlib.snd a ] ) | Pexp_constant a -> @@ -8911,18 +9279,13 @@ class virtual ['ctx, 'res] lift_map_with_context = ( Pexp_let (Stdlib.fst a, Stdlib.fst b, Stdlib.fst c), self#constr ctx "Pexp_let" [ Stdlib.snd a; Stdlib.snd b; Stdlib.snd c ] ) - | Pexp_function a -> - let a = self#cases ctx a in - ( Pexp_function (Stdlib.fst a), - self#constr ctx "Pexp_function" [ Stdlib.snd a ] ) - | Pexp_fun (a, b, c, d) -> - let a = self#arg_label ctx a in - let b = self#option self#expression ctx b in - let c = self#pattern ctx c in - let d = self#expression ctx d in - ( Pexp_fun (Stdlib.fst a, Stdlib.fst b, Stdlib.fst c, Stdlib.fst d), - self#constr ctx "Pexp_fun" - [ Stdlib.snd a; Stdlib.snd b; Stdlib.snd c; Stdlib.snd d ] ) + | Pexp_function (a, b, c) -> + let a = self#list self#function_param ctx a in + let b = self#option self#type_constraint ctx b in + let c = self#function_body ctx c in + ( Pexp_function (Stdlib.fst a, Stdlib.fst b, Stdlib.fst c), + self#constr ctx "Pexp_function" + [ Stdlib.snd a; Stdlib.snd b; Stdlib.snd c ] ) | Pexp_apply (a, b) -> let a = self#expression ctx a in let b = @@ -8951,7 +9314,7 @@ class virtual ['ctx, 'res] lift_map_with_context = ( Pexp_tuple (Stdlib.fst a), self#constr ctx "Pexp_tuple" [ Stdlib.snd a ] ) | Pexp_construct (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#option self#expression ctx b in ( Pexp_construct (Stdlib.fst a, Stdlib.fst b), self#constr ctx "Pexp_construct" [ Stdlib.snd a; Stdlib.snd b ] ) @@ -8964,7 +9327,7 @@ class virtual ['ctx, 'res] lift_map_with_context = let a = self#list (fun ctx (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#expression ctx b in ( (Stdlib.fst a, Stdlib.fst b), self#tuple ctx [ Stdlib.snd a; Stdlib.snd b ] )) @@ -8975,12 +9338,12 @@ class virtual ['ctx, 'res] lift_map_with_context = self#constr ctx "Pexp_record" [ Stdlib.snd a; Stdlib.snd b ] ) | Pexp_field (a, b) -> let a = self#expression ctx a in - let b = self#longident_loc ctx b in + let b = self#loc self#longident ctx b in ( Pexp_field (Stdlib.fst a, Stdlib.fst b), self#constr ctx "Pexp_field" [ Stdlib.snd a; Stdlib.snd b ] ) | Pexp_setfield (a, b, c) -> let a = self#expression ctx a in - let b = self#longident_loc ctx b in + let b = self#loc self#longident ctx b in let c = self#expression ctx c in ( Pexp_setfield (Stdlib.fst a, Stdlib.fst b, Stdlib.fst c), self#constr ctx "Pexp_setfield" @@ -9045,7 +9408,7 @@ class virtual ['ctx, 'res] lift_map_with_context = ( Pexp_send (Stdlib.fst a, Stdlib.fst b), self#constr ctx "Pexp_send" [ Stdlib.snd a; Stdlib.snd b ] ) | Pexp_new a -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in ( Pexp_new (Stdlib.fst a), self#constr ctx "Pexp_new" [ Stdlib.snd a ] ) | Pexp_setinstvar (a, b) -> @@ -9175,6 +9538,64 @@ class virtual ['ctx, 'res] lift_map_with_context = ("pbop_loc", Stdlib.snd pbop_loc); ] ) + method function_param_desc + : 'ctx -> function_param_desc -> function_param_desc * 'res = + fun ctx x -> + match x with + | Pparam_val (a, b, c) -> + let a = self#arg_label ctx a in + let b = self#option self#expression ctx b in + let c = self#pattern ctx c in + ( Pparam_val (Stdlib.fst a, Stdlib.fst b, Stdlib.fst c), + self#constr ctx "Pparam_val" + [ Stdlib.snd a; Stdlib.snd b; Stdlib.snd c ] ) + | Pparam_newtype a -> + let a = self#loc self#string ctx a in + ( Pparam_newtype (Stdlib.fst a), + self#constr ctx "Pparam_newtype" [ Stdlib.snd a ] ) + + method function_param : 'ctx -> function_param -> function_param * 'res = + fun ctx { pparam_loc; pparam_desc } -> + let pparam_loc = self#location ctx pparam_loc in + let pparam_desc = self#function_param_desc ctx pparam_desc in + ( { + pparam_loc = Stdlib.fst pparam_loc; + pparam_desc = Stdlib.fst pparam_desc; + }, + self#record ctx + [ + ("pparam_loc", Stdlib.snd pparam_loc); + ("pparam_desc", Stdlib.snd pparam_desc); + ] ) + + method function_body : 'ctx -> function_body -> function_body * 'res = + fun ctx x -> + match x with + | Pfunction_body a -> + let a = self#expression ctx a in + ( Pfunction_body (Stdlib.fst a), + self#constr ctx "Pfunction_body" [ Stdlib.snd a ] ) + | Pfunction_cases (a, b, c) -> + let a = self#cases ctx a in + let b = self#location ctx b in + let c = self#attributes ctx c in + ( Pfunction_cases (Stdlib.fst a, Stdlib.fst b, Stdlib.fst c), + self#constr ctx "Pfunction_cases" + [ Stdlib.snd a; Stdlib.snd b; Stdlib.snd c ] ) + + method type_constraint : 'ctx -> type_constraint -> type_constraint * 'res = + fun ctx x -> + match x with + | Pconstraint a -> + let a = self#core_type ctx a in + ( Pconstraint (Stdlib.fst a), + self#constr ctx "Pconstraint" [ Stdlib.snd a ] ) + | Pcoerce (a, b) -> + let a = self#option self#core_type ctx a in + let b = self#core_type ctx b in + ( Pcoerce (Stdlib.fst a, Stdlib.fst b), + self#constr ctx "Pcoerce" [ Stdlib.snd a; Stdlib.snd b ] ) + method value_description : 'ctx -> value_description -> value_description * 'res = fun ctx { pval_name; pval_type; pval_prim; pval_attributes; pval_loc } -> @@ -9354,7 +9775,7 @@ class virtual ['ctx, 'res] lift_map_with_context = ptyext_loc; ptyext_attributes; } -> - let ptyext_path = self#longident_loc ctx ptyext_path in + let ptyext_path = self#loc self#longident ctx ptyext_path in let ptyext_params = self#list (fun ctx (a, b) -> @@ -9449,7 +9870,7 @@ class virtual ['ctx, 'res] lift_map_with_context = self#constr ctx "Pext_decl" [ Stdlib.snd a; Stdlib.snd b; Stdlib.snd c ] ) | Pext_rebind a -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in ( Pext_rebind (Stdlib.fst a), self#constr ctx "Pext_rebind" [ Stdlib.snd a ] ) @@ -9474,7 +9895,7 @@ class virtual ['ctx, 'res] lift_map_with_context = fun ctx x -> match x with | Pcty_constr (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#list self#core_type ctx b in ( Pcty_constr (Stdlib.fst a, Stdlib.fst b), self#constr ctx "Pcty_constr" [ Stdlib.snd a; Stdlib.snd b ] ) @@ -9665,7 +10086,7 @@ class virtual ['ctx, 'res] lift_map_with_context = fun ctx x -> match x with | Pcl_constr (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#list self#core_type ctx b in ( Pcl_constr (Stdlib.fst a, Stdlib.fst b), self#constr ctx "Pcl_constr" [ Stdlib.snd a; Stdlib.snd b ] ) @@ -9845,7 +10266,7 @@ class virtual ['ctx, 'res] lift_map_with_context = fun ctx x -> match x with | Pmty_ident a -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in ( Pmty_ident (Stdlib.fst a), self#constr ctx "Pmty_ident" [ Stdlib.snd a ] ) | Pmty_signature a -> @@ -9871,7 +10292,7 @@ class virtual ['ctx, 'res] lift_map_with_context = ( Pmty_extension (Stdlib.fst a), self#constr ctx "Pmty_extension" [ Stdlib.snd a ] ) | Pmty_alias a -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in ( Pmty_alias (Stdlib.fst a), self#constr ctx "Pmty_alias" [ Stdlib.snd a ] ) @@ -9996,7 +10417,7 @@ class virtual ['ctx, 'res] lift_map_with_context = : 'ctx -> module_substitution -> module_substitution * 'res = fun ctx { pms_name; pms_manifest; pms_attributes; pms_loc } -> let pms_name = self#loc self#string ctx pms_name in - let pms_manifest = self#longident_loc ctx pms_manifest in + let pms_manifest = self#loc self#longident ctx pms_manifest in let pms_attributes = self#attributes ctx pms_attributes in let pms_loc = self#location ctx pms_loc in ( { @@ -10061,7 +10482,7 @@ class virtual ['ctx, 'res] lift_map_with_context = method open_description : 'ctx -> open_description -> open_description * 'res = - self#open_infos self#longident_loc + self#open_infos (self#loc self#longident) method open_declaration : 'ctx -> open_declaration -> open_declaration * 'res = @@ -10101,35 +10522,35 @@ class virtual ['ctx, 'res] lift_map_with_context = fun ctx x -> match x with | Pwith_type (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#type_declaration ctx b in ( Pwith_type (Stdlib.fst a, Stdlib.fst b), self#constr ctx "Pwith_type" [ Stdlib.snd a; Stdlib.snd b ] ) | Pwith_module (a, b) -> - let a = self#longident_loc ctx a in - let b = self#longident_loc ctx b in + let a = self#loc self#longident ctx a in + let b = self#loc self#longident ctx b in ( Pwith_module (Stdlib.fst a, Stdlib.fst b), self#constr ctx "Pwith_module" [ Stdlib.snd a; Stdlib.snd b ] ) | Pwith_modtype (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#module_type ctx b in ( Pwith_modtype (Stdlib.fst a, Stdlib.fst b), self#constr ctx "Pwith_modtype" [ Stdlib.snd a; Stdlib.snd b ] ) | Pwith_modtypesubst (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#module_type ctx b in ( Pwith_modtypesubst (Stdlib.fst a, Stdlib.fst b), self#constr ctx "Pwith_modtypesubst" [ Stdlib.snd a; Stdlib.snd b ] ) | Pwith_typesubst (a, b) -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in let b = self#type_declaration ctx b in ( Pwith_typesubst (Stdlib.fst a, Stdlib.fst b), self#constr ctx "Pwith_typesubst" [ Stdlib.snd a; Stdlib.snd b ] ) | Pwith_modsubst (a, b) -> - let a = self#longident_loc ctx a in - let b = self#longident_loc ctx b in + let a = self#loc self#longident ctx a in + let b = self#loc self#longident ctx b in ( Pwith_modsubst (Stdlib.fst a, Stdlib.fst b), self#constr ctx "Pwith_modsubst" [ Stdlib.snd a; Stdlib.snd b ] ) @@ -10155,7 +10576,7 @@ class virtual ['ctx, 'res] lift_map_with_context = fun ctx x -> match x with | Pmod_ident a -> - let a = self#longident_loc ctx a in + let a = self#loc self#longident ctx a in ( Pmod_ident (Stdlib.fst a), self#constr ctx "Pmod_ident" [ Stdlib.snd a ] ) | Pmod_structure a -> @@ -10172,6 +10593,10 @@ class virtual ['ctx, 'res] lift_map_with_context = let b = self#module_expr ctx b in ( Pmod_apply (Stdlib.fst a, Stdlib.fst b), self#constr ctx "Pmod_apply" [ Stdlib.snd a; Stdlib.snd b ] ) + | Pmod_apply_unit a -> + let a = self#module_expr ctx a in + ( Pmod_apply_unit (Stdlib.fst a), + self#constr ctx "Pmod_apply_unit" [ Stdlib.snd a ] ) | Pmod_constraint (a, b) -> let a = self#module_expr ctx a in let b = self#module_type ctx b in @@ -10270,15 +10695,56 @@ class virtual ['ctx, 'res] lift_map_with_context = ( Pstr_extension (Stdlib.fst a, Stdlib.fst b), self#constr ctx "Pstr_extension" [ Stdlib.snd a; Stdlib.snd b ] ) + method value_constraint + : 'ctx -> value_constraint -> value_constraint * 'res = + fun ctx x -> + match x with + | Pvc_constraint { locally_abstract_univars; typ } -> + let locally_abstract_univars = + self#list (self#loc self#string) ctx locally_abstract_univars + in + let typ = self#core_type ctx typ in + ( Pvc_constraint + { + locally_abstract_univars = Stdlib.fst locally_abstract_univars; + typ = Stdlib.fst typ; + }, + self#constr ctx "Pvc_constraint" + [ + self#record ctx + [ + ( "locally_abstract_univars", + Stdlib.snd locally_abstract_univars ); + ("typ", Stdlib.snd typ); + ]; + ] ) + | Pvc_coercion { ground; coercion } -> + let ground = self#option self#core_type ctx ground in + let coercion = self#core_type ctx coercion in + ( Pvc_coercion + { ground = Stdlib.fst ground; coercion = Stdlib.fst coercion }, + self#constr ctx "Pvc_coercion" + [ + self#record ctx + [ + ("ground", Stdlib.snd ground); + ("coercion", Stdlib.snd coercion); + ]; + ] ) + method value_binding : 'ctx -> value_binding -> value_binding * 'res = - fun ctx { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } -> + fun ctx { pvb_pat; pvb_expr; pvb_constraint; pvb_attributes; pvb_loc } -> let pvb_pat = self#pattern ctx pvb_pat in let pvb_expr = self#expression ctx pvb_expr in + let pvb_constraint = + self#option self#value_constraint ctx pvb_constraint + in let pvb_attributes = self#attributes ctx pvb_attributes in let pvb_loc = self#location ctx pvb_loc in ( { pvb_pat = Stdlib.fst pvb_pat; pvb_expr = Stdlib.fst pvb_expr; + pvb_constraint = Stdlib.fst pvb_constraint; pvb_attributes = Stdlib.fst pvb_attributes; pvb_loc = Stdlib.fst pvb_loc; }, @@ -10286,6 +10752,7 @@ class virtual ['ctx, 'res] lift_map_with_context = [ ("pvb_pat", Stdlib.snd pvb_pat); ("pvb_expr", Stdlib.snd pvb_expr); + ("pvb_constraint", Stdlib.snd pvb_constraint); ("pvb_attributes", Stdlib.snd pvb_attributes); ("pvb_loc", Stdlib.snd pvb_loc); ] ) @@ -10381,4 +10848,3 @@ class virtual ['ctx, 'res] lift_map_with_context = end [@@@end] -[@@@end] diff --git a/ast/ast_helper_lite.ml b/ast/ast_helper_lite.ml index 2b45e6c0a..a76d0b037 100644 --- a/ast/ast_helper_lite.ml +++ b/ast/ast_helper_lite.ml @@ -17,7 +17,7 @@ open Stdlib0 module Location = Astlib.Location module Longident = Astlib.Longident -open Astlib.Ast_500 +open Astlib.Ast_502 [@@@warning "-9"] @@ -121,7 +121,7 @@ module Typ = struct | Ptyp_class (longident, lst) -> Ptyp_class (longident, List.map loop lst) | Ptyp_alias (core_type, string) -> - check_variable var_names t.ptyp_loc string; + check_variable var_names t.ptyp_loc string.txt; Ptyp_alias (loop core_type, string) | Ptyp_variant (row_field_list, flag, lbl_lst_option) -> Ptyp_variant @@ -135,6 +135,7 @@ module Typ = struct Ptyp_package (longident, List.map (fun (n, typ) -> (n, loop typ)) lst) | Ptyp_extension (s, arg) -> Ptyp_extension (s, arg) + | Ptyp_open (l, ct) -> Ptyp_open (l, loop ct) in { t with ptyp_desc = desc } and loop_row_field field = @@ -201,8 +202,20 @@ module Exp = struct let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d)) - let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) + + let function_ ?loc ?attrs ?loc_location cases = + let loc_locations = + match loc_location with Some l -> l | None -> !default_loc + in + mk ?loc ?attrs + (Pexp_function ([], None, Pfunction_cases (cases, loc_locations, []))) + + let fun_ ?loc ?attrs a b c d = + let pparam_desc = Pparam_val (a, b, c) in + let body = Pfunction_body d in + let pparam_loc = match loc with Some loc -> loc | None -> Location.none in + mk ?loc ?attrs (Pexp_function ([ { pparam_loc; pparam_desc } ], None, body)) + let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) @@ -423,8 +436,14 @@ module Incl = struct end module Vb = struct - let mk ?(loc = !default_loc) ?(attrs = []) pat expr = - { pvb_pat = pat; pvb_expr = expr; pvb_attributes = attrs; pvb_loc = loc } + let mk ?(loc = !default_loc) ?(attrs = []) ?value_constraint pat expr = + { + pvb_pat = pat; + pvb_expr = expr; + pvb_attributes = attrs; + pvb_loc = loc; + pvb_constraint = value_constraint; + } end module Ci = struct @@ -440,6 +459,17 @@ module Ci = struct } end +let constructor ?(loc = !default_loc) ?(attrs = []) ?(vars = []) + ?(args = Pcstr_tuple []) ?res name = + { + pcd_name = name; + pcd_vars = vars; + pcd_args = args; + pcd_res = res; + pcd_loc = loc; + pcd_attributes = attrs; + } + module Type = struct let mk ?(loc = !default_loc) ?(attrs = []) ?(params = []) ?(cstrs = []) ?(kind = Ptype_abstract) ?(priv = Public) ?manifest name = diff --git a/ast/ast_helper_lite.mli b/ast/ast_helper_lite.mli index 5b3f68f54..d5d1910ff 100644 --- a/ast/ast_helper_lite.mli +++ b/ast/ast_helper_lite.mli @@ -15,7 +15,7 @@ (** Copy of Ast_helper from OCaml 4.14 with docstring related stuff removed *) -open Astlib.Ast_500 +open Astlib.Ast_502 open Asttypes open Parsetree @@ -72,7 +72,7 @@ module Typ : sig ?loc:loc -> ?attrs:attrs -> object_field list -> closed_flag -> core_type val class_ : ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val alias : ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type + val alias : ?loc:loc -> ?attrs:attrs -> core_type -> str -> core_type val variant : ?loc:loc -> @@ -151,7 +151,8 @@ module Exp : sig expression -> expression - val function_ : ?loc:loc -> ?attrs:attrs -> case list -> expression + val function_ : + ?loc:loc -> ?attrs:attrs -> ?loc_location:loc -> case list -> expression val apply : ?loc:loc -> @@ -466,7 +467,13 @@ end (** Value bindings *) module Vb : sig - val mk : ?loc:loc -> ?attrs:attrs -> pattern -> expression -> value_binding + val mk : + ?loc:loc -> + ?attrs:attrs -> + ?value_constraint:value_constraint -> + pattern -> + expression -> + value_binding end (** {1 Class language} *) diff --git a/ast/import.ml b/ast/import.ml index 57168b7fd..4711919a0 100644 --- a/ast/import.ml +++ b/ast/import.ml @@ -6,7 +6,7 @@ (*$ open Ast_cinaps_helpers $*) -module Js = Versions.OCaml_500 +module Js = Versions.OCaml_502 module Ocaml = Versions.OCaml_current module Select_ast (Ocaml : Versions.OCaml_version) = struct diff --git a/astlib/pprintast.ml b/astlib/pprintast.ml index 51316cca8..ae6a86342 100644 --- a/astlib/pprintast.ml +++ b/astlib/pprintast.ml @@ -21,7 +21,7 @@ (* Extensive Rewrite: Hongbo Zhang: University of Pennsylvania *) (* TODO more fine-grained precedence pretty-printing *) -open Ast_414 +open Ast_502 open Asttypes open Format open Location @@ -56,7 +56,7 @@ let varify_type_constructors var_names t = | Ptyp_object (lst, o) -> Ptyp_object (List.map loop_object_field lst, o) | Ptyp_class (longident, lst) -> Ptyp_class (longident, List.map loop lst) | Ptyp_alias (core_type, string) -> - check_variable var_names t.ptyp_loc string; + check_variable var_names t.ptyp_loc string.txt; Ptyp_alias (loop core_type, string) | Ptyp_variant (row_field_list, flag, lbl_lst_option) -> Ptyp_variant @@ -69,6 +69,7 @@ let varify_type_constructors var_names t = | Ptyp_package (longident, lst) -> Ptyp_package (longident, List.map (fun (n, typ) -> (n, loop typ)) lst) | Ptyp_extension (s, arg) -> Ptyp_extension (s, arg) + | Ptyp_open (s, ct) -> Ptyp_open (s, loop ct) in { t with ptyp_desc = desc } and loop_row_field field = @@ -220,12 +221,15 @@ let is_simple_construct : construct -> bool = function let pp = fprintf -type ctxt = { pipe : bool; semi : bool; ifthenelse : bool } +type ctxt = { pipe : bool; semi : bool; ifthenelse : bool; functionrhs : bool } + +let reset_ctxt = + { pipe = false; semi = false; ifthenelse = false; functionrhs = false } -let reset_ctxt = { pipe = false; semi = false; ifthenelse = false } let under_pipe ctxt = { ctxt with pipe = true } let under_semi ctxt = { ctxt with semi = true } let under_ifthenelse ctxt = { ctxt with ifthenelse = true } +let under_functionrhs ctxt = { ctxt with functionrhs = true } (* let reset_semi ctxt = { ctxt with semi=false } let reset_ifthenelse ctxt = { ctxt with ifthenelse=false } @@ -368,7 +372,7 @@ and core_type ctxt f x = pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) (type_with_label ctxt) (l, ct1) (core_type ctxt) ct2 | Ptyp_alias (ct, s) -> - pp f "@[<2>%a@;as@;%a@]" (core_type1 ctxt) ct tyvar s + pp f "@[<2>%a@;as@;%a@]" (core_type1 ctxt) ct tyvar_loc s | Ptyp_poly ([], ct) -> core_type ctxt f ct | Ptyp_poly (sl, ct) -> pp f "@[<2>%a%a@]" @@ -456,6 +460,8 @@ and core_type1 ctxt f x = pp f "@[%a#%a@]" (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") l longident_loc li + | Ptyp_open (li, ct) -> + pp f "@[%a.(%a)@]" longident_loc li (core_type ctxt) ct | Ptyp_package (lid, cstrs) -> ( let aux f (s, ct) = pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct @@ -688,7 +694,7 @@ and expression ctxt f x = (attributes ctxt) x.pexp_attributes else match x.pexp_desc with - | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _ + | Pexp_function _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _ | Pexp_newtype _ when ctxt.pipe || ctxt.semi -> paren true (expression reset_ctxt) f x @@ -698,12 +704,30 @@ and expression ctxt f x = | Pexp_letop _ when ctxt.semi -> paren true (expression reset_ctxt) f x - | Pexp_fun (l, e0, p, e) -> - pp f "@[<2>fun@;%a->@;%a@]" (label_exp ctxt) (l, e0, p) - (expression ctxt) e | Pexp_newtype (lid, e) -> pp f "@[<2>fun@;(type@;%s)@;->@;%a@]" lid.txt (expression ctxt) e - | Pexp_function l -> pp f "@[function%a@]" (case_list ctxt) l + | Pexp_function (params, c, body) -> ( + match (params, c) with + (* Omit [fun] if there are no params. *) + | [], None -> + (* If function cases are a direct body of a function, + the function node should be wrapped in parens so + it doesn't become part of the enclosing function. *) + let should_paren = + match body with + | Pfunction_cases _ -> ctxt.functionrhs + | Pfunction_body _ -> false + in + let ctxt' = if should_paren then reset_ctxt else ctxt in + pp f "@[<2>%a@]" (paren should_paren (function_body ctxt')) body + | [], Some c -> + pp f "@[<2>(%a@;%a)@]" (function_body ctxt) body + (type_constraint ctxt) c + | _ :: _, _ -> + pp f "@[<2>fun@;%a@]" + (fun f () -> + function_params_then_body ctxt f params c body ~delimiter:"->") + ()) | Pexp_match (e, l) -> pp f "@[@[@[<2>match %a@]@ with@]%a@]" (expression reset_ctxt) e (case_list ctxt) l @@ -832,6 +856,35 @@ and expression ctxt f x = | Pexp_unreachable -> pp f "." | _ -> expression1 ctxt f x +and function_param ctxt f param = + match param.pparam_desc with + | Pparam_val (a, b, c) -> label_exp ctxt f (a, b, c) + | Pparam_newtype ty -> pp f "(type %a)@;" protect_ident ty.txt + +and function_body ctxt f function_body = + match function_body with + | Pfunction_body body -> expression ctxt f body + | Pfunction_cases (cases, _, attrs) -> + pp f "@[function%a%a@]" (item_attributes ctxt) attrs (case_list ctxt) + cases + +and type_constraint ctxt f constraint_ = + match constraint_ with + | Pconstraint ty -> pp f ":@;%a" (core_type ctxt) ty + | Pcoerce (ty1, ty2) -> + pp f "%a:>@;%a" + (option ~first:":@;" (core_type ctxt)) + ty1 (core_type ctxt) ty2 + +and function_params_then_body ctxt f params constraint_ body ~delimiter = + pp f "%a%a%s@;%a" + (list (function_param ctxt) ~sep:"") + params + (option (type_constraint ctxt)) + constraint_ delimiter + (function_body (under_functionrhs ctxt)) + body + and expression1 ctxt f x = if x.pexp_attributes <> [] then expression ctxt f x else @@ -1041,6 +1094,7 @@ and class_field ctxt f x = pvb_expr = e; pvb_attributes = []; pvb_loc = Location.none; + pvb_constraint = None; } in pp f "@[<2>method%s %a%a@]%a" (override ovf) private_flag pf @@ -1281,6 +1335,7 @@ and module_expr ctxt f x = | Pmod_apply (me1, me2) -> pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2 (* Cf: #7200 *) + | Pmod_apply_unit me1 -> pp f "(%a)()" (module_expr ctxt) me1 | Pmod_unpack e -> pp f "(val@ %a)" (expression ctxt) e | Pmod_extension e -> extension ctxt f e @@ -1312,12 +1367,8 @@ and binding ctxt f { pvb_pat = p; pvb_expr = x; _ } = if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x else match x.pexp_desc with - | Pexp_fun (label, eo, p, e) -> - if label = Nolabel then - pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function e - else - pp f "%a@ %a" (label_exp ctxt) (label, eo, p) pp_print_pexp_function - e + | Pexp_function (params, c, body) -> + function_params_then_body ctxt f params c body ~delimiter:"=" | Pexp_newtype (str, e) -> pp f "(type@ %s)@ %a" str.txt pp_print_pexp_function e | _ -> pp f "=@;%a" (expression ctxt) x diff --git a/astlib/pprintast.mli b/astlib/pprintast.mli index 65e221734..126626597 100644 --- a/astlib/pprintast.mli +++ b/astlib/pprintast.mli @@ -13,7 +13,7 @@ (* *) (**************************************************************************) -open Ast_414 +open Ast_502 type space_formatter = (unit, Format.formatter, unit) format diff --git a/bench/vendored/ppx_sexp_conv.v0.15.1/expander/conversion.ml b/bench/vendored/ppx_sexp_conv.v0.15.1/expander/conversion.ml index a02385f64..08c0b3045 100644 --- a/bench/vendored/ppx_sexp_conv.v0.15.1/expander/conversion.ml +++ b/bench/vendored/ppx_sexp_conv.v0.15.1/expander/conversion.ml @@ -49,7 +49,7 @@ module Lambda = struct let maybe_apply_generic ~loc ~binds maybe_arg cases = let expr = match maybe_arg with - | None -> pexp_function ~loc cases + | None -> pexp_function_cases ~loc cases | Some arg -> pexp_match ~loc arg cases in with_let ~loc ~binds expr diff --git a/bench/vendored/ppx_sexp_conv.v0.15.1/expander/expand_of_sexp.ml b/bench/vendored/ppx_sexp_conv.v0.15.1/expander/expand_of_sexp.ml index affcf0caf..2da070934 100644 --- a/bench/vendored/ppx_sexp_conv.v0.15.1/expander/expand_of_sexp.ml +++ b/bench/vendored/ppx_sexp_conv.v0.15.1/expander/expand_of_sexp.ml @@ -186,6 +186,7 @@ module Str_generate_of_sexp = struct | { ptyp_desc = Ptyp_class (_, _); _ } | { ptyp_desc = Ptyp_alias (_, _); _ } | { ptyp_desc = Ptyp_package _; _ } + | { ptyp_desc = Ptyp_open _; _ } | { ptyp_desc = Ptyp_extension _; _ } -> Location.raise_errorf ~loc "Type unsupported for ppx [of_sexp] conversion" @@ -841,7 +842,7 @@ module Str_generate_of_sexp = struct [%expr let rec [%p Fresh_name.pattern fresh_iter] = [%e - pexp_function + pexp_function_cases ~loc [ [%pat? Sexplib0.Sexp.List diff --git a/bench/vendored/ppx_sexp_conv.v0.15.1/expander/expand_sexp_of.ml b/bench/vendored/ppx_sexp_conv.v0.15.1/expander/expand_sexp_of.ml index ff30eb2e6..06a078035 100644 --- a/bench/vendored/ppx_sexp_conv.v0.15.1/expander/expand_sexp_of.ml +++ b/bench/vendored/ppx_sexp_conv.v0.15.1/expander/expand_sexp_of.ml @@ -82,6 +82,7 @@ module Str_generate_sexp_of = struct | { ptyp_desc = Ptyp_class (_, _); _ } | { ptyp_desc = Ptyp_alias (_, _); _ } | { ptyp_desc = Ptyp_package _; _ } + | { ptyp_desc = Ptyp_open _; _ } | { ptyp_desc = Ptyp_extension _; _ } -> Location.raise_errorf ~loc "Type unsupported for ppx [sexp_of] conversion" diff --git a/bench/vendored/ppx_sexp_conv.v0.15.1/expander/helpers.ml b/bench/vendored/ppx_sexp_conv.v0.15.1/expander/helpers.ml index 513786bc7..2817d02c0 100644 --- a/bench/vendored/ppx_sexp_conv.v0.15.1/expander/helpers.ml +++ b/bench/vendored/ppx_sexp_conv.v0.15.1/expander/helpers.ml @@ -139,7 +139,7 @@ let fresh_lambda ~loc apply = let rec is_value_expression expr = match expr.pexp_desc with (* Syntactic values. *) - | Pexp_ident _ | Pexp_constant _ | Pexp_function _ | Pexp_fun _ | Pexp_lazy _ -> true + | Pexp_ident _ | Pexp_constant _ | Pexp_function _ | Pexp_lazy _ -> true (* Type-only wrappers; we check their contents. *) | Pexp_constraint (expr, (_ : core_type)) | Pexp_coerce (expr, (_ : core_type option), (_ : core_type)) diff --git a/bench/vendored/ppx_sexp_conv.v0.15.1/expander/ppx_sexp_conv_grammar.ml b/bench/vendored/ppx_sexp_conv.v0.15.1/expander/ppx_sexp_conv_grammar.ml index e0697a801..4d59913dd 100644 --- a/bench/vendored/ppx_sexp_conv.v0.15.1/expander/ppx_sexp_conv_grammar.ml +++ b/bench/vendored/ppx_sexp_conv.v0.15.1/expander/ppx_sexp_conv_grammar.ml @@ -218,6 +218,7 @@ let rec grammar_of_type core_type ~rec_flag ~tags_of_doc_comments = grammar_of_polymorphic_variant ~loc ~rec_flag ~tags_of_doc_comments rows) | Ptyp_poly _ -> unsupported ~loc "explicitly polymorphic types" | Ptyp_package _ -> unsupported ~loc "first-class module types" + | Ptyp_open _ -> unsupported ~loc "locally opened modules" | Ptyp_extension _ -> unsupported ~loc "unexpanded ppx extensions") in grammar_of_type_tags core_type grammar ~tags_of_doc_comments diff --git a/examples/simple-deriver/ppx_deriving_accessors.ml b/examples/simple-deriver/ppx_deriving_accessors.ml index a951b9e97..0bc4e47dc 100644 --- a/examples/simple-deriver/ppx_deriving_accessors.ml +++ b/examples/simple-deriver/ppx_deriving_accessors.ml @@ -16,6 +16,7 @@ let accessor_impl (ld : label_declaration) = { loc; txt = lident ld.pld_name.txt }); pvb_attributes = []; pvb_loc = loc; + pvb_constraint = None; }; ] diff --git a/metaquot/ppxlib_metaquot.ml b/metaquot/ppxlib_metaquot.ml index 1de3eeff4..d4d3ae9e5 100644 --- a/metaquot/ppxlib_metaquot.ml +++ b/metaquot/ppxlib_metaquot.ml @@ -11,6 +11,19 @@ type quoted_attributes = { attributes are placed on, e.g. pexp_attributes. *) } +let coalesce_arity (input : expression) result = + match input with + | { pexp_desc = Pexp_function _; pexp_loc = loc; _ } -> + let ppxlib_coalesce_arity = + Ldot + ( Ldot (Ldot (Lident "Ppxlib", "Ast_builder"), "Default"), + "coalesce_arity" ) + in + pexp_apply ~loc + (pexp_ident ~loc { txt = ppxlib_coalesce_arity; loc }) + [ (Nolabel, result) ] + | _ -> result + module Make (M : sig type result @@ -33,6 +46,7 @@ module Make (M : sig val location : location -> result val location_stack : (location -> result) option val attributes : (location -> result) option + val coalesce : (expression -> result -> result) option class std_lifters : location -> [result] Ppxlib_traverse_builtins.std_lifters end) = @@ -68,8 +82,8 @@ struct | Some f -> f loc method! expression e = - match e.pexp_desc with - | Pexp_extension (({ txt = "e"; _ }, _) as ext) -> + match (M.coalesce, e.pexp_desc) with + | _, Pexp_extension (({ txt = "e"; _ }, _) as ext) -> let attributes = { quoted_attributes = e.pexp_attributes; @@ -77,7 +91,8 @@ struct } in M.cast self ext (Some attributes) ~type_name:"expression" - | _ -> super#expression e + | Some f, _ -> f e (super#expression e) + | None, _ -> super#expression e method! pattern p = match p.ppat_desc with @@ -149,6 +164,7 @@ module Expr = Make (struct let location loc = evar ~loc:{ loc with loc_ghost = true } "loc" let location_stack = None let attributes = None + let coalesce = Some coalesce_arity class std_lifters = Ppxlib_metaquot_lifters.expression_lifters @@ -228,6 +244,7 @@ module Patt = Make (struct Some (fun loc -> ppat_any ~loc:{ loc with loc_ghost = true }) let attributes = Some (fun loc -> ppat_any ~loc:{ loc with loc_ghost = true }) + let coalesce = None class std_lifters = Ppxlib_metaquot_lifters.pattern_lifters diff --git a/src/ast_builder.ml b/src/ast_builder.ml index fbe8a1f23..8e124ec30 100644 --- a/src/ast_builder.ml +++ b/src/ast_builder.ml @@ -15,6 +15,10 @@ module Default = struct module Latest = struct let ppat_construct = ppat_construct + let pexp_function = pexp_function + + let value_binding ?constraint_ ~loc ~pat ~expr () = + value_binding ~constraint_ ~loc ~pat ~expr let constructor_declaration ~loc ~name ~vars ~args ~res () = constructor_declaration ~loc ~name ~vars ~args ~res @@ -29,6 +33,36 @@ module Default = struct ppat_desc = Ppat_construct (lid, Option.map p ~f:(fun p -> ([], p))); } + let pexp_function_cases ~loc cases = + { + pexp_loc_stack = []; + pexp_attributes = []; + pexp_loc = loc; + pexp_desc = Pexp_function ([], None, Pfunction_cases (cases, loc, [])); + } + + (* let pexp_function ~loc cases = pexp_function_cases ~loc cases *) + + let add_fun_params return_constraint ~loc params body = + match params with + | [] -> body + | _ -> ( + match body.pexp_desc with + | Pexp_function (more_params, constraint_, func_body) -> + pexp_function ~loc (params @ more_params) constraint_ func_body + | _ -> + assert (match params with [] -> false | _ -> true); + pexp_function ~loc params return_constraint (Pfunction_body body)) + + let pexp_fun ~loc (label : arg_label) expr p e = + let param : function_param = + { pparam_desc = Pparam_val (label, expr, p); pparam_loc = loc } + in + add_fun_params ~loc None [ param ] e + + let value_binding ~loc ~pat ~expr = + value_binding ~loc ~pat ~expr ~constraint_:None + let constructor_declaration ~loc ~name ~args ~res = { pcd_name = name; @@ -41,6 +75,22 @@ module Default = struct (*-------------------------------------------------------*) + let coalesce_arity e = + match e.pexp_desc with + (* We stop coalescing parameters if there is a constraint on the result of a function + (i.e [fun x y : T -> ...] or the body is a function_case. *) + | Pexp_function (_, Some _, _) | Pexp_function (_, _, Pfunction_cases _) -> + e + | Pexp_function + (params1, None, Pfunction_body ({ pexp_attributes = []; _ } as body1)) + -> ( + match body1.pexp_desc with + | Pexp_function (params2, constraint_, body2) -> + Latest.pexp_function ~loc:e.pexp_loc (params1 @ params2) constraint_ + body2 + | _ -> e) + | _ -> e + let pstr_value_list ~loc rec_flag = function | [] -> [] | vbs -> [ pstr_value ~loc rec_flag vbs ] @@ -196,7 +246,11 @@ module Default = struct match expr with | { pexp_desc = - Pexp_fun (label, None (* no default expression *), subpat, body); + Pexp_function + ( [ { pparam_loc = _; pparam_desc = Pparam_val (label, _, subpat) } ], + _constraint, + Pfunction_body body ); + (* Pexp_fun (label, None (* no default expression *), subpat, body); *) pexp_attributes = []; pexp_loc = _; pexp_loc_stack = _; @@ -373,6 +427,8 @@ end) : S = struct let ppat_tuple_opt l = Default.ppat_tuple_opt ~loc l let ptyp_poly vars ty = Default.ptyp_poly ~loc vars ty let pexp_apply e el = Default.pexp_apply ~loc e el + let pexp_fun lbl e1 p e2 = Default.pexp_fun ~loc lbl e1 p e2 + let pexp_function_cases cases = Default.pexp_function_cases ~loc cases let eint t = Default.eint ~loc t let echar t = Default.echar ~loc t let estring t = Default.estring ~loc t @@ -402,6 +458,7 @@ end) : S = struct let plist_tail l tail = Default.plist_tail ~loc l tail let elist l = Default.elist ~loc l let plist l = Default.plist ~loc l + let value_binding = Default.value_binding ~loc let type_constr_conv ident ~f args = Default.type_constr_conv ~loc ident ~f args diff --git a/src/ast_builder.mli b/src/ast_builder.mli index 4df5368d6..78d80f8d3 100644 --- a/src/ast_builder.mli +++ b/src/ast_builder.mli @@ -35,6 +35,14 @@ module Default : sig (label loc list * pattern) option -> pattern + val value_binding : + ?constraint_:value_constraint -> + loc:location -> + pat:pattern -> + expr:expression -> + unit -> + value_binding + val constructor_declaration : loc:location -> name:label loc -> @@ -48,6 +56,14 @@ module Default : sig val ppat_construct : loc:location -> longident loc -> pattern option -> pattern + val coalesce_arity : expression -> expression + (** [coalesce_arity e] will produce a maximum arity function from an + expression. + + For example, [fun x -> fun y -> x + y] becomes [fun x y -> x + y]. Since + OCaml 5.2, these two functions have a different {! Parsetree} + representation. *) + val constructor_declaration : loc:location -> name:label loc -> diff --git a/src/ast_builder_intf.ml b/src/ast_builder_intf.ml index ef3bfaed4..adbbab355 100644 --- a/src/ast_builder_intf.ml +++ b/src/ast_builder_intf.ml @@ -40,6 +40,22 @@ module type Additional_helpers = sig val esequence : (expression list -> expression) with_loc val ppat_tuple_opt : (pattern list -> pattern option) with_loc val pexp_tuple_opt : (expression list -> expression option) with_loc + + val pexp_fun : + (arg_label -> expression option -> pattern -> expression -> expression) + with_loc + + val pexp_function : + (function_param list -> + type_constraint option -> + function_body -> + expression) + with_loc + + val pexp_function_cases : (Import.cases -> expression) with_loc + (** [pexp_function_cases] builds an expression in the shape + [function C1 -> E1 | ...]. *) + val pconstruct : constructor_declaration -> pattern option -> pattern val econstruct : constructor_declaration -> expression option -> expression @@ -59,6 +75,10 @@ module type Additional_helpers = sig (** [plist ~loc [pat1; pat2; pat3]] produces the list pattern [[pat1; pat2; pat3]]. *) + val value_binding : + (pat:Import.pattern -> expr:Import.expression -> Import.value_binding) + with_loc + val pstr_value_list : loc:Location.t -> Asttypes.rec_flag -> diff --git a/src/ast_pattern.ml b/src/ast_pattern.ml index 84cf29e91..8efafda67 100644 --- a/src/ast_pattern.ml +++ b/src/ast_pattern.ml @@ -205,6 +205,7 @@ let pack3 t = map t ~f:(fun f x y z -> f (x, y, z)) include Ast_pattern_generated +let value_binding ~pat ~expr = value_binding ~pat ~expr let echar t = pexp_constant (pconst_char t) let estring t = pexp_constant (pconst_string t drop drop) let efloat t = pexp_constant (pconst_float t drop) diff --git a/src/ast_traverse.ml b/src/ast_traverse.ml index e44fbb0c2..15302c6ef 100644 --- a/src/ast_traverse.ml +++ b/src/ast_traverse.ml @@ -241,7 +241,7 @@ class map_with_expansion_context_and_errors = with_value_description >>= fun ctxt -> super#value_description ctxt vd method! value_binding ctxt - ({ pvb_pat; pvb_expr; pvb_attributes; pvb_loc } as vb) = + ({ pvb_pat; pvb_expr; pvb_attributes; pvb_loc; pvb_constraint } as vb) = Attribute.get_res do_not_enter_value_binding vb |> of_result ~default:None >>= function | Some () -> super#value_binding ctxt vb @@ -260,6 +260,13 @@ class map_with_expansion_context_and_errors = self#attributes in_binding_ctxt pvb_attributes in let pvb_loc, loc_errors = self#location ctxt pvb_loc in + let pvb_constraint, constraint_errors = + match pvb_constraint with + | Some c -> + let v, err = self#value_constraint ctxt c in + (Some v, err) + | None -> (None, []) + in let errors = self#record ctxt [ @@ -267,9 +274,11 @@ class map_with_expansion_context_and_errors = ("pvb_expr", expr_errors); ("pvb_attributes", attributes_errors); ("pvb_loc", loc_errors); + ("pvb_constraint", constraint_errors); ] in - ({ pvb_pat; pvb_expr; pvb_attributes; pvb_loc }, errors) + ( { pvb_pat; pvb_expr; pvb_attributes; pvb_loc; pvb_constraint }, + errors ) end class sexp_of = diff --git a/src/common.mli b/src/common.mli index 72e1a507e..d760caf1a 100644 --- a/src/common.mli +++ b/src/common.mli @@ -36,7 +36,20 @@ val get_type_param_name : core_type * (variance * injectivity) -> string Loc.t (** [(new type_is_recursive rec_flag tds)#go ()] returns whether [rec_flag, tds] is really a recursive type. We disregard recursive occurrences appearing in arrow types. You can override the search for certain type expressions by - inheriting from this class. *) + inheriting from this class. + + Note that this is an {b approximation} due to global and/or local openings + of modules. + + {[ + module M = struct + type t = Foo + end + + type t = M.(t) + ]} + + The outer [t] will return [Recursive] even though it is not. *) class type_is_recursive : rec_flag -> type_declaration list -> object inherit Ast_traverse0.iter val type_names : string list @@ -45,7 +58,8 @@ class type_is_recursive : rec_flag -> type_declaration list -> object end val really_recursive : rec_flag -> type_declaration list -> rec_flag -(** [really_recursive rec_flag tds = (new type_is_recursive rec_flag tds)#go ()] *) +(** [really_recursive rec_flag tds = (new type_is_recursive rec_flag tds)#go ()]. + See the documentation for {! type_is_recursive}.*) val loc_of_payload : attribute -> Location.t val loc_of_attribute : attribute -> Location.t diff --git a/src/driver.ml b/src/driver.ml index 9571373fa..7f0a42cf7 100644 --- a/src/driver.ml +++ b/src/driver.ml @@ -913,6 +913,7 @@ let load_source_file fn = type output_mode = | Pretty_print + | Pp_ast | Dump_ast | Dparsetree | Reconcile of Reconcile.mode @@ -1149,13 +1150,21 @@ let process_file (kind : Kind.t) fn ~input_name ~relocate ~output_mode Ast_io.write oc { input_name; input_version; ast } ~add_ppx_context:true) + | Pp_ast -> + with_output output ~binary:false ~f:(fun oc -> + let ppf = Stdlib.Format.formatter_of_out_channel oc in + let ast = add_cookies ast in + (match ast with + | Intf ast -> Pp_ast.signature ppf ast + | Impl ast -> Pp_ast.structure ppf ast); + Stdlib.Format.pp_print_newline ppf ()) | Dparsetree -> with_output output ~binary:false ~f:(fun oc -> let ppf = Stdlib.Format.formatter_of_out_channel oc in let ast = add_cookies ast in (match ast with - | Intf ast -> Sexp.pp_hum ppf (Ast_traverse.sexp_of#signature ast) - | Impl ast -> Sexp.pp_hum ppf (Ast_traverse.sexp_of#structure ast)); + | Intf ast -> Pp_ast.signature ppf ast + | Impl ast -> Pp_ast.structure ppf ast); Stdlib.Format.pp_print_newline ppf ()) | Reconcile mode -> Reconcile.reconcile !replacements @@ -1191,11 +1200,12 @@ let set_output_mode mode = match (!output_mode, mode) with | Pretty_print, _ -> output_mode := mode | _, Pretty_print -> assert false - | Dump_ast, Dump_ast | Dparsetree, Dparsetree -> () + | Dump_ast, Dump_ast | Pp_ast, Pp_ast | Dparsetree, Dparsetree -> () | Reconcile a, Reconcile b when Poly.equal a b -> () | x, y -> let arg_of_output_mode = function | Pretty_print -> assert false + | Pp_ast -> "-pp-ast" | Dump_ast -> "-dump-ast" | Dparsetree -> "-dparsetree" | Reconcile Using_line_directives -> "-reconcile" @@ -1343,6 +1353,14 @@ let standalone_args = Arg.Unit (fun () -> set_output_mode Dump_ast), " Dump the marshaled ast to the output file instead of pretty-printing it" ); + ( "-pp-ast", + Arg.Unit (fun () -> set_output_mode Pp_ast), + " Pretty-print a simple version of the AST using the internal Pp_ast \ + module. This is useful for comparing ASTs. For more configuration see \ + the ppxlib-tools package." ); + ( "--pp-ast", + Arg.Unit (fun () -> set_output_mode Pp_ast), + " Same as -pp-simple" ); ( "--dump-ast", Arg.Unit (fun () -> set_output_mode Dump_ast), " Same as -dump-ast" ); diff --git a/src/gen/gen_ast_pattern.ml b/src/gen/gen_ast_pattern.ml index 2a013e119..5f078b1cd 100644 --- a/src/gen/gen_ast_pattern.ml +++ b/src/gen/gen_ast_pattern.ml @@ -21,60 +21,81 @@ let assert_no_attributes ~path ~prefix = (fqn_longident' path (prefix ^ "attributes")) let gen_combinator_for_constructor ?wrapper path ~prefix cd = - match cd.pcd_args with - | Pcstr_record _ -> failwith "Pcstr_record not supported" - | Pcstr_tuple cd_args -> - let args = List.mapi cd_args ~f:(fun i _ -> sprintf "x%d" i) in - let funcs = List.mapi cd_args ~f:(fun i _ -> sprintf "f%d" i) in - let pat = - Pat.construct - (Loc.mk (fqn_longident path cd.pcd_name.txt)) - (match args with - | [] -> None - | [ x ] -> Some (pvar x) - | _ -> Some (Pat.tuple (List.map args ~f:pvar))) - in - let exp, _ = apply_parsers funcs (List.map args ~f:evar) cd_args in - let expected = without_prefix ~prefix cd.pcd_name.txt in - let body = - M.expr - {|match x with + let exp, pat, _args, funcs = + match cd.pcd_args with + | Pcstr_record r -> + let args = List.map ~f:(fun p -> sprintf "%s" p.pld_name.txt) r in + let funcs = List.map ~f:(fun p -> sprintf "f%s" p.pld_name.txt) r in + let typs = List.map ~f:(fun p -> p.pld_type) r in + let pat = + Pat.construct + (Loc.mk (fqn_longident path cd.pcd_name.txt)) + (match args with + | [] -> None + | [ x ] -> Some (pvar x) + | _ -> + Some + (Pat.record + (List.map r ~f:(fun v -> + ( { loc = v.pld_loc; txt = Lident v.pld_name.txt }, + pvar v.pld_name.txt ))) + Closed)) + in + let exp, _ = apply_parsers funcs (List.map args ~f:evar) typs in + (exp, pat, args, funcs) + | Pcstr_tuple cd_args -> + let args = List.mapi cd_args ~f:(fun i _ -> sprintf "x%d" i) in + let funcs = List.mapi cd_args ~f:(fun i _ -> sprintf "f%d" i) in + let pat = + Pat.construct + (Loc.mk (fqn_longident path cd.pcd_name.txt)) + (match args with + | [] -> None + | [ x ] -> Some (pvar x) + | _ -> Some (Pat.tuple (List.map args ~f:pvar))) + in + let exp, _ = apply_parsers funcs (List.map args ~f:evar) cd_args in + (exp, pat, args, funcs) + in + let expected = without_prefix ~prefix cd.pcd_name.txt in + let body = + M.expr + {|match x with | %a -> ctx.matched <- ctx.matched + 1; %a | _ -> fail loc %S|} - A.patt pat A.expr exp expected - in - let body = - match wrapper with - | None -> body - | Some (path, prefix, has_attrs) -> - let body = - M.expr - {|let loc = x.%a in + A.patt pat A.expr exp expected + in + let body = + match wrapper with + | None -> body + | Some (path, prefix, has_attrs) -> + let body = + M.expr + {|let loc = x.%a in let x = x.%a in %a|} - A.id - (fqn_longident' path (prefix ^ "loc")) - A.id - (fqn_longident' path (prefix ^ "desc")) - A.expr body - in - if has_attrs then - Exp.sequence (assert_no_attributes ~path ~prefix) body - else body - in - let body = - let loc = - match wrapper with None -> M.patt "loc" | Some _ -> M.patt "_loc" + A.id + (fqn_longident' path (prefix ^ "loc")) + A.id + (fqn_longident' path (prefix ^ "desc")) + A.expr body in - M.expr "T (fun ctx %a x k -> %a)" A.patt loc A.expr body - in - let body = - List.fold_right funcs ~init:body ~f:(fun func acc -> - M.expr "fun (T %a) -> %a" A.patt (pvar func) A.expr acc) - in - M.stri "let %a = %a" A.patt - (pvar (function_name_of_id ~prefix cd.pcd_name.txt)) - A.expr body + if has_attrs then Exp.sequence (assert_no_attributes ~path ~prefix) body + else body + in + let body = + let loc = + match wrapper with None -> M.patt "loc" | Some _ -> M.patt "_loc" + in + M.expr "T (fun ctx %a x k -> %a)" A.patt loc A.expr body + in + let body = + List.fold_right funcs ~init:body ~f:(fun func acc -> + M.expr "fun (T %a) -> %a" A.patt (pvar func) A.expr acc) + in + M.stri "let %a = %a" A.patt + (pvar (function_name_of_id ~prefix cd.pcd_name.txt)) + A.expr body let gen_combinator_for_record path ~prefix ~has_attrs lds = let fields = List.map lds ~f:(fun ld -> fqn_longident path ld.pld_name.txt) in @@ -242,7 +263,4 @@ let usage = Printf.sprintf "%s [options] <.ml files>\n" Sys.argv.(0) let () = let fns = ref [] in Arg.parse (Arg.align args) (fun fn -> fns := fn :: !fns) usage; - try List.iter (List.rev !fns) ~f:generate - with exn -> - Astlib.Location.report_exception Format.err_formatter exn; - exit 2 + List.iter (List.rev !fns) ~f:generate diff --git a/src/gen/import.ml b/src/gen/import.ml index 544d95826..479cfb3ab 100644 --- a/src/gen/import.ml +++ b/src/gen/import.ml @@ -38,7 +38,7 @@ let common_prefix l = let map_keyword = function | ( "open" | "private" | "downto" | "to" | "mutable" | "rec" | "nonrec" - | "virtual" | "type" | "mod" | "begin" | "end" ) as s -> + | "virtual" | "type" | "mod" | "begin" | "end" | "constraint" ) as s -> s ^ "_" | s -> s diff --git a/src/pp_ast.ml b/src/pp_ast.ml index d755854b4..693d89f1e 100644 --- a/src/pp_ast.ml +++ b/src/pp_ast.ml @@ -208,6 +208,50 @@ class lift_simple_val = method! structure_item stri = self#structure_item_desc stri.pstr_desc method! signature_item sigi = self#signature_item_desc sigi.psig_desc + method! structure str = + match config.show_attrs with + | true -> super#structure str + | false -> + List.filter + ~f:(function + | { pstr_desc = Pstr_attribute _; _ } -> false | _ -> true) + str + |> super#structure + + method! signature sig_ = + match config.show_attrs with + | true -> super#signature sig_ + | false -> + List.filter + ~f:(function + | { psig_desc = Psig_attribute _; _ } -> false | _ -> true) + sig_ + |> super#signature + + method! class_structure cstr = + match config.show_attrs with + | true -> super#class_structure cstr + | false -> + let pcstr_fields = + List.filter + ~f:(function + | { pcf_desc = Pcf_attribute _; _ } -> false | _ -> true) + cstr.pcstr_fields + in + super#class_structure { cstr with pcstr_fields } + + method! class_signature csig = + match config.show_attrs with + | true -> super#class_signature csig + | false -> + let pcsig_fields = + List.filter + ~f:(function + | { pctf_desc = Pctf_attribute _; _ } -> false | _ -> true) + csig.pcsig_fields + in + super#class_signature { csig with pcsig_fields } + method! directive_argument dira = self#directive_argument_desc dira.pdira_desc diff --git a/src/quoter.ml b/src/quoter.ml index 6ff79e674..00da8d680 100644 --- a/src/quoter.ml +++ b/src/quoter.ml @@ -24,12 +24,19 @@ let quote t (e : expression) = See https://github.com/ocaml-ppx/ppx_deriving/pull/252. *) | { pexp_desc = Pexp_ident _; _ } -> (e, Ast.evar name) | _ -> - let binding_expr = - Ast.pexp_fun Nolabel None - (let unit = Ast_builder.Default.Located.lident ~loc "()" in - Ast.ppat_construct unit None) - e + let p = + let unit = Ast_builder.Default.Located.lident ~loc "()" in + Ast.ppat_construct unit None in + let params = + [ + { + pparam_desc = Pparam_val (Nolabel, None, p); + pparam_loc = Location.none; + }; + ] + in + let binding_expr = Ast.pexp_function params None (Pfunction_body e) in let quoted_expr = Ast.eapply (Ast.evar name) [ Ast.eunit ] in (binding_expr, quoted_expr) in diff --git a/test/501_migrations/normal_migrations.t b/test/501_migrations/normal_migrations.t index 8e0de5f89..00975330b 100644 --- a/test/501_migrations/normal_migrations.t +++ b/test/501_migrations/normal_migrations.t @@ -61,49 +61,11 @@ Tests for the Parsetree change for type constraints in value bindings [1] -Here might be a problem in the upward migration: the 5.1.0 parser parses the constraint as a pattern constraint. -However, the upward migration makes a value binding constraint out of it. +There used to be a problem in the upward migration to 5.1.0: the 5.1.0 parser parses the constraint as a pattern constraint. +However, the upward migration makes a value binding constraint out of it. Since the internal AST was bumped to 5.2.0, this is no longer an issue. $ echo "let ((x,y) : (int*int)) = (assert false: int * int)" > file.ml $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations" - @@ -6,20 +6,18 @@ - - pattern (file.ml[1,0+4]..[1,0+23]) - - Ppat_constraint - - pattern (file.ml[1,0+5]..[1,0+10]) - - Ppat_tuple - - [ - - pattern (file.ml[1,0+6]..[1,0+7]) - - Ppat_var "x" (file.ml[1,0+6]..[1,0+7]) - - pattern (file.ml[1,0+8]..[1,0+9]) - - Ppat_var "y" (file.ml[1,0+8]..[1,0+9]) - - ] - - core_type (file.ml[1,0+14]..[1,0+21]) - - Ptyp_tuple - - [ - - core_type (file.ml[1,0+14]..[1,0+17]) - - Ptyp_constr "int" (file.ml[1,0+14]..[1,0+17]) - - [] - - core_type (file.ml[1,0+18]..[1,0+21]) - - Ptyp_constr "int" (file.ml[1,0+18]..[1,0+21]) - - [] - - ] - + pattern (file.ml[1,0+5]..[1,0+10]) - + Ppat_tuple - + [ - + pattern (file.ml[1,0+6]..[1,0+7]) - + Ppat_var "x" (file.ml[1,0+6]..[1,0+7]) - + pattern (file.ml[1,0+8]..[1,0+9]) - + Ppat_var "y" (file.ml[1,0+8]..[1,0+9]) - + ] - + core_type (file.ml[1,0+14]..[1,0+21]) - + Ptyp_tuple - + [ - + core_type (file.ml[1,0+14]..[1,0+17]) - + Ptyp_constr "int" (file.ml[1,0+14]..[1,0+17]) - + [] - + core_type (file.ml[1,0+18]..[1,0+21]) - + Ptyp_constr "int" (file.ml[1,0+18]..[1,0+21]) - + [] - + ] + [1] $ echo "let f: type a. a option -> _ = assert false" > file.ml $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations" diff --git a/test/501_migrations/one_migration.t b/test/501_migrations/one_migration.t index 48e844466..c1ff88571 100644 --- a/test/501_migrations/one_migration.t +++ b/test/501_migrations/one_migration.t @@ -3,1128 +3,43 @@ as the ppxlib AST is either 5.0.0 or 5.1.0. While the ppxlib AST is on 5.0.0, th test checks whether parsing on 5.0.0 (result of test running on 5.0.0) is the same as parsing on 5.1.0 and then migrating down to 5.0.0 (result of test running on 5.1.0). -The test is mostly useful for debuggung problems in a full round-trip. Since Ppxlib's -`dparsetree` option doesn't compactify or strip locations, its output is very long. -So let's only keep one example. +The test is mostly useful for debuggung problems in a full round-trip. $ echo "let x : int = 5" > file.ml $ ./identity_driver.exe -dparsetree file.ml - (((pstr_desc - (Pstr_attribute - ((attr_name - ((txt ocaml.ppx.context) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) - (loc_ghost true))))) - (attr_payload - (PStr - (((pstr_desc - (Pstr_eval - ((pexp_desc - (Pexp_record - ((((txt (Lident tool_name)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ((pexp_desc - (Pexp_constant - (Pconst_string ppxlib_driver - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)) - ()))) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ()))) - (((txt (Lident include_dirs)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ((pexp_desc - (Pexp_construct - ((txt (Lident [])) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ())) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ()))) - (((txt (Lident load_path)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ((pexp_desc - (Pexp_construct - ((txt (Lident [])) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ())) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ()))) - (((txt (Lident open_modules)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ((pexp_desc - (Pexp_construct - ((txt (Lident [])) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ())) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ()))) - (((txt (Lident for_package)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ((pexp_desc - (Pexp_construct - ((txt (Lident None)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ())) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ()))) - (((txt (Lident debug)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ((pexp_desc - (Pexp_construct - ((txt (Lident false)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ())) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ()))) - (((txt (Lident use_threads)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ((pexp_desc - (Pexp_construct - ((txt (Lident false)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ())) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ()))) - (((txt (Lident use_vmthreads)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ((pexp_desc - (Pexp_construct - ((txt (Lident false)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ())) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ()))) - (((txt (Lident recursive_types)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ((pexp_desc - (Pexp_construct - ((txt (Lident false)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ())) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ()))) - (((txt (Lident principal)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ((pexp_desc - (Pexp_construct - ((txt (Lident false)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ())) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ()))) - (((txt (Lident transparent_modules)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ((pexp_desc - (Pexp_construct - ((txt (Lident false)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ())) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ()))) - (((txt (Lident unboxed_types)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ((pexp_desc - (Pexp_construct - ((txt (Lident false)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ())) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ()))) - (((txt (Lident unsafe_string)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ((pexp_desc - (Pexp_construct - ((txt (Lident false)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ())) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ()))) - (((txt (Lident cookies)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ((pexp_desc - (Pexp_construct - ((txt (Lident [])) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ())) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ())))) - ())) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ())) - ())) - (pstr_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) - (loc_ghost true))))))) - (attr_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) - (loc_end ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) - (loc_ghost true)))))) - (pstr_loc - ((loc_start ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) - (loc_end ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) - (loc_ghost true)))) - ((pstr_desc - (Pstr_value Nonrecursive - (((pvb_pat - ((ppat_desc - (Ppat_constraint - ((ppat_desc - (Ppat_var - ((txt x) - (loc - ((loc_start - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 4))) - (loc_end - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 5))) - (loc_ghost false)))))) - (ppat_loc - ((loc_start - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 4))) - (loc_end - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 5))) - (loc_ghost false))) - (ppat_loc_stack ()) (ppat_attributes ())) - ((ptyp_desc - (Ptyp_poly () - ((ptyp_desc - (Ptyp_constr - ((txt (Lident int)) - (loc - ((loc_start - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) - (pos_cnum 8))) - (loc_end - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) - (pos_cnum 11))) - (loc_ghost false)))) - ())) - (ptyp_loc - ((loc_start - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 8))) - (loc_end - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 11))) - (loc_ghost false))) - (ptyp_loc_stack ()) (ptyp_attributes ())))) - (ptyp_loc - ((loc_start - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 8))) - (loc_end - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 11))) - (loc_ghost true))) - (ptyp_loc_stack ()) (ptyp_attributes ())))) - (ppat_loc - ((loc_start - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 4))) - (loc_end - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 11))) - (loc_ghost true))) - (ppat_loc_stack ()) (ppat_attributes ()))) - (pvb_expr - ((pexp_desc - (Pexp_constraint - ((pexp_desc (Pexp_constant (Pconst_integer 5 ()))) - (pexp_loc - ((loc_start - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 14))) - (loc_end - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 15))) - (loc_ghost false))) - (pexp_loc_stack ()) (pexp_attributes ())) - ((ptyp_desc - (Ptyp_constr - ((txt (Lident int)) - (loc - ((loc_start - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 8))) - (loc_end - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 11))) - (loc_ghost false)))) - ())) - (ptyp_loc - ((loc_start - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 8))) - (loc_end - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 11))) - (loc_ghost false))) - (ptyp_loc_stack ()) (ptyp_attributes ())))) - (pexp_loc - ((loc_start - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 4))) - (loc_end - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 15))) - (loc_ghost false))) - (pexp_loc_stack ()) (pexp_attributes ()))) - (pvb_attributes ()) - (pvb_loc - ((loc_start - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) - (loc_end - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 15))) - (loc_ghost false))))))) - (pstr_loc - ((loc_start ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) - (loc_end ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 15))) - (loc_ghost false))))) + [ Pstr_value + ( Nonrecursive + , [ { pvb_pat = Ppat_var "x" + ; pvb_expr = Pexp_constant (Pconst_integer ( "5", None)) + ; pvb_constraint = + Some + (Pvc_constraint + { locally_abstract_univars = [] + ; typ = Ptyp_constr ( Lident "int", []) + }) + ; pvb_attributes = __attrs + ; pvb_loc = __loc + } + ] + ) + ] $ cat > file.ml << EOF > module F () = struct end > module M = F () > EOF + $ ./identity_driver.exe -dparsetree file.ml - (((pstr_desc - (Pstr_attribute - ((attr_name - ((txt ocaml.ppx.context) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) - (loc_ghost true))))) - (attr_payload - (PStr - (((pstr_desc - (Pstr_eval - ((pexp_desc - (Pexp_record - ((((txt (Lident tool_name)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ((pexp_desc - (Pexp_constant - (Pconst_string ppxlib_driver - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)) - ()))) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ()))) - (((txt (Lident include_dirs)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ((pexp_desc - (Pexp_construct - ((txt (Lident [])) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ())) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ()))) - (((txt (Lident load_path)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ((pexp_desc - (Pexp_construct - ((txt (Lident [])) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ())) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ()))) - (((txt (Lident open_modules)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ((pexp_desc - (Pexp_construct - ((txt (Lident [])) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ())) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ()))) - (((txt (Lident for_package)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ((pexp_desc - (Pexp_construct - ((txt (Lident None)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ())) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ()))) - (((txt (Lident debug)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ((pexp_desc - (Pexp_construct - ((txt (Lident false)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ())) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ()))) - (((txt (Lident use_threads)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ((pexp_desc - (Pexp_construct - ((txt (Lident false)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ())) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ()))) - (((txt (Lident use_vmthreads)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ((pexp_desc - (Pexp_construct - ((txt (Lident false)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ())) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ()))) - (((txt (Lident recursive_types)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ((pexp_desc - (Pexp_construct - ((txt (Lident false)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ())) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ()))) - (((txt (Lident principal)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ((pexp_desc - (Pexp_construct - ((txt (Lident false)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ())) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ()))) - (((txt (Lident transparent_modules)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ((pexp_desc - (Pexp_construct - ((txt (Lident false)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ())) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ()))) - (((txt (Lident unboxed_types)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ((pexp_desc - (Pexp_construct - ((txt (Lident false)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ())) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ()))) - (((txt (Lident unsafe_string)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ((pexp_desc - (Pexp_construct - ((txt (Lident false)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ())) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ()))) - (((txt (Lident cookies)) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ((pexp_desc - (Pexp_construct - ((txt (Lident [])) - (loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true)))) - ())) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) - (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ())))) - ())) - (pexp_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) - (loc_ghost true))) - (pexp_loc_stack ()) (pexp_attributes ())) - ())) - (pstr_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) - (loc_end - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) - (loc_ghost true))))))) - (attr_loc - ((loc_start - ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) - (loc_end ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) - (loc_ghost true)))))) - (pstr_loc - ((loc_start ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) - (loc_end ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) - (loc_ghost true)))) - ((pstr_desc - (Pstr_module - ((pmb_name - ((txt (F)) - (loc - ((loc_start - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 7))) - (loc_end - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 8))) - (loc_ghost false))))) - (pmb_expr - ((pmod_desc - (Pmod_functor Unit - ((pmod_desc (Pmod_structure ())) - (pmod_loc - ((loc_start - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 14))) - (loc_end - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 24))) - (loc_ghost false))) - (pmod_attributes ())))) - (pmod_loc - ((loc_start - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 9))) - (loc_end - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 24))) - (loc_ghost false))) - (pmod_attributes ()))) - (pmb_attributes ()) - (pmb_loc - ((loc_start - ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) - (loc_end ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 24))) - (loc_ghost false)))))) - (pstr_loc - ((loc_start ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) - (loc_end ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 24))) - (loc_ghost false)))) - ((pstr_desc - (Pstr_module - ((pmb_name - ((txt (M)) - (loc - ((loc_start - ((pos_fname file.ml) (pos_lnum 2) (pos_bol 25) (pos_cnum 32))) - (loc_end - ((pos_fname file.ml) (pos_lnum 2) (pos_bol 25) (pos_cnum 33))) - (loc_ghost false))))) - (pmb_expr - ((pmod_desc - (Pmod_apply - ((pmod_desc - (Pmod_ident - ((txt (Lident F)) - (loc - ((loc_start - ((pos_fname file.ml) (pos_lnum 2) (pos_bol 25) (pos_cnum 36))) - (loc_end - ((pos_fname file.ml) (pos_lnum 2) (pos_bol 25) (pos_cnum 37))) - (loc_ghost false)))))) - (pmod_loc - ((loc_start - ((pos_fname file.ml) (pos_lnum 2) (pos_bol 25) (pos_cnum 36))) - (loc_end - ((pos_fname file.ml) (pos_lnum 2) (pos_bol 25) (pos_cnum 37))) - (loc_ghost false))) - (pmod_attributes ())) - ((pmod_desc (Pmod_structure ())) - (pmod_loc - ((loc_start - ((pos_fname file.ml) (pos_lnum 2) (pos_bol 25) (pos_cnum 36))) - (loc_end - ((pos_fname file.ml) (pos_lnum 2) (pos_bol 25) (pos_cnum 40))) - (loc_ghost false))) - (pmod_attributes ())))) - (pmod_loc - ((loc_start - ((pos_fname file.ml) (pos_lnum 2) (pos_bol 25) (pos_cnum 36))) - (loc_end - ((pos_fname file.ml) (pos_lnum 2) (pos_bol 25) (pos_cnum 40))) - (loc_ghost false))) - (pmod_attributes ()))) - (pmb_attributes ()) - (pmb_loc - ((loc_start - ((pos_fname file.ml) (pos_lnum 2) (pos_bol 25) (pos_cnum 25))) - (loc_end - ((pos_fname file.ml) (pos_lnum 2) (pos_bol 25) (pos_cnum 40))) - (loc_ghost false)))))) - (pstr_loc - ((loc_start ((pos_fname file.ml) (pos_lnum 2) (pos_bol 25) (pos_cnum 25))) - (loc_end ((pos_fname file.ml) (pos_lnum 2) (pos_bol 25) (pos_cnum 40))) - (loc_ghost false))))) + [ Pstr_module + { pmb_name = Some "F" + ; pmb_expr = Pmod_functor ( Unit, Pmod_structure []) + ; pmb_attributes = __attrs + ; pmb_loc = __loc + } + ; Pstr_module + { pmb_name = Some "M" + ; pmb_expr = Pmod_apply_unit (Pmod_ident (Lident "F")) + ; pmb_attributes = __attrs + ; pmb_loc = __loc + } + ] diff --git a/test/deriving/inline/foo-deriver/ppx_foo_deriver.ml b/test/deriving/inline/foo-deriver/ppx_foo_deriver.ml index ac632efee..2be058f2e 100644 --- a/test/deriving/inline/foo-deriver/ppx_foo_deriver.ml +++ b/test/deriving/inline/foo-deriver/ppx_foo_deriver.ml @@ -65,6 +65,7 @@ let add_deriver () = ]; pvb_attributes = []; pvb_loc = loc; + pvb_constraint = None; }; ] ); }; diff --git a/test/error_embedding/deriver.ml b/test/error_embedding/deriver.ml index bc6f140ec..0d20dbaf7 100644 --- a/test/error_embedding/deriver.ml +++ b/test/error_embedding/deriver.ml @@ -11,6 +11,7 @@ let derive_a_string ~ctxt (_rec_flag, _type_declarations) = pvb_expr = estring ~loc "derived_string"; pvb_attributes = []; pvb_loc = loc; + pvb_constraint = None; }; ]; ] diff --git a/test/metaquot/test.ml b/test/metaquot/test.ml index 026e8dc2e..b50a8dd58 100644 --- a/test/metaquot/test.ml +++ b/test/metaquot/test.ml @@ -126,7 +126,7 @@ let _ = [%stri let _ = ()] pos_cnum = -1}; loc_ghost = true}; pexp_loc_stack = []; pexp_attributes = []}; - pvb_attributes = []; + pvb_constraint = None; pvb_attributes = []; pvb_loc = {Ppxlib_ast.Ast.loc_start = {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; @@ -228,7 +228,7 @@ let _ = [%str let _ = ()] pos_cnum = -1}; loc_ghost = true}; pexp_loc_stack = []; pexp_attributes = []}; - pvb_attributes = []; + pvb_constraint = None; pvb_attributes = []; pvb_loc = {Ppxlib_ast.Ast.loc_start = {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; @@ -602,3 +602,16 @@ Line _, characters 36-38: Error: This expression should not be a unit literal, the expected type is Ppxlib_ast.Ast.module_type |}] + +(* Coalescing arguments from [fun x -> fun y -> fun z -> ...] to + [fun x y z -> ...] *) +let _ = + let e = [%expr fun z -> x + y + z] in + let f = [%expr fun y -> [%e e]] in + let func = [%expr fun x -> [%e f]] in + Format.asprintf "%a" Astlib.Pprintast.expression func + + +[%%expect{| +- : string = "fun x y z -> (x + y) + z" +|}] diff --git a/test/ppxlib-pp-ast/basic.t b/test/ppxlib-pp-ast/basic.t index e9f100830..1f66247f3 100644 --- a/test/ppxlib-pp-ast/basic.t +++ b/test/ppxlib-pp-ast/basic.t @@ -17,6 +17,7 @@ It can be used on regular .ml files: ; ( Nolabel, Pexp_constant (Pconst_integer ( "2", None))) ] ) + ; pvb_constraint = None ; pvb_attributes = __attrs ; pvb_loc = __loc } diff --git a/test/ppxlib-pp-ast/input.t b/test/ppxlib-pp-ast/input.t index 1728a94c9..e432ddfe6 100644 --- a/test/ppxlib-pp-ast/input.t +++ b/test/ppxlib-pp-ast/input.t @@ -14,6 +14,7 @@ ppxlib-pp-ast can be used on files but it can also read from stdin: ; ( Nolabel, Pexp_constant (Pconst_integer ( "2", None))) ] ) + ; pvb_constraint = None ; pvb_attributes = __attrs ; pvb_loc = __loc } diff --git a/test/ppxlib-pp-ast/show-attrs.t b/test/ppxlib-pp-ast/show-attrs.t index 5f6e94b94..1826f4c3c 100644 --- a/test/ppxlib-pp-ast/show-attrs.t +++ b/test/ppxlib-pp-ast/show-attrs.t @@ -20,6 +20,7 @@ And how it's printed without the flag: ; ( Nolabel, Pexp_constant (Pconst_integer ( "2", None))) ] ) + ; pvb_constraint = None ; pvb_attributes = __attrs ; pvb_loc = __loc } @@ -58,6 +59,7 @@ And with the flag: ) ] ) + ; pvb_constraint = None ; pvb_attributes = [ { attr_name = "bar" ; attr_payload = @@ -74,3 +76,216 @@ And with the flag: ] ) ] + +Without the flag, floating attributes are simply skipped. Consider the following +files: + + $ cat > test_floating.ml << EOF + > [@@@floating] + > let x = 2 + > class c = object + > [@@@floating] + > method! f () = () + > end + > EOF + +and: + + $ cat > test_floating.mli << EOF + > [@@@floating] + > val x : int + > class type t = object + > [@@@floating] + > method f : unit -> unit + > end + > EOF + +When printed without the flag, floating attributes are filtered out: + + $ ppxlib-pp-ast test_floating.ml + [ Pstr_value + ( Nonrecursive + , [ { pvb_pat = Ppat_var "x" + ; pvb_expr = Pexp_constant (Pconst_integer ( "2", None)) + ; pvb_constraint = None + ; pvb_attributes = __attrs + ; pvb_loc = __loc + } + ] + ) + ; Pstr_class + [ { pci_virt = Concrete + ; pci_params = [] + ; pci_name = "c" + ; pci_expr = + Pcl_structure + { pcstr_self = Ppat_any + ; pcstr_fields = + [ Pcf_method + ( "f" + , Public + , Cfk_concrete + ( Override + , Pexp_poly + ( Pexp_function + ( [ { pparam_loc = __loc + ; pparam_desc = + Pparam_val + ( Nolabel + , None + , Ppat_construct + ( Lident "()", None) + ) + } + ] + , None + , Pfunction_body + (Pexp_construct ( Lident "()", None)) + ) + , None + ) + ) + ) + ] + } + ; pci_loc = __loc + ; pci_attributes = __attrs + } + ] + ] + + $ ppxlib-pp-ast test_floating.mli + [ Psig_value + { pval_name = "x" + ; pval_type = Ptyp_constr ( Lident "int", []) + ; pval_prim = [] + ; pval_attributes = __attrs + ; pval_loc = __loc + } + ; Psig_class_type + [ { pci_virt = Concrete + ; pci_params = [] + ; pci_name = "t" + ; pci_expr = + Pcty_signature + { pcsig_self = Ptyp_any + ; pcsig_fields = + [ Pctf_method + ( "f" + , Public + , Concrete + , Ptyp_arrow + ( Nolabel + , Ptyp_constr ( Lident "unit", []) + , Ptyp_constr ( Lident "unit", []) + ) + ) + ] + } + ; pci_loc = __loc + ; pci_attributes = __attrs + } + ] + ] + +And now with the flag, we can see our floating attributes: + + $ ppxlib-pp-ast --show-attrs test_floating.ml + [ Pstr_attribute + { attr_name = "floating"; attr_payload = PStr []; attr_loc = __loc} + ; Pstr_value + ( Nonrecursive + , [ { pvb_pat = Ppat_var "x" + ; pvb_expr = Pexp_constant (Pconst_integer ( "2", None)) + ; pvb_constraint = None + ; pvb_attributes = [] + ; pvb_loc = __loc + } + ] + ) + ; Pstr_class + [ { pci_virt = Concrete + ; pci_params = [] + ; pci_name = "c" + ; pci_expr = + Pcl_structure + { pcstr_self = Ppat_any + ; pcstr_fields = + [ Pcf_attribute + { attr_name = "floating" + ; attr_payload = PStr [] + ; attr_loc = __loc + } + ; Pcf_method + ( "f" + , Public + , Cfk_concrete + ( Override + , Pexp_poly + ( Pexp_function + ( [ { pparam_loc = __loc + ; pparam_desc = + Pparam_val + ( Nolabel + , None + , Ppat_construct + ( Lident "()", None) + ) + } + ] + , None + , Pfunction_body + (Pexp_construct ( Lident "()", None)) + ) + , None + ) + ) + ) + ] + } + ; pci_loc = __loc + ; pci_attributes = [] + } + ] + ] + + $ ppxlib-pp-ast --show-attrs test_floating.mli + [ Psig_attribute + { attr_name = "floating"; attr_payload = PStr []; attr_loc = __loc} + ; Psig_value + { pval_name = "x" + ; pval_type = Ptyp_constr ( Lident "int", []) + ; pval_prim = [] + ; pval_attributes = [] + ; pval_loc = __loc + } + ; Psig_class_type + [ { pci_virt = Concrete + ; pci_params = [] + ; pci_name = "t" + ; pci_expr = + Pcty_signature + { pcsig_self = Ptyp_any + ; pcsig_fields = + [ Pctf_attribute + { attr_name = "floating" + ; attr_payload = PStr [] + ; attr_loc = __loc + } + ; Pctf_method + ( "f" + , Public + , Concrete + , Ptyp_arrow + ( Nolabel + , Ptyp_constr ( Lident "unit", []) + , Ptyp_constr ( Lident "unit", []) + ) + ) + ] + } + ; pci_loc = __loc + ; pci_attributes = [] + } + ] + ] diff --git a/test/ppxlib-pp-ast/show-locs.t b/test/ppxlib-pp-ast/show-locs.t index e5331c124..f99015025 100644 --- a/test/ppxlib-pp-ast/show-locs.t +++ b/test/ppxlib-pp-ast/show-locs.t @@ -17,6 +17,7 @@ This is how it's printed without the flag: ( Nonrecursive , [ { pvb_pat = Ppat_var "x" ; pvb_expr = Pexp_constant (Pconst_integer ( "2", None)) + ; pvb_constraint = None ; pvb_attributes = __attrs ; pvb_loc = __loc } @@ -26,6 +27,7 @@ This is how it's printed without the flag: ( Nonrecursive , [ { pvb_pat = Ppat_var "y" ; pvb_expr = Pexp_construct ( Lident "true", None) + ; pvb_constraint = None ; pvb_attributes = __attrs ; pvb_loc = __loc } @@ -35,7 +37,15 @@ This is how it's printed without the flag: ( Nonrecursive , [ { pvb_pat = Ppat_var "z" ; pvb_expr = - Pexp_fun ( Nolabel, None, Ppat_var "x", Pexp_ident (Lident "x")) + Pexp_function + ( [ { pparam_loc = __loc + ; pparam_desc = Pparam_val ( Nolabel, None, Ppat_var "x") + } + ] + , None + , Pfunction_body (Pexp_ident (Lident "x")) + ) + ; pvb_constraint = None ; pvb_attributes = __attrs ; pvb_loc = __loc } @@ -60,6 +70,7 @@ Now how it's printed with the flag: ; pexp_loc_stack = __lstack ; pexp_attributes = __attrs } + ; pvb_constraint = None ; pvb_attributes = __attrs ; pvb_loc = l1c0..9 } @@ -81,6 +92,7 @@ Now how it's printed with the flag: ; pexp_loc_stack = __lstack ; pexp_attributes = __attrs } + ; pvb_constraint = None ; pvb_attributes = __attrs ; pvb_loc = l2c0..12 } @@ -96,25 +108,35 @@ Now how it's printed with the flag: } ; pvb_expr = { pexp_desc = - Pexp_fun - ( Nolabel + Pexp_function + ( [ { pparam_loc = l4c5..6 + ; pparam_desc = + Pparam_val + ( Nolabel + , None + , { ppat_desc = + Ppat_var { txt = "x"; loc = l4c5..6} + ; ppat_loc = l4c5..6 + ; ppat_loc_stack = __lstack + ; ppat_attributes = __attrs + } + ) + } + ] , None - , { ppat_desc = Ppat_var { txt = "x"; loc = l4c5..6} - ; ppat_loc = l4c5..6 - ; ppat_loc_stack = __lstack - ; ppat_attributes = __attrs - } - , { pexp_desc = - Pexp_ident { txt = Lident "x"; loc = l5c1..2} - ; pexp_loc = l5c1..2 - ; pexp_loc_stack = __lstack - ; pexp_attributes = __attrs - } + , Pfunction_body + { pexp_desc = + Pexp_ident { txt = Lident "x"; loc = l5c1..2} + ; pexp_loc = l5c1..2 + ; pexp_loc_stack = __lstack + ; pexp_attributes = __attrs + } ) ; pexp_loc = l4c1..l5c2 ; pexp_loc_stack = __lstack ; pexp_attributes = __attrs } + ; pvb_constraint = None ; pvb_attributes = __attrs ; pvb_loc = l3c0..l5c2 } @@ -186,6 +208,7 @@ original form as opposed to the default, condensed one shown above: ; pexp_loc_stack = __lstack ; pexp_attributes = __attrs } + ; pvb_constraint = None ; pvb_attributes = __attrs ; pvb_loc = { loc_start = @@ -285,6 +308,7 @@ original form as opposed to the default, condensed one shown above: ; pexp_loc_stack = __lstack ; pexp_attributes = __attrs } + ; pvb_constraint = None ; pvb_attributes = __attrs ; pvb_loc = { loc_start = @@ -346,83 +370,105 @@ original form as opposed to the default, condensed one shown above: } ; pvb_expr = { pexp_desc = - Pexp_fun - ( Nolabel - , None - , { ppat_desc = - Ppat_var - { txt = "x" - ; loc = - { loc_start = - { pos_fname = "test.ml" - ; pos_lnum = 4 - ; pos_bol = 31 - ; pos_cnum = 36 - } - ; loc_end = - { pos_fname = "test.ml" - ; pos_lnum = 4 - ; pos_bol = 31 - ; pos_cnum = 37 - } - ; loc_ghost = false + Pexp_function + ( [ { pparam_loc = + { loc_start = + { pos_fname = "test.ml" + ; pos_lnum = 4 + ; pos_bol = 31 + ; pos_cnum = 36 } + ; loc_end = + { pos_fname = "test.ml" + ; pos_lnum = 4 + ; pos_bol = 31 + ; pos_cnum = 37 + } + ; loc_ghost = false } - ; ppat_loc = - { loc_start = - { pos_fname = "test.ml" - ; pos_lnum = 4 - ; pos_bol = 31 - ; pos_cnum = 36 - } - ; loc_end = - { pos_fname = "test.ml" - ; pos_lnum = 4 - ; pos_bol = 31 - ; pos_cnum = 37 - } - ; loc_ghost = false - } - ; ppat_loc_stack = __lstack - ; ppat_attributes = __attrs - } - , { pexp_desc = - Pexp_ident - { txt = Lident "x" - ; loc = - { loc_start = - { pos_fname = "test.ml" - ; pos_lnum = 5 - ; pos_bol = 41 - ; pos_cnum = 42 - } - ; loc_end = - { pos_fname = "test.ml" - ; pos_lnum = 5 - ; pos_bol = 41 - ; pos_cnum = 43 + ; pparam_desc = + Pparam_val + ( Nolabel + , None + , { ppat_desc = + Ppat_var + { txt = "x" + ; loc = + { loc_start = + { pos_fname = "test.ml" + ; pos_lnum = 4 + ; pos_bol = 31 + ; pos_cnum = 36 + } + ; loc_end = + { pos_fname = "test.ml" + ; pos_lnum = 4 + ; pos_bol = 31 + ; pos_cnum = 37 + } + ; loc_ghost = false + } + } + ; ppat_loc = + { loc_start = + { pos_fname = "test.ml" + ; pos_lnum = 4 + ; pos_bol = 31 + ; pos_cnum = 36 + } + ; loc_end = + { pos_fname = "test.ml" + ; pos_lnum = 4 + ; pos_bol = 31 + ; pos_cnum = 37 + } + ; loc_ghost = false } - ; loc_ghost = false + ; ppat_loc_stack = __lstack + ; ppat_attributes = __attrs } - } - ; pexp_loc = - { loc_start = - { pos_fname = "test.ml" - ; pos_lnum = 5 - ; pos_bol = 41 - ; pos_cnum = 42 - } - ; loc_end = - { pos_fname = "test.ml" - ; pos_lnum = 5 - ; pos_bol = 41 - ; pos_cnum = 43 + ) + } + ] + , None + , Pfunction_body + { pexp_desc = + Pexp_ident + { txt = Lident "x" + ; loc = + { loc_start = + { pos_fname = "test.ml" + ; pos_lnum = 5 + ; pos_bol = 41 + ; pos_cnum = 42 + } + ; loc_end = + { pos_fname = "test.ml" + ; pos_lnum = 5 + ; pos_bol = 41 + ; pos_cnum = 43 + } + ; loc_ghost = false + } } - ; loc_ghost = false - } - ; pexp_loc_stack = __lstack - ; pexp_attributes = __attrs - } + ; pexp_loc = + { loc_start = + { pos_fname = "test.ml" + ; pos_lnum = 5 + ; pos_bol = 41 + ; pos_cnum = 42 + } + ; loc_end = + { pos_fname = "test.ml" + ; pos_lnum = 5 + ; pos_bol = 41 + ; pos_cnum = 43 + } + ; loc_ghost = false + } + ; pexp_loc_stack = __lstack + ; pexp_attributes = __attrs + } ) ; pexp_loc = { loc_start = @@ -442,6 +488,7 @@ original form as opposed to the default, condensed one shown above: ; pexp_loc_stack = __lstack ; pexp_attributes = __attrs } + ; pvb_constraint = None ; pvb_attributes = __attrs ; pvb_loc = { loc_start = diff --git a/test/quoter/test.ml b/test/quoter/test.ml index d028a9c59..57b282312 100644 --- a/test/quoter/test.ml +++ b/test/quoter/test.ml @@ -165,53 +165,19 @@ val quoted : expression = ppat_loc_stack = []; ppat_attributes = []}; pvb_expr = {Ppxlib__.Import.pexp_desc = - Ppxlib__.Import.Pexp_fun (Ppxlib__.Import.Nolabel, None, - {Ppxlib__.Import.ppat_desc = - Ppxlib__.Import.Ppat_construct - ({Ppxlib__.Import.txt = Ppxlib__.Import.Lident "()"; - loc = - {Ppxlib__.Import.loc_start = - {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; - pos_bol = 0; pos_cnum = -1}; - loc_end = - {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; - pos_bol = 0; pos_cnum = -1}; - loc_ghost = true}}, - None); - ppat_loc = - {Ppxlib__.Import.loc_start = - {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; - pos_bol = 0; pos_cnum = -1}; - loc_end = - {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; - pos_bol = 0; pos_cnum = -1}; - loc_ghost = true}; - ppat_loc_stack = []; ppat_attributes = []}, - {Ppxlib__.Import.pexp_desc = - Ppxlib__.Import.Pexp_apply - ({Ppxlib__.Import.pexp_desc = - Ppxlib__.Import.Pexp_ident - {Ppxlib__.Import.txt = Ppxlib__.Import.Lident "foo"; - loc = - {Ppxlib__.Import.loc_start = - {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; - pos_bol = 0; pos_cnum = -1}; - loc_end = - {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; - pos_bol = 0; pos_cnum = -1}; - loc_ghost = true}}; - pexp_loc = - {Ppxlib__.Import.loc_start = - {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; - pos_bol = 0; pos_cnum = -1}; - loc_end = - {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; - pos_bol = 0; pos_cnum = -1}; - loc_ghost = true}; - pexp_loc_stack = []; pexp_attributes = []}, - [(Ppxlib__.Import.Nolabel, - {Ppxlib__.Import.pexp_desc = - Ppxlib__.Import.Pexp_construct + Ppxlib__.Import.Pexp_function + ([{Ppxlib__.Import.pparam_loc = + {Ppxlib__.Import.loc_start = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_end = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_ghost = true}; + pparam_desc = + Ppxlib__.Import.Pparam_val (Ppxlib__.Import.Nolabel, None, + {Ppxlib__.Import.ppat_desc = + Ppxlib__.Import.Ppat_construct ({Ppxlib__.Import.txt = Ppxlib__.Import.Lident "()"; loc = {Ppxlib__.Import.loc_start = @@ -222,6 +188,30 @@ val quoted : expression = pos_bol = 0; pos_cnum = -1}; loc_ghost = true}}, None); + ppat_loc = + {Ppxlib__.Import.loc_start = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_end = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_ghost = true}; + ppat_loc_stack = []; ppat_attributes = []})}], + None, + Ppxlib__.Import.Pfunction_body + {Ppxlib__.Import.pexp_desc = + Ppxlib__.Import.Pexp_apply + ({Ppxlib__.Import.pexp_desc = + Ppxlib__.Import.Pexp_ident + {Ppxlib__.Import.txt = Ppxlib__.Import.Lident "foo"; + loc = + {Ppxlib__.Import.loc_start = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_end = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_ghost = true}}; pexp_loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; @@ -230,16 +220,38 @@ val quoted : expression = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_ghost = true}; - pexp_loc_stack = []; pexp_attributes = []})]); - pexp_loc = - {Ppxlib__.Import.loc_start = - {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; - pos_bol = 0; pos_cnum = -1}; - loc_end = - {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; - pos_bol = 0; pos_cnum = -1}; - loc_ghost = true}; - pexp_loc_stack = []; pexp_attributes = []}); + pexp_loc_stack = []; pexp_attributes = []}, + [(Ppxlib__.Import.Nolabel, + {Ppxlib__.Import.pexp_desc = + Ppxlib__.Import.Pexp_construct + ({Ppxlib__.Import.txt = Ppxlib__.Import.Lident "()"; + loc = + {Ppxlib__.Import.loc_start = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_end = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_ghost = true}}, + None); + pexp_loc = + {Ppxlib__.Import.loc_start = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_end = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_ghost = true}; + pexp_loc_stack = []; pexp_attributes = []})]); + pexp_loc = + {Ppxlib__.Import.loc_start = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_end = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_ghost = true}; + pexp_loc_stack = []; pexp_attributes = []}); pexp_loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; @@ -249,7 +261,7 @@ val quoted : expression = pos_cnum = -1}; loc_ghost = true}; pexp_loc_stack = []; pexp_attributes = []}; - pvb_attributes = []; + pvb_constraint = None; pvb_attributes = []; pvb_loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; @@ -300,7 +312,7 @@ val quoted : expression = pos_cnum = -1}; loc_ghost = true}; pexp_loc_stack = []; pexp_attributes = []}; - pvb_attributes = []; + pvb_constraint = None; pvb_attributes = []; pvb_loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; @@ -315,19 +327,12 @@ val quoted : expression = {Ppxlib__.Import.txt = "__0"; loc = {Ppxlib__.Import.loc_start = - {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; - pos_bol = 0; pos_cnum = -1}; - loc_end = - {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; - pos_bol = 0; pos_cnum = -1}; - loc_ghost = true}}; - ppat_loc = - {Ppxlib__.Import.loc_start = - {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; - pos_cnum = -1}; - loc_end = ...; loc_ghost = ...}; - ppat_loc_stack = ...; ppat_attributes = ...}; - pvb_expr = ...; pvb_attributes = ...; pvb_loc = ...}; + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = ...; + pos_bol = ...; pos_cnum = ...}; + loc_end = ...; loc_ghost = ...}}; + ppat_loc = ...; ppat_loc_stack = ...; ppat_attributes = ...}; + pvb_expr = ...; pvb_constraint = ...; pvb_attributes = ...; + pvb_loc = ...}; ...], ...); pexp_loc = ...; pexp_loc_stack = ...; pexp_attributes = ...}