diff --git a/.ocamlformat-ignore b/.ocamlformat-ignore index ece258d97..c85cb641e 100644 --- a/.ocamlformat-ignore +++ b/.ocamlformat-ignore @@ -16,6 +16,7 @@ astlib/ast_411.ml astlib/ast_412.ml astlib/ast_413.ml astlib/ast_414.ml +astlib/ast_501.ml # Files that use cinaps to generate bode blocks from other code blocks work well, # but files that inject freely formatted code via cinaps must be excluded @@ -25,9 +26,13 @@ ast/versions.mli # Currently our expect-test lexer is too strict for our expect tests to # work well with ocamlformat test/base/test.ml +test/base/test_510.ml test/code_path/test.ml +test/code_path/test_510.ml test/deriving/test.ml +test/deriving/test_510.ml test/driver/attributes/test.ml +test/driver/attributes/test_510.ml test/driver/instrument/test.ml test/driver/non-compressible-suffix/test.ml test/driver/transformations/test.ml @@ -35,8 +40,10 @@ test/expand-header-and-footer/test.ml test/expansion_helpers/mangle/test.ml test/expansion_inside_payloads/test.ml test/extensions_and_deriving/test.ml +test/extensions_and_deriving/test_510.ml test/location/exception/test.ml test/metaquot/test.ml +test/metaquot/test_510.ml test/ppx_import_support/test.ml test/quoter/test.ml test/traverse/test.ml diff --git a/CHANGES.md b/CHANGES.md index f28e40843..9e3099d74 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -25,6 +25,9 @@ unreleased - Update description to reflect that `ppxlib` contains more than a library (#422, @pitag-ha) +- Add support for OCaml 5.1, excluding OCaml `5.1.0~alpha1` (#428, @shym, @Octachron , @pitag-ha, @panglesd) +- Driver: Fix `-locations-check` option for coercions with ground (#428, @Octachron) + 0.29.1 (14/02/2023) ------------------ diff --git a/ast/supported_version/supported_version.ml b/ast/supported_version/supported_version.ml index 1e63e0e6d..9d9a458ad 100644 --- a/ast/supported_version/supported_version.ml +++ b/ast/supported_version/supported_version.ml @@ -16,6 +16,7 @@ let all = (4, 13); (4, 14); (5, 0); + (5, 1); ] let to_string (a, b) = diff --git a/ast/versions.ml b/ast/versions.ml index 69ebe18de..cf7bb2081 100644 --- a/ast/versions.ml +++ b/ast/versions.ml @@ -506,6 +506,13 @@ module OCaml_500 = struct let string_version = "5.0" end let ocaml_500 : OCaml_500.types ocaml_version = (module OCaml_500) +module OCaml_501 = struct + module Ast = Astlib.Ast_501 + include Make_witness(Astlib.Ast_501) + let version = 501 + let string_version = "5.1" +end +let ocaml_501 : OCaml_501.types ocaml_version = (module OCaml_501) (*$*) let all_versions : (module OCaml_version) list = [ @@ -525,6 +532,7 @@ let all_versions : (module OCaml_version) list = [ (module OCaml_413 : OCaml_version); (module OCaml_414 : OCaml_version); (module OCaml_500 : OCaml_version); +(module OCaml_501 : OCaml_version); (*$*) ] @@ -559,6 +567,8 @@ include Register_migration(OCaml_413)(OCaml_414) (Astlib.Migrate_413_414)(Astlib.Migrate_414_413) include Register_migration(OCaml_414)(OCaml_500) (Astlib.Migrate_414_500)(Astlib.Migrate_500_414) +include Register_migration(OCaml_500)(OCaml_501) + (Astlib.Migrate_500_501)(Astlib.Migrate_501_500) (*$*) module OCaml_current = OCaml_OCAML_VERSION @@ -577,10 +587,10 @@ module Find_version = struct else loop tail in - (* First check whether it could be the current version, probably - the most common use case. - This bias towards the current version also provides a way to - choose wisely between, say, `trunk` and the latest stable - release, for which the magic numbers are not distinguished *) - loop @@ ((module OCaml_current : OCaml_version) :: all_versions) + (* Traverse the versions from last to first: + if the magic numbers aren't unique among versions, + we want the latest version with a magic number match. + The situation in mind is trunk support. *) + let all_versions_top_down = List.rev all_versions in + loop all_versions_top_down end diff --git a/ast/versions.mli b/ast/versions.mli index 2418e0224..83b2ea78f 100644 --- a/ast/versions.mli +++ b/ast/versions.mli @@ -129,6 +129,7 @@ module OCaml_412 : OCaml_version with module Ast = Astlib.Ast_412 module OCaml_413 : OCaml_version with module Ast = Astlib.Ast_413 module OCaml_414 : OCaml_version with module Ast = Astlib.Ast_414 module OCaml_500 : OCaml_version with module Ast = Astlib.Ast_500 +module OCaml_501 : OCaml_version with module Ast = Astlib.Ast_501 (*$*) (* An alias to the current compiler version *) diff --git a/astlib/ast_501.ml b/astlib/ast_501.ml new file mode 100644 index 000000000..4e0de3173 --- /dev/null +++ b/astlib/ast_501.ml @@ -0,0 +1,1090 @@ +module Asttypes = struct + type constant (*IF_CURRENT = Asttypes.constant *) = + Const_int of int + | Const_char of char + | Const_string of string * Location.t * string option + | Const_float of string + | Const_int32 of int32 + | Const_int64 of int64 + | Const_nativeint of nativeint + + type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive + + type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto + + (* Order matters, used in polymorphic comparison *) + type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public + + type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable + + type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete + + type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh + + type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open + + type label = string + + type arg_label (*IF_CURRENT = Asttypes.arg_label *) = + Nolabel + | Labelled of string (** [label:T -> ...] *) + | Optional of string (** [?label:T -> ...] *) + + type 'a loc = 'a Location.loc = { + txt : 'a; + loc : Location.t; + } + + type variance (*IF_CURRENT = Asttypes.variance *) = + | Covariant + | Contravariant + | NoVariance + + type injectivity (*IF_CURRENT = Asttypes.injectivity *) = + | Injective + | NoInjectivity +end + +module Parsetree = struct + open Asttypes + + type constant (*IF_CURRENT = Parsetree.constant *) = + | Pconst_integer of string * char option + (** Integer constants such as [3] [3l] [3L] [3n]. + + Suffixes [[g-z][G-Z]] are accepted by the parser. + Suffixes except ['l'], ['L'] and ['n'] are rejected by the typechecker + *) + | Pconst_char of char (** Character such as ['c']. *) + | Pconst_string of string * Location.t * string option + (** Constant string such as ["constant"] or + [{delim|other constant|delim}]. + + The location span the content of the string, without the delimiters. + *) + | Pconst_float of string * char option + (** Float constant such as [3.4], [2e5] or [1.4e-4]. + + Suffixes [g-z][G-Z] are accepted by the parser. + Suffixes are rejected by the typechecker. + *) + + type location_stack = Location.t list + + (** {1 Extension points} *) + + type attribute (*IF_CURRENT = Parsetree.attribute *) = { + attr_name : string loc; + attr_payload : payload; + attr_loc : Location.t; + } + (** Attributes such as [[\@id ARG]] and [[\@\@id ARG]]. + + Metadata containers passed around within the AST. + The compiler ignores unknown attributes. + *) + + and extension = string loc * payload + (** Extension points such as [[%id ARG] and [%%id ARG]]. + + Sub-language placeholder -- rejected by the typechecker. + *) + + and attributes = attribute list + + and payload (*IF_CURRENT = Parsetree.payload *) = + | PStr of structure + | PSig of signature (** [: SIG] in an attribute or an extension point *) + | PTyp of core_type (** [: T] in an attribute or an extension point *) + | PPat of pattern * expression option + (** [? P] or [? P when E], in an attribute or an extension point *) + + (** {1 Core language} *) + (** {2 Type expressions} *) + + and core_type (*IF_CURRENT = Parsetree.core_type *) = + { + ptyp_desc: core_type_desc; + ptyp_loc: Location.t; + ptyp_loc_stack: location_stack; + ptyp_attributes: attributes; (** [... [\@id1] [\@id2]] *) + } + + and core_type_desc (*IF_CURRENT = Parsetree.core_type_desc *) = + | Ptyp_any (** [_] *) + | 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]}, + - [?l:T1 -> T2] when [lbl] is + {{!Asttypes.arg_label.Optional}[Optional]}. + *) + | Ptyp_tuple of core_type list + (** [Ptyp_tuple([T1 ; ... ; Tn])] + represents a product type [T1 * ... * Tn]. + + Invariant: [n >= 2]. + *) + | Ptyp_constr of Longident.t 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.t 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_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]}, + and [labels] is [None], + - [[< `A|`B ]] + when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]}, + and [labels] is [Some []], + - [[< `A|`B > `X `Y ]] + when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]}, + and [labels] is [Some ["X";"Y"]]. + *) + | Ptyp_poly of string loc list * core_type + (** ['a1 ... 'an. T] + + Can only appear in the following context: + + - As the {!core_type} of a + {{!pattern_desc.Ppat_constraint}[Ppat_constraint]} node corresponding + to a constraint on a let-binding: + + {[let x : 'a1 ... 'an. T = e ...]} + - Under {{!class_field_kind.Cfk_virtual}[Cfk_virtual]} for methods + (not values). + + - As the {!core_type} of a + {{!class_type_field_desc.Pctf_method}[Pctf_method]} node. + + - As the {!core_type} of a {{!expression_desc.Pexp_poly}[Pexp_poly]} + node. + + - As the {{!label_declaration.pld_type}[pld_type]} field of a + {!label_declaration}. + + - As a {!core_type} of a {{!core_type_desc.Ptyp_object}[Ptyp_object]} + node. + + - As the {{!value_description.pval_type}[pval_type]} field of a + {!value_description}. + *) + | Ptyp_package of package_type (** [(module S)]. *) + | Ptyp_extension of extension (** [[%id]]. *) + + and package_type = Longident.t loc * (Longident.t 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)]. + *) + + and row_field (*IF_CURRENT = Parsetree.row_field *) = { + prf_desc : row_field_desc; + prf_loc : Location.t; + prf_attributes : attributes; + } + + and row_field_desc (*IF_CURRENT = 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]], + - [`A of & T1 & .. & Tn] when [b] is [true] and [l] is [[T1;...Tn]]. + + - The [bool] field is true if the tag contains a + constant (empty) constructor. + - [&] occurs when several types are used for the same constructor + (see 4.2 in the manual) + *) + | Rinherit of core_type (** [[ | t ]] *) + + and object_field (*IF_CURRENT = Parsetree.object_field *) = { + pof_desc : object_field_desc; + pof_loc : Location.t; + pof_attributes : attributes; + } + + and object_field_desc (*IF_CURRENT = Parsetree.object_field_desc *) = + | Otag of label loc * core_type + | Oinherit of core_type + + (** {2 Patterns} *) + + and pattern (*IF_CURRENT = Parsetree.pattern *) = + { + ppat_desc: pattern_desc; + ppat_loc: Location.t; + ppat_loc_stack: location_stack; + ppat_attributes: attributes; (** [... [\@id1] [\@id2]] *) + } + + and pattern_desc (*IF_CURRENT = Parsetree.pattern_desc *) = + | Ppat_any (** The pattern [_]. *) + | Ppat_var of string loc (** A variable pattern such as [x] *) + | Ppat_alias of pattern * string loc + (** An alias pattern such as [P as 'a] *) + | Ppat_constant of constant + (** Patterns such as [1], ['a'], ["true"], [1.0], [1l], [1L], [1n] *) + | Ppat_interval of constant * constant + (** Patterns such as ['a'..'z']. + + Other forms of interval are recognized by the parser + but rejected by the type-checker. *) + | Ppat_tuple of pattern list + (** Patterns [(P1, ..., Pn)]. + + Invariant: [n >= 2] + *) + | Ppat_construct of Longident.t 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 + [Some ([], Ppat_tuple [P1; ...; Pn])] + - [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.t 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 {{!Asttypes.closed_flag.Open}[Open]} + + Invariant: [n > 0] + *) + | 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.t 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] + + Note: [(module P : S)] is represented as + [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.t loc * pattern (** Pattern [M.(P)] *) + + (** {2 Value expressions} *) + + and expression (*IF_CURRENT = Parsetree.expression *) = + { + pexp_desc: expression_desc; + pexp_loc: Location.t; + pexp_loc_stack: location_stack; + pexp_attributes: attributes; (** [... [\@id1] [\@id2]] *) + } + + and expression_desc (*IF_CURRENT = Parsetree.expression_desc *) = + | Pexp_ident of Longident.t 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 case list (** [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_apply of expression * (arg_label * expression) list + (** [Pexp_apply(E0, [(l1, E1) ; ... ; (ln, En)])] + represents [E0 ~l1:E1 ... ~ln:En] + + [li] can be + {{!Asttypes.arg_label.Nolabel}[Nolabel]} (non labeled argument), + {{!Asttypes.arg_label.Labelled}[Labelled]} (labelled arguments) or + {{!Asttypes.arg_label.Optional}[Optional]} (optional argument). + + Invariant: [n > 0] + *) + | Pexp_match of expression * case list + (** [match E0 with P1 -> E1 | ... | Pn -> En] *) + | Pexp_try of expression * case list + (** [try E0 with P1 -> E1 | ... | Pn -> En] *) + | Pexp_tuple of expression list + (** Expressions [(E1, ..., En)] + + Invariant: [n >= 2] + *) + | Pexp_construct of Longident.t 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.t 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.t loc (** [E.l] *) + | Pexp_setfield of expression * Longident.t loc * expression + (** [E1.l <- E2] *) + | Pexp_array of expression list (** [[| E1; ...; En |]] *) + | Pexp_ifthenelse of expression * expression * expression option + (** [if E1 then E2 else E3] *) + | Pexp_sequence of expression * expression (** [E1; E2] *) + | 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 {{!Asttypes.direction_flag.Downto}[Downto]} + *) + | 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.t loc (** [new M.c] *) + | Pexp_setinstvar of label loc * expression (** [x <- 2] *) + | Pexp_override of (label loc * expression) list + (** [{< x1 = E1; ...; xn = En >}] *) + | Pexp_letmodule of string option loc * module_expr * expression + (** [let module M = ME in E] *) + | Pexp_letexception of extension_constructor * expression + (** [let exception C in E] *) + | Pexp_assert of expression + (** [assert E]. + + Note: [assert false] is treated in a special way by the + type-checker. *) + | Pexp_lazy of expression (** [lazy E] *) + | Pexp_poly of expression * core_type option + (** Used for method bodies. + + Can only be used as the expression under + {{!class_field_kind.Cfk_concrete}[Cfk_concrete]} for methods (not + values). *) + | Pexp_object of class_structure (** [object ... end] *) + | Pexp_newtype of string loc * expression (** [fun (type t) -> E] *) + | Pexp_pack of module_expr + (** [(module ME)]. + + [(module ME : S)] is represented as + [Pexp_constraint(Pexp_pack ME, Ptyp_package S)] *) + | Pexp_open of open_declaration * expression + (** - [M.(E)] + - [let open M in E] + - [let open! M in E] *) + | Pexp_letop of letop + (** - [let* P = E0 in E1] + - [let* P0 = E00 and* P1 = E01 in E1] *) + | Pexp_extension of extension (** [[%id]] *) + | Pexp_unreachable (** [.] *) + + and case (*IF_CURRENT = Parsetree.case *) = + { + pc_lhs: pattern; + pc_guard: expression option; + pc_rhs: expression; + } + (** Values of type {!case} represents [(P -> E)] or [(P when E0 -> E)] *) + + and letop (*IF_CURRENT = Parsetree.letop *) = + { + let_ : binding_op; + ands : binding_op list; + body : expression; + } + + and binding_op (*IF_CURRENT = Parsetree.binding_op *) = + { + pbop_op : string loc; + pbop_pat : pattern; + pbop_exp : expression; + pbop_loc : Location.t; + } + + (** {2 Value descriptions} *) + + and value_description (*IF_CURRENT = Parsetree.value_description *) = + { + pval_name: string loc; + pval_type: core_type; + pval_prim: string list; + pval_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + pval_loc: Location.t; + } + (** 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"]] + *) + + (** {2 Type declarations} *) + + and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = + { + ptype_name: string loc; + ptype_params: (core_type * (variance * injectivity)) list; + (** [('a1,...'an) t] *) + ptype_cstrs: (core_type * core_type * Location.t) list; + (** [... constraint T1=T1' ... constraint Tn=Tn'] *) + ptype_kind: type_kind; + ptype_private: private_flag; (** for [= private ...] *) + ptype_manifest: core_type option; (** represents [= T] *) + ptype_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + ptype_loc: Location.t; + } + (** + 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}[Ptype_abstract]}, + and [manifest] is [Some T0], + - [type t = C of T | ...] + when [type_kind] is {{!type_kind.Ptype_variant}[Ptype_variant]}, + and [manifest] is [None], + - [type t = T0 = C of T | ...] + when [type_kind] is {{!type_kind.Ptype_variant}[Ptype_variant]}, + and [manifest] is [Some T0], + - [type t = {l: T; ...}] + when [type_kind] is {{!type_kind.Ptype_record}[Ptype_record]}, + and [manifest] is [None], + - [type t = T0 = {l : T; ...}] + when [type_kind] is {{!type_kind.Ptype_record}[Ptype_record]}, + and [manifest] is [Some T0], + - [type t = ..] + when [type_kind] is {{!type_kind.Ptype_open}[Ptype_open]}, + and [manifest] is [None]. + *) + + and type_kind (*IF_CURRENT = Parsetree.type_kind *) = + | Ptype_abstract + | Ptype_variant of constructor_declaration list + | Ptype_record of label_declaration list (** Invariant: non-empty list *) + | Ptype_open + + and label_declaration (*IF_CURRENT = Parsetree.label_declaration *) = + { + pld_name: string loc; + pld_mutable: mutable_flag; + pld_type: core_type; + pld_loc: Location.t; + pld_attributes: attributes; (** [l : T [\@id1] [\@id2]] *) + } + (** + - [{ ...; l: T; ... }] + when {{!label_declaration.pld_mutable}[pld_mutable]} + is {{!Asttypes.mutable_flag.Immutable}[Immutable]}, + - [{ ...; mutable l: T; ... }] + when {{!label_declaration.pld_mutable}[pld_mutable]} + is {{!Asttypes.mutable_flag.Mutable}[Mutable]}. + + Note: [T] can be a {{!core_type_desc.Ptyp_poly}[Ptyp_poly]}. + *) + + and constructor_declaration (*IF_CURRENT = Parsetree.constructor_declaration *) = + { + pcd_name: string loc; + pcd_vars: string loc list; + pcd_args: constructor_arguments; + pcd_res: core_type option; + pcd_loc: Location.t; + pcd_attributes: attributes; (** [C of ... [\@id1] [\@id2]] *) + } + + and constructor_arguments (*IF_CURRENT = Parsetree.constructor_arguments *) = + | Pcstr_tuple of core_type list + | 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 []], + - [C: T1 * ... * Tn -> T0] when [res = Some T0], + and [args = Pcstr_tuple [T1; ... ; Tn]], + - [C of {...}] when [res = None], + and [args = Pcstr_record [...]], + - [C: {...} -> T0] when [res = Some T0], + and [args = Pcstr_record [...]]. + *) + + and type_extension (*IF_CURRENT = Parsetree.type_extension *) = + { + ptyext_path: Longident.t loc; + ptyext_params: (core_type * (variance * injectivity)) list; + ptyext_constructors: extension_constructor list; + ptyext_private: private_flag; + ptyext_loc: Location.t; + ptyext_attributes: attributes; (** ... [\@\@id1] [\@\@id2] *) + } + (** + Definition of new extensions constructors for the extensive sum type [t] + ([type t += ...]). + *) + + and extension_constructor (*IF_CURRENT = Parsetree.extension_constructor *) = + { + pext_name: string loc; + pext_kind: extension_constructor_kind; + pext_loc: Location.t; + pext_attributes: attributes; (** [C of ... [\@id1] [\@id2]] *) + } + + and type_exception (*IF_CURRENT = Parsetree.type_exception *) = + { + ptyexn_constructor : extension_constructor; + ptyexn_loc : Location.t; + ptyexn_attributes : attributes; (** [... [\@\@id1] [\@\@id2]] *) + } + (** Definition of a new exception ([exception E]). *) + + and extension_constructor_kind (*IF_CURRENT = 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: + - [C of T1 * ... * Tn] when: + {ul {- [existentials] is [[]],} + {- [c_args] is [[T1; ...; Tn]],} + {- [t_opt] is [None].}} + - [C: T0] when + {ul {- [existentials] is [[]],} + {- [c_args] is [[]],} + {- [t_opt] is [Some T0].}} + - [C: T1 * ... * Tn -> T0] when + {ul {- [existentials] is [[]],} + {- [c_args] is [[T1; ...; Tn]],} + {- [t_opt] is [Some T0].}} + - [C: 'a... . T1 * ... * Tn -> T0] when + {ul {- [existentials] is [['a;...]],} + {- [c_args] is [[T1; ... ; Tn]],} + {- [t_opt] is [Some T0].}} + *) + | Pext_rebind of Longident.t loc + (** [Pext_rebind(D)] re-export the constructor [D] with the new name [C] *) + + (** {1 Class language} *) + (** {2 Type expressions for the class language} *) + + and class_type (*IF_CURRENT = Parsetree.class_type *) = + { + pcty_desc: class_type_desc; + pcty_loc: Location.t; + pcty_attributes: attributes; (** [... [\@id1] [\@id2]] *) + } + + and class_type_desc (*IF_CURRENT = Parsetree.class_type_desc *) = + | Pcty_constr of Longident.t 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]}, + - [?l:T -> CT] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]}. + *) + | Pcty_extension of extension (** [%id] *) + | Pcty_open of open_description * class_type (** [let open M in CT] *) + + and class_signature (*IF_CURRENT = Parsetree.class_signature *) = + { + pcsig_self: core_type; + 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]} + *) + + and class_type_field (*IF_CURRENT = Parsetree.class_type_field *) = + { + pctf_desc: class_type_field_desc; + pctf_loc: Location.t; + pctf_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + } + + and class_type_field_desc (*IF_CURRENT = Parsetree.class_type_field_desc *) = + | Pctf_inherit of class_type (** [inherit CT] *) + | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type) + (** [val x: T] *) + | Pctf_method of (label loc * private_flag * virtual_flag * core_type) + (** [method x: T] + + 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_extension of extension (** [[%%id]] *) + + and 'a class_infos (*IF_CURRENT = 'a Parsetree.class_infos *) = + { + pci_virt: virtual_flag; + pci_params: (core_type * (variance * injectivity)) list; + pci_name: string loc; + pci_expr: 'a; + pci_loc: Location.t; + pci_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + } + (** Values of type [class_expr class_infos] represents: + - [class c = ...] + - [class ['a1,...,'an] c = ...] + - [class virtual c = ...] + + They are also used for "class type" declaration. + *) + + and class_description = class_type class_infos + + and class_type_declaration = class_type class_infos + + (** {2 Value expressions for the class language} *) + + and class_expr (*IF_CURRENT = Parsetree.class_expr *) = + { + pcl_desc: class_expr_desc; + pcl_loc: Location.t; + pcl_attributes: attributes; (** [... [\@id1] [\@id2]] *) + } + + and class_expr_desc (*IF_CURRENT = Parsetree.class_expr_desc *) = + | Pcl_constr of Longident.t 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}[Labelled l]} + and [exp0] is [None], + - [fun ?l:P -> CE] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [None], + - [fun ?l:(P = E0) -> CE] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [Some E0]. + *) + | Pcl_apply of class_expr * (arg_label * expression) list + (** [Pcl_apply(CE, [(l1,E1) ; ... ; (ln,En)])] + represents [CE ~l1:E1 ... ~ln:En]. + [li] can be empty (non labeled argument) or start with [?] + (optional argument). + + 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 {{!Asttypes.rec_flag.Recursive}[Recursive]}. + *) + | Pcl_constraint of class_expr * class_type (** [(CE : CT)] *) + | Pcl_extension of extension (** [[%id]] *) + | Pcl_open of open_description * class_expr (** [let open M in CE] *) + + and class_structure (*IF_CURRENT = Parsetree.class_structure *) = + { + pcstr_self: pattern; + 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]} + *) + + and class_field (*IF_CURRENT = Parsetree.class_field *) = + { + pcf_desc: class_field_desc; + pcf_loc: Location.t; + pcf_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + } + + and class_field_desc (*IF_CURRENT = 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}[Fresh]} + and [s] is [Some x], + - [inherit! CE] + when [flag] is {{!Asttypes.override_flag.Override}[Override]} + and [s] is [None], + - [inherit! CE as x] + when [flag] is {{!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)]} + - [val virtual x: T] + when [flag] is {{!Asttypes.mutable_flag.Immutable}[Immutable]} + and [kind] is {{!class_field_kind.Cfk_virtual}[Cfk_virtual(T)]} + - [val mutable x = E] + when [flag] is {{!Asttypes.mutable_flag.Mutable}[Mutable]} + and [kind] is {{!class_field_kind.Cfk_concrete}[Cfk_concrete(Fresh, E)]} + - [val mutable virtual x: T] + when [flag] is {{!Asttypes.mutable_flag.Mutable}[Mutable]} + and [kind] is {{!class_field_kind.Cfk_virtual}[Cfk_virtual(T)]} + *) + | Pcf_method of (label loc * private_flag * class_field_kind) + (** - [method x = E] + ([E] can be a {{!expression_desc.Pexp_poly}[Pexp_poly]}) + - [method virtual x: T] + ([T] can be a {{!core_type_desc.Ptyp_poly}[Ptyp_poly]}) + *) + | Pcf_constraint of (core_type * core_type) (** [constraint T1 = T2] *) + | Pcf_initializer of expression (** [initializer E] *) + | Pcf_attribute of attribute (** [[\@\@\@id]] *) + | Pcf_extension of extension (** [[%%id]] *) + + and class_field_kind (*IF_CURRENT = Parsetree.class_field_kind *) = + | Cfk_virtual of core_type + | Cfk_concrete of override_flag * expression + + and class_declaration = class_expr class_infos + + (** {1 Module language} *) + (** {2 Type expressions for the module language} *) + + and module_type (*IF_CURRENT = Parsetree.module_type *) = + { + pmty_desc: module_type_desc; + pmty_loc: Location.t; + pmty_attributes: attributes; (** [... [\@id1] [\@id2]] *) + } + + and module_type_desc (*IF_CURRENT = Parsetree.module_type_desc *) = + | Pmty_ident of Longident.t 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.t loc (** [(module M)] *) + + and functor_parameter (*IF_CURRENT = 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] *) + + and signature = signature_item list + + and signature_item (*IF_CURRENT = Parsetree.signature_item *) = + { + psig_desc: signature_item_desc; + psig_loc: Location.t; + } + + and signature_item_desc (*IF_CURRENT = Parsetree.signature_item_desc *) = + | Psig_value of value_description + (** - [val x: T] + - [external x: T = "s1" ... "sn"] + *) + | Psig_type of rec_flag * type_declaration list + (** [type t1 = ... and ... and tn = ...] *) + | Psig_typesubst of type_declaration list + (** [type t1 := ... and ... and tn := ...] *) + | Psig_typext of type_extension (** [type t1 += ...] *) + | Psig_exception of type_exception (** [exception C of T] *) + | Psig_module of module_declaration (** [module X = M] and [module X : MT] *) + | Psig_modsubst of module_substitution (** [module X := M] *) + | Psig_recmodule of module_declaration list + (** [module rec X1 : MT1 and ... and Xn : MTn] *) + | Psig_modtype of module_type_declaration + (** [module type S = MT] and [module type S] *) + | Psig_modtypesubst of module_type_declaration + (** [module type S := ...] *) + | Psig_open of open_description (** [open X] *) + | Psig_include of include_description (** [include MT] *) + | Psig_class of class_description list + (** [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_extension of extension * attributes (** [[%%id]] *) + + and module_declaration (*IF_CURRENT = Parsetree.module_declaration *) = + { + pmd_name: string option loc; + pmd_type: module_type; + pmd_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + pmd_loc: Location.t; + } + (** Values of type [module_declaration] represents [S : MT] *) + + and module_substitution (*IF_CURRENT = Parsetree.module_substitution *) = + { + pms_name: string loc; + pms_manifest: Longident.t loc; + pms_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + pms_loc: Location.t; + } + (** Values of type [module_substitution] represents [S := M] *) + + and module_type_declaration (*IF_CURRENT = Parsetree.module_type_declaration *) = + { + pmtd_name: string loc; + pmtd_type: module_type option; + pmtd_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + pmtd_loc: Location.t; + } + (** 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]. + *) + + and 'a open_infos (*IF_CURRENT = 'a Parsetree.open_infos *) = + { + popen_expr: 'a; + popen_override: override_flag; + popen_loc: Location.t; + 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.t 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] *) + + and 'a include_infos (*IF_CURRENT = 'a Parsetree.include_infos *) = + { + pincl_mod: 'a; + pincl_loc: Location.t; + pincl_attributes: attributes; + } + + and include_description = module_type include_infos + (** Values of type [include_description] represents [include MT] *) + + and include_declaration = module_expr include_infos + (** Values of type [include_declaration] represents [include ME] *) + + and with_constraint (*IF_CURRENT = Parsetree.with_constraint *) = + | Pwith_type of Longident.t 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.t loc * Longident.t loc + (** [with module X.Y = Z] *) + | Pwith_modtype of Longident.t loc * module_type + (** [with module type X.Y = Z] *) + | Pwith_modtypesubst of Longident.t loc * module_type + (** [with module type X.Y := sig end] *) + | Pwith_typesubst of Longident.t loc * type_declaration + (** [with type X.t := ..., same format as [Pwith_type]] *) + | Pwith_modsubst of Longident.t loc * Longident.t loc + (** [with module X.Y := Z] *) + + (** {2 Value expressions for the module language} *) + + and module_expr (*IF_CURRENT = Parsetree.module_expr *) = + { + pmod_desc: module_expr_desc; + pmod_loc: Location.t; + pmod_attributes: attributes; (** [... [\@id1] [\@id2]] *) + } + + and module_expr_desc (*IF_CURRENT = Parsetree.module_expr_desc *) = + | Pmod_ident of Longident.t 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]] *) + + and structure = structure_item list + + and structure_item (*IF_CURRENT = Parsetree.structure_item *) = + { + pstr_desc: structure_item_desc; + pstr_loc: Location.t; + } + + and structure_item_desc (*IF_CURRENT = 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 {{!Asttypes.rec_flag.Recursive}[Recursive]}. + *) + | Pstr_primitive of value_description + (** - [val x: T] + - [external x: T = "s1" ... "sn" ]*) + | Pstr_type of rec_flag * type_declaration list + (** [type t1 = ... and ... and tn = ...] *) + | Pstr_typext of type_extension (** [type t1 += ...] *) + | Pstr_exception of type_exception + (** - [exception C of T] + - [exception C = M.X] *) + | Pstr_module of module_binding (** [module X = ME] *) + | Pstr_recmodule of module_binding list + (** [module rec X1 = ME1 and ... and Xn = MEn] *) + | Pstr_modtype of module_type_declaration (** [module type S = MT] *) + | Pstr_open of open_declaration (** [open X] *) + | Pstr_class of class_declaration list + (** [class c1 = ... and ... and cn = ...] *) + | 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_extension of extension * attributes (** [[%%id]] *) + + and value_constraint (*IF_CURRENT = 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 (*IF_CURRENT = Parsetree.value_binding *) = + { + pvb_pat: pattern; + pvb_expr: expression; + pvb_constraint: value_constraint option; + pvb_attributes: attributes; + pvb_loc: Location.t; + } + + and module_binding (*IF_CURRENT = Parsetree.module_binding *) = + { + pmb_name: string option loc; + pmb_expr: module_expr; + pmb_attributes: attributes; + pmb_loc: Location.t; + } + (** Values of type [module_binding] represents [module X = ME] *) + + (** {1 Toplevel} *) + + (** {2 Toplevel phrases} *) + + type toplevel_phrase (*IF_CURRENT = Parsetree.toplevel_phrase *) = + | Ptop_def of structure + | Ptop_dir of toplevel_directive (** [#use], [#load] ... *) + + and toplevel_directive (*IF_CURRENT = Parsetree.toplevel_directive *) = + { + pdir_name: string loc; + pdir_arg: directive_argument option; + pdir_loc: Location.t; + } + + and directive_argument (*IF_CURRENT = Parsetree.directive_argument *) = + { + pdira_desc: directive_argument_desc; + pdira_loc: Location.t; + } + + and directive_argument_desc (*IF_CURRENT = Parsetree.directive_argument_desc *) = + | Pdir_string of string + | Pdir_int of string * char option + | Pdir_ident of Longident.t + | Pdir_bool of bool +end + +module Config = struct + let ast_impl_magic_number = "Caml1999M033" + let ast_intf_magic_number = "Caml1999N033" +end diff --git a/astlib/astlib.ml b/astlib/astlib.ml index a77918400..d13d986c9 100644 --- a/astlib/astlib.ml +++ b/astlib/astlib.ml @@ -36,6 +36,7 @@ module Ast_412 = Ast_412 module Ast_413 = Ast_413 module Ast_414 = Ast_414 module Ast_500 = Ast_500 +module Ast_501 = Ast_501 (*$*) (* Manual migration between versions *) @@ -70,6 +71,8 @@ module Migrate_413_414 = Migrate_413_414 module Migrate_414_413 = Migrate_414_413 module Migrate_414_500 = Migrate_414_500 module Migrate_500_414 = Migrate_500_414 +module Migrate_500_501 = Migrate_500_501 +module Migrate_501_500 = Migrate_501_500 (*$*) (* Compiler modules *) diff --git a/astlib/cinaps/astlib_cinaps_helpers.ml b/astlib/cinaps/astlib_cinaps_helpers.ml index 15ebcfacf..550c84021 100644 --- a/astlib/cinaps/astlib_cinaps_helpers.ml +++ b/astlib/cinaps/astlib_cinaps_helpers.ml @@ -21,6 +21,7 @@ let supported_versions = ("413", "4.13"); ("414", "4.14"); ("500", "5.00"); + ("501", "5.01"); ] let foreach_version f = diff --git a/astlib/config/gen.ml b/astlib/config/gen.ml index b29965fb9..e590dda34 100644 --- a/astlib/config/gen.ml +++ b/astlib/config/gen.ml @@ -26,6 +26,7 @@ let () = | 5, 0 -> "414" (* Ast_500 aliases Ast_414, since the AST hasn't changed between those two *) + | 5, 1 -> "501" | _ -> Printf.eprintf "Unknown OCaml version %s\n" ocaml_version_str; exit 1) diff --git a/astlib/migrate_500_501.ml b/astlib/migrate_500_501.ml new file mode 100644 index 000000000..bb26e4f38 --- /dev/null +++ b/astlib/migrate_500_501.ml @@ -0,0 +1,1358 @@ +open Stdlib0 +module From = Ast_500 +module To = Ast_501 + +let rec copy_toplevel_phrase : + Ast_500.Parsetree.toplevel_phrase -> Ast_501.Parsetree.toplevel_phrase = + function + | Ast_500.Parsetree.Ptop_def x0 -> + Ast_501.Parsetree.Ptop_def (copy_structure x0) + | Ast_500.Parsetree.Ptop_dir x0 -> + Ast_501.Parsetree.Ptop_dir (copy_toplevel_directive x0) + +and copy_toplevel_directive : + Ast_500.Parsetree.toplevel_directive -> Ast_501.Parsetree.toplevel_directive + = + fun { + Ast_500.Parsetree.pdir_name; + Ast_500.Parsetree.pdir_arg; + Ast_500.Parsetree.pdir_loc; + } -> + { + Ast_501.Parsetree.pdir_name = copy_loc (fun x -> x) pdir_name; + Ast_501.Parsetree.pdir_arg = Option.map copy_directive_argument pdir_arg; + Ast_501.Parsetree.pdir_loc = copy_location pdir_loc; + } + +and copy_directive_argument : + Ast_500.Parsetree.directive_argument -> Ast_501.Parsetree.directive_argument + = + fun { Ast_500.Parsetree.pdira_desc; Ast_500.Parsetree.pdira_loc } -> + { + Ast_501.Parsetree.pdira_desc = copy_directive_argument_desc pdira_desc; + Ast_501.Parsetree.pdira_loc = copy_location pdira_loc; + } + +and copy_directive_argument_desc : + Ast_500.Parsetree.directive_argument_desc -> + Ast_501.Parsetree.directive_argument_desc = function + | Ast_500.Parsetree.Pdir_string x0 -> Ast_501.Parsetree.Pdir_string x0 + | Ast_500.Parsetree.Pdir_int (x0, x1) -> + Ast_501.Parsetree.Pdir_int (x0, Option.map (fun x -> x) x1) + | Ast_500.Parsetree.Pdir_ident x0 -> + Ast_501.Parsetree.Pdir_ident (copy_Longident_t x0) + | Ast_500.Parsetree.Pdir_bool x0 -> Ast_501.Parsetree.Pdir_bool x0 + +and copy_expression : + Ast_500.Parsetree.expression -> Ast_501.Parsetree.expression = + fun { + Ast_500.Parsetree.pexp_desc; + Ast_500.Parsetree.pexp_loc; + Ast_500.Parsetree.pexp_loc_stack; + Ast_500.Parsetree.pexp_attributes; + } -> + { + Ast_501.Parsetree.pexp_desc = copy_expression_desc pexp_desc; + Ast_501.Parsetree.pexp_loc = copy_location pexp_loc; + Ast_501.Parsetree.pexp_loc_stack = copy_location_stack pexp_loc_stack; + Ast_501.Parsetree.pexp_attributes = copy_attributes pexp_attributes; + } + +and copy_expression_desc : + Ast_500.Parsetree.expression_desc -> Ast_501.Parsetree.expression_desc = + function + | Ast_500.Parsetree.Pexp_ident x0 -> + Ast_501.Parsetree.Pexp_ident (copy_loc copy_Longident_t x0) + | Ast_500.Parsetree.Pexp_constant x0 -> + Ast_501.Parsetree.Pexp_constant (copy_constant x0) + | Ast_500.Parsetree.Pexp_let (x0, x1, x2) -> + Ast_501.Parsetree.Pexp_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_expression x2) + | Ast_500.Parsetree.Pexp_function x0 -> + Ast_501.Parsetree.Pexp_function (List.map copy_case x0) + | Ast_500.Parsetree.Pexp_fun (x0, x1, x2, x3) -> + Ast_501.Parsetree.Pexp_fun + ( copy_arg_label x0, + Option.map copy_expression x1, + copy_pattern x2, + copy_expression x3 ) + | Ast_500.Parsetree.Pexp_apply (x0, x1) -> + Ast_501.Parsetree.Pexp_apply + ( copy_expression x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | Ast_500.Parsetree.Pexp_match (x0, x1) -> + Ast_501.Parsetree.Pexp_match (copy_expression x0, List.map copy_case x1) + | Ast_500.Parsetree.Pexp_try (x0, x1) -> + Ast_501.Parsetree.Pexp_try (copy_expression x0, List.map copy_case x1) + | Ast_500.Parsetree.Pexp_tuple x0 -> + Ast_501.Parsetree.Pexp_tuple (List.map copy_expression x0) + | Ast_500.Parsetree.Pexp_construct (x0, x1) -> + Ast_501.Parsetree.Pexp_construct + (copy_loc copy_Longident_t x0, Option.map copy_expression x1) + | Ast_500.Parsetree.Pexp_variant (x0, x1) -> + Ast_501.Parsetree.Pexp_variant + (copy_label x0, Option.map copy_expression x1) + | Ast_500.Parsetree.Pexp_record (x0, x1) -> + Ast_501.Parsetree.Pexp_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_Longident_t x0, copy_expression x1)) + x0, + Option.map copy_expression x1 ) + | Ast_500.Parsetree.Pexp_field (x0, x1) -> + Ast_501.Parsetree.Pexp_field + (copy_expression x0, copy_loc copy_Longident_t x1) + | Ast_500.Parsetree.Pexp_setfield (x0, x1, x2) -> + Ast_501.Parsetree.Pexp_setfield + (copy_expression x0, copy_loc copy_Longident_t x1, copy_expression x2) + | Ast_500.Parsetree.Pexp_array x0 -> + Ast_501.Parsetree.Pexp_array (List.map copy_expression x0) + | Ast_500.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> + Ast_501.Parsetree.Pexp_ifthenelse + (copy_expression x0, copy_expression x1, Option.map copy_expression x2) + | Ast_500.Parsetree.Pexp_sequence (x0, x1) -> + Ast_501.Parsetree.Pexp_sequence (copy_expression x0, copy_expression x1) + | Ast_500.Parsetree.Pexp_while (x0, x1) -> + Ast_501.Parsetree.Pexp_while (copy_expression x0, copy_expression x1) + | Ast_500.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> + Ast_501.Parsetree.Pexp_for + ( copy_pattern x0, + copy_expression x1, + copy_expression x2, + copy_direction_flag x3, + copy_expression x4 ) + | Ast_500.Parsetree.Pexp_constraint (x0, x1) -> + Ast_501.Parsetree.Pexp_constraint (copy_expression x0, copy_core_type x1) + | Ast_500.Parsetree.Pexp_coerce (x0, x1, x2) -> + Ast_501.Parsetree.Pexp_coerce + (copy_expression x0, Option.map copy_core_type x1, copy_core_type x2) + | Ast_500.Parsetree.Pexp_send (x0, x1) -> + Ast_501.Parsetree.Pexp_send (copy_expression x0, copy_loc copy_label x1) + | Ast_500.Parsetree.Pexp_new x0 -> + Ast_501.Parsetree.Pexp_new (copy_loc copy_Longident_t x0) + | Ast_500.Parsetree.Pexp_setinstvar (x0, x1) -> + Ast_501.Parsetree.Pexp_setinstvar + (copy_loc copy_label x0, copy_expression x1) + | Ast_500.Parsetree.Pexp_override x0 -> + Ast_501.Parsetree.Pexp_override + (List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_label x0, copy_expression x1)) + x0) + | Ast_500.Parsetree.Pexp_letmodule (x0, x1, x2) -> + Ast_501.Parsetree.Pexp_letmodule + ( copy_loc (fun x -> Option.map (fun x -> x) x) x0, + copy_module_expr x1, + copy_expression x2 ) + | Ast_500.Parsetree.Pexp_letexception (x0, x1) -> + Ast_501.Parsetree.Pexp_letexception + (copy_extension_constructor x0, copy_expression x1) + | Ast_500.Parsetree.Pexp_assert x0 -> + Ast_501.Parsetree.Pexp_assert (copy_expression x0) + | Ast_500.Parsetree.Pexp_lazy x0 -> + Ast_501.Parsetree.Pexp_lazy (copy_expression x0) + | Ast_500.Parsetree.Pexp_poly (x0, x1) -> + Ast_501.Parsetree.Pexp_poly + (copy_expression x0, Option.map copy_core_type x1) + | Ast_500.Parsetree.Pexp_object x0 -> + Ast_501.Parsetree.Pexp_object (copy_class_structure x0) + | Ast_500.Parsetree.Pexp_newtype (x0, x1) -> + Ast_501.Parsetree.Pexp_newtype + (copy_loc (fun x -> x) x0, copy_expression x1) + | Ast_500.Parsetree.Pexp_pack x0 -> + Ast_501.Parsetree.Pexp_pack (copy_module_expr x0) + | Ast_500.Parsetree.Pexp_open (x0, x1) -> + Ast_501.Parsetree.Pexp_open (copy_open_declaration x0, copy_expression x1) + | Ast_500.Parsetree.Pexp_letop x0 -> + Ast_501.Parsetree.Pexp_letop (copy_letop x0) + | Ast_500.Parsetree.Pexp_extension x0 -> + Ast_501.Parsetree.Pexp_extension (copy_extension x0) + | Ast_500.Parsetree.Pexp_unreachable -> Ast_501.Parsetree.Pexp_unreachable + +and copy_letop : Ast_500.Parsetree.letop -> Ast_501.Parsetree.letop = + fun { Ast_500.Parsetree.let_; Ast_500.Parsetree.ands; Ast_500.Parsetree.body } -> + { + Ast_501.Parsetree.let_ = copy_binding_op let_; + Ast_501.Parsetree.ands = List.map copy_binding_op ands; + Ast_501.Parsetree.body = copy_expression body; + } + +and copy_binding_op : + Ast_500.Parsetree.binding_op -> Ast_501.Parsetree.binding_op = + fun { + Ast_500.Parsetree.pbop_op; + Ast_500.Parsetree.pbop_pat; + Ast_500.Parsetree.pbop_exp; + Ast_500.Parsetree.pbop_loc; + } -> + { + Ast_501.Parsetree.pbop_op = copy_loc (fun x -> x) pbop_op; + Ast_501.Parsetree.pbop_pat = copy_pattern pbop_pat; + Ast_501.Parsetree.pbop_exp = copy_expression pbop_exp; + Ast_501.Parsetree.pbop_loc = copy_location pbop_loc; + } + +and copy_direction_flag : + Ast_500.Asttypes.direction_flag -> Ast_501.Asttypes.direction_flag = + function + | Ast_500.Asttypes.Upto -> Ast_501.Asttypes.Upto + | Ast_500.Asttypes.Downto -> Ast_501.Asttypes.Downto + +and copy_case : Ast_500.Parsetree.case -> Ast_501.Parsetree.case = + fun { + Ast_500.Parsetree.pc_lhs; + Ast_500.Parsetree.pc_guard; + Ast_500.Parsetree.pc_rhs; + } -> + { + Ast_501.Parsetree.pc_lhs = copy_pattern pc_lhs; + Ast_501.Parsetree.pc_guard = Option.map copy_expression pc_guard; + Ast_501.Parsetree.pc_rhs = copy_expression pc_rhs; + } + +and copy_value_binding : + Ast_500.Parsetree.value_binding -> Ast_501.Parsetree.value_binding = + fun { + Ast_500.Parsetree.pvb_pat; + Ast_500.Parsetree.pvb_expr; + Ast_500.Parsetree.pvb_attributes; + Ast_500.Parsetree.pvb_loc; + } -> + (* Copied and adapted from OCaml 5.0 Ast_helper *) + let varify_constructors var_names t = + let var_names = List.map (fun v -> v.Location.txt) var_names in + let rec loop t = + let desc = + match t.Ast_500.Parsetree.ptyp_desc with + | Ast_500.Parsetree.Ptyp_any -> Ast_500.Parsetree.Ptyp_any + | Ptyp_var x -> Ptyp_var x + | Ptyp_arrow (label, core_type, core_type') -> + Ptyp_arrow (label, loop core_type, loop core_type') + | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) + | Ptyp_constr ({ txt = Longident.Lident s }, []) + when List.mem s var_names -> + Ptyp_var s + | Ptyp_constr (longident, lst) -> + Ptyp_constr (longident, List.map loop lst) + | 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) -> Ptyp_alias (loop core_type, string) + | Ptyp_variant (row_field_list, flag, lbl_lst_option) -> + Ptyp_variant + (List.map loop_row_field row_field_list, flag, lbl_lst_option) + | Ptyp_poly (string_lst, core_type) -> + Ptyp_poly (string_lst, loop core_type) + | Ptyp_package (longident, lst) -> + Ptyp_package + (longident, List.map (fun (n, typ) -> (n, loop typ)) lst) + | Ptyp_extension (s, arg) -> Ptyp_extension (s, arg) + in + { t with ptyp_desc = desc } + and loop_row_field field = + let prf_desc = + match field.prf_desc with + | Ast_500.Parsetree.Rtag (label, flag, lst) -> + Ast_500.Parsetree.Rtag (label, flag, List.map loop lst) + | Rinherit t -> Rinherit (loop t) + in + { field with prf_desc } + and loop_object_field field = + let pof_desc = + match field.pof_desc with + | Ast_500.Parsetree.Otag (label, t) -> + Ast_500.Parsetree.Otag (label, loop t) + | Oinherit t -> Oinherit (loop t) + in + { field with pof_desc } + in + loop t + in + (* Match the form of the expr and pattern to decide the value of + [pvb_constraint]. Adapted from OCaml 5.0 PPrinter. *) + let tyvars_str tyvars = List.map (fun v -> v.Location.txt) tyvars in + let resugarable_value_binding p e = + let value_pattern = + match p with + | { + Ast_500.Parsetree.ppat_desc = + Ppat_constraint + ( ({ ppat_desc = Ppat_var _ } as pat), + ({ ptyp_desc = Ptyp_poly (args_tyvars, rt) } as ty_ext) ); + ppat_attributes = []; + } -> + assert (match rt.ptyp_desc with Ptyp_poly _ -> false | _ -> true); + let ty = match args_tyvars with [] -> rt | _ -> ty_ext in + `Var (pat, args_tyvars, rt, ty) + | { + Ast_500.Parsetree.ppat_desc = Ppat_constraint (pat, rt); + ppat_attributes = []; + } -> + `NonVar (pat, rt) + | _ -> `None + in + let rec value_exp tyvars e = + match e with + | { + Ast_500.Parsetree.pexp_desc = Pexp_newtype (tyvar, e); + pexp_attributes = []; + } -> + value_exp (tyvar :: tyvars) e + | { pexp_desc = Pexp_constraint (e, ct); pexp_attributes = [] } -> + Some (List.rev tyvars, e, ct) + | _ -> None + in + let value_exp = value_exp [] e in + match (value_pattern, value_exp) with + | `Var (p, pt_tyvars, pt_ct, extern_ct), Some (e_tyvars, inner_e, e_ct) + when tyvars_str pt_tyvars = tyvars_str e_tyvars -> + let ety = varify_constructors e_tyvars e_ct in + if ety = pt_ct then + `Desugared_locally_abstract (p, pt_tyvars, e_ct, inner_e) + else + (* the expression constraint and the pattern constraint, + don't match, but we still have a Ptyp_poly pattern constraint that + should be resugared to a value binding *) + `Univars (p, pt_tyvars, extern_ct, e) + | `Var (p, pt_tyvars, pt_ct, extern_ct), _ -> + `Univars (p, pt_tyvars, extern_ct, e) + | `NonVar (pat, ct), _ -> `NonVar (pat, ct, e) + | _ -> `None + in + let with_constraint ty_vars typ = + let typ = copy_core_type typ in + Some + (Ast_501.Parsetree.Pvc_constraint + { locally_abstract_univars = ty_vars; typ }) + in + let pvb_pat, pvb_expr, pvb_constraint = + match resugarable_value_binding pvb_pat pvb_expr with + | `Desugared_locally_abstract (p, ty_vars, typ, e) -> + (p, e, with_constraint ty_vars typ) + | `Univars (pat, [], ct, expr) -> ( + (* check if we are in the [let x : ty? :> coer = expr ] case *) + match expr with + | { pexp_desc = Pexp_coerce (expr, gr, coerce); pexp_attributes = [] } + -> + let ground = Option.map copy_core_type gr in + let coercion = copy_core_type coerce in + let pvb_constraint = + Some (Ast_501.Parsetree.Pvc_coercion { ground; coercion }) + in + (pat, expr, pvb_constraint) + | _ -> (pat, expr, with_constraint [] ct)) + | `Univars (pat, _, ct, expr) -> (pat, expr, with_constraint [] ct) + | `NonVar (p, typ, e) -> (p, e, with_constraint [] typ) + | `None -> (pvb_pat, pvb_expr, None) + in + { + Ast_501.Parsetree.pvb_pat = copy_pattern pvb_pat; + Ast_501.Parsetree.pvb_expr = copy_expression pvb_expr; + Ast_501.Parsetree.pvb_constraint; + Ast_501.Parsetree.pvb_attributes = copy_attributes pvb_attributes; + Ast_501.Parsetree.pvb_loc = copy_location pvb_loc; + } + +and copy_pattern : Ast_500.Parsetree.pattern -> Ast_501.Parsetree.pattern = + fun { + Ast_500.Parsetree.ppat_desc; + Ast_500.Parsetree.ppat_loc; + Ast_500.Parsetree.ppat_loc_stack; + Ast_500.Parsetree.ppat_attributes; + } -> + { + Ast_501.Parsetree.ppat_desc = copy_pattern_desc ppat_desc; + Ast_501.Parsetree.ppat_loc = copy_location ppat_loc; + Ast_501.Parsetree.ppat_loc_stack = copy_location_stack ppat_loc_stack; + Ast_501.Parsetree.ppat_attributes = copy_attributes ppat_attributes; + } + +and copy_pattern_desc : + Ast_500.Parsetree.pattern_desc -> Ast_501.Parsetree.pattern_desc = function + | Ast_500.Parsetree.Ppat_any -> Ast_501.Parsetree.Ppat_any + | Ast_500.Parsetree.Ppat_var x0 -> + Ast_501.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) + | Ast_500.Parsetree.Ppat_alias (x0, x1) -> + Ast_501.Parsetree.Ppat_alias (copy_pattern x0, copy_loc (fun x -> x) x1) + | Ast_500.Parsetree.Ppat_constant x0 -> + Ast_501.Parsetree.Ppat_constant (copy_constant x0) + | Ast_500.Parsetree.Ppat_interval (x0, x1) -> + Ast_501.Parsetree.Ppat_interval (copy_constant x0, copy_constant x1) + | Ast_500.Parsetree.Ppat_tuple x0 -> + Ast_501.Parsetree.Ppat_tuple (List.map copy_pattern x0) + | Ast_500.Parsetree.Ppat_construct (x0, x1) -> + Ast_501.Parsetree.Ppat_construct + ( copy_loc copy_Longident_t x0, + Option.map + (fun x -> + let x0, x1 = x in + (List.map (fun x -> copy_loc (fun x -> x) x) x0, copy_pattern x1)) + x1 ) + | Ast_500.Parsetree.Ppat_variant (x0, x1) -> + Ast_501.Parsetree.Ppat_variant (copy_label x0, Option.map copy_pattern x1) + | Ast_500.Parsetree.Ppat_record (x0, x1) -> + Ast_501.Parsetree.Ppat_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_Longident_t x0, copy_pattern x1)) + x0, + copy_closed_flag x1 ) + | Ast_500.Parsetree.Ppat_array x0 -> + Ast_501.Parsetree.Ppat_array (List.map copy_pattern x0) + | Ast_500.Parsetree.Ppat_or (x0, x1) -> + Ast_501.Parsetree.Ppat_or (copy_pattern x0, copy_pattern x1) + | Ast_500.Parsetree.Ppat_constraint (x0, x1) -> + Ast_501.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1) + | Ast_500.Parsetree.Ppat_type x0 -> + Ast_501.Parsetree.Ppat_type (copy_loc copy_Longident_t x0) + | Ast_500.Parsetree.Ppat_lazy x0 -> + Ast_501.Parsetree.Ppat_lazy (copy_pattern x0) + | Ast_500.Parsetree.Ppat_unpack x0 -> + Ast_501.Parsetree.Ppat_unpack + (copy_loc (fun x -> Option.map (fun x -> x) x) x0) + | Ast_500.Parsetree.Ppat_exception x0 -> + Ast_501.Parsetree.Ppat_exception (copy_pattern x0) + | Ast_500.Parsetree.Ppat_extension x0 -> + Ast_501.Parsetree.Ppat_extension (copy_extension x0) + | Ast_500.Parsetree.Ppat_open (x0, x1) -> + Ast_501.Parsetree.Ppat_open (copy_loc copy_Longident_t x0, copy_pattern x1) + +and copy_core_type : Ast_500.Parsetree.core_type -> Ast_501.Parsetree.core_type + = + fun { + Ast_500.Parsetree.ptyp_desc; + Ast_500.Parsetree.ptyp_loc; + Ast_500.Parsetree.ptyp_loc_stack; + Ast_500.Parsetree.ptyp_attributes; + } -> + { + Ast_501.Parsetree.ptyp_desc = copy_core_type_desc ptyp_desc; + Ast_501.Parsetree.ptyp_loc = copy_location ptyp_loc; + Ast_501.Parsetree.ptyp_loc_stack = copy_location_stack ptyp_loc_stack; + Ast_501.Parsetree.ptyp_attributes = copy_attributes ptyp_attributes; + } + +and copy_location_stack : + Ast_500.Parsetree.location_stack -> Ast_501.Parsetree.location_stack = + fun x -> List.map copy_location x + +and copy_core_type_desc : + Ast_500.Parsetree.core_type_desc -> Ast_501.Parsetree.core_type_desc = + function + | Ast_500.Parsetree.Ptyp_any -> Ast_501.Parsetree.Ptyp_any + | Ast_500.Parsetree.Ptyp_var x0 -> Ast_501.Parsetree.Ptyp_var x0 + | Ast_500.Parsetree.Ptyp_arrow (x0, x1, x2) -> + Ast_501.Parsetree.Ptyp_arrow + (copy_arg_label x0, copy_core_type x1, copy_core_type x2) + | Ast_500.Parsetree.Ptyp_tuple x0 -> + Ast_501.Parsetree.Ptyp_tuple (List.map copy_core_type x0) + | Ast_500.Parsetree.Ptyp_constr (x0, x1) -> + Ast_501.Parsetree.Ptyp_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_500.Parsetree.Ptyp_object (x0, x1) -> + Ast_501.Parsetree.Ptyp_object + (List.map copy_object_field x0, copy_closed_flag x1) + | Ast_500.Parsetree.Ptyp_class (x0, x1) -> + Ast_501.Parsetree.Ptyp_class + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_500.Parsetree.Ptyp_alias (x0, x1) -> + Ast_501.Parsetree.Ptyp_alias (copy_core_type x0, x1) + | Ast_500.Parsetree.Ptyp_variant (x0, x1, x2) -> + Ast_501.Parsetree.Ptyp_variant + ( List.map copy_row_field x0, + copy_closed_flag x1, + Option.map (fun x -> List.map copy_label x) x2 ) + | Ast_500.Parsetree.Ptyp_poly (x0, x1) -> + Ast_501.Parsetree.Ptyp_poly + (List.map (fun x -> copy_loc (fun x -> x) x) x0, copy_core_type x1) + | Ast_500.Parsetree.Ptyp_package x0 -> + Ast_501.Parsetree.Ptyp_package (copy_package_type x0) + | Ast_500.Parsetree.Ptyp_extension x0 -> + Ast_501.Parsetree.Ptyp_extension (copy_extension x0) + +and copy_package_type : + Ast_500.Parsetree.package_type -> Ast_501.Parsetree.package_type = + fun x -> + let x0, x1 = x in + ( copy_loc copy_Longident_t x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_Longident_t x0, copy_core_type x1)) + x1 ) + +and copy_row_field : Ast_500.Parsetree.row_field -> Ast_501.Parsetree.row_field + = + fun { + Ast_500.Parsetree.prf_desc; + Ast_500.Parsetree.prf_loc; + Ast_500.Parsetree.prf_attributes; + } -> + { + Ast_501.Parsetree.prf_desc = copy_row_field_desc prf_desc; + Ast_501.Parsetree.prf_loc = copy_location prf_loc; + Ast_501.Parsetree.prf_attributes = copy_attributes prf_attributes; + } + +and copy_row_field_desc : + Ast_500.Parsetree.row_field_desc -> Ast_501.Parsetree.row_field_desc = + function + | Ast_500.Parsetree.Rtag (x0, x1, x2) -> + Ast_501.Parsetree.Rtag + (copy_loc copy_label x0, x1, List.map copy_core_type x2) + | Ast_500.Parsetree.Rinherit x0 -> + Ast_501.Parsetree.Rinherit (copy_core_type x0) + +and copy_object_field : + Ast_500.Parsetree.object_field -> Ast_501.Parsetree.object_field = + fun { + Ast_500.Parsetree.pof_desc; + Ast_500.Parsetree.pof_loc; + Ast_500.Parsetree.pof_attributes; + } -> + { + Ast_501.Parsetree.pof_desc = copy_object_field_desc pof_desc; + Ast_501.Parsetree.pof_loc = copy_location pof_loc; + Ast_501.Parsetree.pof_attributes = copy_attributes pof_attributes; + } + +and copy_attributes : + Ast_500.Parsetree.attributes -> Ast_501.Parsetree.attributes = + fun x -> List.map copy_attribute x + +and copy_attribute : Ast_500.Parsetree.attribute -> Ast_501.Parsetree.attribute + = + fun { + Ast_500.Parsetree.attr_name; + Ast_500.Parsetree.attr_payload; + Ast_500.Parsetree.attr_loc; + } -> + { + Ast_501.Parsetree.attr_name = copy_loc (fun x -> x) attr_name; + Ast_501.Parsetree.attr_payload = copy_payload attr_payload; + Ast_501.Parsetree.attr_loc = copy_location attr_loc; + } + +and copy_payload : Ast_500.Parsetree.payload -> Ast_501.Parsetree.payload = + function + | Ast_500.Parsetree.PStr x0 -> Ast_501.Parsetree.PStr (copy_structure x0) + | Ast_500.Parsetree.PSig x0 -> Ast_501.Parsetree.PSig (copy_signature x0) + | Ast_500.Parsetree.PTyp x0 -> Ast_501.Parsetree.PTyp (copy_core_type x0) + | Ast_500.Parsetree.PPat (x0, x1) -> + Ast_501.Parsetree.PPat (copy_pattern x0, Option.map copy_expression x1) + +and copy_structure : Ast_500.Parsetree.structure -> Ast_501.Parsetree.structure + = + fun x -> List.map copy_structure_item x + +and copy_structure_item : + Ast_500.Parsetree.structure_item -> Ast_501.Parsetree.structure_item = + fun { Ast_500.Parsetree.pstr_desc; Ast_500.Parsetree.pstr_loc } -> + { + Ast_501.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc; + Ast_501.Parsetree.pstr_loc = copy_location pstr_loc; + } + +and copy_structure_item_desc : + Ast_500.Parsetree.structure_item_desc -> + Ast_501.Parsetree.structure_item_desc = function + | Ast_500.Parsetree.Pstr_eval (x0, x1) -> + Ast_501.Parsetree.Pstr_eval (copy_expression x0, copy_attributes x1) + | Ast_500.Parsetree.Pstr_value (x0, x1) -> + Ast_501.Parsetree.Pstr_value + (copy_rec_flag x0, List.map copy_value_binding x1) + | Ast_500.Parsetree.Pstr_primitive x0 -> + Ast_501.Parsetree.Pstr_primitive (copy_value_description x0) + | Ast_500.Parsetree.Pstr_type (x0, x1) -> + Ast_501.Parsetree.Pstr_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | Ast_500.Parsetree.Pstr_typext x0 -> + Ast_501.Parsetree.Pstr_typext (copy_type_extension x0) + | Ast_500.Parsetree.Pstr_exception x0 -> + Ast_501.Parsetree.Pstr_exception (copy_type_exception x0) + | Ast_500.Parsetree.Pstr_module x0 -> + Ast_501.Parsetree.Pstr_module (copy_module_binding x0) + | Ast_500.Parsetree.Pstr_recmodule x0 -> + Ast_501.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) + | Ast_500.Parsetree.Pstr_modtype x0 -> + Ast_501.Parsetree.Pstr_modtype (copy_module_type_declaration x0) + | Ast_500.Parsetree.Pstr_open x0 -> + Ast_501.Parsetree.Pstr_open (copy_open_declaration x0) + | Ast_500.Parsetree.Pstr_class x0 -> + Ast_501.Parsetree.Pstr_class (List.map copy_class_declaration x0) + | Ast_500.Parsetree.Pstr_class_type x0 -> + Ast_501.Parsetree.Pstr_class_type + (List.map copy_class_type_declaration x0) + | Ast_500.Parsetree.Pstr_include x0 -> + Ast_501.Parsetree.Pstr_include (copy_include_declaration x0) + | Ast_500.Parsetree.Pstr_attribute x0 -> + Ast_501.Parsetree.Pstr_attribute (copy_attribute x0) + | Ast_500.Parsetree.Pstr_extension (x0, x1) -> + Ast_501.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1) + +and copy_include_declaration : + Ast_500.Parsetree.include_declaration -> + Ast_501.Parsetree.include_declaration = + fun x -> copy_include_infos copy_module_expr x + +and copy_class_declaration : + Ast_500.Parsetree.class_declaration -> Ast_501.Parsetree.class_declaration = + fun x -> copy_class_infos copy_class_expr x + +and copy_class_expr : + Ast_500.Parsetree.class_expr -> Ast_501.Parsetree.class_expr = + fun { + Ast_500.Parsetree.pcl_desc; + Ast_500.Parsetree.pcl_loc; + Ast_500.Parsetree.pcl_attributes; + } -> + { + Ast_501.Parsetree.pcl_desc = copy_class_expr_desc pcl_desc; + Ast_501.Parsetree.pcl_loc = copy_location pcl_loc; + Ast_501.Parsetree.pcl_attributes = copy_attributes pcl_attributes; + } + +and copy_class_expr_desc : + Ast_500.Parsetree.class_expr_desc -> Ast_501.Parsetree.class_expr_desc = + function + | Ast_500.Parsetree.Pcl_constr (x0, x1) -> + Ast_501.Parsetree.Pcl_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_500.Parsetree.Pcl_structure x0 -> + Ast_501.Parsetree.Pcl_structure (copy_class_structure x0) + | Ast_500.Parsetree.Pcl_fun (x0, x1, x2, x3) -> + Ast_501.Parsetree.Pcl_fun + ( copy_arg_label x0, + Option.map copy_expression x1, + copy_pattern x2, + copy_class_expr x3 ) + | Ast_500.Parsetree.Pcl_apply (x0, x1) -> + Ast_501.Parsetree.Pcl_apply + ( copy_class_expr x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | Ast_500.Parsetree.Pcl_let (x0, x1, x2) -> + Ast_501.Parsetree.Pcl_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_class_expr x2) + | Ast_500.Parsetree.Pcl_constraint (x0, x1) -> + Ast_501.Parsetree.Pcl_constraint (copy_class_expr x0, copy_class_type x1) + | Ast_500.Parsetree.Pcl_extension x0 -> + Ast_501.Parsetree.Pcl_extension (copy_extension x0) + | Ast_500.Parsetree.Pcl_open (x0, x1) -> + Ast_501.Parsetree.Pcl_open (copy_open_description x0, copy_class_expr x1) + +and copy_class_structure : + Ast_500.Parsetree.class_structure -> Ast_501.Parsetree.class_structure = + fun { Ast_500.Parsetree.pcstr_self; Ast_500.Parsetree.pcstr_fields } -> + { + Ast_501.Parsetree.pcstr_self = copy_pattern pcstr_self; + Ast_501.Parsetree.pcstr_fields = List.map copy_class_field pcstr_fields; + } + +and copy_class_field : + Ast_500.Parsetree.class_field -> Ast_501.Parsetree.class_field = + fun { + Ast_500.Parsetree.pcf_desc; + Ast_500.Parsetree.pcf_loc; + Ast_500.Parsetree.pcf_attributes; + } -> + { + Ast_501.Parsetree.pcf_desc = copy_class_field_desc pcf_desc; + Ast_501.Parsetree.pcf_loc = copy_location pcf_loc; + Ast_501.Parsetree.pcf_attributes = copy_attributes pcf_attributes; + } + +and copy_class_field_desc : + Ast_500.Parsetree.class_field_desc -> Ast_501.Parsetree.class_field_desc = + function + | Ast_500.Parsetree.Pcf_inherit (x0, x1, x2) -> + Ast_501.Parsetree.Pcf_inherit + ( copy_override_flag x0, + copy_class_expr x1, + Option.map (fun x -> copy_loc (fun x -> x) x) x2 ) + | Ast_500.Parsetree.Pcf_val x0 -> + Ast_501.Parsetree.Pcf_val + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_mutable_flag x1, copy_class_field_kind x2)) + | Ast_500.Parsetree.Pcf_method x0 -> + Ast_501.Parsetree.Pcf_method + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_private_flag x1, copy_class_field_kind x2)) + | Ast_500.Parsetree.Pcf_constraint x0 -> + Ast_501.Parsetree.Pcf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | Ast_500.Parsetree.Pcf_initializer x0 -> + Ast_501.Parsetree.Pcf_initializer (copy_expression x0) + | Ast_500.Parsetree.Pcf_attribute x0 -> + Ast_501.Parsetree.Pcf_attribute (copy_attribute x0) + | Ast_500.Parsetree.Pcf_extension x0 -> + Ast_501.Parsetree.Pcf_extension (copy_extension x0) + +and copy_class_field_kind : + Ast_500.Parsetree.class_field_kind -> Ast_501.Parsetree.class_field_kind = + function + | Ast_500.Parsetree.Cfk_virtual x0 -> + Ast_501.Parsetree.Cfk_virtual (copy_core_type x0) + | Ast_500.Parsetree.Cfk_concrete (x0, x1) -> + Ast_501.Parsetree.Cfk_concrete (copy_override_flag x0, copy_expression x1) + +and copy_open_declaration : + Ast_500.Parsetree.open_declaration -> Ast_501.Parsetree.open_declaration = + fun x -> copy_open_infos copy_module_expr x + +and copy_module_binding : + Ast_500.Parsetree.module_binding -> Ast_501.Parsetree.module_binding = + fun { + Ast_500.Parsetree.pmb_name; + Ast_500.Parsetree.pmb_expr; + Ast_500.Parsetree.pmb_attributes; + Ast_500.Parsetree.pmb_loc; + } -> + { + Ast_501.Parsetree.pmb_name = + copy_loc (fun x -> Option.map (fun x -> x) x) pmb_name; + Ast_501.Parsetree.pmb_expr = copy_module_expr pmb_expr; + Ast_501.Parsetree.pmb_attributes = copy_attributes pmb_attributes; + Ast_501.Parsetree.pmb_loc = copy_location pmb_loc; + } + +and copy_module_expr : + Ast_500.Parsetree.module_expr -> Ast_501.Parsetree.module_expr = + fun { + Ast_500.Parsetree.pmod_desc; + Ast_500.Parsetree.pmod_loc; + Ast_500.Parsetree.pmod_attributes; + } -> + { + Ast_501.Parsetree.pmod_desc = copy_module_expr_desc pmod_desc; + Ast_501.Parsetree.pmod_loc = copy_location pmod_loc; + Ast_501.Parsetree.pmod_attributes = copy_attributes pmod_attributes; + } + +and copy_module_expr_desc : + Ast_500.Parsetree.module_expr_desc -> Ast_501.Parsetree.module_expr_desc = + function + | Ast_500.Parsetree.Pmod_ident x0 -> + Ast_501.Parsetree.Pmod_ident (copy_loc copy_Longident_t x0) + | Ast_500.Parsetree.Pmod_structure x0 -> + Ast_501.Parsetree.Pmod_structure (copy_structure x0) + | Ast_500.Parsetree.Pmod_functor (x0, x1) -> + Ast_501.Parsetree.Pmod_functor + (copy_functor_parameter x0, copy_module_expr x1) + | Ast_500.Parsetree.Pmod_apply (x0, x1) -> + Ast_501.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) + | Ast_500.Parsetree.Pmod_constraint (x0, x1) -> + Ast_501.Parsetree.Pmod_constraint + (copy_module_expr x0, copy_module_type x1) + | Ast_500.Parsetree.Pmod_unpack x0 -> + Ast_501.Parsetree.Pmod_unpack (copy_expression x0) + | Ast_500.Parsetree.Pmod_extension x0 -> + Ast_501.Parsetree.Pmod_extension (copy_extension x0) + +and copy_functor_parameter : + Ast_500.Parsetree.functor_parameter -> Ast_501.Parsetree.functor_parameter = + function + | Ast_500.Parsetree.Unit -> Ast_501.Parsetree.Unit + | Ast_500.Parsetree.Named (x0, x1) -> + Ast_501.Parsetree.Named + (copy_loc (fun x -> Option.map (fun x -> x) x) x0, copy_module_type x1) + +and copy_module_type : + Ast_500.Parsetree.module_type -> Ast_501.Parsetree.module_type = + fun { + Ast_500.Parsetree.pmty_desc; + Ast_500.Parsetree.pmty_loc; + Ast_500.Parsetree.pmty_attributes; + } -> + { + Ast_501.Parsetree.pmty_desc = copy_module_type_desc pmty_desc; + Ast_501.Parsetree.pmty_loc = copy_location pmty_loc; + Ast_501.Parsetree.pmty_attributes = copy_attributes pmty_attributes; + } + +and copy_module_type_desc : + Ast_500.Parsetree.module_type_desc -> Ast_501.Parsetree.module_type_desc = + function + | Ast_500.Parsetree.Pmty_ident x0 -> + Ast_501.Parsetree.Pmty_ident (copy_loc copy_Longident_t x0) + | Ast_500.Parsetree.Pmty_signature x0 -> + Ast_501.Parsetree.Pmty_signature (copy_signature x0) + | Ast_500.Parsetree.Pmty_functor (x0, x1) -> + Ast_501.Parsetree.Pmty_functor + (copy_functor_parameter x0, copy_module_type x1) + | Ast_500.Parsetree.Pmty_with (x0, x1) -> + Ast_501.Parsetree.Pmty_with + (copy_module_type x0, List.map copy_with_constraint x1) + | Ast_500.Parsetree.Pmty_typeof x0 -> + Ast_501.Parsetree.Pmty_typeof (copy_module_expr x0) + | Ast_500.Parsetree.Pmty_extension x0 -> + Ast_501.Parsetree.Pmty_extension (copy_extension x0) + | Ast_500.Parsetree.Pmty_alias x0 -> + Ast_501.Parsetree.Pmty_alias (copy_loc copy_Longident_t x0) + +and copy_with_constraint : + Ast_500.Parsetree.with_constraint -> Ast_501.Parsetree.with_constraint = + function + | Ast_500.Parsetree.Pwith_type (x0, x1) -> + Ast_501.Parsetree.Pwith_type + (copy_loc copy_Longident_t x0, copy_type_declaration x1) + | Ast_500.Parsetree.Pwith_module (x0, x1) -> + Ast_501.Parsetree.Pwith_module + (copy_loc copy_Longident_t x0, copy_loc copy_Longident_t x1) + | Ast_500.Parsetree.Pwith_modtype (x0, x1) -> + Ast_501.Parsetree.Pwith_modtype + (copy_loc copy_Longident_t x0, copy_module_type x1) + | Ast_500.Parsetree.Pwith_modtypesubst (x0, x1) -> + Ast_501.Parsetree.Pwith_modtypesubst + (copy_loc copy_Longident_t x0, copy_module_type x1) + | Ast_500.Parsetree.Pwith_typesubst (x0, x1) -> + Ast_501.Parsetree.Pwith_typesubst + (copy_loc copy_Longident_t x0, copy_type_declaration x1) + | Ast_500.Parsetree.Pwith_modsubst (x0, x1) -> + Ast_501.Parsetree.Pwith_modsubst + (copy_loc copy_Longident_t x0, copy_loc copy_Longident_t x1) + +and copy_signature : Ast_500.Parsetree.signature -> Ast_501.Parsetree.signature + = + fun x -> List.map copy_signature_item x + +and copy_signature_item : + Ast_500.Parsetree.signature_item -> Ast_501.Parsetree.signature_item = + fun { Ast_500.Parsetree.psig_desc; Ast_500.Parsetree.psig_loc } -> + { + Ast_501.Parsetree.psig_desc = copy_signature_item_desc psig_desc; + Ast_501.Parsetree.psig_loc = copy_location psig_loc; + } + +and copy_signature_item_desc : + Ast_500.Parsetree.signature_item_desc -> + Ast_501.Parsetree.signature_item_desc = function + | Ast_500.Parsetree.Psig_value x0 -> + Ast_501.Parsetree.Psig_value (copy_value_description x0) + | Ast_500.Parsetree.Psig_type (x0, x1) -> + Ast_501.Parsetree.Psig_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | Ast_500.Parsetree.Psig_typesubst x0 -> + Ast_501.Parsetree.Psig_typesubst (List.map copy_type_declaration x0) + | Ast_500.Parsetree.Psig_typext x0 -> + Ast_501.Parsetree.Psig_typext (copy_type_extension x0) + | Ast_500.Parsetree.Psig_exception x0 -> + Ast_501.Parsetree.Psig_exception (copy_type_exception x0) + | Ast_500.Parsetree.Psig_module x0 -> + Ast_501.Parsetree.Psig_module (copy_module_declaration x0) + | Ast_500.Parsetree.Psig_modsubst x0 -> + Ast_501.Parsetree.Psig_modsubst (copy_module_substitution x0) + | Ast_500.Parsetree.Psig_recmodule x0 -> + Ast_501.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) + | Ast_500.Parsetree.Psig_modtype x0 -> + Ast_501.Parsetree.Psig_modtype (copy_module_type_declaration x0) + | Ast_500.Parsetree.Psig_modtypesubst x0 -> + Ast_501.Parsetree.Psig_modtypesubst (copy_module_type_declaration x0) + | Ast_500.Parsetree.Psig_open x0 -> + Ast_501.Parsetree.Psig_open (copy_open_description x0) + | Ast_500.Parsetree.Psig_include x0 -> + Ast_501.Parsetree.Psig_include (copy_include_description x0) + | Ast_500.Parsetree.Psig_class x0 -> + Ast_501.Parsetree.Psig_class (List.map copy_class_description x0) + | Ast_500.Parsetree.Psig_class_type x0 -> + Ast_501.Parsetree.Psig_class_type + (List.map copy_class_type_declaration x0) + | Ast_500.Parsetree.Psig_attribute x0 -> + Ast_501.Parsetree.Psig_attribute (copy_attribute x0) + | Ast_500.Parsetree.Psig_extension (x0, x1) -> + Ast_501.Parsetree.Psig_extension (copy_extension x0, copy_attributes x1) + +and copy_class_type_declaration : + Ast_500.Parsetree.class_type_declaration -> + Ast_501.Parsetree.class_type_declaration = + fun x -> copy_class_infos copy_class_type x + +and copy_class_description : + Ast_500.Parsetree.class_description -> Ast_501.Parsetree.class_description = + fun x -> copy_class_infos copy_class_type x + +and copy_class_type : + Ast_500.Parsetree.class_type -> Ast_501.Parsetree.class_type = + fun { + Ast_500.Parsetree.pcty_desc; + Ast_500.Parsetree.pcty_loc; + Ast_500.Parsetree.pcty_attributes; + } -> + { + Ast_501.Parsetree.pcty_desc = copy_class_type_desc pcty_desc; + Ast_501.Parsetree.pcty_loc = copy_location pcty_loc; + Ast_501.Parsetree.pcty_attributes = copy_attributes pcty_attributes; + } + +and copy_class_type_desc : + Ast_500.Parsetree.class_type_desc -> Ast_501.Parsetree.class_type_desc = + function + | Ast_500.Parsetree.Pcty_constr (x0, x1) -> + Ast_501.Parsetree.Pcty_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_500.Parsetree.Pcty_signature x0 -> + Ast_501.Parsetree.Pcty_signature (copy_class_signature x0) + | Ast_500.Parsetree.Pcty_arrow (x0, x1, x2) -> + Ast_501.Parsetree.Pcty_arrow + (copy_arg_label x0, copy_core_type x1, copy_class_type x2) + | Ast_500.Parsetree.Pcty_extension x0 -> + Ast_501.Parsetree.Pcty_extension (copy_extension x0) + | Ast_500.Parsetree.Pcty_open (x0, x1) -> + Ast_501.Parsetree.Pcty_open (copy_open_description x0, copy_class_type x1) + +and copy_class_signature : + Ast_500.Parsetree.class_signature -> Ast_501.Parsetree.class_signature = + fun { Ast_500.Parsetree.pcsig_self; Ast_500.Parsetree.pcsig_fields } -> + { + Ast_501.Parsetree.pcsig_self = copy_core_type pcsig_self; + Ast_501.Parsetree.pcsig_fields = List.map copy_class_type_field pcsig_fields; + } + +and copy_class_type_field : + Ast_500.Parsetree.class_type_field -> Ast_501.Parsetree.class_type_field = + fun { + Ast_500.Parsetree.pctf_desc; + Ast_500.Parsetree.pctf_loc; + Ast_500.Parsetree.pctf_attributes; + } -> + { + Ast_501.Parsetree.pctf_desc = copy_class_type_field_desc pctf_desc; + Ast_501.Parsetree.pctf_loc = copy_location pctf_loc; + Ast_501.Parsetree.pctf_attributes = copy_attributes pctf_attributes; + } + +and copy_class_type_field_desc : + Ast_500.Parsetree.class_type_field_desc -> + Ast_501.Parsetree.class_type_field_desc = function + | Ast_500.Parsetree.Pctf_inherit x0 -> + Ast_501.Parsetree.Pctf_inherit (copy_class_type x0) + | Ast_500.Parsetree.Pctf_val x0 -> + Ast_501.Parsetree.Pctf_val + (let x0, x1, x2, x3 = x0 in + ( copy_loc copy_label x0, + copy_mutable_flag x1, + copy_virtual_flag x2, + copy_core_type x3 )) + | Ast_500.Parsetree.Pctf_method x0 -> + Ast_501.Parsetree.Pctf_method + (let x0, x1, x2, x3 = x0 in + ( copy_loc copy_label x0, + copy_private_flag x1, + copy_virtual_flag x2, + copy_core_type x3 )) + | Ast_500.Parsetree.Pctf_constraint x0 -> + Ast_501.Parsetree.Pctf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | Ast_500.Parsetree.Pctf_attribute x0 -> + Ast_501.Parsetree.Pctf_attribute (copy_attribute x0) + | Ast_500.Parsetree.Pctf_extension x0 -> + Ast_501.Parsetree.Pctf_extension (copy_extension x0) + +and copy_extension : Ast_500.Parsetree.extension -> Ast_501.Parsetree.extension + = + fun x -> + let x0, x1 = x in + (copy_loc (fun x -> x) x0, copy_payload x1) + +and copy_class_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 Ast_500.Parsetree.class_infos -> + 'g0 Ast_501.Parsetree.class_infos = + fun f0 + { + Ast_500.Parsetree.pci_virt; + Ast_500.Parsetree.pci_params; + Ast_500.Parsetree.pci_name; + Ast_500.Parsetree.pci_expr; + Ast_500.Parsetree.pci_loc; + Ast_500.Parsetree.pci_attributes; + } -> + { + Ast_501.Parsetree.pci_virt = copy_virtual_flag pci_virt; + Ast_501.Parsetree.pci_params = + List.map + (fun x -> + let x0, x1 = x in + ( copy_core_type x0, + let x0, x1 = x1 in + (copy_variance x0, copy_injectivity x1) )) + pci_params; + Ast_501.Parsetree.pci_name = copy_loc (fun x -> x) pci_name; + Ast_501.Parsetree.pci_expr = f0 pci_expr; + Ast_501.Parsetree.pci_loc = copy_location pci_loc; + Ast_501.Parsetree.pci_attributes = copy_attributes pci_attributes; + } + +and copy_virtual_flag : + Ast_500.Asttypes.virtual_flag -> Ast_501.Asttypes.virtual_flag = function + | Ast_500.Asttypes.Virtual -> Ast_501.Asttypes.Virtual + | Ast_500.Asttypes.Concrete -> Ast_501.Asttypes.Concrete + +and copy_include_description : + Ast_500.Parsetree.include_description -> + Ast_501.Parsetree.include_description = + fun x -> copy_include_infos copy_module_type x + +and copy_include_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 Ast_500.Parsetree.include_infos -> + 'g0 Ast_501.Parsetree.include_infos = + fun f0 + { + Ast_500.Parsetree.pincl_mod; + Ast_500.Parsetree.pincl_loc; + Ast_500.Parsetree.pincl_attributes; + } -> + { + Ast_501.Parsetree.pincl_mod = f0 pincl_mod; + Ast_501.Parsetree.pincl_loc = copy_location pincl_loc; + Ast_501.Parsetree.pincl_attributes = copy_attributes pincl_attributes; + } + +and copy_open_description : + Ast_500.Parsetree.open_description -> Ast_501.Parsetree.open_description = + fun x -> copy_open_infos (fun x -> copy_loc copy_Longident_t x) x + +and copy_open_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 Ast_500.Parsetree.open_infos -> + 'g0 Ast_501.Parsetree.open_infos = + fun f0 + { + Ast_500.Parsetree.popen_expr; + Ast_500.Parsetree.popen_override; + Ast_500.Parsetree.popen_loc; + Ast_500.Parsetree.popen_attributes; + } -> + { + Ast_501.Parsetree.popen_expr = f0 popen_expr; + Ast_501.Parsetree.popen_override = copy_override_flag popen_override; + Ast_501.Parsetree.popen_loc = copy_location popen_loc; + Ast_501.Parsetree.popen_attributes = copy_attributes popen_attributes; + } + +and copy_override_flag : + Ast_500.Asttypes.override_flag -> Ast_501.Asttypes.override_flag = function + | Ast_500.Asttypes.Override -> Ast_501.Asttypes.Override + | Ast_500.Asttypes.Fresh -> Ast_501.Asttypes.Fresh + +and copy_module_type_declaration : + Ast_500.Parsetree.module_type_declaration -> + Ast_501.Parsetree.module_type_declaration = + fun { + Ast_500.Parsetree.pmtd_name; + Ast_500.Parsetree.pmtd_type; + Ast_500.Parsetree.pmtd_attributes; + Ast_500.Parsetree.pmtd_loc; + } -> + { + Ast_501.Parsetree.pmtd_name = copy_loc (fun x -> x) pmtd_name; + Ast_501.Parsetree.pmtd_type = Option.map copy_module_type pmtd_type; + Ast_501.Parsetree.pmtd_attributes = copy_attributes pmtd_attributes; + Ast_501.Parsetree.pmtd_loc = copy_location pmtd_loc; + } + +and copy_module_substitution : + Ast_500.Parsetree.module_substitution -> + Ast_501.Parsetree.module_substitution = + fun { + Ast_500.Parsetree.pms_name; + Ast_500.Parsetree.pms_manifest; + Ast_500.Parsetree.pms_attributes; + Ast_500.Parsetree.pms_loc; + } -> + { + Ast_501.Parsetree.pms_name = copy_loc (fun x -> x) pms_name; + Ast_501.Parsetree.pms_manifest = copy_loc copy_Longident_t pms_manifest; + Ast_501.Parsetree.pms_attributes = copy_attributes pms_attributes; + Ast_501.Parsetree.pms_loc = copy_location pms_loc; + } + +and copy_module_declaration : + Ast_500.Parsetree.module_declaration -> Ast_501.Parsetree.module_declaration + = + fun { + Ast_500.Parsetree.pmd_name; + Ast_500.Parsetree.pmd_type; + Ast_500.Parsetree.pmd_attributes; + Ast_500.Parsetree.pmd_loc; + } -> + { + Ast_501.Parsetree.pmd_name = + copy_loc (fun x -> Option.map (fun x -> x) x) pmd_name; + Ast_501.Parsetree.pmd_type = copy_module_type pmd_type; + Ast_501.Parsetree.pmd_attributes = copy_attributes pmd_attributes; + Ast_501.Parsetree.pmd_loc = copy_location pmd_loc; + } + +and copy_type_exception : + Ast_500.Parsetree.type_exception -> Ast_501.Parsetree.type_exception = + fun { + Ast_500.Parsetree.ptyexn_constructor; + Ast_500.Parsetree.ptyexn_loc; + Ast_500.Parsetree.ptyexn_attributes; + } -> + { + Ast_501.Parsetree.ptyexn_constructor = + copy_extension_constructor ptyexn_constructor; + Ast_501.Parsetree.ptyexn_loc = copy_location ptyexn_loc; + Ast_501.Parsetree.ptyexn_attributes = copy_attributes ptyexn_attributes; + } + +and copy_type_extension : + Ast_500.Parsetree.type_extension -> Ast_501.Parsetree.type_extension = + fun { + Ast_500.Parsetree.ptyext_path; + Ast_500.Parsetree.ptyext_params; + Ast_500.Parsetree.ptyext_constructors; + Ast_500.Parsetree.ptyext_private; + Ast_500.Parsetree.ptyext_loc; + Ast_500.Parsetree.ptyext_attributes; + } -> + { + Ast_501.Parsetree.ptyext_path = copy_loc copy_Longident_t ptyext_path; + Ast_501.Parsetree.ptyext_params = + List.map + (fun x -> + let x0, x1 = x in + ( copy_core_type x0, + let x0, x1 = x1 in + (copy_variance x0, copy_injectivity x1) )) + ptyext_params; + Ast_501.Parsetree.ptyext_constructors = + List.map copy_extension_constructor ptyext_constructors; + Ast_501.Parsetree.ptyext_private = copy_private_flag ptyext_private; + Ast_501.Parsetree.ptyext_loc = copy_location ptyext_loc; + Ast_501.Parsetree.ptyext_attributes = copy_attributes ptyext_attributes; + } + +and copy_extension_constructor : + Ast_500.Parsetree.extension_constructor -> + Ast_501.Parsetree.extension_constructor = + fun { + Ast_500.Parsetree.pext_name; + Ast_500.Parsetree.pext_kind; + Ast_500.Parsetree.pext_loc; + Ast_500.Parsetree.pext_attributes; + } -> + { + Ast_501.Parsetree.pext_name = copy_loc (fun x -> x) pext_name; + Ast_501.Parsetree.pext_kind = copy_extension_constructor_kind pext_kind; + Ast_501.Parsetree.pext_loc = copy_location pext_loc; + Ast_501.Parsetree.pext_attributes = copy_attributes pext_attributes; + } + +and copy_extension_constructor_kind : + Ast_500.Parsetree.extension_constructor_kind -> + Ast_501.Parsetree.extension_constructor_kind = function + | Ast_500.Parsetree.Pext_decl (x0, x1, x2) -> + Ast_501.Parsetree.Pext_decl + ( List.map (fun x -> copy_loc (fun x -> x) x) x0, + copy_constructor_arguments x1, + Option.map copy_core_type x2 ) + | Ast_500.Parsetree.Pext_rebind x0 -> + Ast_501.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0) + +and copy_type_declaration : + Ast_500.Parsetree.type_declaration -> Ast_501.Parsetree.type_declaration = + fun { + Ast_500.Parsetree.ptype_name; + Ast_500.Parsetree.ptype_params; + Ast_500.Parsetree.ptype_cstrs; + Ast_500.Parsetree.ptype_kind; + Ast_500.Parsetree.ptype_private; + Ast_500.Parsetree.ptype_manifest; + Ast_500.Parsetree.ptype_attributes; + Ast_500.Parsetree.ptype_loc; + } -> + { + Ast_501.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name; + Ast_501.Parsetree.ptype_params = + List.map + (fun x -> + let x0, x1 = x in + ( copy_core_type x0, + let x0, x1 = x1 in + (copy_variance x0, copy_injectivity x1) )) + ptype_params; + Ast_501.Parsetree.ptype_cstrs = + List.map + (fun x -> + let x0, x1, x2 = x in + (copy_core_type x0, copy_core_type x1, copy_location x2)) + ptype_cstrs; + Ast_501.Parsetree.ptype_kind = copy_type_kind ptype_kind; + Ast_501.Parsetree.ptype_private = copy_private_flag ptype_private; + Ast_501.Parsetree.ptype_manifest = Option.map copy_core_type ptype_manifest; + Ast_501.Parsetree.ptype_attributes = copy_attributes ptype_attributes; + Ast_501.Parsetree.ptype_loc = copy_location ptype_loc; + } + +and copy_private_flag : + Ast_500.Asttypes.private_flag -> Ast_501.Asttypes.private_flag = function + | Ast_500.Asttypes.Private -> Ast_501.Asttypes.Private + | Ast_500.Asttypes.Public -> Ast_501.Asttypes.Public + +and copy_type_kind : Ast_500.Parsetree.type_kind -> Ast_501.Parsetree.type_kind + = function + | Ast_500.Parsetree.Ptype_abstract -> Ast_501.Parsetree.Ptype_abstract + | Ast_500.Parsetree.Ptype_variant x0 -> + Ast_501.Parsetree.Ptype_variant (List.map copy_constructor_declaration x0) + | Ast_500.Parsetree.Ptype_record x0 -> + Ast_501.Parsetree.Ptype_record (List.map copy_label_declaration x0) + | Ast_500.Parsetree.Ptype_open -> Ast_501.Parsetree.Ptype_open + +and copy_constructor_declaration : + Ast_500.Parsetree.constructor_declaration -> + Ast_501.Parsetree.constructor_declaration = + fun { + Ast_500.Parsetree.pcd_name; + Ast_500.Parsetree.pcd_vars; + Ast_500.Parsetree.pcd_args; + Ast_500.Parsetree.pcd_res; + Ast_500.Parsetree.pcd_loc; + Ast_500.Parsetree.pcd_attributes; + } -> + { + Ast_501.Parsetree.pcd_name = copy_loc (fun x -> x) pcd_name; + Ast_501.Parsetree.pcd_vars = + List.map (fun x -> copy_loc (fun x -> x) x) pcd_vars; + Ast_501.Parsetree.pcd_args = copy_constructor_arguments pcd_args; + Ast_501.Parsetree.pcd_res = Option.map copy_core_type pcd_res; + Ast_501.Parsetree.pcd_loc = copy_location pcd_loc; + Ast_501.Parsetree.pcd_attributes = copy_attributes pcd_attributes; + } + +and copy_constructor_arguments : + Ast_500.Parsetree.constructor_arguments -> + Ast_501.Parsetree.constructor_arguments = function + | Ast_500.Parsetree.Pcstr_tuple x0 -> + Ast_501.Parsetree.Pcstr_tuple (List.map copy_core_type x0) + | Ast_500.Parsetree.Pcstr_record x0 -> + Ast_501.Parsetree.Pcstr_record (List.map copy_label_declaration x0) + +and copy_label_declaration : + Ast_500.Parsetree.label_declaration -> Ast_501.Parsetree.label_declaration = + fun { + Ast_500.Parsetree.pld_name; + Ast_500.Parsetree.pld_mutable; + Ast_500.Parsetree.pld_type; + Ast_500.Parsetree.pld_loc; + Ast_500.Parsetree.pld_attributes; + } -> + { + Ast_501.Parsetree.pld_name = copy_loc (fun x -> x) pld_name; + Ast_501.Parsetree.pld_mutable = copy_mutable_flag pld_mutable; + Ast_501.Parsetree.pld_type = copy_core_type pld_type; + Ast_501.Parsetree.pld_loc = copy_location pld_loc; + Ast_501.Parsetree.pld_attributes = copy_attributes pld_attributes; + } + +and copy_mutable_flag : + Ast_500.Asttypes.mutable_flag -> Ast_501.Asttypes.mutable_flag = function + | Ast_500.Asttypes.Immutable -> Ast_501.Asttypes.Immutable + | Ast_500.Asttypes.Mutable -> Ast_501.Asttypes.Mutable + +and copy_injectivity : + Ast_500.Asttypes.injectivity -> Ast_501.Asttypes.injectivity = function + | Ast_500.Asttypes.Injective -> Ast_501.Asttypes.Injective + | Ast_500.Asttypes.NoInjectivity -> Ast_501.Asttypes.NoInjectivity + +and copy_variance : Ast_500.Asttypes.variance -> Ast_501.Asttypes.variance = + function + | Ast_500.Asttypes.Covariant -> Ast_501.Asttypes.Covariant + | Ast_500.Asttypes.Contravariant -> Ast_501.Asttypes.Contravariant + | Ast_500.Asttypes.NoVariance -> Ast_501.Asttypes.NoVariance + +and copy_value_description : + Ast_500.Parsetree.value_description -> Ast_501.Parsetree.value_description = + fun { + Ast_500.Parsetree.pval_name; + Ast_500.Parsetree.pval_type; + Ast_500.Parsetree.pval_prim; + Ast_500.Parsetree.pval_attributes; + Ast_500.Parsetree.pval_loc; + } -> + { + Ast_501.Parsetree.pval_name = copy_loc (fun x -> x) pval_name; + Ast_501.Parsetree.pval_type = copy_core_type pval_type; + Ast_501.Parsetree.pval_prim = List.map (fun x -> x) pval_prim; + Ast_501.Parsetree.pval_attributes = copy_attributes pval_attributes; + Ast_501.Parsetree.pval_loc = copy_location pval_loc; + } + +and copy_object_field_desc : + Ast_500.Parsetree.object_field_desc -> Ast_501.Parsetree.object_field_desc = + function + | Ast_500.Parsetree.Otag (x0, x1) -> + Ast_501.Parsetree.Otag (copy_loc copy_label x0, copy_core_type x1) + | Ast_500.Parsetree.Oinherit x0 -> + Ast_501.Parsetree.Oinherit (copy_core_type x0) + +and copy_arg_label : Ast_500.Asttypes.arg_label -> Ast_501.Asttypes.arg_label = + function + | Ast_500.Asttypes.Nolabel -> Ast_501.Asttypes.Nolabel + | Ast_500.Asttypes.Labelled x0 -> Ast_501.Asttypes.Labelled x0 + | Ast_500.Asttypes.Optional x0 -> Ast_501.Asttypes.Optional x0 + +and copy_closed_flag : + Ast_500.Asttypes.closed_flag -> Ast_501.Asttypes.closed_flag = function + | Ast_500.Asttypes.Closed -> Ast_501.Asttypes.Closed + | Ast_500.Asttypes.Open -> Ast_501.Asttypes.Open + +and copy_label : Ast_500.Asttypes.label -> Ast_501.Asttypes.label = fun x -> x + +and copy_rec_flag : Ast_500.Asttypes.rec_flag -> Ast_501.Asttypes.rec_flag = + function + | Ast_500.Asttypes.Nonrecursive -> Ast_501.Asttypes.Nonrecursive + | Ast_500.Asttypes.Recursive -> Ast_501.Asttypes.Recursive + +and copy_constant : Ast_500.Parsetree.constant -> Ast_501.Parsetree.constant = + function + | Ast_500.Parsetree.Pconst_integer (x0, x1) -> + Ast_501.Parsetree.Pconst_integer (x0, Option.map (fun x -> x) x1) + | Ast_500.Parsetree.Pconst_char x0 -> Ast_501.Parsetree.Pconst_char x0 + | Ast_500.Parsetree.Pconst_string (x0, x1, x2) -> + Ast_501.Parsetree.Pconst_string + (x0, copy_location x1, Option.map (fun x -> x) x2) + | Ast_500.Parsetree.Pconst_float (x0, x1) -> + Ast_501.Parsetree.Pconst_float (x0, Option.map (fun x -> x) x1) + +and copy_Longident_t : Longident.t -> Longident.t = function + | Longident.Lident x0 -> Longident.Lident x0 + | Longident.Ldot (x0, x1) -> Longident.Ldot (copy_Longident_t x0, x1) + | Longident.Lapply (x0, x1) -> + Longident.Lapply (copy_Longident_t x0, copy_Longident_t x1) + +and copy_loc : + 'f0 'g0. + ('f0 -> 'g0) -> 'f0 Ast_500.Asttypes.loc -> 'g0 Ast_501.Asttypes.loc = + fun f0 { Ast_500.Asttypes.txt; Ast_500.Asttypes.loc } -> + { Ast_501.Asttypes.txt = f0 txt; Ast_501.Asttypes.loc = copy_location loc } + +and copy_location : Location.t -> Location.t = + fun { Location.loc_start; Location.loc_end; Location.loc_ghost } -> + { + Location.loc_start = copy_position loc_start; + Location.loc_end = copy_position loc_end; + Location.loc_ghost; + } + +and copy_position : Lexing.position -> Lexing.position = + fun { Lexing.pos_fname; Lexing.pos_lnum; Lexing.pos_bol; Lexing.pos_cnum } -> + { Lexing.pos_fname; Lexing.pos_lnum; Lexing.pos_bol; Lexing.pos_cnum } diff --git a/astlib/migrate_501_500.ml b/astlib/migrate_501_500.ml new file mode 100644 index 000000000..ac53b3203 --- /dev/null +++ b/astlib/migrate_501_500.ml @@ -0,0 +1,1404 @@ +open Stdlib0 +module From = Ast_501 +module To = Ast_500 + +let rec copy_toplevel_phrase : + Ast_501.Parsetree.toplevel_phrase -> Ast_500.Parsetree.toplevel_phrase = + function + | Ast_501.Parsetree.Ptop_def x0 -> + Ast_500.Parsetree.Ptop_def (copy_structure x0) + | Ast_501.Parsetree.Ptop_dir x0 -> + Ast_500.Parsetree.Ptop_dir (copy_toplevel_directive x0) + +and copy_toplevel_directive : + Ast_501.Parsetree.toplevel_directive -> Ast_500.Parsetree.toplevel_directive + = + fun { + Ast_501.Parsetree.pdir_name; + Ast_501.Parsetree.pdir_arg; + Ast_501.Parsetree.pdir_loc; + } -> + { + Ast_500.Parsetree.pdir_name = copy_loc (fun x -> x) pdir_name; + Ast_500.Parsetree.pdir_arg = Option.map copy_directive_argument pdir_arg; + Ast_500.Parsetree.pdir_loc = copy_location pdir_loc; + } + +and copy_directive_argument : + Ast_501.Parsetree.directive_argument -> Ast_500.Parsetree.directive_argument + = + fun { Ast_501.Parsetree.pdira_desc; Ast_501.Parsetree.pdira_loc } -> + { + Ast_500.Parsetree.pdira_desc = copy_directive_argument_desc pdira_desc; + Ast_500.Parsetree.pdira_loc = copy_location pdira_loc; + } + +and copy_directive_argument_desc : + Ast_501.Parsetree.directive_argument_desc -> + Ast_500.Parsetree.directive_argument_desc = function + | Ast_501.Parsetree.Pdir_string x0 -> Ast_500.Parsetree.Pdir_string x0 + | Ast_501.Parsetree.Pdir_int (x0, x1) -> + Ast_500.Parsetree.Pdir_int (x0, Option.map (fun x -> x) x1) + | Ast_501.Parsetree.Pdir_ident x0 -> + Ast_500.Parsetree.Pdir_ident (copy_Longident_t x0) + | Ast_501.Parsetree.Pdir_bool x0 -> Ast_500.Parsetree.Pdir_bool x0 + +and copy_expression : + Ast_501.Parsetree.expression -> Ast_500.Parsetree.expression = + fun { + Ast_501.Parsetree.pexp_desc; + Ast_501.Parsetree.pexp_loc; + Ast_501.Parsetree.pexp_loc_stack; + Ast_501.Parsetree.pexp_attributes; + } -> + { + Ast_500.Parsetree.pexp_desc = copy_expression_desc pexp_desc; + Ast_500.Parsetree.pexp_loc = copy_location pexp_loc; + Ast_500.Parsetree.pexp_loc_stack = copy_location_stack pexp_loc_stack; + Ast_500.Parsetree.pexp_attributes = copy_attributes pexp_attributes; + } + +and copy_expression_desc : + Ast_501.Parsetree.expression_desc -> Ast_500.Parsetree.expression_desc = + function + | Ast_501.Parsetree.Pexp_ident x0 -> + Ast_500.Parsetree.Pexp_ident (copy_loc copy_Longident_t x0) + | Ast_501.Parsetree.Pexp_constant x0 -> + Ast_500.Parsetree.Pexp_constant (copy_constant x0) + | Ast_501.Parsetree.Pexp_let (x0, x1, x2) -> + Ast_500.Parsetree.Pexp_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_expression x2) + | Ast_501.Parsetree.Pexp_function x0 -> + Ast_500.Parsetree.Pexp_function (List.map copy_case x0) + | Ast_501.Parsetree.Pexp_fun (x0, x1, x2, x3) -> + Ast_500.Parsetree.Pexp_fun + ( copy_arg_label x0, + Option.map copy_expression x1, + copy_pattern x2, + copy_expression x3 ) + | Ast_501.Parsetree.Pexp_apply (x0, x1) -> + Ast_500.Parsetree.Pexp_apply + ( copy_expression x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | Ast_501.Parsetree.Pexp_match (x0, x1) -> + Ast_500.Parsetree.Pexp_match (copy_expression x0, List.map copy_case x1) + | Ast_501.Parsetree.Pexp_try (x0, x1) -> + Ast_500.Parsetree.Pexp_try (copy_expression x0, List.map copy_case x1) + | Ast_501.Parsetree.Pexp_tuple x0 -> + Ast_500.Parsetree.Pexp_tuple (List.map copy_expression x0) + | Ast_501.Parsetree.Pexp_construct (x0, x1) -> + Ast_500.Parsetree.Pexp_construct + (copy_loc copy_Longident_t x0, Option.map copy_expression x1) + | Ast_501.Parsetree.Pexp_variant (x0, x1) -> + Ast_500.Parsetree.Pexp_variant + (copy_label x0, Option.map copy_expression x1) + | Ast_501.Parsetree.Pexp_record (x0, x1) -> + Ast_500.Parsetree.Pexp_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_Longident_t x0, copy_expression x1)) + x0, + Option.map copy_expression x1 ) + | Ast_501.Parsetree.Pexp_field (x0, x1) -> + Ast_500.Parsetree.Pexp_field + (copy_expression x0, copy_loc copy_Longident_t x1) + | Ast_501.Parsetree.Pexp_setfield (x0, x1, x2) -> + Ast_500.Parsetree.Pexp_setfield + (copy_expression x0, copy_loc copy_Longident_t x1, copy_expression x2) + | Ast_501.Parsetree.Pexp_array x0 -> + Ast_500.Parsetree.Pexp_array (List.map copy_expression x0) + | Ast_501.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> + Ast_500.Parsetree.Pexp_ifthenelse + (copy_expression x0, copy_expression x1, Option.map copy_expression x2) + | Ast_501.Parsetree.Pexp_sequence (x0, x1) -> + Ast_500.Parsetree.Pexp_sequence (copy_expression x0, copy_expression x1) + | Ast_501.Parsetree.Pexp_while (x0, x1) -> + Ast_500.Parsetree.Pexp_while (copy_expression x0, copy_expression x1) + | Ast_501.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> + Ast_500.Parsetree.Pexp_for + ( copy_pattern x0, + copy_expression x1, + copy_expression x2, + copy_direction_flag x3, + copy_expression x4 ) + | Ast_501.Parsetree.Pexp_constraint (x0, x1) -> + Ast_500.Parsetree.Pexp_constraint (copy_expression x0, copy_core_type x1) + | Ast_501.Parsetree.Pexp_coerce (x0, x1, x2) -> + Ast_500.Parsetree.Pexp_coerce + (copy_expression x0, Option.map copy_core_type x1, copy_core_type x2) + | Ast_501.Parsetree.Pexp_send (x0, x1) -> + Ast_500.Parsetree.Pexp_send (copy_expression x0, copy_loc copy_label x1) + | Ast_501.Parsetree.Pexp_new x0 -> + Ast_500.Parsetree.Pexp_new (copy_loc copy_Longident_t x0) + | Ast_501.Parsetree.Pexp_setinstvar (x0, x1) -> + Ast_500.Parsetree.Pexp_setinstvar + (copy_loc copy_label x0, copy_expression x1) + | Ast_501.Parsetree.Pexp_override x0 -> + Ast_500.Parsetree.Pexp_override + (List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_label x0, copy_expression x1)) + x0) + | Ast_501.Parsetree.Pexp_letmodule (x0, x1, x2) -> + Ast_500.Parsetree.Pexp_letmodule + ( copy_loc (fun x -> Option.map (fun x -> x) x) x0, + copy_module_expr x1, + copy_expression x2 ) + | Ast_501.Parsetree.Pexp_letexception (x0, x1) -> + Ast_500.Parsetree.Pexp_letexception + (copy_extension_constructor x0, copy_expression x1) + | Ast_501.Parsetree.Pexp_assert x0 -> + Ast_500.Parsetree.Pexp_assert (copy_expression x0) + | Ast_501.Parsetree.Pexp_lazy x0 -> + Ast_500.Parsetree.Pexp_lazy (copy_expression x0) + | Ast_501.Parsetree.Pexp_poly (x0, x1) -> + Ast_500.Parsetree.Pexp_poly + (copy_expression x0, Option.map copy_core_type x1) + | Ast_501.Parsetree.Pexp_object x0 -> + Ast_500.Parsetree.Pexp_object (copy_class_structure x0) + | Ast_501.Parsetree.Pexp_newtype (x0, x1) -> + Ast_500.Parsetree.Pexp_newtype + (copy_loc (fun x -> x) x0, copy_expression x1) + | Ast_501.Parsetree.Pexp_pack x0 -> + Ast_500.Parsetree.Pexp_pack (copy_module_expr x0) + | Ast_501.Parsetree.Pexp_open (x0, x1) -> + Ast_500.Parsetree.Pexp_open (copy_open_declaration x0, copy_expression x1) + | Ast_501.Parsetree.Pexp_letop x0 -> + Ast_500.Parsetree.Pexp_letop (copy_letop x0) + | Ast_501.Parsetree.Pexp_extension x0 -> + Ast_500.Parsetree.Pexp_extension (copy_extension x0) + | Ast_501.Parsetree.Pexp_unreachable -> Ast_500.Parsetree.Pexp_unreachable + +and copy_letop : Ast_501.Parsetree.letop -> Ast_500.Parsetree.letop = + fun { Ast_501.Parsetree.let_; Ast_501.Parsetree.ands; Ast_501.Parsetree.body } -> + { + Ast_500.Parsetree.let_ = copy_binding_op let_; + Ast_500.Parsetree.ands = List.map copy_binding_op ands; + Ast_500.Parsetree.body = copy_expression body; + } + +and copy_binding_op : + Ast_501.Parsetree.binding_op -> Ast_500.Parsetree.binding_op = + fun { + Ast_501.Parsetree.pbop_op; + Ast_501.Parsetree.pbop_pat; + Ast_501.Parsetree.pbop_exp; + Ast_501.Parsetree.pbop_loc; + } -> + { + Ast_500.Parsetree.pbop_op = copy_loc (fun x -> x) pbop_op; + Ast_500.Parsetree.pbop_pat = copy_pattern pbop_pat; + Ast_500.Parsetree.pbop_exp = copy_expression pbop_exp; + Ast_500.Parsetree.pbop_loc = copy_location pbop_loc; + } + +and copy_direction_flag : + Ast_501.Asttypes.direction_flag -> Ast_500.Asttypes.direction_flag = + function + | Ast_501.Asttypes.Upto -> Ast_500.Asttypes.Upto + | Ast_501.Asttypes.Downto -> Ast_500.Asttypes.Downto + +and copy_case : Ast_501.Parsetree.case -> Ast_500.Parsetree.case = + fun { + Ast_501.Parsetree.pc_lhs; + Ast_501.Parsetree.pc_guard; + Ast_501.Parsetree.pc_rhs; + } -> + { + Ast_500.Parsetree.pc_lhs = copy_pattern pc_lhs; + Ast_500.Parsetree.pc_guard = Option.map copy_expression pc_guard; + Ast_500.Parsetree.pc_rhs = copy_expression pc_rhs; + } + +and copy_value_binding : + Ast_501.Parsetree.value_binding -> Ast_500.Parsetree.value_binding = + fun { + Ast_501.Parsetree.pvb_pat; + Ast_501.Parsetree.pvb_expr; + Ast_501.Parsetree.pvb_constraint; + Ast_501.Parsetree.pvb_attributes; + Ast_501.Parsetree.pvb_loc; + } -> + let merge_loc left right = + Location. + { loc_start = left.loc_start; loc_end = right.loc_end; loc_ghost = false } + in + let ghost_loc loc = { loc with Location.loc_ghost = true } in + let ghost_constraint pat typ = + let ppat_loc = + ghost_loc + (merge_loc pat.Ast_500.Parsetree.ppat_loc typ.Ast_500.Parsetree.ptyp_loc) + in + { + Ast_500.Parsetree.ppat_attributes = []; + ppat_loc; + ppat_desc = Ast_500.Parsetree.Ppat_constraint (pat, typ); + ppat_loc_stack = []; + } + in + let pvb_pat = copy_pattern pvb_pat and pvb_expr = copy_expression pvb_expr in + let constrain_pat pat typ expr = + let typ = copy_core_type typ in + let pvb_pat = ghost_constraint pat typ in + (pvb_pat, pvb_expr) + in + let pvb_pat, pvb_expr = + match (pvb_constraint, pvb_pat) with + | ( Some + (Pvc_constraint + { + locally_abstract_univars = []; + typ = { ptyp_desc = Ptyp_poly _; _ } as typ; + }), + { Ast_500.Parsetree.ppat_desc = Ppat_var _; ppat_attributes = [] } ) -> + (* the sugaring of [let x: univars . typ = exp ] was desugared to + [let (x:univars . typ) = exp] in 5.0 which doesn't fit the case below *) + constrain_pat pvb_pat typ pvb_expr + | ( Some (Pvc_constraint { locally_abstract_univars; typ }), + { Ast_500.Parsetree.ppat_desc = Ppat_var _; ppat_attributes = [] } ) -> + (* Copied and adapted from OCaml 5.0 Ast_helper *) + let varify_constructors var_names t = + let var_names = List.map (fun v -> v.Location.txt) var_names in + let rec loop t = + let desc = + match t.Ast_500.Parsetree.ptyp_desc with + | Ast_500.Parsetree.Ptyp_any -> Ast_500.Parsetree.Ptyp_any + | Ptyp_var x -> Ptyp_var x + | Ptyp_arrow (label, core_type, core_type') -> + Ptyp_arrow (label, loop core_type, loop core_type') + | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) + | Ptyp_constr ({ txt = Longident.Lident s }, []) + when List.mem s var_names -> + Ptyp_var s + | Ptyp_constr (longident, lst) -> + Ptyp_constr (longident, List.map loop lst) + | 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) -> + Ptyp_alias (loop core_type, string) + | Ptyp_variant (row_field_list, flag, lbl_lst_option) -> + Ptyp_variant + ( List.map loop_row_field row_field_list, + flag, + lbl_lst_option ) + | Ptyp_poly (string_lst, core_type) -> + Ptyp_poly (string_lst, loop core_type) + | Ptyp_package (longident, lst) -> + Ptyp_package + (longident, List.map (fun (n, typ) -> (n, loop typ)) lst) + | Ptyp_extension (s, arg) -> Ptyp_extension (s, arg) + in + { t with ptyp_desc = desc } + and loop_row_field field = + let prf_desc = + match field.prf_desc with + | Ast_500.Parsetree.Rtag (label, flag, lst) -> + Ast_500.Parsetree.Rtag (label, flag, List.map loop lst) + | Rinherit t -> Rinherit (loop t) + in + { field with prf_desc } + and loop_object_field field = + let pof_desc = + match field.pof_desc with + | Ast_500.Parsetree.Otag (label, t) -> + Ast_500.Parsetree.Otag (label, loop t) + | Oinherit t -> Oinherit (loop t) + in + { field with pof_desc } + in + loop t + in + let typ = copy_core_type typ in + let pexp_loc = merge_loc pvb_pat.ppat_loc pvb_expr.pexp_loc in + let ptyp_loc = + match locally_abstract_univars with + | [] -> ghost_loc typ.ptyp_loc + | _ :: _ -> ghost_loc pexp_loc + in + let typ_poly = + { + typ with + ptyp_loc; + ptyp_attributes = []; + ptyp_desc = + Ast_500.Parsetree.Ptyp_poly + ( locally_abstract_univars, + varify_constructors locally_abstract_univars typ ); + } + in + + let ppat_loc = + ghost_loc + (merge_loc pvb_pat.Ast_500.Parsetree.ppat_loc + typ.Ast_500.Parsetree.ptyp_loc) + in + let pvb_pat = { (ghost_constraint pvb_pat typ_poly) with ppat_loc } + and pvb_expr = + List.fold_left + (fun expr var -> + { + expr with + pexp_attributes = []; + pexp_loc; + Ast_500.Parsetree.pexp_desc = + Ast_500.Parsetree.Pexp_newtype (var, expr); + }) + { + pvb_expr with + pexp_attributes = []; + pexp_loc; + pexp_desc = Pexp_constraint (pvb_expr, typ); + } + (List.rev locally_abstract_univars) + in + (pvb_pat, pvb_expr) + | Some (Pvc_constraint { locally_abstract_univars = []; typ }), _ -> + constrain_pat pvb_pat typ pvb_expr + | Some (Pvc_coercion { ground; coercion }), _ -> + let coercion = copy_core_type coercion in + let ptyp_loc = ghost_loc coercion.ptyp_loc in + let typ = + { + coercion with + ptyp_attributes = []; + ptyp_loc; + ptyp_desc = Ast_500.Parsetree.Ptyp_poly ([], coercion); + } + in + let pvb_pat = ghost_constraint pvb_pat typ in + let ground = Option.map copy_core_type ground in + let pexp_loc = merge_loc pvb_pat.ppat_loc pvb_expr.pexp_loc in + let pvb_expr = + { + pvb_expr with + pexp_attributes = []; + pexp_loc; + pexp_desc = + Ast_500.Parsetree.Pexp_coerce (pvb_expr, ground, coercion); + } + in + (pvb_pat, pvb_expr) + | _ -> (pvb_pat, pvb_expr) + in + { + Ast_500.Parsetree.pvb_pat; + Ast_500.Parsetree.pvb_expr; + Ast_500.Parsetree.pvb_attributes = copy_attributes pvb_attributes; + Ast_500.Parsetree.pvb_loc = copy_location pvb_loc; + } + +and copy_pattern : Ast_501.Parsetree.pattern -> Ast_500.Parsetree.pattern = + fun { + Ast_501.Parsetree.ppat_desc; + Ast_501.Parsetree.ppat_loc; + Ast_501.Parsetree.ppat_loc_stack; + Ast_501.Parsetree.ppat_attributes; + } -> + { + Ast_500.Parsetree.ppat_desc = copy_pattern_desc ppat_desc; + Ast_500.Parsetree.ppat_loc = copy_location ppat_loc; + Ast_500.Parsetree.ppat_loc_stack = copy_location_stack ppat_loc_stack; + Ast_500.Parsetree.ppat_attributes = copy_attributes ppat_attributes; + } + +and copy_pattern_desc : + Ast_501.Parsetree.pattern_desc -> Ast_500.Parsetree.pattern_desc = function + | Ast_501.Parsetree.Ppat_any -> Ast_500.Parsetree.Ppat_any + | Ast_501.Parsetree.Ppat_var x0 -> + Ast_500.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) + | Ast_501.Parsetree.Ppat_alias (x0, x1) -> + Ast_500.Parsetree.Ppat_alias (copy_pattern x0, copy_loc (fun x -> x) x1) + | Ast_501.Parsetree.Ppat_constant x0 -> + Ast_500.Parsetree.Ppat_constant (copy_constant x0) + | Ast_501.Parsetree.Ppat_interval (x0, x1) -> + Ast_500.Parsetree.Ppat_interval (copy_constant x0, copy_constant x1) + | Ast_501.Parsetree.Ppat_tuple x0 -> + Ast_500.Parsetree.Ppat_tuple (List.map copy_pattern x0) + | Ast_501.Parsetree.Ppat_construct (x0, x1) -> + Ast_500.Parsetree.Ppat_construct + ( copy_loc copy_Longident_t x0, + Option.map + (fun x -> + let x0, x1 = x in + (List.map (fun x -> copy_loc (fun x -> x) x) x0, copy_pattern x1)) + x1 ) + | Ast_501.Parsetree.Ppat_variant (x0, x1) -> + Ast_500.Parsetree.Ppat_variant (copy_label x0, Option.map copy_pattern x1) + | Ast_501.Parsetree.Ppat_record (x0, x1) -> + Ast_500.Parsetree.Ppat_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_Longident_t x0, copy_pattern x1)) + x0, + copy_closed_flag x1 ) + | Ast_501.Parsetree.Ppat_array x0 -> + Ast_500.Parsetree.Ppat_array (List.map copy_pattern x0) + | Ast_501.Parsetree.Ppat_or (x0, x1) -> + Ast_500.Parsetree.Ppat_or (copy_pattern x0, copy_pattern x1) + | Ast_501.Parsetree.Ppat_constraint (x0, x1) -> + Ast_500.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1) + | Ast_501.Parsetree.Ppat_type x0 -> + Ast_500.Parsetree.Ppat_type (copy_loc copy_Longident_t x0) + | Ast_501.Parsetree.Ppat_lazy x0 -> + Ast_500.Parsetree.Ppat_lazy (copy_pattern x0) + | Ast_501.Parsetree.Ppat_unpack x0 -> + Ast_500.Parsetree.Ppat_unpack + (copy_loc (fun x -> Option.map (fun x -> x) x) x0) + | Ast_501.Parsetree.Ppat_exception x0 -> + Ast_500.Parsetree.Ppat_exception (copy_pattern x0) + | Ast_501.Parsetree.Ppat_extension x0 -> + Ast_500.Parsetree.Ppat_extension (copy_extension x0) + | Ast_501.Parsetree.Ppat_open (x0, x1) -> + Ast_500.Parsetree.Ppat_open (copy_loc copy_Longident_t x0, copy_pattern x1) + +and copy_core_type : Ast_501.Parsetree.core_type -> Ast_500.Parsetree.core_type + = + fun { + Ast_501.Parsetree.ptyp_desc; + Ast_501.Parsetree.ptyp_loc; + Ast_501.Parsetree.ptyp_loc_stack; + Ast_501.Parsetree.ptyp_attributes; + } -> + { + Ast_500.Parsetree.ptyp_desc = copy_core_type_desc ptyp_desc; + Ast_500.Parsetree.ptyp_loc = copy_location ptyp_loc; + Ast_500.Parsetree.ptyp_loc_stack = copy_location_stack ptyp_loc_stack; + Ast_500.Parsetree.ptyp_attributes = copy_attributes ptyp_attributes; + } + +and copy_location_stack : + Ast_501.Parsetree.location_stack -> Ast_500.Parsetree.location_stack = + fun x -> List.map copy_location x + +and copy_core_type_desc : + Ast_501.Parsetree.core_type_desc -> Ast_500.Parsetree.core_type_desc = + function + | Ast_501.Parsetree.Ptyp_any -> Ast_500.Parsetree.Ptyp_any + | Ast_501.Parsetree.Ptyp_var x0 -> Ast_500.Parsetree.Ptyp_var x0 + | Ast_501.Parsetree.Ptyp_arrow (x0, x1, x2) -> + Ast_500.Parsetree.Ptyp_arrow + (copy_arg_label x0, copy_core_type x1, copy_core_type x2) + | Ast_501.Parsetree.Ptyp_tuple x0 -> + Ast_500.Parsetree.Ptyp_tuple (List.map copy_core_type x0) + | Ast_501.Parsetree.Ptyp_constr (x0, x1) -> + Ast_500.Parsetree.Ptyp_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_501.Parsetree.Ptyp_object (x0, x1) -> + Ast_500.Parsetree.Ptyp_object + (List.map copy_object_field x0, copy_closed_flag x1) + | Ast_501.Parsetree.Ptyp_class (x0, x1) -> + Ast_500.Parsetree.Ptyp_class + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_501.Parsetree.Ptyp_alias (x0, x1) -> + Ast_500.Parsetree.Ptyp_alias (copy_core_type x0, x1) + | Ast_501.Parsetree.Ptyp_variant (x0, x1, x2) -> + Ast_500.Parsetree.Ptyp_variant + ( List.map copy_row_field x0, + copy_closed_flag x1, + Option.map (fun x -> List.map copy_label x) x2 ) + | Ast_501.Parsetree.Ptyp_poly (x0, x1) -> + Ast_500.Parsetree.Ptyp_poly + (List.map (fun x -> copy_loc (fun x -> x) x) x0, copy_core_type x1) + | Ast_501.Parsetree.Ptyp_package x0 -> + Ast_500.Parsetree.Ptyp_package (copy_package_type x0) + | Ast_501.Parsetree.Ptyp_extension x0 -> + Ast_500.Parsetree.Ptyp_extension (copy_extension x0) + +and copy_package_type : + Ast_501.Parsetree.package_type -> Ast_500.Parsetree.package_type = + fun x -> + let x0, x1 = x in + ( copy_loc copy_Longident_t x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_Longident_t x0, copy_core_type x1)) + x1 ) + +and copy_row_field : Ast_501.Parsetree.row_field -> Ast_500.Parsetree.row_field + = + fun { + Ast_501.Parsetree.prf_desc; + Ast_501.Parsetree.prf_loc; + Ast_501.Parsetree.prf_attributes; + } -> + { + Ast_500.Parsetree.prf_desc = copy_row_field_desc prf_desc; + Ast_500.Parsetree.prf_loc = copy_location prf_loc; + Ast_500.Parsetree.prf_attributes = copy_attributes prf_attributes; + } + +and copy_row_field_desc : + Ast_501.Parsetree.row_field_desc -> Ast_500.Parsetree.row_field_desc = + function + | Ast_501.Parsetree.Rtag (x0, x1, x2) -> + Ast_500.Parsetree.Rtag + (copy_loc copy_label x0, x1, List.map copy_core_type x2) + | Ast_501.Parsetree.Rinherit x0 -> + Ast_500.Parsetree.Rinherit (copy_core_type x0) + +and copy_object_field : + Ast_501.Parsetree.object_field -> Ast_500.Parsetree.object_field = + fun { + Ast_501.Parsetree.pof_desc; + Ast_501.Parsetree.pof_loc; + Ast_501.Parsetree.pof_attributes; + } -> + { + Ast_500.Parsetree.pof_desc = copy_object_field_desc pof_desc; + Ast_500.Parsetree.pof_loc = copy_location pof_loc; + Ast_500.Parsetree.pof_attributes = copy_attributes pof_attributes; + } + +and copy_attributes : + Ast_501.Parsetree.attributes -> Ast_500.Parsetree.attributes = + fun x -> List.map copy_attribute x + +and copy_attribute : Ast_501.Parsetree.attribute -> Ast_500.Parsetree.attribute + = + fun { + Ast_501.Parsetree.attr_name; + Ast_501.Parsetree.attr_payload; + Ast_501.Parsetree.attr_loc; + } -> + { + Ast_500.Parsetree.attr_name = copy_loc (fun x -> x) attr_name; + Ast_500.Parsetree.attr_payload = copy_payload attr_payload; + Ast_500.Parsetree.attr_loc = copy_location attr_loc; + } + +and copy_payload : Ast_501.Parsetree.payload -> Ast_500.Parsetree.payload = + function + | Ast_501.Parsetree.PStr x0 -> Ast_500.Parsetree.PStr (copy_structure x0) + | Ast_501.Parsetree.PSig x0 -> Ast_500.Parsetree.PSig (copy_signature x0) + | Ast_501.Parsetree.PTyp x0 -> Ast_500.Parsetree.PTyp (copy_core_type x0) + | Ast_501.Parsetree.PPat (x0, x1) -> + Ast_500.Parsetree.PPat (copy_pattern x0, Option.map copy_expression x1) + +and copy_structure : Ast_501.Parsetree.structure -> Ast_500.Parsetree.structure + = + fun x -> List.map copy_structure_item x + +and copy_structure_item : + Ast_501.Parsetree.structure_item -> Ast_500.Parsetree.structure_item = + fun { Ast_501.Parsetree.pstr_desc; Ast_501.Parsetree.pstr_loc } -> + { + Ast_500.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc; + Ast_500.Parsetree.pstr_loc = copy_location pstr_loc; + } + +and copy_structure_item_desc : + Ast_501.Parsetree.structure_item_desc -> + Ast_500.Parsetree.structure_item_desc = function + | Ast_501.Parsetree.Pstr_eval (x0, x1) -> + Ast_500.Parsetree.Pstr_eval (copy_expression x0, copy_attributes x1) + | Ast_501.Parsetree.Pstr_value (x0, x1) -> + Ast_500.Parsetree.Pstr_value + (copy_rec_flag x0, List.map copy_value_binding x1) + | Ast_501.Parsetree.Pstr_primitive x0 -> + Ast_500.Parsetree.Pstr_primitive (copy_value_description x0) + | Ast_501.Parsetree.Pstr_type (x0, x1) -> + Ast_500.Parsetree.Pstr_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | Ast_501.Parsetree.Pstr_typext x0 -> + Ast_500.Parsetree.Pstr_typext (copy_type_extension x0) + | Ast_501.Parsetree.Pstr_exception x0 -> + Ast_500.Parsetree.Pstr_exception (copy_type_exception x0) + | Ast_501.Parsetree.Pstr_module x0 -> + Ast_500.Parsetree.Pstr_module (copy_module_binding x0) + | Ast_501.Parsetree.Pstr_recmodule x0 -> + Ast_500.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) + | Ast_501.Parsetree.Pstr_modtype x0 -> + Ast_500.Parsetree.Pstr_modtype (copy_module_type_declaration x0) + | Ast_501.Parsetree.Pstr_open x0 -> + Ast_500.Parsetree.Pstr_open (copy_open_declaration x0) + | Ast_501.Parsetree.Pstr_class x0 -> + Ast_500.Parsetree.Pstr_class (List.map copy_class_declaration x0) + | Ast_501.Parsetree.Pstr_class_type x0 -> + Ast_500.Parsetree.Pstr_class_type + (List.map copy_class_type_declaration x0) + | Ast_501.Parsetree.Pstr_include x0 -> + Ast_500.Parsetree.Pstr_include (copy_include_declaration x0) + | Ast_501.Parsetree.Pstr_attribute x0 -> + Ast_500.Parsetree.Pstr_attribute (copy_attribute x0) + | Ast_501.Parsetree.Pstr_extension (x0, x1) -> + Ast_500.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1) + +and copy_include_declaration : + Ast_501.Parsetree.include_declaration -> + Ast_500.Parsetree.include_declaration = + fun x -> copy_include_infos copy_module_expr x + +and copy_class_declaration : + Ast_501.Parsetree.class_declaration -> Ast_500.Parsetree.class_declaration = + fun x -> copy_class_infos copy_class_expr x + +and copy_class_expr : + Ast_501.Parsetree.class_expr -> Ast_500.Parsetree.class_expr = + fun { + Ast_501.Parsetree.pcl_desc; + Ast_501.Parsetree.pcl_loc; + Ast_501.Parsetree.pcl_attributes; + } -> + { + Ast_500.Parsetree.pcl_desc = copy_class_expr_desc pcl_desc; + Ast_500.Parsetree.pcl_loc = copy_location pcl_loc; + Ast_500.Parsetree.pcl_attributes = copy_attributes pcl_attributes; + } + +and copy_class_expr_desc : + Ast_501.Parsetree.class_expr_desc -> Ast_500.Parsetree.class_expr_desc = + function + | Ast_501.Parsetree.Pcl_constr (x0, x1) -> + Ast_500.Parsetree.Pcl_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_501.Parsetree.Pcl_structure x0 -> + Ast_500.Parsetree.Pcl_structure (copy_class_structure x0) + | Ast_501.Parsetree.Pcl_fun (x0, x1, x2, x3) -> + Ast_500.Parsetree.Pcl_fun + ( copy_arg_label x0, + Option.map copy_expression x1, + copy_pattern x2, + copy_class_expr x3 ) + | Ast_501.Parsetree.Pcl_apply (x0, x1) -> + Ast_500.Parsetree.Pcl_apply + ( copy_class_expr x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | Ast_501.Parsetree.Pcl_let (x0, x1, x2) -> + Ast_500.Parsetree.Pcl_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_class_expr x2) + | Ast_501.Parsetree.Pcl_constraint (x0, x1) -> + Ast_500.Parsetree.Pcl_constraint (copy_class_expr x0, copy_class_type x1) + | Ast_501.Parsetree.Pcl_extension x0 -> + Ast_500.Parsetree.Pcl_extension (copy_extension x0) + | Ast_501.Parsetree.Pcl_open (x0, x1) -> + Ast_500.Parsetree.Pcl_open (copy_open_description x0, copy_class_expr x1) + +and copy_class_structure : + Ast_501.Parsetree.class_structure -> Ast_500.Parsetree.class_structure = + fun { Ast_501.Parsetree.pcstr_self; Ast_501.Parsetree.pcstr_fields } -> + { + Ast_500.Parsetree.pcstr_self = copy_pattern pcstr_self; + Ast_500.Parsetree.pcstr_fields = List.map copy_class_field pcstr_fields; + } + +and copy_class_field : + Ast_501.Parsetree.class_field -> Ast_500.Parsetree.class_field = + fun { + Ast_501.Parsetree.pcf_desc; + Ast_501.Parsetree.pcf_loc; + Ast_501.Parsetree.pcf_attributes; + } -> + { + Ast_500.Parsetree.pcf_desc = copy_class_field_desc pcf_desc; + Ast_500.Parsetree.pcf_loc = copy_location pcf_loc; + Ast_500.Parsetree.pcf_attributes = copy_attributes pcf_attributes; + } + +and copy_class_field_desc : + Ast_501.Parsetree.class_field_desc -> Ast_500.Parsetree.class_field_desc = + function + | Ast_501.Parsetree.Pcf_inherit (x0, x1, x2) -> + Ast_500.Parsetree.Pcf_inherit + ( copy_override_flag x0, + copy_class_expr x1, + Option.map (fun x -> copy_loc (fun x -> x) x) x2 ) + | Ast_501.Parsetree.Pcf_val x0 -> + Ast_500.Parsetree.Pcf_val + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_mutable_flag x1, copy_class_field_kind x2)) + | Ast_501.Parsetree.Pcf_method x0 -> + Ast_500.Parsetree.Pcf_method + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_private_flag x1, copy_class_field_kind x2)) + | Ast_501.Parsetree.Pcf_constraint x0 -> + Ast_500.Parsetree.Pcf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | Ast_501.Parsetree.Pcf_initializer x0 -> + Ast_500.Parsetree.Pcf_initializer (copy_expression x0) + | Ast_501.Parsetree.Pcf_attribute x0 -> + Ast_500.Parsetree.Pcf_attribute (copy_attribute x0) + | Ast_501.Parsetree.Pcf_extension x0 -> + Ast_500.Parsetree.Pcf_extension (copy_extension x0) + +and copy_class_field_kind : + Ast_501.Parsetree.class_field_kind -> Ast_500.Parsetree.class_field_kind = + function + | Ast_501.Parsetree.Cfk_virtual x0 -> + Ast_500.Parsetree.Cfk_virtual (copy_core_type x0) + | Ast_501.Parsetree.Cfk_concrete (x0, x1) -> + Ast_500.Parsetree.Cfk_concrete (copy_override_flag x0, copy_expression x1) + +and copy_open_declaration : + Ast_501.Parsetree.open_declaration -> Ast_500.Parsetree.open_declaration = + fun x -> copy_open_infos copy_module_expr x + +and copy_module_binding : + Ast_501.Parsetree.module_binding -> Ast_500.Parsetree.module_binding = + fun { + Ast_501.Parsetree.pmb_name; + Ast_501.Parsetree.pmb_expr; + Ast_501.Parsetree.pmb_attributes; + Ast_501.Parsetree.pmb_loc; + } -> + { + Ast_500.Parsetree.pmb_name = + copy_loc (fun x -> Option.map (fun x -> x) x) pmb_name; + Ast_500.Parsetree.pmb_expr = copy_module_expr pmb_expr; + Ast_500.Parsetree.pmb_attributes = copy_attributes pmb_attributes; + Ast_500.Parsetree.pmb_loc = copy_location pmb_loc; + } + +and copy_module_expr : + Ast_501.Parsetree.module_expr -> Ast_500.Parsetree.module_expr = + fun { + Ast_501.Parsetree.pmod_desc; + Ast_501.Parsetree.pmod_loc; + Ast_501.Parsetree.pmod_attributes; + } -> + { + Ast_500.Parsetree.pmod_desc = copy_module_expr_desc pmod_desc; + Ast_500.Parsetree.pmod_loc = copy_location pmod_loc; + Ast_500.Parsetree.pmod_attributes = copy_attributes pmod_attributes; + } + +and copy_module_expr_desc : + Ast_501.Parsetree.module_expr_desc -> Ast_500.Parsetree.module_expr_desc = + function + | Ast_501.Parsetree.Pmod_ident x0 -> + Ast_500.Parsetree.Pmod_ident (copy_loc copy_Longident_t x0) + | Ast_501.Parsetree.Pmod_structure x0 -> + Ast_500.Parsetree.Pmod_structure (copy_structure x0) + | Ast_501.Parsetree.Pmod_functor (x0, x1) -> + Ast_500.Parsetree.Pmod_functor + (copy_functor_parameter x0, copy_module_expr x1) + | Ast_501.Parsetree.Pmod_apply (x0, x1) -> + Ast_500.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) + | Ast_501.Parsetree.Pmod_apply_unit x0 -> + let empty_struct = + Ast_500.Parsetree. + { + pmod_desc = Pmod_structure []; + pmod_loc = Location.none; + pmod_attributes = []; + } + in + Ast_500.Parsetree.Pmod_apply (copy_module_expr x0, empty_struct) + | Ast_501.Parsetree.Pmod_constraint (x0, x1) -> + Ast_500.Parsetree.Pmod_constraint + (copy_module_expr x0, copy_module_type x1) + | Ast_501.Parsetree.Pmod_unpack x0 -> + Ast_500.Parsetree.Pmod_unpack (copy_expression x0) + | Ast_501.Parsetree.Pmod_extension x0 -> + Ast_500.Parsetree.Pmod_extension (copy_extension x0) + +and copy_functor_parameter : + Ast_501.Parsetree.functor_parameter -> Ast_500.Parsetree.functor_parameter = + function + | Ast_501.Parsetree.Unit -> Ast_500.Parsetree.Unit + | Ast_501.Parsetree.Named (x0, x1) -> + Ast_500.Parsetree.Named + (copy_loc (fun x -> Option.map (fun x -> x) x) x0, copy_module_type x1) + +and copy_module_type : + Ast_501.Parsetree.module_type -> Ast_500.Parsetree.module_type = + fun { + Ast_501.Parsetree.pmty_desc; + Ast_501.Parsetree.pmty_loc; + Ast_501.Parsetree.pmty_attributes; + } -> + { + Ast_500.Parsetree.pmty_desc = copy_module_type_desc pmty_desc; + Ast_500.Parsetree.pmty_loc = copy_location pmty_loc; + Ast_500.Parsetree.pmty_attributes = copy_attributes pmty_attributes; + } + +and copy_module_type_desc : + Ast_501.Parsetree.module_type_desc -> Ast_500.Parsetree.module_type_desc = + function + | Ast_501.Parsetree.Pmty_ident x0 -> + Ast_500.Parsetree.Pmty_ident (copy_loc copy_Longident_t x0) + | Ast_501.Parsetree.Pmty_signature x0 -> + Ast_500.Parsetree.Pmty_signature (copy_signature x0) + | Ast_501.Parsetree.Pmty_functor (x0, x1) -> + Ast_500.Parsetree.Pmty_functor + (copy_functor_parameter x0, copy_module_type x1) + | Ast_501.Parsetree.Pmty_with (x0, x1) -> + Ast_500.Parsetree.Pmty_with + (copy_module_type x0, List.map copy_with_constraint x1) + | Ast_501.Parsetree.Pmty_typeof x0 -> + Ast_500.Parsetree.Pmty_typeof (copy_module_expr x0) + | Ast_501.Parsetree.Pmty_extension x0 -> + Ast_500.Parsetree.Pmty_extension (copy_extension x0) + | Ast_501.Parsetree.Pmty_alias x0 -> + Ast_500.Parsetree.Pmty_alias (copy_loc copy_Longident_t x0) + +and copy_with_constraint : + Ast_501.Parsetree.with_constraint -> Ast_500.Parsetree.with_constraint = + function + | Ast_501.Parsetree.Pwith_type (x0, x1) -> + Ast_500.Parsetree.Pwith_type + (copy_loc copy_Longident_t x0, copy_type_declaration x1) + | Ast_501.Parsetree.Pwith_module (x0, x1) -> + Ast_500.Parsetree.Pwith_module + (copy_loc copy_Longident_t x0, copy_loc copy_Longident_t x1) + | Ast_501.Parsetree.Pwith_modtype (x0, x1) -> + Ast_500.Parsetree.Pwith_modtype + (copy_loc copy_Longident_t x0, copy_module_type x1) + | Ast_501.Parsetree.Pwith_modtypesubst (x0, x1) -> + Ast_500.Parsetree.Pwith_modtypesubst + (copy_loc copy_Longident_t x0, copy_module_type x1) + | Ast_501.Parsetree.Pwith_typesubst (x0, x1) -> + Ast_500.Parsetree.Pwith_typesubst + (copy_loc copy_Longident_t x0, copy_type_declaration x1) + | Ast_501.Parsetree.Pwith_modsubst (x0, x1) -> + Ast_500.Parsetree.Pwith_modsubst + (copy_loc copy_Longident_t x0, copy_loc copy_Longident_t x1) + +and copy_signature : Ast_501.Parsetree.signature -> Ast_500.Parsetree.signature + = + fun x -> List.map copy_signature_item x + +and copy_signature_item : + Ast_501.Parsetree.signature_item -> Ast_500.Parsetree.signature_item = + fun { Ast_501.Parsetree.psig_desc; Ast_501.Parsetree.psig_loc } -> + { + Ast_500.Parsetree.psig_desc = copy_signature_item_desc psig_desc; + Ast_500.Parsetree.psig_loc = copy_location psig_loc; + } + +and copy_signature_item_desc : + Ast_501.Parsetree.signature_item_desc -> + Ast_500.Parsetree.signature_item_desc = function + | Ast_501.Parsetree.Psig_value x0 -> + Ast_500.Parsetree.Psig_value (copy_value_description x0) + | Ast_501.Parsetree.Psig_type (x0, x1) -> + Ast_500.Parsetree.Psig_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | Ast_501.Parsetree.Psig_typesubst x0 -> + Ast_500.Parsetree.Psig_typesubst (List.map copy_type_declaration x0) + | Ast_501.Parsetree.Psig_typext x0 -> + Ast_500.Parsetree.Psig_typext (copy_type_extension x0) + | Ast_501.Parsetree.Psig_exception x0 -> + Ast_500.Parsetree.Psig_exception (copy_type_exception x0) + | Ast_501.Parsetree.Psig_module x0 -> + Ast_500.Parsetree.Psig_module (copy_module_declaration x0) + | Ast_501.Parsetree.Psig_modsubst x0 -> + Ast_500.Parsetree.Psig_modsubst (copy_module_substitution x0) + | Ast_501.Parsetree.Psig_recmodule x0 -> + Ast_500.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) + | Ast_501.Parsetree.Psig_modtype x0 -> + Ast_500.Parsetree.Psig_modtype (copy_module_type_declaration x0) + | Ast_501.Parsetree.Psig_modtypesubst x0 -> + Ast_500.Parsetree.Psig_modtypesubst (copy_module_type_declaration x0) + | Ast_501.Parsetree.Psig_open x0 -> + Ast_500.Parsetree.Psig_open (copy_open_description x0) + | Ast_501.Parsetree.Psig_include x0 -> + Ast_500.Parsetree.Psig_include (copy_include_description x0) + | Ast_501.Parsetree.Psig_class x0 -> + Ast_500.Parsetree.Psig_class (List.map copy_class_description x0) + | Ast_501.Parsetree.Psig_class_type x0 -> + Ast_500.Parsetree.Psig_class_type + (List.map copy_class_type_declaration x0) + | Ast_501.Parsetree.Psig_attribute x0 -> + Ast_500.Parsetree.Psig_attribute (copy_attribute x0) + | Ast_501.Parsetree.Psig_extension (x0, x1) -> + Ast_500.Parsetree.Psig_extension (copy_extension x0, copy_attributes x1) + +and copy_class_type_declaration : + Ast_501.Parsetree.class_type_declaration -> + Ast_500.Parsetree.class_type_declaration = + fun x -> copy_class_infos copy_class_type x + +and copy_class_description : + Ast_501.Parsetree.class_description -> Ast_500.Parsetree.class_description = + fun x -> copy_class_infos copy_class_type x + +and copy_class_type : + Ast_501.Parsetree.class_type -> Ast_500.Parsetree.class_type = + fun { + Ast_501.Parsetree.pcty_desc; + Ast_501.Parsetree.pcty_loc; + Ast_501.Parsetree.pcty_attributes; + } -> + { + Ast_500.Parsetree.pcty_desc = copy_class_type_desc pcty_desc; + Ast_500.Parsetree.pcty_loc = copy_location pcty_loc; + Ast_500.Parsetree.pcty_attributes = copy_attributes pcty_attributes; + } + +and copy_class_type_desc : + Ast_501.Parsetree.class_type_desc -> Ast_500.Parsetree.class_type_desc = + function + | Ast_501.Parsetree.Pcty_constr (x0, x1) -> + Ast_500.Parsetree.Pcty_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_501.Parsetree.Pcty_signature x0 -> + Ast_500.Parsetree.Pcty_signature (copy_class_signature x0) + | Ast_501.Parsetree.Pcty_arrow (x0, x1, x2) -> + Ast_500.Parsetree.Pcty_arrow + (copy_arg_label x0, copy_core_type x1, copy_class_type x2) + | Ast_501.Parsetree.Pcty_extension x0 -> + Ast_500.Parsetree.Pcty_extension (copy_extension x0) + | Ast_501.Parsetree.Pcty_open (x0, x1) -> + Ast_500.Parsetree.Pcty_open (copy_open_description x0, copy_class_type x1) + +and copy_class_signature : + Ast_501.Parsetree.class_signature -> Ast_500.Parsetree.class_signature = + fun { Ast_501.Parsetree.pcsig_self; Ast_501.Parsetree.pcsig_fields } -> + { + Ast_500.Parsetree.pcsig_self = copy_core_type pcsig_self; + Ast_500.Parsetree.pcsig_fields = List.map copy_class_type_field pcsig_fields; + } + +and copy_class_type_field : + Ast_501.Parsetree.class_type_field -> Ast_500.Parsetree.class_type_field = + fun { + Ast_501.Parsetree.pctf_desc; + Ast_501.Parsetree.pctf_loc; + Ast_501.Parsetree.pctf_attributes; + } -> + { + Ast_500.Parsetree.pctf_desc = copy_class_type_field_desc pctf_desc; + Ast_500.Parsetree.pctf_loc = copy_location pctf_loc; + Ast_500.Parsetree.pctf_attributes = copy_attributes pctf_attributes; + } + +and copy_class_type_field_desc : + Ast_501.Parsetree.class_type_field_desc -> + Ast_500.Parsetree.class_type_field_desc = function + | Ast_501.Parsetree.Pctf_inherit x0 -> + Ast_500.Parsetree.Pctf_inherit (copy_class_type x0) + | Ast_501.Parsetree.Pctf_val x0 -> + Ast_500.Parsetree.Pctf_val + (let x0, x1, x2, x3 = x0 in + ( copy_loc copy_label x0, + copy_mutable_flag x1, + copy_virtual_flag x2, + copy_core_type x3 )) + | Ast_501.Parsetree.Pctf_method x0 -> + Ast_500.Parsetree.Pctf_method + (let x0, x1, x2, x3 = x0 in + ( copy_loc copy_label x0, + copy_private_flag x1, + copy_virtual_flag x2, + copy_core_type x3 )) + | Ast_501.Parsetree.Pctf_constraint x0 -> + Ast_500.Parsetree.Pctf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | Ast_501.Parsetree.Pctf_attribute x0 -> + Ast_500.Parsetree.Pctf_attribute (copy_attribute x0) + | Ast_501.Parsetree.Pctf_extension x0 -> + Ast_500.Parsetree.Pctf_extension (copy_extension x0) + +and copy_extension : Ast_501.Parsetree.extension -> Ast_500.Parsetree.extension + = + fun x -> + let x0, x1 = x in + (copy_loc (fun x -> x) x0, copy_payload x1) + +and copy_class_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 Ast_501.Parsetree.class_infos -> + 'g0 Ast_500.Parsetree.class_infos = + fun f0 + { + Ast_501.Parsetree.pci_virt; + Ast_501.Parsetree.pci_params; + Ast_501.Parsetree.pci_name; + Ast_501.Parsetree.pci_expr; + Ast_501.Parsetree.pci_loc; + Ast_501.Parsetree.pci_attributes; + } -> + { + Ast_500.Parsetree.pci_virt = copy_virtual_flag pci_virt; + Ast_500.Parsetree.pci_params = + List.map + (fun x -> + let x0, x1 = x in + ( copy_core_type x0, + let x0, x1 = x1 in + (copy_variance x0, copy_injectivity x1) )) + pci_params; + Ast_500.Parsetree.pci_name = copy_loc (fun x -> x) pci_name; + Ast_500.Parsetree.pci_expr = f0 pci_expr; + Ast_500.Parsetree.pci_loc = copy_location pci_loc; + Ast_500.Parsetree.pci_attributes = copy_attributes pci_attributes; + } + +and copy_virtual_flag : + Ast_501.Asttypes.virtual_flag -> Ast_500.Asttypes.virtual_flag = function + | Ast_501.Asttypes.Virtual -> Ast_500.Asttypes.Virtual + | Ast_501.Asttypes.Concrete -> Ast_500.Asttypes.Concrete + +and copy_include_description : + Ast_501.Parsetree.include_description -> + Ast_500.Parsetree.include_description = + fun x -> copy_include_infos copy_module_type x + +and copy_include_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 Ast_501.Parsetree.include_infos -> + 'g0 Ast_500.Parsetree.include_infos = + fun f0 + { + Ast_501.Parsetree.pincl_mod; + Ast_501.Parsetree.pincl_loc; + Ast_501.Parsetree.pincl_attributes; + } -> + { + Ast_500.Parsetree.pincl_mod = f0 pincl_mod; + Ast_500.Parsetree.pincl_loc = copy_location pincl_loc; + Ast_500.Parsetree.pincl_attributes = copy_attributes pincl_attributes; + } + +and copy_open_description : + Ast_501.Parsetree.open_description -> Ast_500.Parsetree.open_description = + fun x -> copy_open_infos (fun x -> copy_loc copy_Longident_t x) x + +and copy_open_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 Ast_501.Parsetree.open_infos -> + 'g0 Ast_500.Parsetree.open_infos = + fun f0 + { + Ast_501.Parsetree.popen_expr; + Ast_501.Parsetree.popen_override; + Ast_501.Parsetree.popen_loc; + Ast_501.Parsetree.popen_attributes; + } -> + { + Ast_500.Parsetree.popen_expr = f0 popen_expr; + Ast_500.Parsetree.popen_override = copy_override_flag popen_override; + Ast_500.Parsetree.popen_loc = copy_location popen_loc; + Ast_500.Parsetree.popen_attributes = copy_attributes popen_attributes; + } + +and copy_override_flag : + Ast_501.Asttypes.override_flag -> Ast_500.Asttypes.override_flag = function + | Ast_501.Asttypes.Override -> Ast_500.Asttypes.Override + | Ast_501.Asttypes.Fresh -> Ast_500.Asttypes.Fresh + +and copy_module_type_declaration : + Ast_501.Parsetree.module_type_declaration -> + Ast_500.Parsetree.module_type_declaration = + fun { + Ast_501.Parsetree.pmtd_name; + Ast_501.Parsetree.pmtd_type; + Ast_501.Parsetree.pmtd_attributes; + Ast_501.Parsetree.pmtd_loc; + } -> + { + Ast_500.Parsetree.pmtd_name = copy_loc (fun x -> x) pmtd_name; + Ast_500.Parsetree.pmtd_type = Option.map copy_module_type pmtd_type; + Ast_500.Parsetree.pmtd_attributes = copy_attributes pmtd_attributes; + Ast_500.Parsetree.pmtd_loc = copy_location pmtd_loc; + } + +and copy_module_substitution : + Ast_501.Parsetree.module_substitution -> + Ast_500.Parsetree.module_substitution = + fun { + Ast_501.Parsetree.pms_name; + Ast_501.Parsetree.pms_manifest; + Ast_501.Parsetree.pms_attributes; + Ast_501.Parsetree.pms_loc; + } -> + { + Ast_500.Parsetree.pms_name = copy_loc (fun x -> x) pms_name; + Ast_500.Parsetree.pms_manifest = copy_loc copy_Longident_t pms_manifest; + Ast_500.Parsetree.pms_attributes = copy_attributes pms_attributes; + Ast_500.Parsetree.pms_loc = copy_location pms_loc; + } + +and copy_module_declaration : + Ast_501.Parsetree.module_declaration -> Ast_500.Parsetree.module_declaration + = + fun { + Ast_501.Parsetree.pmd_name; + Ast_501.Parsetree.pmd_type; + Ast_501.Parsetree.pmd_attributes; + Ast_501.Parsetree.pmd_loc; + } -> + { + Ast_500.Parsetree.pmd_name = + copy_loc (fun x -> Option.map (fun x -> x) x) pmd_name; + Ast_500.Parsetree.pmd_type = copy_module_type pmd_type; + Ast_500.Parsetree.pmd_attributes = copy_attributes pmd_attributes; + Ast_500.Parsetree.pmd_loc = copy_location pmd_loc; + } + +and copy_type_exception : + Ast_501.Parsetree.type_exception -> Ast_500.Parsetree.type_exception = + fun { + Ast_501.Parsetree.ptyexn_constructor; + Ast_501.Parsetree.ptyexn_loc; + Ast_501.Parsetree.ptyexn_attributes; + } -> + { + Ast_500.Parsetree.ptyexn_constructor = + copy_extension_constructor ptyexn_constructor; + Ast_500.Parsetree.ptyexn_loc = copy_location ptyexn_loc; + Ast_500.Parsetree.ptyexn_attributes = copy_attributes ptyexn_attributes; + } + +and copy_type_extension : + Ast_501.Parsetree.type_extension -> Ast_500.Parsetree.type_extension = + fun { + Ast_501.Parsetree.ptyext_path; + Ast_501.Parsetree.ptyext_params; + Ast_501.Parsetree.ptyext_constructors; + Ast_501.Parsetree.ptyext_private; + Ast_501.Parsetree.ptyext_loc; + Ast_501.Parsetree.ptyext_attributes; + } -> + { + Ast_500.Parsetree.ptyext_path = copy_loc copy_Longident_t ptyext_path; + Ast_500.Parsetree.ptyext_params = + List.map + (fun x -> + let x0, x1 = x in + ( copy_core_type x0, + let x0, x1 = x1 in + (copy_variance x0, copy_injectivity x1) )) + ptyext_params; + Ast_500.Parsetree.ptyext_constructors = + List.map copy_extension_constructor ptyext_constructors; + Ast_500.Parsetree.ptyext_private = copy_private_flag ptyext_private; + Ast_500.Parsetree.ptyext_loc = copy_location ptyext_loc; + Ast_500.Parsetree.ptyext_attributes = copy_attributes ptyext_attributes; + } + +and copy_extension_constructor : + Ast_501.Parsetree.extension_constructor -> + Ast_500.Parsetree.extension_constructor = + fun { + Ast_501.Parsetree.pext_name; + Ast_501.Parsetree.pext_kind; + Ast_501.Parsetree.pext_loc; + Ast_501.Parsetree.pext_attributes; + } -> + { + Ast_500.Parsetree.pext_name = copy_loc (fun x -> x) pext_name; + Ast_500.Parsetree.pext_kind = copy_extension_constructor_kind pext_kind; + Ast_500.Parsetree.pext_loc = copy_location pext_loc; + Ast_500.Parsetree.pext_attributes = copy_attributes pext_attributes; + } + +and copy_extension_constructor_kind : + Ast_501.Parsetree.extension_constructor_kind -> + Ast_500.Parsetree.extension_constructor_kind = function + | Ast_501.Parsetree.Pext_decl (x0, x1, x2) -> + Ast_500.Parsetree.Pext_decl + ( List.map (fun x -> copy_loc (fun x -> x) x) x0, + copy_constructor_arguments x1, + Option.map copy_core_type x2 ) + | Ast_501.Parsetree.Pext_rebind x0 -> + Ast_500.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0) + +and copy_type_declaration : + Ast_501.Parsetree.type_declaration -> Ast_500.Parsetree.type_declaration = + fun { + Ast_501.Parsetree.ptype_name; + Ast_501.Parsetree.ptype_params; + Ast_501.Parsetree.ptype_cstrs; + Ast_501.Parsetree.ptype_kind; + Ast_501.Parsetree.ptype_private; + Ast_501.Parsetree.ptype_manifest; + Ast_501.Parsetree.ptype_attributes; + Ast_501.Parsetree.ptype_loc; + } -> + { + Ast_500.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name; + Ast_500.Parsetree.ptype_params = + List.map + (fun x -> + let x0, x1 = x in + ( copy_core_type x0, + let x0, x1 = x1 in + (copy_variance x0, copy_injectivity x1) )) + ptype_params; + Ast_500.Parsetree.ptype_cstrs = + List.map + (fun x -> + let x0, x1, x2 = x in + (copy_core_type x0, copy_core_type x1, copy_location x2)) + ptype_cstrs; + Ast_500.Parsetree.ptype_kind = copy_type_kind ptype_kind; + Ast_500.Parsetree.ptype_private = copy_private_flag ptype_private; + Ast_500.Parsetree.ptype_manifest = Option.map copy_core_type ptype_manifest; + Ast_500.Parsetree.ptype_attributes = copy_attributes ptype_attributes; + Ast_500.Parsetree.ptype_loc = copy_location ptype_loc; + } + +and copy_private_flag : + Ast_501.Asttypes.private_flag -> Ast_500.Asttypes.private_flag = function + | Ast_501.Asttypes.Private -> Ast_500.Asttypes.Private + | Ast_501.Asttypes.Public -> Ast_500.Asttypes.Public + +and copy_type_kind : Ast_501.Parsetree.type_kind -> Ast_500.Parsetree.type_kind + = function + | Ast_501.Parsetree.Ptype_abstract -> Ast_500.Parsetree.Ptype_abstract + | Ast_501.Parsetree.Ptype_variant x0 -> + Ast_500.Parsetree.Ptype_variant (List.map copy_constructor_declaration x0) + | Ast_501.Parsetree.Ptype_record x0 -> + Ast_500.Parsetree.Ptype_record (List.map copy_label_declaration x0) + | Ast_501.Parsetree.Ptype_open -> Ast_500.Parsetree.Ptype_open + +and copy_constructor_declaration : + Ast_501.Parsetree.constructor_declaration -> + Ast_500.Parsetree.constructor_declaration = + fun { + Ast_501.Parsetree.pcd_name; + Ast_501.Parsetree.pcd_vars; + Ast_501.Parsetree.pcd_args; + Ast_501.Parsetree.pcd_res; + Ast_501.Parsetree.pcd_loc; + Ast_501.Parsetree.pcd_attributes; + } -> + { + Ast_500.Parsetree.pcd_name = copy_loc (fun x -> x) pcd_name; + Ast_500.Parsetree.pcd_vars = + List.map (fun x -> copy_loc (fun x -> x) x) pcd_vars; + Ast_500.Parsetree.pcd_args = copy_constructor_arguments pcd_args; + Ast_500.Parsetree.pcd_res = Option.map copy_core_type pcd_res; + Ast_500.Parsetree.pcd_loc = copy_location pcd_loc; + Ast_500.Parsetree.pcd_attributes = copy_attributes pcd_attributes; + } + +and copy_constructor_arguments : + Ast_501.Parsetree.constructor_arguments -> + Ast_500.Parsetree.constructor_arguments = function + | Ast_501.Parsetree.Pcstr_tuple x0 -> + Ast_500.Parsetree.Pcstr_tuple (List.map copy_core_type x0) + | Ast_501.Parsetree.Pcstr_record x0 -> + Ast_500.Parsetree.Pcstr_record (List.map copy_label_declaration x0) + +and copy_label_declaration : + Ast_501.Parsetree.label_declaration -> Ast_500.Parsetree.label_declaration = + fun { + Ast_501.Parsetree.pld_name; + Ast_501.Parsetree.pld_mutable; + Ast_501.Parsetree.pld_type; + Ast_501.Parsetree.pld_loc; + Ast_501.Parsetree.pld_attributes; + } -> + { + Ast_500.Parsetree.pld_name = copy_loc (fun x -> x) pld_name; + Ast_500.Parsetree.pld_mutable = copy_mutable_flag pld_mutable; + Ast_500.Parsetree.pld_type = copy_core_type pld_type; + Ast_500.Parsetree.pld_loc = copy_location pld_loc; + Ast_500.Parsetree.pld_attributes = copy_attributes pld_attributes; + } + +and copy_mutable_flag : + Ast_501.Asttypes.mutable_flag -> Ast_500.Asttypes.mutable_flag = function + | Ast_501.Asttypes.Immutable -> Ast_500.Asttypes.Immutable + | Ast_501.Asttypes.Mutable -> Ast_500.Asttypes.Mutable + +and copy_injectivity : + Ast_501.Asttypes.injectivity -> Ast_500.Asttypes.injectivity = function + | Ast_501.Asttypes.Injective -> Ast_500.Asttypes.Injective + | Ast_501.Asttypes.NoInjectivity -> Ast_500.Asttypes.NoInjectivity + +and copy_variance : Ast_501.Asttypes.variance -> Ast_500.Asttypes.variance = + function + | Ast_501.Asttypes.Covariant -> Ast_500.Asttypes.Covariant + | Ast_501.Asttypes.Contravariant -> Ast_500.Asttypes.Contravariant + | Ast_501.Asttypes.NoVariance -> Ast_500.Asttypes.NoVariance + +and copy_value_description : + Ast_501.Parsetree.value_description -> Ast_500.Parsetree.value_description = + fun { + Ast_501.Parsetree.pval_name; + Ast_501.Parsetree.pval_type; + Ast_501.Parsetree.pval_prim; + Ast_501.Parsetree.pval_attributes; + Ast_501.Parsetree.pval_loc; + } -> + { + Ast_500.Parsetree.pval_name = copy_loc (fun x -> x) pval_name; + Ast_500.Parsetree.pval_type = copy_core_type pval_type; + Ast_500.Parsetree.pval_prim = List.map (fun x -> x) pval_prim; + Ast_500.Parsetree.pval_attributes = copy_attributes pval_attributes; + Ast_500.Parsetree.pval_loc = copy_location pval_loc; + } + +and copy_object_field_desc : + Ast_501.Parsetree.object_field_desc -> Ast_500.Parsetree.object_field_desc = + function + | Ast_501.Parsetree.Otag (x0, x1) -> + Ast_500.Parsetree.Otag (copy_loc copy_label x0, copy_core_type x1) + | Ast_501.Parsetree.Oinherit x0 -> + Ast_500.Parsetree.Oinherit (copy_core_type x0) + +and copy_arg_label : Ast_501.Asttypes.arg_label -> Ast_500.Asttypes.arg_label = + function + | Ast_501.Asttypes.Nolabel -> Ast_500.Asttypes.Nolabel + | Ast_501.Asttypes.Labelled x0 -> Ast_500.Asttypes.Labelled x0 + | Ast_501.Asttypes.Optional x0 -> Ast_500.Asttypes.Optional x0 + +and copy_closed_flag : + Ast_501.Asttypes.closed_flag -> Ast_500.Asttypes.closed_flag = function + | Ast_501.Asttypes.Closed -> Ast_500.Asttypes.Closed + | Ast_501.Asttypes.Open -> Ast_500.Asttypes.Open + +and copy_label : Ast_501.Asttypes.label -> Ast_500.Asttypes.label = fun x -> x + +and copy_rec_flag : Ast_501.Asttypes.rec_flag -> Ast_500.Asttypes.rec_flag = + function + | Ast_501.Asttypes.Nonrecursive -> Ast_500.Asttypes.Nonrecursive + | Ast_501.Asttypes.Recursive -> Ast_500.Asttypes.Recursive + +and copy_constant : Ast_501.Parsetree.constant -> Ast_500.Parsetree.constant = + function + | Ast_501.Parsetree.Pconst_integer (x0, x1) -> + Ast_500.Parsetree.Pconst_integer (x0, Option.map (fun x -> x) x1) + | Ast_501.Parsetree.Pconst_char x0 -> Ast_500.Parsetree.Pconst_char x0 + | Ast_501.Parsetree.Pconst_string (x0, x1, x2) -> + Ast_500.Parsetree.Pconst_string + (x0, copy_location x1, Option.map (fun x -> x) x2) + | Ast_501.Parsetree.Pconst_float (x0, x1) -> + Ast_500.Parsetree.Pconst_float (x0, Option.map (fun x -> x) x1) + +and copy_Longident_t : Longident.t -> Longident.t = function + | Longident.Lident x0 -> Longident.Lident x0 + | Longident.Ldot (x0, x1) -> Longident.Ldot (copy_Longident_t x0, x1) + | Longident.Lapply (x0, x1) -> + Longident.Lapply (copy_Longident_t x0, copy_Longident_t x1) + +and copy_loc : + 'f0 'g0. + ('f0 -> 'g0) -> 'f0 Ast_501.Asttypes.loc -> 'g0 Ast_500.Asttypes.loc = + fun f0 { Ast_501.Asttypes.txt; Ast_501.Asttypes.loc } -> + { Ast_500.Asttypes.txt = f0 txt; Ast_500.Asttypes.loc = copy_location loc } + +and copy_location : Location.t -> Location.t = + fun { Location.loc_start; Location.loc_end; Location.loc_ghost } -> + { + Location.loc_start = copy_position loc_start; + Location.loc_end = copy_position loc_end; + Location.loc_ghost; + } + +and copy_position : Lexing.position -> Lexing.position = + fun { Lexing.pos_fname; Lexing.pos_lnum; Lexing.pos_bol; Lexing.pos_cnum } -> + { Lexing.pos_fname; Lexing.pos_lnum; Lexing.pos_bol; Lexing.pos_cnum } diff --git a/dune-project b/dune-project index 54683d0ed..de18121e7 100644 --- a/dune-project +++ b/dune-project @@ -15,7 +15,7 @@ (package (name ppxlib) (depends - (ocaml (and (>= 4.04.1) (< 5.1.0))) + (ocaml (and (>= 4.04.1) (<> 5.1.0~alpha1))) (ocaml-compiler-libs (>= v0.11.0)) (ppx_derivers (>= 1.0)) (sexplib0 (>= v0.12)) diff --git a/ppxlib.opam b/ppxlib.opam index 56fa0c809..9acd806c1 100644 --- a/ppxlib.opam +++ b/ppxlib.opam @@ -21,7 +21,7 @@ doc: "https://ocaml-ppx.github.io/ppxlib/" bug-reports: "https://github.com/ocaml-ppx/ppxlib/issues" depends: [ "dune" {>= "2.7"} - "ocaml" {>= "4.04.1" & < "5.1.0"} + "ocaml" {>= "4.04.1" & != "5.1.0~alpha1"} "ocaml-compiler-libs" {>= "v0.11.0"} "ppx_derivers" {>= "1.0"} "sexplib0" {>= "v0.12"} diff --git a/src/location_check.ml b/src/location_check.ml index e29ff1c97..2c0e35fe2 100644 --- a/src/location_check.ml +++ b/src/location_check.ml @@ -161,7 +161,7 @@ let should_ignore loc attrs = let rec extract_constraint e = match e.pexp_desc with - | Pexp_constraint (e, ct) | Pexp_coerce (e, None, ct) -> Some (e, ct) + | Pexp_constraint (e, ct) | Pexp_coerce (e, _, ct) -> Some (e, ct) | Pexp_newtype (name, exp) -> Option.map (extract_constraint exp) ~f:(fun (exp, ct) -> ( { diff --git a/test/501_migrations/compare_on.ml b/test/501_migrations/compare_on.ml new file mode 100644 index 000000000..ecd059cf5 --- /dev/null +++ b/test/501_migrations/compare_on.ml @@ -0,0 +1,30 @@ +let run () = + let example_fn, ppx = + let args = Sys.argv in + if not (Array.length args = 3) then failwith "expected exactly two args" + else (Array.get args 1, Array.get args 2) + in + let direct = "without_migrations" in + let migrations = "with_migrations" in + let direct_ec = + Sys.command ("ocamlc -dparsetree " ^ example_fn ^ " 2> " ^ direct) + in + if direct_ec > 0 then ( + print_endline "compile error even without migrations"; + let _ = Sys.command ("cat " ^ direct) in + ()) + else + let migrations_ec = + Sys.command + ("ocamlc -dparsetree -ppx '" ^ ppx ^ " -as-ppx' " ^ example_fn ^ " 2> " + ^ migrations) + in + if migrations_ec > 0 then ( + print_endline "compile error after migrations"; + let _ = Sys.command ("cat " ^ migrations) in + ()) + else + let _ = Sys.command ("diff -U 0 " ^ direct ^ " " ^ migrations) in + () + +let () = run () diff --git a/test/501_migrations/dune b/test/501_migrations/dune new file mode 100644 index 000000000..886d2881a --- /dev/null +++ b/test/501_migrations/dune @@ -0,0 +1,36 @@ +(executable + (name identity_driver) + (modules identity_driver) + (libraries ppxlib)) + +(executable + (name reverse_migrations) + (modules reverse_migrations) + (libraries ppxlib)) + +(executable + (name compare_on) + (libraries unix) + (modules compare_on)) + +(cram + (enabled_if + (and + (>= %{ocaml_version} "5.1.0~alpha2") + (< %{ocaml_version} "5.2.0"))) + (applies_to normal_migrations) + (deps identity_driver.exe compare_on.exe)) + +(cram + (enabled_if + (= %{ocaml_version} "5.0.0")) + (applies_to reverse_migrations) + (deps reverse_migrations.exe compare_on.exe)) + +(cram + (enabled_if + (and + (>= %{ocaml_version} "5.0.0") + (< %{ocaml_version} "5.2.0"))) + (applies_to one_migration) + (deps identity_driver.exe compare_on.exe)) diff --git a/test/501_migrations/identity_driver.ml b/test/501_migrations/identity_driver.ml new file mode 100644 index 000000000..e3cba4049 --- /dev/null +++ b/test/501_migrations/identity_driver.ml @@ -0,0 +1 @@ +let () = Ppxlib.Driver.standalone () diff --git a/test/501_migrations/normal_migrations.t b/test/501_migrations/normal_migrations.t new file mode 100644 index 000000000..c9d2c8d42 --- /dev/null +++ b/test/501_migrations/normal_migrations.t @@ -0,0 +1,131 @@ +The 501 parsetree contains a parsing modificacion. +[compare_on.exe ] checks if there's a diff between the +AST's resulting from +1. parsing on 5.1.0 directly +2. parsing on 5.1.0, migrating down to 5.0.0 and migrating back to 5.1.0 +We only expect a diff in one special case. + + $ echo "let x : int = 5" > file.ml + $ ./compare_on.exe file.ml ./identity_driver.exe + + $ echo "let (x) : int = 5" > file.ml + $ ./compare_on.exe file.ml ./identity_driver.exe + + $ echo "let _ : int = 5" > file.ml + $ ./compare_on.exe file.ml ./identity_driver.exe + + $ echo "let f : type a b c. a -> b -> c = fun x y -> assert false" > file.ml + $ ./compare_on.exe file.ml ./identity_driver.exe + + $ echo "let f = (fun (type a) (type b) (type c) -> (fun x y -> assert false : a -> b -> c))" > file.ml + $ ./compare_on.exe file.ml ./identity_driver.exe + + $ echo "let _ = (fun (type a) (type b) (type c) -> (fun x y -> assert false : a -> b -> c))" > file.ml + $ ./compare_on.exe file.ml ./identity_driver.exe + + $ echo "let f : type a . a -> a = fun x -> x" > file.ml + $ ./compare_on.exe file.ml ./identity_driver.exe + + $ echo "let (x, y) : (int * int) = assert false" > file.ml + $ ./compare_on.exe file.ml ./identity_driver.exe + + $ echo "let f : type a . a = assert false" > file.ml + $ ./compare_on.exe file.ml ./identity_driver.exe + + $ echo 'let x : [`A] :> [`A | `B] = `A' > file.ml + $ ./compare_on.exe file.ml ./identity_driver.exe + + $ echo 'let x : [`A | `B] = (`A : [`A] :> [`A | `B])' > file.ml + $ ./compare_on.exe file.ml ./identity_driver.exe + + $ echo 'let x : :> = object method m = 0 method n = 1 end' > file.ml + $ ./compare_on.exe file.ml ./identity_driver.exe + + $ echo 'let x :> = object method m = 0 method n = 1 end' > file.ml + $ ./compare_on.exe file.ml ./identity_driver.exe + + +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. + $ echo "let ((x,y) : (int*int)) = (assert false: int * int)" > file.ml + $ ./compare_on.exe file.ml ./identity_driver.exe + 6,25c6,23 + < 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]) + > [] + > ] + + $ echo "let f: type a. a option -> _ = assert false" > file.ml + $ ./compare_on.exe file.ml ./identity_driver.exe + + +Here we may expect a diff (downwards migrating should yield the same as in the example right above). +However, those case are recoverable. + +First, both + + $ echo "let f : 'a . 'a = (fun (type a) -> (assert false : a))" > file.ml + $ ./compare_on.exe file.ml ./identity_driver.exe + +and + $ echo "let f : type a . a = assert false" > file.ml + $ ./compare_on.exe file.ml ./identity_driver.exe + +are translated to the same 5.0 AST tree. But the locations on the expression +constraint and pattern constraint are only the same in the second case. +Thus, we can distinguish between the two. + +Similarly, the syntactic translation for + + $ echo 'let x :> [`A | `B] = `A' > file.ml + $ ./compare_on.exe file.ml ./identity_driver.exe + +and + + $ echo 'let x : [`A | `B] = (`A :> [ `A | `B ] )' > file.ml + $ ./compare_on.exe file.ml ./identity_driver.exe + +are pretty close: The former is translated to "let (x: ø . [`A | `B]) = (`A :> [`A | `B])" +whereas the latter is mapped to "let (x: ø . [`A | `B]) = ((`A :> [`A | `B]): [`A | `B]) ". +However, the two case can be distingued by the fact that we have either an outward coercion +or an outward constraint associated to a `Ptyp_poly([],...)` pattern constraint. + +Let's make sure that in the examples with diffs, +the location invariants are still fulfilled. + $ echo "let ((x,y) : (int*int)) = (assert false: int * int)" > file.ml + $ ./identity_driver.exe -check -locations-check file.ml > /dev/null diff --git a/test/501_migrations/one_migration.t b/test/501_migrations/one_migration.t new file mode 100644 index 000000000..70a549b1f --- /dev/null +++ b/test/501_migrations/one_migration.t @@ -0,0 +1,572 @@ +This test is enabled both on 5.0.0 and 5.1.0. The test makes sense for as long +as the ppxlib AST is either 5.0.0 or 5.1.0. While the ppxlib AST is on 5.0.0, the +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. + + $ 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))))) diff --git a/test/501_migrations/reverse_migrations.ml b/test/501_migrations/reverse_migrations.ml new file mode 100644 index 000000000..0a3586b4d --- /dev/null +++ b/test/501_migrations/reverse_migrations.ml @@ -0,0 +1,9 @@ +module Reverse = Ppxlib_ast.Select_ast (Ppxlib_ast__.Versions.OCaml_501) + +let () = + let impl str = + Reverse.Of_ocaml.copy_structure @@ Reverse.To_ocaml.copy_structure str + in + Ppxlib.Driver.register_transformation ~impl "reverse_migrations" + +let () = Ppxlib.Driver.standalone () diff --git a/test/501_migrations/reverse_migrations.t b/test/501_migrations/reverse_migrations.t new file mode 100644 index 000000000..9120ed91e --- /dev/null +++ b/test/501_migrations/reverse_migrations.t @@ -0,0 +1,164 @@ +The 501 parsetree contains a parsing modificacion. +[compare_on.exe ./reverse_migrations.exe] checks if there's a diff between the +AST's resulting from +1. parsing on 5.0.0 directly +2. parsing on 5.0.0, migrating up to 5.1.0 and migrating back to 5.0.0 + + $ echo "let x : int = 5" > file.ml + $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] + + $ echo "let _ : int = 5" > file.ml + $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] + + $ echo "let f : type a b c. a -> b -> c = fun x y -> assert false" > file.ml + $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] + + $ echo "let f = (fun (type a) (type b) (type c) -> (fun x y -> assert false : a -> b -> c))" > file.ml + $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] + + $ echo "let _ = (fun (type a) (type b) (type c) -> (fun x y -> assert false : a -> b -> c))" > file.ml + $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] + + $ echo "let f : type a . a -> a = fun x -> x" > file.ml + $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] + + $ echo "let f: type a. a option -> _ = assert false" > file.ml + $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] + + $ echo "let f : 'a . 'a = (fun (type a) -> (assert false : a))" > file.ml + $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] + + $ echo "let f : type a . a = assert false" > file.ml + $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] + + $ echo 'let x :> [`A | `B] = `A' > file.ml + $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] + + $ echo 'let x : [`A] :> [`A | `B] = `A' > file.ml + $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] + + $ echo 'let x : [`A | `B] = (`A : [`A] :> [`A | `B])' > file.ml + $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] + + $ echo 'let x : :> = object method m = 0 method n = 1 end' > file.ml + $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] + + $ echo 'let x :> = object method m = 0 method n = 1 end' > file.ml + $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] + +The downward migration isn't able to recover the whole pattern location range, +since it doesn't track the location of the closing brackets. + $ echo "let (x, y) : (int * int) = assert false" > file.ml + $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" + @@ -6 +6 @@ + - pattern (file.ml[1,0+4]..[1,0+24]) ghost + + pattern (file.ml[1,0+4]..[1,0+23]) ghost + + $ echo "let (x, y) : (int * int) = assert false" > file.ml + $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" + @@ -6 +6 @@ + - pattern (file.ml[1,0+4]..[1,0+24]) ghost + + pattern (file.ml[1,0+4]..[1,0+23]) ghost + + $ echo "let f: type a. a option -> _ = assert false" > file.ml + $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] + + $ echo "let f : 'a . 'a = (fun (type a) -> (assert false : a))" > file.ml + $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] + + $ echo "let f : type a . a = assert false" > file.ml + $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] + + $ echo 'let x :> [`A | `B] = `A' > file.ml + $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] + + $ echo 'let x : [`A] :> [`A | `B] = `A' > file.ml + $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] + + $ echo 'let x : [`A | `B] = (`A : [`A] :> [`A | `B])' > file.ml + $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] + + $ echo 'let x : :> = object method m = 0 method n = 1 end' > file.ml + $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] + + $ echo 'let x :> = object method m = 0 method n = 1 end' > file.ml + $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] + +The diffs are on locations. If the location modification +at least preserved the location invariants, it might be acceptable. +However, in several cases it doesn't. + + $ echo "let x : int = 5" > file.ml + $ ./reverse_migrations.exe -check -locations-check file.ml > /dev/null + + $ echo "let (x as y) : int = 5" > file.ml + $ ./reverse_migrations.exe -check -locations-check file.ml > /dev/null + + $ cat > file.ml << EOF + > type t = {a : int} + > let {a} = {a = 5} + > EOF + $ ./reverse_migrations.exe -check -locations-check file.ml > /dev/null + + + $ echo "let _ : int = 5" > file.ml + $ ./reverse_migrations.exe -check -locations-check file.ml > /dev/null + + $ echo "let f : type a b c. a -> b -> c = fun x y -> assert false" > file.ml + $ ./reverse_migrations.exe -check -locations-check file.ml > /dev/null + + $ echo "let f = (fun (type a) (type b) (type c) -> (fun x y -> assert false : a -> b -> c))" > file.ml + $ ./reverse_migrations.exe -check -locations-check file.ml > /dev/null + + $ echo "let _ = (fun (type a) (type b) (type c) -> (fun x y -> assert false : a -> b -> c))" > file.ml + $ ./reverse_migrations.exe -check -locations-check file.ml > /dev/null + +Here we're expecting a similar location diff as above. However, the downward +migration is faulty: it turns [let (x) : int = 5] (constraint only on pattern) +into [let x : int = 5] (contraint on both pattern an expression). + $ echo "let (x) : int = 5" > file.ml + $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" + @@ -9,0 +10,9 @@ + + core_type (file.ml[1,0+10]..[1,0+13]) ghost + + Ptyp_poly + + core_type (file.ml[1,0+10]..[1,0+13]) + + Ptyp_constr "int" (file.ml[1,0+10]..[1,0+13]) + + [] + + expression (file.ml[1,0+4]..[1,0+17]) + + Pexp_constraint + + expression (file.ml[1,0+16]..[1,0+17]) + + Pexp_constant PConst_int (5,None) + @@ -13,2 +21,0 @@ + - expression (file.ml[1,0+16]..[1,0+17]) + - Pexp_constant PConst_int (5,None) + +Let's make sure that in the examples with diffs, +the location invariants are still fulfilled. + + $ echo "let (x, y) : (int * int) = assert false" > file.ml + $ ./reverse_migrations.exe -check -locations-check file.ml > /dev/null + + $ echo "let (x) : int = 5" > file.ml + $ ./reverse_migrations.exe -check -locations-check file.ml > /dev/null diff --git a/test/base/dune b/test/base/dune index 37beb0365..c13dc64c8 100644 --- a/test/base/dune +++ b/test/base/dune @@ -1,7 +1,9 @@ (rule (alias runtest) (enabled_if - (>= %{ocaml_version} "4.09.0")) + (and + (>= %{ocaml_version} "4.09.0") + (< %{ocaml_version} "5.1.0"))) (deps (:test test.ml) (package ppxlib)) @@ -11,3 +13,21 @@ (progn (run expect-test %{test}) (diff? %{test} %{test}.corrected))))) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} "5.1.0")) + (deps + (:test test.ml) + (:t test_510.ml) + (package ppxlib)) + (action + (chdir + %{project_root} + (progn + (run mv %{t} %{t}.old) + (run cp %{test} %{t}) + (run expect-test %{t}) + (run mv %{t}.old %{t}) + (diff? %{t} %{t}.corrected))))) diff --git a/test/base/test_510.ml b/test/base/test_510.ml new file mode 100644 index 000000000..4cd6b7ed6 --- /dev/null +++ b/test/base/test_510.ml @@ -0,0 +1,180 @@ +#require "base";; +#require "stdio";; + +let () = Printexc.record_backtrace false + +open Base +open Stdio +open Ppxlib + +module N = Ppxlib_private.Name +[%%expect{| +module N = Ppxlib.Ppxlib_private.Name +|}] + + +let dot_suffixes name = + Caml.Printf.sprintf "%s" + (Sexp.to_string_hum + (List.sexp_of_t String.sexp_of_t (N.dot_suffixes name))) +[%%expect{| +val dot_suffixes : string/2 -> string/2 = +|}] + +let _ = dot_suffixes "foo.bar.baz" +[%%expect{| +- : string/2 = "(baz bar.baz foo.bar.baz)" +|}] + +let _ = dot_suffixes "foo.@bar.baz" +[%%expect{| +- : string/2 = "(bar.baz foo.bar.baz)" +|}] + + +let split_path name = + let a, b = N.split_path name in + Caml.Printf.sprintf "%s" + (Sexp.to_string_hum + (List [sexp_of_string a; Option.sexp_of_t sexp_of_string b])) +[%%expect{| +val split_path : string/2 -> string/2 = +|}] + +let _ = split_path "a.b.c" +[%%expect{| +- : string/2 = "(a.b.c ())" +|}] + +let _ = split_path "a.b.c.D" +[%%expect{| +- : string/2 = "(a.b.c (D))" +|}] + +let _ = split_path ".D" +[%%expect{| +- : string/2 = "(\"\" (D))" +|}] + +let convert_longident string = + let lident = Longident.parse string in + let name = Longident.name lident in + (name, lident) +[%%expect{| +val convert_longident : string/2 -> string/2 * longident = +|}] + +let _ = convert_longident "x" +[%%expect{| +- : string/2 * longident = ("x", Ppxlib.Longident.Lident "x") +|}] + +let _ = convert_longident "(+)" +[%%expect{| +- : string/2 * longident = ("( + )", Ppxlib.Longident.Lident "+") +|}] + +let _ = convert_longident "( + )" +[%%expect{| +- : string/2 * longident = ("( + )", Ppxlib.Longident.Lident "+") +|}] + +let _ = convert_longident "Base.x" +[%%expect{| +- : string/2 * longident = +("Base.x", Ppxlib.Longident.Ldot (Ppxlib.Longident.Lident "Base", "x")) +|}] + +let _ = convert_longident "Base.(+)" +[%%expect{| +- : string/2 * longident = +("Base.( + )", Ppxlib.Longident.Ldot (Ppxlib.Longident.Lident "Base", "+")) +|}] + +let _ = convert_longident "Base.( + )" +[%%expect{| +- : string/2 * longident = +("Base.( + )", Ppxlib.Longident.Ldot (Ppxlib.Longident.Lident "Base", "+")) +|}] + +let _ = convert_longident "Base.( land )" +[%%expect{| +- : string/2 * longident = +("Base.( land )", + Ppxlib.Longident.Ldot (Ppxlib.Longident.Lident "Base", "land")) +|}] + +let _ = convert_longident "A(B)" +[%%expect{| +Exception: Invalid_argument "Ppxlib.Longident.parse: \"A(B)\"". +|}] + +let _ = convert_longident "A.B(C)" +[%%expect{| +Exception: Invalid_argument "Ppxlib.Longident.parse: \"A.B(C)\"". +|}] + +let _ = convert_longident ")" +[%%expect{| +Exception: Invalid_argument "Ppxlib.Longident.parse: \")\"". +|}] + +let _ = Ppxlib.Code_path.(file_path @@ top_level ~file_path:"dir/main.ml") +[%%expect{| +- : string/2 = "dir/main.ml" +|}] + +let _ = Ppxlib.Code_path.(fully_qualified_path @@ top_level ~file_path:"dir/main.ml") +[%%expect{| +- : string/2 = "Main" +|}] + +let complex_path = + let open Ppxlib.Code_path in + let loc = Ppxlib.Location.none in + top_level ~file_path:"dir/main.ml" + |> enter_module ~loc "Sub" + |> enter_module ~loc "Sub_sub" + |> enter_value ~loc "some_val" +[%%expect{| +val complex_path : Code_path.t = +|}] + +let _ = Ppxlib.Code_path.fully_qualified_path complex_path +[%%expect{| +- : string/2 = "Main.Sub.Sub_sub.some_val" +|}] + +let _ = Ppxlib.Code_path.to_string_path complex_path +[%%expect{| +- : string/2 = "dir/main.ml.Sub.Sub_sub" +|}] + +let _ = + let a = gen_symbol () ~prefix:"__prefix__" in + let b = gen_symbol () ~prefix:a in + a, b +[%%expect{| +- : string/2 * string/2 = ("__prefix____001_", "__prefix____002_") +|}] + +let _ = + let open Ast_builder.Make (struct let loc = Location.none end) in + let params decl = + List.map decl.ptype_params ~f:(fun (core_type, _) -> core_type.ptyp_desc) + in + let decl = + type_declaration + ~name:{ txt = "t"; loc = Location.none } + ~params:(List.init 3 ~f:(fun _ -> ptyp_any, (NoVariance, NoInjectivity))) + ~cstrs:[] + ~kind:Ptype_abstract + ~private_:Public + ~manifest:None + in + params decl, params (name_type_params_in_td decl) +[%%expect{| +- : core_type_desc list * core_type_desc list = +([Ptyp_any; Ptyp_any; Ptyp_any], + [Ptyp_var "a__003_"; Ptyp_var "b__004_"; Ptyp_var "c__005_"]) +|}] diff --git a/test/code_path/dune b/test/code_path/dune index 06179b3fc..b88be2aec 100644 --- a/test/code_path/dune +++ b/test/code_path/dune @@ -1,7 +1,9 @@ (rule (alias runtest) (enabled_if - (>= %{ocaml_version} "4.10.0")) + (and + (>= %{ocaml_version} "4.10.0") + (< %{ocaml_version} "5.1.0"))) (deps (:test test.ml) (package ppxlib)) @@ -11,3 +13,21 @@ (progn (run expect-test %{test}) (diff? %{test} %{test}.corrected))))) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} "5.1.0")) + (deps + (:test test.ml) + (:t test_510.ml) + (package ppxlib)) + (action + (chdir + %{project_root} + (progn + (run mv %{t} %{t}.old) + (run cp %{test} %{t}) + (run expect-test %{t}) + (run mv %{t}.old %{t}) + (diff? %{t} %{t}.corrected))))) diff --git a/test/code_path/test_510.ml b/test/code_path/test_510.ml new file mode 100644 index 000000000..976aac8ef --- /dev/null +++ b/test/code_path/test_510.ml @@ -0,0 +1,152 @@ +open Ppxlib + +let sexp_of_code_path code_path = + Sexplib0.Sexp.message + "code_path" + [ "main_module_name", Sexplib0.Sexp_conv.sexp_of_string (Code_path.main_module_name code_path) + ; "submodule_path", Sexplib0.Sexp_conv.sexp_of_list Sexplib0.Sexp_conv.sexp_of_string (Code_path.submodule_path code_path) + ; "enclosing_module", Sexplib0.Sexp_conv.sexp_of_string (Code_path.enclosing_module code_path) + ; "enclosing_value", Sexplib0.Sexp_conv.sexp_of_option Sexplib0.Sexp_conv.sexp_of_string (Code_path.enclosing_value code_path) + ; "value", Sexplib0.Sexp_conv.sexp_of_option Sexplib0.Sexp_conv.sexp_of_string (Code_path.value code_path) + ; "fully_qualified_path", Sexplib0.Sexp_conv.sexp_of_string (Code_path.fully_qualified_path code_path) + ] + +let () = + Driver.register_transformation "test" + ~extensions:[ + Extension.V3.declare "code_path" + Expression + Ast_pattern.(pstr nil) + (fun ~ctxt -> + let loc = Expansion_context.Extension.extension_point_loc ctxt in + let code_path = Expansion_context.Extension.code_path ctxt in + Ast_builder.Default.estring ~loc + (Sexplib0.Sexp.to_string (sexp_of_code_path code_path))) + ] +[%%expect{| +val sexp_of_code_path : Code_path.t -> Sexplib0.Sexp.t = +|}] + +let s = + let module A = struct + module A' = struct + let a = + let module B = struct + module B' = struct + let b = + let module C = struct + module C' = struct + let c = [%code_path] + end + end + in C.C'.c + end + end + in B.B'.b + end + end + in A.A'.a +;; +[%%expect{| +val s : string = + "(code_path(main_module_name Test_510)(submodule_path())(enclosing_module C')(enclosing_value(c))(value(s))(fully_qualified_path Test_510.s))" +|}] + +let module M = struct + let m = [%code_path] + end + in + M.m +[%%expect{| +- : string = +"(code_path(main_module_name Test_510)(submodule_path())(enclosing_module M)(enclosing_value(m))(value())(fully_qualified_path Test_510))" +|}] + +module Outer = struct + module Inner = struct + let code_path = [%code_path] + end +end +let _ = Outer.Inner.code_path +[%%expect{| +module Outer : sig module Inner : sig val code_path : string end end +- : string = +"(code_path(main_module_name Test_510)(submodule_path(Outer Inner))(enclosing_module Inner)(enclosing_value(code_path))(value(code_path))(fully_qualified_path Test_510.Outer.Inner.code_path))" +|}] + +module Functor() = struct + let code_path = ref "" + module _ = struct + let x = + let module First_class = struct + code_path := [%code_path] + end in + let module _ = First_class in + () + ;; + + ignore x + end +end +let _ = let module M = Functor() in !M.code_path +[%%expect{| +module Functor : functor () -> sig val code_path : string ref end +Line _: +Error (warning 73 [generative-application-expects-unit]): A generative functor +should be applied to '()'; using '(struct end)' is deprecated. +|}] + +module Actual = struct + let code_path = [%code_path] +end [@enter_module Dummy] +let _ = Actual.code_path +[%%expect{| + +module Actual : sig val code_path : string end + +- : string = +"(code_path(main_module_name Test_510)(submodule_path(Actual Dummy))(enclosing_module Dummy)(enclosing_value(code_path))(value(code_path))(fully_qualified_path Test_510.Actual.Dummy.code_path))" +|}] + +module Ignore_me = struct + let code_path = [%code_path] +end [@@do_not_enter_module] +let _ = Ignore_me.code_path +[%%expect{| + +module Ignore_me : sig val code_path : string end + +- : string = +"(code_path(main_module_name Test_510)(submodule_path())(enclosing_module Test_510)(enclosing_value(code_path))(value(code_path))(fully_qualified_path Test_510.code_path))" +|}] + +let _ = + (let module Ignore_me = struct + let code_path = [%code_path] + end + in + Ignore_me.code_path) + [@do_not_enter_module] +[%%expect{| + +- : string = +"(code_path(main_module_name Test_510)(submodule_path())(enclosing_module Test_510)(enclosing_value(code_path))(value())(fully_qualified_path Test_510))" +|}] + +let _ = ([%code_path] [@ppxlib.enter_value dummy]) +[%%expect{| + +- : string = +"(code_path(main_module_name Test_510)(submodule_path())(enclosing_module Test_510)(enclosing_value(dummy))(value(dummy))(fully_qualified_path Test_510.dummy))" +|}] + +let _ = + let ignore_me = [%code_path] + [@@do_not_enter_value] + in + ignore_me +[%%expect{| + +- : string = +"(code_path(main_module_name Test_510)(submodule_path())(enclosing_module Test_510)(enclosing_value())(value())(fully_qualified_path Test_510))" +|}] diff --git a/test/deriving/dune b/test/deriving/dune index 06179b3fc..b88be2aec 100644 --- a/test/deriving/dune +++ b/test/deriving/dune @@ -1,7 +1,9 @@ (rule (alias runtest) (enabled_if - (>= %{ocaml_version} "4.10.0")) + (and + (>= %{ocaml_version} "4.10.0") + (< %{ocaml_version} "5.1.0"))) (deps (:test test.ml) (package ppxlib)) @@ -11,3 +13,21 @@ (progn (run expect-test %{test}) (diff? %{test} %{test}.corrected))))) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} "5.1.0")) + (deps + (:test test.ml) + (:t test_510.ml) + (package ppxlib)) + (action + (chdir + %{project_root} + (progn + (run mv %{t} %{t}.old) + (run cp %{test} %{t}) + (run expect-test %{t}) + (run mv %{t}.old %{t}) + (diff? %{t} %{t}.corrected))))) diff --git a/test/deriving/test_510.ml b/test/deriving/test_510.ml new file mode 100644 index 000000000..756d9b783 --- /dev/null +++ b/test/deriving/test_510.ml @@ -0,0 +1,90 @@ +open Ppxlib + + +let foo = + Deriving.add "foo" + ~str_type_decl:(Deriving.Generator.make_noarg + (fun ~loc ~path:_ _ -> [%str let foo = 42])) + ~sig_type_decl:(Deriving.Generator.make_noarg + (fun ~loc ~path:_ _ -> [%sig: val foo : int])) +[%%expect{| +val foo : Deriving.t = +|}] + +let bar = + Deriving.add "bar" + ~str_type_decl:(Deriving.Generator.make_noarg + ~deps:[foo] + (fun ~loc ~path:_ _ -> [%str let bar = foo + 1])) +[%%expect{| +val bar : Deriving.t = +|}] + +let mtd = + Deriving.add "mtd" + ~sig_module_type_decl:( + Deriving.Generator.make_noarg + (fun ~loc ~path:_ _ -> [%sig: val y : int])) + ~str_module_type_decl:( + Deriving.Generator.make_noarg + (fun ~loc ~path:_ _ -> [%str let y = 42])) +[%%expect{| +val mtd : Deriving.t = +|}] + +type t = int [@@deriving bar] +[%%expect{| +Line _, characters 25-28: +Error: Deriver foo is needed for bar, you need to add it before in the list +|}] + +type t = int [@@deriving bar, foo] +[%%expect{| + +Line _, characters 25-33: +Error: Deriver foo is needed for bar, you need to add it before in the list +|}] + +type nonrec int = int [@@deriving foo, bar] +[%%expect{| + +type nonrec int = int +val foo : int = 42 +val bar : int = 43 +|}] + +module Foo_sig : sig + type t [@@deriving foo] +end = struct + type t +end +[%%expect{| + +Line _, characters 6-25: +Error: Signature mismatch: + Modules do not match: + sig type t end + is not included in + sig type t val foo : int end + The value `foo' is required but not provided + File "test/deriving/test_510.ml", line 3, characters 2-25: + Expected declaration +|}] + +module type X = sig end [@@deriving mtd] +[%%expect{| + +module type X = sig end +val y : int = 42 +|}] + +module Y : sig + module type X = sig end [@@deriving mtd] +end = struct + module type X = sig end + let y = 42 +end +[%%expect{| + +module Y : sig module type X = sig end val y : int end +|}] diff --git a/test/driver/attributes/dune b/test/driver/attributes/dune index 40eea9e16..6da6c9a94 100644 --- a/test/driver/attributes/dune +++ b/test/driver/attributes/dune @@ -1,7 +1,9 @@ (rule (alias runtest) (enabled_if - (>= %{ocaml_version} "4.08.0")) + (and + (>= %{ocaml_version} "4.08.0") + (< %{ocaml_version} "5.1.0"))) (deps (:test test.ml) (package ppxlib)) @@ -11,3 +13,21 @@ (progn (run expect-test %{test}) (diff? %{test} %{test}.corrected))))) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} "5.1.0")) + (deps + (:test test.ml) + (:t test_510.ml) + (package ppxlib)) + (action + (chdir + %{project_root} + (progn + (run mv %{t} %{t}.old) + (run cp %{test} %{t}) + (run expect-test %{t}) + (run mv %{t}.old %{t}) + (diff? %{t} %{t}.corrected))))) diff --git a/test/driver/attributes/test.ml b/test/driver/attributes/test.ml index 5498136e8..51b983a96 100644 --- a/test/driver/attributes/test.ml +++ b/test/driver/attributes/test.ml @@ -1,4 +1,3 @@ -open Stdppx open Ppxlib let () = Driver.enable_checks () diff --git a/test/driver/attributes/test_510.ml b/test/driver/attributes/test_510.ml new file mode 100644 index 000000000..d8b6bed7e --- /dev/null +++ b/test/driver/attributes/test_510.ml @@ -0,0 +1,105 @@ +open Ppxlib + +let () = Driver.enable_checks () + +let x = 1 [@@foo] +[%%expect{| +Line _, characters 13-16: +Error: Attribute `foo' was not used +|}] + +let f x = 1 [@@deprecatd "..."] +[%%expect{| + +Line _, characters 15-24: +Error: Attribute `deprecatd' was not used. + Hint: Did you mean deprecated? +|}] + +let attr : _ Attribute.t = + Attribute.declare "blah" + Attribute.Context.type_declaration + Ast_pattern.(__) + ignore +[%%expect{| + +val attr : (type_declaration, unit) Attribute.t = +|}] + +type t = int [@blah] +[%%expect{| + +Line _, characters 15-19: +Error: Attribute `blah' was not used. + Hint: `blah' is available for type declarations but is used here in + the + context of a core type. + Did you put it at the wrong level? +|}] + +let attr : _ Attribute.t = + Attribute.declare "blah" + Attribute.Context.expression + Ast_pattern.(__) + ignore +[%%expect{| + +val attr : (expression, unit) Attribute.t = +|}] + +type t = int [@blah] +[%%expect{| + +Line _, characters 15-19: +Error: Attribute `blah' was not used. + Hint: `blah' is available for expressions and type declarations but is + used + here in the context of a core type. + Did you put it at the wrong level? +|}] + +let _ = () [@blah] +[%%expect{| + +Line _, characters 13-17: +Error: Attribute `blah' was not used +|}] + +(* Attribute drops *) + +let faulty_transformation = object + inherit Ast_traverse.map as super + + method! expression e = + match e.pexp_desc with + | Pexp_constant c -> + Ast_builder.Default.pexp_constant ~loc:e.pexp_loc c + | _ -> super#expression e +end +[%%expect{| + +val faulty_transformation : Ast_traverse.map = +|}] + +let () = + Driver.register_transformation "faulty" ~impl:faulty_transformation#structure + +let x = (42 [@foo]) +[%%expect{| + +Line _, characters 14-17: +Error: Attribute `foo' was silently dropped +|}] + +type t1 = < > +type t2 = < t1 > +type t3 = < (t1[@foo]) > +[%%expect{| + +type t1 = < > + +type t2 = < > + +Line _, characters 17-20: +Error: Attribute `foo' was not used +|}] diff --git a/test/extensions_and_deriving/dune b/test/extensions_and_deriving/dune index 06179b3fc..b88be2aec 100644 --- a/test/extensions_and_deriving/dune +++ b/test/extensions_and_deriving/dune @@ -1,7 +1,9 @@ (rule (alias runtest) (enabled_if - (>= %{ocaml_version} "4.10.0")) + (and + (>= %{ocaml_version} "4.10.0") + (< %{ocaml_version} "5.1.0"))) (deps (:test test.ml) (package ppxlib)) @@ -11,3 +13,21 @@ (progn (run expect-test %{test}) (diff? %{test} %{test}.corrected))))) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} "5.1.0")) + (deps + (:test test.ml) + (:t test_510.ml) + (package ppxlib)) + (action + (chdir + %{project_root} + (progn + (run mv %{t} %{t}.old) + (run cp %{test} %{t}) + (run expect-test %{t}) + (run mv %{t}.old %{t}) + (diff? %{t} %{t}.corrected))))) diff --git a/test/extensions_and_deriving/test_510.ml b/test/extensions_and_deriving/test_510.ml new file mode 100644 index 000000000..f57a05e0a --- /dev/null +++ b/test/extensions_and_deriving/test_510.ml @@ -0,0 +1,148 @@ +open Ppxlib + +(* Generates a [let derived_ = "ok"] or a + [let derived_ = "uninterpreted extension in input"] if + the type manifest is an uninterpreted extension. *) +let deriver = + let binding ~loc type_name expr = + let var_name = "derived_" ^ type_name in + let pat = Ast_builder.Default.ppat_var ~loc {txt = var_name; loc} in + let vb = Ast_builder.Default.value_binding ~loc ~pat ~expr in + [Ast_builder.Default.pstr_value ~loc Nonrecursive [vb]] + in + let str_type_decl = + Deriving.Generator.V2.make_noarg + (fun ~ctxt (_rec_flag, type_decls) -> + let loc = Expansion_context.Deriver.derived_item_loc ctxt in + match type_decls with + | { ptype_manifest = Some {ptyp_desc = Ptyp_extension _; _} + ; ptype_name = {txt; _}; _}::_ -> + binding ~loc txt [%expr "uninterpreted extension in input"] + | {ptype_name = {txt; _}; _}::_ -> + binding ~loc txt [%expr "ok"] + | [] -> assert false) + in + Deriving.add ~str_type_decl "derived" + +[%%expect{| +val deriver : Deriving.t = +|}] + +(* Generates a [type t = int] *) +let gen_type_decl = + Extension.V3.declare + "gen_type_decl" + Extension.Context.structure_item + Ast_pattern.(pstr nil) + (fun ~ctxt -> + let loc = Expansion_context.Extension.extension_point_loc ctxt in + [%stri type t = int]) + |> Context_free.Rule.extension + +let () = Driver.register_transformation ~rules:[gen_type_decl] "gen_type_decl" + +[%%expect{| +val gen_type_decl : Context_free.Rule.t = +|}] + +(* You cannot attach attributes to structure item extension points *) +[%%gen_type_decl] +[@@deriving derived] + +[%%expect{| +Line _, characters 3-19: +Error: Attributes not allowed here +|}] + +(* Generates a [type t = int[@@deriving derived]] *) +let gen_type_decl_with_derived = + Extension.V3.declare + "gen_type_decl_with_derived" + Extension.Context.structure_item + Ast_pattern.(pstr nil) + (fun ~ctxt -> + let loc = Expansion_context.Extension.extension_point_loc ctxt in + [%stri type t = int[@@deriving derived]]) + |> Context_free.Rule.extension + +let () = + Driver.register_transformation + ~rules:[gen_type_decl_with_derived] + "gen_type_decl_with_derived" + +[%%expect{| + +val gen_type_decl_with_derived : Context_free.Rule.t = +|}] + +(* Attributes rule must be applied in code generated by a structure item + extension *) +[%%gen_type_decl_with_derived] + +[%%expect{| + +type t = int +val derived_t : string = "ok" +|}] + +let gen_inline_type_decls_with_derived = + Extension.V3.declare_inline + "gen_inline_type_decls_with_derived" + Extension.Context.structure_item + Ast_pattern.(pstr nil) + (fun ~ctxt -> + let loc = Expansion_context.Extension.extension_point_loc ctxt in + [%str + type t = int[@@deriving derived] + type u = float[@@deriving derived]]) + |> Context_free.Rule.extension + +let () = + Driver.register_transformation + ~rules:[gen_inline_type_decls_with_derived] + "gen_inline_type_decls_with_derived" + +[%%expect{| + +val gen_inline_type_decls_with_derived : Context_free.Rule.t = +|}] + +(* That also stands for inline extension rules *) +[%%gen_inline_type_decls_with_derived] + +[%%expect{| + +type t = int +val derived_t : string = "ok" +type u = float +val derived_u : string = "ok" +|}] + +let id = + Extension.V3.declare + "id" + Extension.Context.core_type + Ast_pattern.(ptyp __) + (fun ~ctxt:_ core_type -> core_type) + |> Context_free.Rule.extension + +let () = Driver.register_transformation ~rules:[id] "id" + +[%%expect{| + +val id : Context_free.Rule.t = +|}] + +(* Nodes with attributes are expanded before attribute-based, inline + code generation rules are applied. + In this below, the `[[%id: int]]` is interpreted before the deriver + is applied, meaning it can't see this extension point in its expand + function argument. *) +type t = [%id: int] +[@@deriving derived] + +[%%expect{| + +type t = int +val derived_t : string = "ok" +|}] diff --git a/test/metaquot/dune b/test/metaquot/dune index 6e6f4e289..1fdc9c178 100644 --- a/test/metaquot/dune +++ b/test/metaquot/dune @@ -1,7 +1,9 @@ (rule (alias runtest) (enabled_if - (>= %{ocaml_version} "4.14.0")) + (and + (>= %{ocaml_version} "4.14.0") + (< %{ocaml_version} "5.1.0"))) (deps (:test test.ml) (package ppxlib)) @@ -11,3 +13,21 @@ (progn (run expect-test %{test}) (diff? %{test} %{test}.corrected))))) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} "5.1.0")) + (deps + (:test test.ml) + (:t test_510.ml) + (package ppxlib)) + (action + (chdir + %{project_root} + (progn + (run mv %{t} %{t}.old) + (run cp %{test} %{t}) + (run expect-test %{t}) + (run mv %{t}.old %{t}) + (diff? %{t} %{t}.corrected))))) diff --git a/test/metaquot/test_510.ml b/test/metaquot/test_510.ml new file mode 100644 index 000000000..a4cae3339 --- /dev/null +++ b/test/metaquot/test_510.ml @@ -0,0 +1,334 @@ +let loc = Ppxlib.Location.none +[%%expect{| +val loc : Warnings.loc = + {Ppxlib.Location.loc_start = + {Lexing.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; + loc_end = + {Lexing.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; + loc_ghost = true} +|}] + +(* unannotated quotations *) + +let _ = [%expr ()] +[%%expect{| +- : Ppxlib.expression = +{Ppxlib_ast.Ast.pexp_desc = + Ppxlib_ast.Ast.Pexp_construct + ({Ppxlib_ast.Ast.txt = Ppxlib_ast.Ast.Lident "()"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}, + None); + pexp_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}; + pexp_loc_stack = []; pexp_attributes = []} +|}] + +let _ = [%pat? ()] +[%%expect{| +- : Ppxlib.pattern = +{Ppxlib_ast.Ast.ppat_desc = + Ppxlib_ast.Ast.Ppat_construct + ({Ppxlib_ast.Ast.txt = Ppxlib_ast.Ast.Lident "()"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}, + None); + ppat_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}; + ppat_loc_stack = []; ppat_attributes = []} +|}] + +let _ = [%type: unit] +[%%expect{| +- : Ppxlib.core_type = +{Ppxlib_ast.Ast.ptyp_desc = + Ppxlib_ast.Ast.Ptyp_constr + ({Ppxlib_ast.Ast.txt = Ppxlib_ast.Ast.Lident "unit"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}, + []); + ptyp_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}; + ptyp_loc_stack = []; ptyp_attributes = []} +|}] + +let _ = [%stri let _ = ()] +[%%expect{| +- : Ppxlib.structure_item = +{Ppxlib_ast.Ast.pstr_desc = + Ppxlib_ast.Ast.Pstr_value (Ppxlib_ast.Ast.Nonrecursive, + [{Ppxlib_ast.Ast.pvb_pat = + {Ppxlib_ast.Ast.ppat_desc = Ppxlib_ast.Ast.Ppat_any; + ppat_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}; + ppat_loc_stack = []; ppat_attributes = []}; + pvb_expr = + {Ppxlib_ast.Ast.pexp_desc = + Ppxlib_ast.Ast.Pexp_construct + ({Ppxlib_ast.Ast.txt = Ppxlib_ast.Ast.Lident "()"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_ghost = true}}, + None); + pexp_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}; + pexp_loc_stack = []; pexp_attributes = []}; + pvb_attributes = []; + pvb_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}]); + pstr_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}} +|}] + +let _ = [%sigi: include S] +[%%expect{| +- : Ppxlib.signature_item = +{Ppxlib_ast.Ast.psig_desc = + Ppxlib_ast.Ast.Psig_include + {Ppxlib_ast.Ast.pincl_mod = + {Ppxlib_ast.Ast.pmty_desc = + Ppxlib_ast.Ast.Pmty_ident + {Ppxlib_ast.Ast.txt = Ppxlib_ast.Ast.Lident "S"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + pmty_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}; + pmty_attributes = []}; + pincl_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}; + pincl_attributes = []}; + psig_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}} +|}] + +let _ = [%str let _ = ()] +[%%expect{| +- : Ppxlib_ast.Ast.structure = +[{Ppxlib_ast.Ast.pstr_desc = + Ppxlib_ast.Ast.Pstr_value (Ppxlib_ast.Ast.Nonrecursive, + [{Ppxlib_ast.Ast.pvb_pat = + {Ppxlib_ast.Ast.ppat_desc = Ppxlib_ast.Ast.Ppat_any; + ppat_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}; + ppat_loc_stack = []; ppat_attributes = []}; + pvb_expr = + {Ppxlib_ast.Ast.pexp_desc = + Ppxlib_ast.Ast.Pexp_construct + ({Ppxlib_ast.Ast.txt = Ppxlib_ast.Ast.Lident "()"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_ghost = true}}, + None); + pexp_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}; + pexp_loc_stack = []; pexp_attributes = []}; + pvb_attributes = []; + pvb_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}]); + pstr_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}] +|}] + +let _ = [%sig: include S] +[%%expect{| +- : Ppxlib_ast.Ast.signature = +[{Ppxlib_ast.Ast.psig_desc = + Ppxlib_ast.Ast.Psig_include + {Ppxlib_ast.Ast.pincl_mod = + {Ppxlib_ast.Ast.pmty_desc = + Ppxlib_ast.Ast.Pmty_ident + {Ppxlib_ast.Ast.txt = Ppxlib_ast.Ast.Lident "S"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + pmty_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}; + pmty_attributes = []}; + pincl_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}; + pincl_attributes = []}; + psig_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}] +|}] + +(* mistyped escapes (not producing ASTs at all) *) + +let _ = [%expr [%e ()]] +[%%expect{| +Line _, characters 19-21: +Error: This expression should not be a unit literal, the expected type is + Ppxlib_ast.Ast.expression +|}] + +let _ = [%pat? [%p ()]] +[%%expect{| + +Line _, characters 19-21: +Error: This expression should not be a unit literal, the expected type is + Ppxlib_ast.Ast.pattern +|}] + +let _ = [%type: [%t ()]] +[%%expect{| + +Line _, characters 20-22: +Error: This expression should not be a unit literal, the expected type is + Ppxlib_ast.Ast.core_type +|}] + +let _ = [%stri [%%i ()]] +[%%expect{| + +Line _, characters 20-22: +Error: This expression should not be a unit literal, the expected type is + Ppxlib_ast.Ast.structure_item +|}] + +let _ = [%sigi: [%%i ()]] +[%%expect{| + +Line _, characters 21-23: +Error: This expression should not be a unit literal, the expected type is + Ppxlib_ast.Ast.signature_item +|}]