diff -Nru ppxlib-0.15.0/appveyor.yml ppxlib-0.24.0/appveyor.yml --- ppxlib-0.15.0/appveyor.yml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/appveyor.yml 2021-12-08 21:53:37.000000000 +0000 @@ -43,10 +43,16 @@ - OPAM_SWITCH: 4.09.0+mingw32c PACKAGE: ppxlib TESTS: false - - OPAM_SWITCH: 4.10.0+mingw64c + - OPAM_SWITCH: 4.10.1+mingw64c PACKAGE: ppxlib TESTS: false - - OPAM_SWITCH: 4.10.0+mingw32c + - OPAM_SWITCH: 4.10.1+mingw32c + PACKAGE: ppxlib + TESTS: false + - OPAM_SWITCH: 4.11.1+mingw64c + PACKAGE: ppxlib + TESTS: false + - OPAM_SWITCH: 4.11.1+mingw32c PACKAGE: ppxlib TESTS: false install: diff -Nru ppxlib-0.15.0/ast/ast_helper_lite.ml ppxlib-0.24.0/ast/ast_helper_lite.ml --- ppxlib-0.15.0/ast/ast_helper_lite.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/ast/ast_helper_lite.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,696 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* TODO: remove this open *) +open Stdlib0 +module Location = Astlib.Location +module Longident = Astlib.Longident +open Astlib.Ast_412 + +[@@@warning "-9"] + +open Asttypes +open Parsetree + +type 'a with_loc = 'a Location.loc + +type loc = Location.t + +type lid = Longident.t with_loc + +type str = string with_loc + +type str_opt = string option with_loc + +type attrs = attribute list + +let default_loc = ref Location.none + +type ref_and_value = R : 'a ref * 'a -> ref_and_value + +let protect_ref = + let set_ref (R (r, v)) = r := v in + fun ref f -> + let (R (r, _)) = ref in + let backup = R (r, !r) in + set_ref ref; + match f () with + | x -> + set_ref backup; + x + | exception e -> + set_ref backup; + raise e + +let with_default_loc l f = protect_ref (R (default_loc, l)) f + +module Const = struct + let integer ?suffix i = Pconst_integer (i, suffix) + + let int ?suffix i = integer ?suffix (Int.to_string i) + + let int32 ?(suffix = 'l') i = integer ~suffix (Int32.to_string i) + + let int64 ?(suffix = 'L') i = integer ~suffix (Int64.to_string i) + + let nativeint ?(suffix = 'n') i = integer ~suffix (Nativeint.to_string i) + + let float ?suffix f = Pconst_float (f, suffix) + + let char c = Pconst_char c + + let string ?quotation_delimiter ?(loc = !default_loc) s = + Pconst_string (s, loc, quotation_delimiter) +end + +module Attr = struct + let mk ?(loc = !default_loc) name payload = + { attr_name = name; attr_payload = payload; attr_loc = loc } +end + +module Typ = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + { + ptyp_desc = d; + ptyp_loc = loc; + ptyp_loc_stack = []; + ptyp_attributes = attrs; + } + + let attr d a = { d with ptyp_attributes = d.ptyp_attributes @ [ a ] } + + let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any + + let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) + + let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c)) + + let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) + + let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) + + let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) + + let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b)) + + let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b)) + + let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c)) + + let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b)) + + let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b)) + + let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a) + + let force_poly t = + match t.ptyp_desc with Ptyp_poly _ -> t | _ -> poly ~loc:t.ptyp_loc [] t + (* -> ghost? *) + + let varify_constructors var_names t = + let check_variable vl loc v = + if List.mem v vl then + Location.raise_errorf ~loc "variable in scope syntax error: %s" v + in + let var_names = List.map (fun v -> v.txt) var_names in + let rec loop t = + let desc = + match t.ptyp_desc with + | Ptyp_any -> Ptyp_any + | Ptyp_var x -> + check_variable var_names t.ptyp_loc 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) -> + check_variable var_names t.ptyp_loc 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) -> + List.iter + (fun v -> check_variable var_names t.ptyp_loc v.txt) + string_lst; + 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 + | Rtag (label, flag, lst) -> 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 + | Otag (label, t) -> Otag (label, loop t) + | Oinherit t -> Oinherit (loop t) + in + { field with pof_desc } + in + loop t +end + +module Pat = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + { + ppat_desc = d; + ppat_loc = loc; + ppat_loc_stack = []; + ppat_attributes = attrs; + } + + let attr d a = { d with ppat_attributes = d.ppat_attributes @ [ a ] } + + let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any + + let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a) + + let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b)) + + let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a) + + let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b)) + + let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) + + let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) + + let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) + + let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) + + let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a) + + let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) + + let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b)) + + let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a) + + let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a) + + let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a) + + let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b)) + + let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a) + + let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a) +end + +module Exp = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + { + pexp_desc = d; + pexp_loc = loc; + pexp_loc_stack = []; + pexp_attributes = attrs; + } + + let attr d a = { d with pexp_attributes = d.pexp_attributes @ [ a ] } + + let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) + + let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) + + let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) + + let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d)) + + let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) + + let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) + + let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) + + let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) + + let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) + + let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) + + let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) + + let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) + + let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) + + let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) + + let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a) + + let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c)) + + let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b)) + + let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b)) + + let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e)) + + let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b)) + + let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c)) + + let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) + + let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a) + + let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b)) + + let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a) + + let letmodule ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_letmodule (a, b, c)) + + let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) + + let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) + + let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a) + + let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b)) + + let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a) + + let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b)) + + let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) + + let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_open (a, b)) + + let letop ?loc ?attrs let_ ands body = + mk ?loc ?attrs (Pexp_letop { let_; ands; body }) + + let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) + + let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable + + let case lhs ?guard rhs = { pc_lhs = lhs; pc_guard = guard; pc_rhs = rhs } + + let binding_op op pat exp loc = + { pbop_op = op; pbop_pat = pat; pbop_exp = exp; pbop_loc = loc } +end + +module Mty = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + { pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs } + + let attr d a = { d with pmty_attributes = d.pmty_attributes @ [ a ] } + + let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) + + let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) + + let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a) + + let functor_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_functor (a, b)) + + let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b)) + + let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a) + + let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a) +end + +module Mod = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + { pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs } + + let attr d a = { d with pmod_attributes = d.pmod_attributes @ [ a ] } + + let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) + + let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) + + let functor_ ?loc ?attrs arg body = mk ?loc ?attrs (Pmod_functor (arg, body)) + + let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) + + let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) + + let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) + + let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a) +end + +module Sig = struct + let mk ?(loc = !default_loc) d = { psig_desc = d; psig_loc = loc } + + let value ?loc a = mk ?loc (Psig_value a) + + let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a)) + + let type_subst ?loc a = mk ?loc (Psig_typesubst a) + + let type_extension ?loc a = mk ?loc (Psig_typext a) + + let exception_ ?loc a = mk ?loc (Psig_exception a) + + let module_ ?loc a = mk ?loc (Psig_module a) + + let mod_subst ?loc a = mk ?loc (Psig_modsubst a) + + let rec_module ?loc a = mk ?loc (Psig_recmodule a) + + let modtype ?loc a = mk ?loc (Psig_modtype a) + + let open_ ?loc a = mk ?loc (Psig_open a) + + let include_ ?loc a = mk ?loc (Psig_include a) + + let class_ ?loc a = mk ?loc (Psig_class a) + + let class_type ?loc a = mk ?loc (Psig_class_type a) + + let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs)) + + let attribute ?loc a = mk ?loc (Psig_attribute a) +end + +module Str = struct + let mk ?(loc = !default_loc) d = { pstr_desc = d; pstr_loc = loc } + + let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs)) + + let value ?loc a b = mk ?loc (Pstr_value (a, b)) + + let primitive ?loc a = mk ?loc (Pstr_primitive a) + + let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a)) + + let type_extension ?loc a = mk ?loc (Pstr_typext a) + + let exception_ ?loc a = mk ?loc (Pstr_exception a) + + let module_ ?loc a = mk ?loc (Pstr_module a) + + let rec_module ?loc a = mk ?loc (Pstr_recmodule a) + + let modtype ?loc a = mk ?loc (Pstr_modtype a) + + let open_ ?loc a = mk ?loc (Pstr_open a) + + let class_ ?loc a = mk ?loc (Pstr_class a) + + let class_type ?loc a = mk ?loc (Pstr_class_type a) + + let include_ ?loc a = mk ?loc (Pstr_include a) + + let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs)) + + let attribute ?loc a = mk ?loc (Pstr_attribute a) +end + +module Cl = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + { pcl_desc = d; pcl_loc = loc; pcl_attributes = attrs } + + let attr d a = { d with pcl_attributes = d.pcl_attributes @ [ a ] } + + let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b)) + + let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a) + + let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d)) + + let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b)) + + let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c)) + + let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b)) + + let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a) + + let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_open (a, b)) +end + +module Cty = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + { pcty_desc = d; pcty_loc = loc; pcty_attributes = attrs } + + let attr d a = { d with pcty_attributes = d.pcty_attributes @ [ a ] } + + let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b)) + + let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a) + + let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c)) + + let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a) + + let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcty_open (a, b)) +end + +module Ctf = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + { pctf_desc = d; pctf_loc = loc; pctf_attributes = attrs } + + let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a) + + let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d)) + + let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d)) + + let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b)) + + let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a) + + let attribute ?loc a = mk ?loc (Pctf_attribute a) + + let attr d a = { d with pctf_attributes = d.pctf_attributes @ [ a ] } +end + +module Cf = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + { pcf_desc = d; pcf_loc = loc; pcf_attributes = attrs } + + let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c)) + + let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c)) + + let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c)) + + let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b)) + + let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a) + + let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a) + + let attribute ?loc a = mk ?loc (Pcf_attribute a) + + let virtual_ ct = Cfk_virtual ct + + let concrete o e = Cfk_concrete (o, e) + + let attr d a = { d with pcf_attributes = d.pcf_attributes @ [ a ] } +end + +module Val = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?(prim = []) name typ = + { + pval_name = name; + pval_type = typ; + pval_attributes = attrs; + pval_loc = loc; + pval_prim = prim; + } +end + +module Md = struct + let mk ?(loc = !default_loc) ?(attrs = []) name typ = + { pmd_name = name; pmd_type = typ; pmd_attributes = attrs; pmd_loc = loc } +end + +module Ms = struct + let mk ?(loc = !default_loc) ?(attrs = []) name syn = + { + pms_name = name; + pms_manifest = syn; + pms_attributes = attrs; + pms_loc = loc; + } +end + +module Mtd = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?typ name = + { + pmtd_name = name; + pmtd_type = typ; + pmtd_attributes = attrs; + pmtd_loc = loc; + } +end + +module Mb = struct + let mk ?(loc = !default_loc) ?(attrs = []) name expr = + { pmb_name = name; pmb_expr = expr; pmb_attributes = attrs; pmb_loc = loc } +end + +module Opn = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?(override = Fresh) expr = + { + popen_expr = expr; + popen_override = override; + popen_loc = loc; + popen_attributes = attrs; + } +end + +module Incl = struct + let mk ?(loc = !default_loc) ?(attrs = []) mexpr = + { pincl_mod = mexpr; pincl_loc = loc; pincl_attributes = attrs } +end + +module Vb = struct + let mk ?(loc = !default_loc) ?(attrs = []) pat expr = + { pvb_pat = pat; pvb_expr = expr; pvb_attributes = attrs; pvb_loc = loc } +end + +module Ci = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?(virt = Concrete) ?(params = []) + name expr = + { + pci_virt = virt; + pci_params = params; + pci_name = name; + pci_expr = expr; + pci_attributes = attrs; + pci_loc = loc; + } +end + +module Type = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?(params = []) ?(cstrs = []) + ?(kind = Ptype_abstract) ?(priv = Public) ?manifest name = + { + ptype_name = name; + ptype_params = params; + ptype_cstrs = cstrs; + ptype_kind = kind; + ptype_private = priv; + ptype_manifest = manifest; + ptype_attributes = attrs; + ptype_loc = loc; + } + + let constructor ?(loc = !default_loc) ?(attrs = []) ?(args = Pcstr_tuple []) + ?res name = + { + pcd_name = name; + pcd_args = args; + pcd_res = res; + pcd_loc = loc; + pcd_attributes = attrs; + } + + let field ?(loc = !default_loc) ?(attrs = []) ?(mut = Immutable) name typ = + { + pld_name = name; + pld_mutable = mut; + pld_type = typ; + pld_loc = loc; + pld_attributes = attrs; + } +end + +(** Type extensions *) +module Te = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?(params = []) ?(priv = Public) + path constructors = + { + ptyext_path = path; + ptyext_params = params; + ptyext_constructors = constructors; + ptyext_private = priv; + ptyext_loc = loc; + ptyext_attributes = attrs; + } + + let mk_exception ?(loc = !default_loc) ?(attrs = []) constructor = + { + ptyexn_constructor = constructor; + ptyexn_loc = loc; + ptyexn_attributes = attrs; + } + + let constructor ?(loc = !default_loc) ?(attrs = []) name kind = + { + pext_name = name; + pext_kind = kind; + pext_loc = loc; + pext_attributes = attrs; + } + + let decl ?(loc = !default_loc) ?(attrs = []) ?(args = Pcstr_tuple []) ?res + name = + { + pext_name = name; + pext_kind = Pext_decl (args, res); + pext_loc = loc; + pext_attributes = attrs; + } + + let rebind ?(loc = !default_loc) ?(attrs = []) name lid = + { + pext_name = name; + pext_kind = Pext_rebind lid; + pext_loc = loc; + pext_attributes = attrs; + } +end + +module Csig = struct + let mk self fields = { pcsig_self = self; pcsig_fields = fields } +end + +module Cstr = struct + let mk self fields = { pcstr_self = self; pcstr_fields = fields } +end + +(** Row fields *) +module Rf = struct + let mk ?(loc = !default_loc) ?(attrs = []) desc = + { prf_desc = desc; prf_loc = loc; prf_attributes = attrs } + + let tag ?loc ?attrs label const tys = + mk ?loc ?attrs (Rtag (label, const, tys)) + + let inherit_ ?loc ty = mk ?loc (Rinherit ty) +end + +(** Object fields *) +module Of = struct + let mk ?(loc = !default_loc) ?(attrs = []) desc = + { pof_desc = desc; pof_loc = loc; pof_attributes = attrs } + + let tag ?loc ?attrs label ty = mk ?loc ?attrs (Otag (label, ty)) + + let inherit_ ?loc ty = mk ?loc (Oinherit ty) +end diff -Nru ppxlib-0.15.0/ast/ast_helper_lite.mli ppxlib-0.24.0/ast/ast_helper_lite.mli --- ppxlib-0.15.0/ast/ast_helper_lite.mli 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/ast/ast_helper_lite.mli 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,749 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Copy of Ast_helper from OCaml 4.12 with docstring related stuff removed *) + +open Astlib.Ast_412 +open Asttypes +open Parsetree + +type 'a with_loc = 'a Astlib.Location.loc + +type loc = Astlib.Location.t + +type lid = Astlib.Longident.t with_loc + +type str = string with_loc + +type str_opt = string option with_loc + +type attrs = attribute list + +(** {1 Default locations} *) + +val default_loc : loc ref +(** Default value for all optional location arguments. *) + +val with_default_loc : loc -> (unit -> 'a) -> 'a +(** Set the [default_loc] within the scope of the execution of the provided + function. *) + +(** {1 Constants} *) + +module Const : sig + val char : char -> constant + + val string : ?quotation_delimiter:string -> ?loc:loc -> string -> constant + + val integer : ?suffix:char -> string -> constant + + val int : ?suffix:char -> int -> constant + + val int32 : ?suffix:char -> int32 -> constant + + val int64 : ?suffix:char -> int64 -> constant + + val nativeint : ?suffix:char -> nativeint -> constant + + val float : ?suffix:char -> string -> constant +end + +(** {1 Attributes} *) +module Attr : sig + val mk : ?loc:loc -> str -> payload -> attribute +end + +(** {1 Core language} *) + +(** Type expressions *) +module Typ : sig + val mk : ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type + + val attr : core_type -> attribute -> core_type + + val any : ?loc:loc -> ?attrs:attrs -> unit -> core_type + + val var : ?loc:loc -> ?attrs:attrs -> string -> core_type + + val arrow : + ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type -> core_type + + val tuple : ?loc:loc -> ?attrs:attrs -> core_type list -> core_type + + val constr : ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type + + val object_ : + ?loc:loc -> ?attrs:attrs -> object_field list -> closed_flag -> core_type + + val class_ : ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type + + val alias : ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type + + val variant : + ?loc:loc -> + ?attrs:attrs -> + row_field list -> + closed_flag -> + label list option -> + core_type + + val poly : ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type + + val package : + ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list -> core_type + + val extension : ?loc:loc -> ?attrs:attrs -> extension -> core_type + + val force_poly : core_type -> core_type + + val varify_constructors : str list -> core_type -> core_type + (** [varify_constructors newtypes te] is type expression [te], of which any of + nullary type constructor [tc] is replaced by type variable of the same + name, if [tc]'s name appears in [newtypes]. Raise + [Syntaxerr.Variable_in_scope] if any type variable inside [te] appears in + [newtypes]. + + @since 4.05 *) +end + +(** Patterns *) +module Pat : sig + val mk : ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern + + val attr : pattern -> attribute -> pattern + + val any : ?loc:loc -> ?attrs:attrs -> unit -> pattern + + val var : ?loc:loc -> ?attrs:attrs -> str -> pattern + + val alias : ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern + + val constant : ?loc:loc -> ?attrs:attrs -> constant -> pattern + + val interval : ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern + + val tuple : ?loc:loc -> ?attrs:attrs -> pattern list -> pattern + + val construct : ?loc:loc -> ?attrs:attrs -> lid -> pattern option -> pattern + + val variant : ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern + + val record : + ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag -> pattern + + val array : ?loc:loc -> ?attrs:attrs -> pattern list -> pattern + + val or_ : ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern + + val constraint_ : ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern + + val type_ : ?loc:loc -> ?attrs:attrs -> lid -> pattern + + val lazy_ : ?loc:loc -> ?attrs:attrs -> pattern -> pattern + + val unpack : ?loc:loc -> ?attrs:attrs -> str_opt -> pattern + + val open_ : ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern + + val exception_ : ?loc:loc -> ?attrs:attrs -> pattern -> pattern + + val extension : ?loc:loc -> ?attrs:attrs -> extension -> pattern +end + +(** Expressions *) +module Exp : sig + val mk : ?loc:loc -> ?attrs:attrs -> expression_desc -> expression + + val attr : expression -> attribute -> expression + + val ident : ?loc:loc -> ?attrs:attrs -> lid -> expression + + val constant : ?loc:loc -> ?attrs:attrs -> constant -> expression + + val let_ : + ?loc:loc -> + ?attrs:attrs -> + rec_flag -> + value_binding list -> + expression -> + expression + + val fun_ : + ?loc:loc -> + ?attrs:attrs -> + arg_label -> + expression option -> + pattern -> + expression -> + expression + + val function_ : ?loc:loc -> ?attrs:attrs -> case list -> expression + + val apply : + ?loc:loc -> + ?attrs:attrs -> + expression -> + (arg_label * expression) list -> + expression + + val match_ : ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression + + val try_ : ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression + + val tuple : ?loc:loc -> ?attrs:attrs -> expression list -> expression + + val construct : + ?loc:loc -> ?attrs:attrs -> lid -> expression option -> expression + + val variant : + ?loc:loc -> ?attrs:attrs -> label -> expression option -> expression + + val record : + ?loc:loc -> + ?attrs:attrs -> + (lid * expression) list -> + expression option -> + expression + + val field : ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression + + val setfield : + ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression -> expression + + val array : ?loc:loc -> ?attrs:attrs -> expression list -> expression + + val ifthenelse : + ?loc:loc -> + ?attrs:attrs -> + expression -> + expression -> + expression option -> + expression + + val sequence : + ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression + + val while_ : + ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression + + val for_ : + ?loc:loc -> + ?attrs:attrs -> + pattern -> + expression -> + expression -> + direction_flag -> + expression -> + expression + + val coerce : + ?loc:loc -> + ?attrs:attrs -> + expression -> + core_type option -> + core_type -> + expression + + val constraint_ : + ?loc:loc -> ?attrs:attrs -> expression -> core_type -> expression + + val send : ?loc:loc -> ?attrs:attrs -> expression -> str -> expression + + val new_ : ?loc:loc -> ?attrs:attrs -> lid -> expression + + val setinstvar : ?loc:loc -> ?attrs:attrs -> str -> expression -> expression + + val override : + ?loc:loc -> ?attrs:attrs -> (str * expression) list -> expression + + val letmodule : + ?loc:loc -> + ?attrs:attrs -> + str_opt -> + module_expr -> + expression -> + expression + + val letexception : + ?loc:loc -> + ?attrs:attrs -> + extension_constructor -> + expression -> + expression + + val assert_ : ?loc:loc -> ?attrs:attrs -> expression -> expression + + val lazy_ : ?loc:loc -> ?attrs:attrs -> expression -> expression + + val poly : + ?loc:loc -> ?attrs:attrs -> expression -> core_type option -> expression + + val object_ : ?loc:loc -> ?attrs:attrs -> class_structure -> expression + + val newtype : ?loc:loc -> ?attrs:attrs -> str -> expression -> expression + + val pack : ?loc:loc -> ?attrs:attrs -> module_expr -> expression + + val open_ : + ?loc:loc -> ?attrs:attrs -> open_declaration -> expression -> expression + + val letop : + ?loc:loc -> + ?attrs:attrs -> + binding_op -> + binding_op list -> + expression -> + expression + + val extension : ?loc:loc -> ?attrs:attrs -> extension -> expression + + val unreachable : ?loc:loc -> ?attrs:attrs -> unit -> expression + + val case : pattern -> ?guard:expression -> expression -> case + + val binding_op : str -> pattern -> expression -> loc -> binding_op +end + +(** Value declarations *) +module Val : sig + val mk : + ?loc:loc -> + ?attrs:attrs -> + ?prim:string list -> + str -> + core_type -> + value_description +end + +(** Type declarations *) +module Type : sig + val mk : + ?loc:loc -> + ?attrs:attrs -> + ?params:(core_type * (variance * injectivity)) list -> + ?cstrs:(core_type * core_type * loc) list -> + ?kind:type_kind -> + ?priv:private_flag -> + ?manifest:core_type -> + str -> + type_declaration + + val constructor : + ?loc:loc -> + ?attrs:attrs -> + ?args:constructor_arguments -> + ?res:core_type -> + str -> + constructor_declaration + + val field : + ?loc:loc -> + ?attrs:attrs -> + ?mut:mutable_flag -> + str -> + core_type -> + label_declaration +end + +(** Type extensions *) +module Te : sig + val mk : + ?loc:loc -> + ?attrs:attrs -> + ?params:(core_type * (variance * injectivity)) list -> + ?priv:private_flag -> + lid -> + extension_constructor list -> + type_extension + + val mk_exception : + ?loc:loc -> ?attrs:attrs -> extension_constructor -> type_exception + + val constructor : + ?loc:loc -> + ?attrs:attrs -> + str -> + extension_constructor_kind -> + extension_constructor + + val decl : + ?loc:loc -> + ?attrs:attrs -> + ?args:constructor_arguments -> + ?res:core_type -> + str -> + extension_constructor + + val rebind : ?loc:loc -> ?attrs:attrs -> str -> lid -> extension_constructor +end + +(** {1 Module language} *) + +(** Module type expressions *) +module Mty : sig + val mk : ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type + + val attr : module_type -> attribute -> module_type + + val ident : ?loc:loc -> ?attrs:attrs -> lid -> module_type + + val alias : ?loc:loc -> ?attrs:attrs -> lid -> module_type + + val signature : ?loc:loc -> ?attrs:attrs -> signature -> module_type + + val functor_ : + ?loc:loc -> ?attrs:attrs -> functor_parameter -> module_type -> module_type + + val with_ : + ?loc:loc -> + ?attrs:attrs -> + module_type -> + with_constraint list -> + module_type + + val typeof_ : ?loc:loc -> ?attrs:attrs -> module_expr -> module_type + + val extension : ?loc:loc -> ?attrs:attrs -> extension -> module_type +end + +(** Module expressions *) +module Mod : sig + val mk : ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr + + val attr : module_expr -> attribute -> module_expr + + val ident : ?loc:loc -> ?attrs:attrs -> lid -> module_expr + + val structure : ?loc:loc -> ?attrs:attrs -> structure -> module_expr + + val functor_ : + ?loc:loc -> ?attrs:attrs -> functor_parameter -> module_expr -> module_expr + + val apply : + ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> module_expr + + val constraint_ : + ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> module_expr + + val unpack : ?loc:loc -> ?attrs:attrs -> expression -> module_expr + + val extension : ?loc:loc -> ?attrs:attrs -> extension -> module_expr +end + +(** Signature items *) +module Sig : sig + val mk : ?loc:loc -> signature_item_desc -> signature_item + + val value : ?loc:loc -> value_description -> signature_item + + val type_ : ?loc:loc -> rec_flag -> type_declaration list -> signature_item + + val type_subst : ?loc:loc -> type_declaration list -> signature_item + + val type_extension : ?loc:loc -> type_extension -> signature_item + + val exception_ : ?loc:loc -> type_exception -> signature_item + + val module_ : ?loc:loc -> module_declaration -> signature_item + + val mod_subst : ?loc:loc -> module_substitution -> signature_item + + val rec_module : ?loc:loc -> module_declaration list -> signature_item + + val modtype : ?loc:loc -> module_type_declaration -> signature_item + + val open_ : ?loc:loc -> open_description -> signature_item + + val include_ : ?loc:loc -> include_description -> signature_item + + val class_ : ?loc:loc -> class_description list -> signature_item + + val class_type : ?loc:loc -> class_type_declaration list -> signature_item + + val extension : ?loc:loc -> ?attrs:attrs -> extension -> signature_item + + val attribute : ?loc:loc -> attribute -> signature_item +end + +(** Structure items *) +module Str : sig + val mk : ?loc:loc -> structure_item_desc -> structure_item + + val eval : ?loc:loc -> ?attrs:attributes -> expression -> structure_item + + val value : ?loc:loc -> rec_flag -> value_binding list -> structure_item + + val primitive : ?loc:loc -> value_description -> structure_item + + val type_ : ?loc:loc -> rec_flag -> type_declaration list -> structure_item + + val type_extension : ?loc:loc -> type_extension -> structure_item + + val exception_ : ?loc:loc -> type_exception -> structure_item + + val module_ : ?loc:loc -> module_binding -> structure_item + + val rec_module : ?loc:loc -> module_binding list -> structure_item + + val modtype : ?loc:loc -> module_type_declaration -> structure_item + + val open_ : ?loc:loc -> open_declaration -> structure_item + + val class_ : ?loc:loc -> class_declaration list -> structure_item + + val class_type : ?loc:loc -> class_type_declaration list -> structure_item + + val include_ : ?loc:loc -> include_declaration -> structure_item + + val extension : ?loc:loc -> ?attrs:attrs -> extension -> structure_item + + val attribute : ?loc:loc -> attribute -> structure_item +end + +(** Module declarations *) +module Md : sig + val mk : + ?loc:loc -> ?attrs:attrs -> str_opt -> module_type -> module_declaration +end + +(** Module substitutions *) +module Ms : sig + val mk : ?loc:loc -> ?attrs:attrs -> str -> lid -> module_substitution +end + +(** Module type declarations *) +module Mtd : sig + val mk : + ?loc:loc -> + ?attrs:attrs -> + ?typ:module_type -> + str -> + module_type_declaration +end + +(** Module bindings *) +module Mb : sig + val mk : ?loc:loc -> ?attrs:attrs -> str_opt -> module_expr -> module_binding +end + +(** Opens *) +module Opn : sig + val mk : + ?loc:loc -> ?attrs:attrs -> ?override:override_flag -> 'a -> 'a open_infos +end + +(** Includes *) +module Incl : sig + val mk : ?loc:loc -> ?attrs:attrs -> 'a -> 'a include_infos +end + +(** Value bindings *) +module Vb : sig + val mk : ?loc:loc -> ?attrs:attrs -> pattern -> expression -> value_binding +end + +(** {1 Class language} *) + +(** Class type expressions *) +module Cty : sig + val mk : ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type + + val attr : class_type -> attribute -> class_type + + val constr : ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type + + val signature : ?loc:loc -> ?attrs:attrs -> class_signature -> class_type + + val arrow : + ?loc:loc -> + ?attrs:attrs -> + arg_label -> + core_type -> + class_type -> + class_type + + val extension : ?loc:loc -> ?attrs:attrs -> extension -> class_type + + val open_ : + ?loc:loc -> ?attrs:attrs -> open_description -> class_type -> class_type +end + +(** Class type fields *) +module Ctf : sig + val mk : ?loc:loc -> ?attrs:attrs -> class_type_field_desc -> class_type_field + + val attr : class_type_field -> attribute -> class_type_field + + val inherit_ : ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field + + val val_ : + ?loc:loc -> + ?attrs:attrs -> + str -> + mutable_flag -> + virtual_flag -> + core_type -> + class_type_field + + val method_ : + ?loc:loc -> + ?attrs:attrs -> + str -> + private_flag -> + virtual_flag -> + core_type -> + class_type_field + + val constraint_ : + ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> class_type_field + + val extension : ?loc:loc -> ?attrs:attrs -> extension -> class_type_field + + val attribute : ?loc:loc -> attribute -> class_type_field +end + +(** Class expressions *) +module Cl : sig + val mk : ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr + + val attr : class_expr -> attribute -> class_expr + + val constr : ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr + + val structure : ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr + + val fun_ : + ?loc:loc -> + ?attrs:attrs -> + arg_label -> + expression option -> + pattern -> + class_expr -> + class_expr + + val apply : + ?loc:loc -> + ?attrs:attrs -> + class_expr -> + (arg_label * expression) list -> + class_expr + + val let_ : + ?loc:loc -> + ?attrs:attrs -> + rec_flag -> + value_binding list -> + class_expr -> + class_expr + + val constraint_ : + ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> class_expr + + val extension : ?loc:loc -> ?attrs:attrs -> extension -> class_expr + + val open_ : + ?loc:loc -> ?attrs:attrs -> open_description -> class_expr -> class_expr +end + +(** Class fields *) +module Cf : sig + val mk : ?loc:loc -> ?attrs:attrs -> class_field_desc -> class_field + + val attr : class_field -> attribute -> class_field + + val inherit_ : + ?loc:loc -> + ?attrs:attrs -> + override_flag -> + class_expr -> + str option -> + class_field + + val val_ : + ?loc:loc -> + ?attrs:attrs -> + str -> + mutable_flag -> + class_field_kind -> + class_field + + val method_ : + ?loc:loc -> + ?attrs:attrs -> + str -> + private_flag -> + class_field_kind -> + class_field + + val constraint_ : + ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> class_field + + val initializer_ : ?loc:loc -> ?attrs:attrs -> expression -> class_field + + val extension : ?loc:loc -> ?attrs:attrs -> extension -> class_field + + val attribute : ?loc:loc -> attribute -> class_field + + val virtual_ : core_type -> class_field_kind + + val concrete : override_flag -> expression -> class_field_kind +end + +(** Classes *) +module Ci : sig + val mk : + ?loc:loc -> + ?attrs:attrs -> + ?virt:virtual_flag -> + ?params:(core_type * (variance * injectivity)) list -> + str -> + 'a -> + 'a class_infos +end + +(** Class signatures *) +module Csig : sig + val mk : core_type -> class_type_field list -> class_signature +end + +(** Class structures *) +module Cstr : sig + val mk : pattern -> class_field list -> class_structure +end + +(** Row fields *) +module Rf : sig + val mk : ?loc:loc -> ?attrs:attrs -> row_field_desc -> row_field + + val tag : + ?loc:loc -> + ?attrs:attrs -> + label with_loc -> + bool -> + core_type list -> + row_field + + val inherit_ : ?loc:loc -> core_type -> row_field +end + +(** Object fields *) +module Of : sig + val mk : ?loc:loc -> ?attrs:attrs -> object_field_desc -> object_field + + val tag : + ?loc:loc -> ?attrs:attrs -> label with_loc -> core_type -> object_field + + val inherit_ : ?loc:loc -> core_type -> object_field +end diff -Nru ppxlib-0.15.0/ast/ast.ml ppxlib-0.24.0/ast/ast.ml --- ppxlib-0.15.0/ast/ast.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/ast/ast.ml 2021-12-08 21:53:37.000000000 +0000 @@ -19,7 +19,7 @@ (* This file is obtained by: - - copying a subset of the corresponding ast_xxx.ml file from migrate-parsetree + - copying a subset of the corresponding ast_xxx.ml file from Astlib (sub-modules Asttypes and Parsetree) - adding the type definitions for position, location, loc and longident - flattening all the modules @@ -27,28 +27,44 @@ - renaming a few types: - - Location.t -> location - - Longident.t -> longident - - adding a type longident_loc = longident loc and replacing all the occurences of the + - adding a type longident_loc = longident loc and replacing all the occurrences of the latter by the former. This is so that we can override iteration an the level of a longident loc + - adding a type cases = case list - replacing all the (*IF_CURRENT = Foo.bar*) by: = Foo.bar - removing the extra values at the end of the file - replacing app [type ...] by [and ...] to make everything one recursive block - adding [@@deriving_inline traverse][@@@end] at the end + + To update it to a newer OCaml version, create a new module with the above from the + latest compiler and add the following module definitions and opens to get it to + compile: + [{ + module Ast = Versions.OCaml_4xx + open Ast.Ast + module Location = Ocaml_common.Location + module Longident = Ocaml_common.Longident + }] + + Once you have generated the inlined derived traversal classes by running + [{ dune build @lint }] you can replace the above mentioned module definitions by a + [open Import] and update [Import] so that the [Js] module points to + [Versions.OCaml_4xx]. *) (* Source code locations (ranges of positions), used in parsetree. *) -type position = Lexing.position = - { pos_fname : string - ; pos_lnum : int - ; pos_bol : int - ; pos_cnum : int - } +type position = Lexing.position = { + pos_fname : string; + pos_lnum : int; + pos_bol : int; + pos_cnum : int; +} and location = Location.t = { - loc_start: position; - loc_end: position; - loc_ghost: bool; + loc_start : position; + loc_end : position; + loc_ghost : bool; } and location_stack = location list @@ -59,16 +75,11 @@ re-parse the file to get the line and character numbers. Else all fields are correct. *) - -and 'a loc = 'a Location.loc = { - txt : 'a; - loc : location; -} +and 'a loc = 'a Location.loc = { txt : 'a; loc : location } (* Long identifiers, used in parsetree. *) - and longident = Longident.t = - Lident of string + | Lident of string | Ldot of longident * string | Lapply of longident * longident @@ -94,19 +105,19 @@ and label = string and arg_label = Asttypes.arg_label = - Nolabel + | Nolabel | Labelled of string (* label:T -> ... *) - | Optional of string (* ?label:T -> ... *) + | Optional of string +(* ?label:T -> ... *) + +and variance = Asttypes.variance = Covariant | Contravariant | NoVariance -and variance = Asttypes.variance = - | Covariant - | Contravariant - | Invariant +and injectivity = Asttypes.injectivity = Injective | NoInjectivity (** Abstract syntax tree produced by parsing *) and constant = Parsetree.constant = - Pconst_integer of string * char option + | Pconst_integer of string * char option (* 3 3l 3L 3n Suffixes [g-z][G-Z] are accepted by the parser. @@ -114,24 +125,26 @@ *) | Pconst_char of char (* 'c' *) - | Pconst_string of string * string option + | Pconst_string of string * location * string option (* "constant" {delim|other constant|delim} + + The location span the content of the string, without the delimiters. *) | Pconst_float of string * char option - (* 3.4 2e5 1.4e-4 +(* 3.4 2e5 1.4e-4 - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes are rejected by the typechecker. - *) + Suffixes [g-z][G-Z] are accepted by the parser. + Suffixes are rejected by the typechecker. +*) (** {1 Extension points} *) -and attribute = Parsetree.attribute = - { attr_name : string loc; - attr_payload : payload; - attr_loc : location; - } +and attribute = Parsetree.attribute = { + attr_name : string loc; + attr_payload : payload; + attr_loc : location; +} (* [@id ARG] [@@id ARG] @@ -151,20 +164,20 @@ and payload = Parsetree.payload = | PStr of structure | PSig of signature (* : SIG *) - | PTyp of core_type (* : T *) - | PPat of pattern * expression option (* ? P or ? P when E *) - -(** {1 Core language} *) + | PTyp of core_type (* : T *) + | PPat of pattern * expression option +(* ? P or ? P when E *) (* Type expressions *) -and core_type = Parsetree.core_type = - { - ptyp_desc: core_type_desc; - ptyp_loc: location; - ptyp_loc_stack: location_stack; - ptyp_attributes: attributes; (* ... [@id1] [@id2] *) - } +(** {1 Core language} *) + +and core_type = Parsetree.core_type = { + ptyp_desc : core_type_desc; + ptyp_loc : location; + ptyp_loc_stack : location_stack; + ptyp_attributes : attributes; (* ... [@id1] [@id2] *) +} and core_type_desc = Parsetree.core_type_desc = | Ptyp_any @@ -203,42 +216,40 @@ [< `A|`B ] (flag = Closed; labels = Some []) [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) *) - | Ptyp_poly of string loc list * core_type - (* 'a1 ... 'an. T + | Ptyp_poly of string loc list * core_type (* 'a1 ... 'an. T - Can only appear in the following context: + Can only appear in the following context: - - As the core_type of a Ppat_constraint node corresponding - to a constraint on a let-binding: let x : 'a1 ... 'an. T - = e ... + - As the core_type of a Ppat_constraint node corresponding + to a constraint on a let-binding: let x : 'a1 ... 'an. T + = e ... - - Under Cfk_virtual for methods (not values). + - Under Cfk_virtual for methods (not values). - - As the core_type of a Pctf_method node. + - As the core_type of a Pctf_method node. - - As the core_type of a Pexp_poly node. + - As the core_type of a Pexp_poly node. - - As the pld_type field of a label_declaration. - - - As a core_type of a Ptyp_object node. - *) + - As the pld_type field of a label_declaration. + - As a core_type of a Ptyp_object node. + *) | Ptyp_package of package_type (* (module S) *) | Ptyp_extension of extension - (* [%id] *) +(* [%id] *) and package_type = longident_loc * (longident_loc * core_type) list - (* +(* (module S) (module S with type t1 = T1 and ... and tn = Tn) *) -and row_field = Parsetree.row_field = - { prf_desc : row_field_desc; - prf_loc : location; - prf_attributes : attributes; - } +and row_field = Parsetree.row_field = { + prf_desc : row_field_desc; + prf_loc : location; + prf_attributes : attributes; +} and row_field_desc = Parsetree.row_field_desc = | Rtag of label loc * bool * core_type list @@ -255,27 +266,25 @@ - TODO: switch to a record representation, and keep location *) | Rinherit of core_type - (* [ T ] *) +(* [ | t ] *) -and object_field = Parsetree.object_field = - { pof_desc : object_field_desc; - pof_loc : location; - pof_attributes : attributes; - } +and object_field = Parsetree.object_field = { + pof_desc : object_field_desc; + pof_loc : location; + pof_attributes : attributes; +} and object_field_desc = Parsetree.object_field_desc = | Otag of label loc * core_type | Oinherit of core_type (* Patterns *) - -and pattern = Parsetree.pattern = - { - ppat_desc: pattern_desc; - ppat_loc: location; - ppat_loc_stack: location_stack; - ppat_attributes: attributes; (* ... [@id1] [@id2] *) - } +and pattern = Parsetree.pattern = { + ppat_desc : pattern_desc; + ppat_loc : location; + ppat_loc_stack : location_stack; + ppat_attributes : attributes; (* ... [@id1] [@id2] *) +} and pattern_desc = Parsetree.pattern_desc = | Ppat_any @@ -331,17 +340,15 @@ | Ppat_extension of extension (* [%id] *) | Ppat_open of longident_loc * pattern - (* M.(P) *) +(* M.(P) *) (* Value expressions *) - -and expression = Parsetree.expression = - { - pexp_desc: expression_desc; - pexp_loc: location; - pexp_loc_stack: location_stack; - pexp_attributes: attributes; (* ... [@id1] [@id2] *) - } +and expression = Parsetree.expression = { + pexp_desc : expression_desc; + pexp_loc : location; + pexp_loc_stack : location_stack; + pexp_attributes : attributes; (* ... [@id1] [@id2] *) +} and expression_desc = Parsetree.expression_desc = | Pexp_ident of longident_loc @@ -354,7 +361,7 @@ (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) *) - | Pexp_function of case list + | Pexp_function of cases (* function P1 -> E1 | ... | Pn -> En *) | Pexp_fun of arg_label * expression option * pattern * expression (* fun P -> E1 (Simple, None) @@ -374,9 +381,9 @@ Invariant: n > 0 *) - | Pexp_match of expression * case list + | Pexp_match of expression * cases (* match E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_try of expression * case list + | Pexp_try of expression * cases (* try E0 with P1 -> E1 | ... | Pn -> En *) | Pexp_tuple of expression list (* (E1, ..., En) @@ -410,8 +417,7 @@ (* E1; E2 *) | Pexp_while of expression * expression (* while E1 do E2 done *) - | Pexp_for of - pattern * expression * expression * direction_flag * expression + | Pexp_for of pattern * expression * expression * direction_flag * expression (* for i = E1 to E2 do E3 done (flag = Upto) for i = E1 downto E2 do E3 done (flag = Downto) *) @@ -463,61 +469,61 @@ | Pexp_extension of extension (* [%id] *) | Pexp_unreachable - (* . *) +(* . *) -and case = Parsetree.case = (* (P -> E) or (P when E0 -> E) *) - { - pc_lhs: pattern; - pc_guard: expression option; - pc_rhs: expression; - } - -and letop = Parsetree.letop = - { let_ : binding_op; - ands : binding_op list; - body : expression; - } - -and binding_op = Parsetree.binding_op = - { pbop_op : string loc; - pbop_pat : pattern; - pbop_exp : expression; - pbop_loc : location; - } +and case = Parsetree.case = { + (* (P -> E) or (P when E0 -> E) *) + pc_lhs : pattern; + pc_guard : expression option; + pc_rhs : expression; +} -(* Value descriptions *) +and letop = Parsetree.letop = { + let_ : binding_op; + ands : binding_op list; + body : expression; +} -and value_description = Parsetree.value_description = - { - pval_name: string loc; - pval_type: core_type; - pval_prim: string list; - pval_attributes: attributes; (* ... [@@id1] [@@id2] *) - pval_loc: location; - } +and binding_op = Parsetree.binding_op = { + pbop_op : string loc; + pbop_pat : pattern; + pbop_exp : expression; + pbop_loc : location; +} - (* +(* Value descriptions *) +and value_description = Parsetree.value_description = { + pval_name : string loc; + pval_type : core_type; + pval_prim : string list; + pval_attributes : attributes; + (* ... [@@id1] [@@id2] *) + pval_loc : location; +} + +(* val x: T (prim = []) external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) *) (* Type declarations *) +and type_declaration = Parsetree.type_declaration = { + ptype_name : string loc; + ptype_params : (core_type * (variance * injectivity)) list; + (* ('a1,...'an) t; None represents _*) + ptype_cstrs : (core_type * core_type * location) list; + (* ... constraint T1=T1' ... constraint Tn=Tn' *) + ptype_kind : type_kind; + ptype_private : private_flag; + (* = private ... *) + ptype_manifest : core_type option; + (* = T *) + ptype_attributes : attributes; + (* ... [@@id1] [@@id2] *) + ptype_loc : location; +} -and type_declaration = Parsetree.type_declaration = - { - ptype_name: string loc; - ptype_params: (core_type * variance) list; - (* ('a1,...'an) t; None represents _*) - ptype_cstrs: (core_type * core_type * location) list; - (* ... constraint T1=T1' ... constraint Tn=Tn' *) - ptype_kind: type_kind; - ptype_private: private_flag; (* = private ... *) - ptype_manifest: core_type option; (* = T *) - ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) - ptype_loc: location; - } - - (* +(* type t (abstract, no manifest) type t = T0 (abstract, manifest=T0) type t = C of T | ... (variant, no manifest) @@ -526,7 +532,6 @@ type t = T0 = {l : T; ...} (record, manifest=T0) type t = .. (open, no manifest) *) - and type_kind = Parsetree.type_kind = | Ptype_abstract | Ptype_variant of constructor_declaration list @@ -534,35 +539,32 @@ (* Invariant: non-empty list *) | Ptype_open -and label_declaration = Parsetree.label_declaration = - { - pld_name: string loc; - pld_mutable: mutable_flag; - pld_type: core_type; - pld_loc: location; - pld_attributes: attributes; (* l : T [@id1] [@id2] *) - } +and label_declaration = Parsetree.label_declaration = { + pld_name : string loc; + pld_mutable : mutable_flag; + pld_type : core_type; + pld_loc : location; + pld_attributes : attributes; (* l : T [@id1] [@id2] *) +} -(* { ...; l: T; ... } (mutable=Immutable) - { ...; mutable l: T; ... } (mutable=Mutable) +(* { ...; l: T; ... } (mutable=Immutable) + { ...; mutable l: T; ... } (mutable=Mutable) - Note: T can be a Ptyp_poly. + Note: T can be a Ptyp_poly. *) - -and constructor_declaration = Parsetree.constructor_declaration = - { - pcd_name: string loc; - pcd_args: constructor_arguments; - pcd_res: core_type option; - pcd_loc: location; - pcd_attributes: attributes; (* C of ... [@id1] [@id2] *) - } +and constructor_declaration = Parsetree.constructor_declaration = { + pcd_name : string loc; + pcd_args : constructor_arguments; + pcd_res : core_type option; + pcd_loc : location; + pcd_attributes : attributes; (* C of ... [@id1] [@id2] *) +} and constructor_arguments = Parsetree.constructor_arguments = | Pcstr_tuple of core_type list | Pcstr_record of label_declaration list - (* +(* | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) | C: T0 (res = Some T0, args = []) | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) @@ -570,56 +572,52 @@ | C: {...} -> T0 (res = Some T0, args = Pcstr_record) | C of {...} as t (res = None, args = Pcstr_record) *) - -and type_extension = Parsetree.type_extension = - { - ptyext_path: longident_loc; - ptyext_params: (core_type * variance) list; - ptyext_constructors: extension_constructor list; - ptyext_private: private_flag; - ptyext_loc: location; - ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - (* +and type_extension = Parsetree.type_extension = { + ptyext_path : longident_loc; + ptyext_params : (core_type * (variance * injectivity)) list; + ptyext_constructors : extension_constructor list; + ptyext_private : private_flag; + ptyext_loc : location; + ptyext_attributes : attributes; (* ... [@@id1] [@@id2] *) +} +(* type t += ... *) -and extension_constructor = Parsetree.extension_constructor = - { - pext_name: string loc; - pext_kind : extension_constructor_kind; - pext_loc : location; - pext_attributes: attributes; (* C of ... [@id1] [@id2] *) - } - -and type_exception = Parsetree.type_exception = - { ptyexn_constructor: extension_constructor; - ptyexn_loc: location; - ptyexn_attributes: attributes; - } +and extension_constructor = Parsetree.extension_constructor = { + pext_name : string loc; + pext_kind : extension_constructor_kind; + pext_loc : location; + pext_attributes : attributes; (* C of ... [@id1] [@id2] *) +} + +and type_exception = Parsetree.type_exception = { + ptyexn_constructor : extension_constructor; + ptyexn_loc : location; + ptyexn_attributes : attributes; +} and extension_constructor_kind = Parsetree.extension_constructor_kind = - Pext_decl of constructor_arguments * core_type option - (* + | Pext_decl of constructor_arguments * core_type option + (* | C of T1 * ... * Tn ([T1; ...; Tn], None) | C: T0 ([], Some T0) | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) *) | Pext_rebind of longident_loc - (* +(* | C = D *) -(** {1 Class language} *) - (* Type expressions for the class language *) -and class_type = Parsetree.class_type = - { - pcty_desc: class_type_desc; - pcty_loc: location; - pcty_attributes: attributes; (* ... [@id1] [@id2] *) - } +(** {1 Class language} *) + +and class_type = Parsetree.class_type = { + pcty_desc : class_type_desc; + pcty_loc : location; + pcty_attributes : attributes; (* ... [@id1] [@id2] *) +} and class_type_desc = Parsetree.class_type_desc = | Pcty_constr of longident_loc * core_type list @@ -635,50 +633,47 @@ | Pcty_extension of extension (* [%id] *) | Pcty_open of open_description * class_type - (* let open M in CT *) +(* let open M in CT *) -and class_signature = Parsetree.class_signature = - { - pcsig_self: core_type; - pcsig_fields: class_type_field list; - } +and class_signature = Parsetree.class_signature = { + pcsig_self : core_type; + pcsig_fields : class_type_field list; +} (* object('selfpat) ... end object ... end (self = Ptyp_any) *) -and class_type_field = Parsetree.class_type_field = - { - pctf_desc: class_type_field_desc; - pctf_loc: location; - pctf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } +and class_type_field = Parsetree.class_type_field = { + pctf_desc : class_type_field_desc; + pctf_loc : location; + pctf_attributes : attributes; (* ... [@@id1] [@@id2] *) +} and class_type_field_desc = 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) + | Pctf_method of (label loc * private_flag * virtual_flag * core_type) (* method x: T Note: T can be a Ptyp_poly. *) - | Pctf_constraint of (core_type * core_type) + | Pctf_constraint of (core_type * core_type) (* constraint T1 = T2 *) | Pctf_attribute of attribute (* [@@@id] *) | Pctf_extension of extension - (* [%%id] *) +(* [%%id] *) -and 'a class_infos = 'a Parsetree.class_infos = - { - pci_virt: virtual_flag; - pci_params: (core_type * variance) list; - pci_name: string loc; - pci_expr: 'a; - pci_loc: location; - pci_attributes: attributes; (* ... [@@id1] [@@id2] *) - } +and 'a class_infos = '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; + pci_attributes : attributes; (* ... [@@id1] [@@id2] *) +} (* class c = ... class ['a1,...,'an] c = ... class virtual c = ... @@ -691,13 +686,11 @@ and class_type_declaration = class_type class_infos (* Value expressions for the class language *) - -and class_expr = Parsetree.class_expr = - { - pcl_desc: class_expr_desc; - pcl_loc: location; - pcl_attributes: attributes; (* ... [@id1] [@id2] *) - } +and class_expr = Parsetree.class_expr = { + pcl_desc : class_expr_desc; + pcl_loc : location; + pcl_attributes : attributes; (* ... [@id1] [@id2] *) +} and class_expr_desc = Parsetree.class_expr_desc = | Pcl_constr of longident_loc * core_type list @@ -727,24 +720,21 @@ | Pcl_extension of extension (* [%id] *) | Pcl_open of open_description * class_expr - (* let open M in CE *) +(* let open M in CE *) - -and class_structure = Parsetree.class_structure = - { - pcstr_self: pattern; - pcstr_fields: class_field list; - } +and class_structure = Parsetree.class_structure = { + pcstr_self : pattern; + pcstr_fields : class_field list; +} (* object(selfpat) ... end object ... end (self = Ppat_any) *) -and class_field = Parsetree.class_field = - { - pcf_desc: class_field_desc; - pcf_loc: location; - pcf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } +and class_field = Parsetree.class_field = { + pcf_desc : class_field_desc; + pcf_loc : location; + pcf_attributes : attributes; (* ... [@@id1] [@@id2] *) +} and class_field_desc = Parsetree.class_field_desc = | Pcf_inherit of override_flag * class_expr * string loc option @@ -768,24 +758,22 @@ | Pcf_attribute of attribute (* [@@@id] *) | Pcf_extension of extension - (* [%%id] *) +(* [%%id] *) and class_field_kind = Parsetree.class_field_kind = | Cfk_virtual of core_type | Cfk_concrete of override_flag * expression and class_declaration = class_expr class_infos +(* Type expressions for the module language *) (** {1 Module language} *) -(* Type expressions for the module language *) - -and module_type = Parsetree.module_type = - { - pmty_desc: module_type_desc; - pmty_loc: location; - pmty_attributes: attributes; (* ... [@id1] [@id2] *) - } +and module_type = Parsetree.module_type = { + pmty_desc : module_type_desc; + pmty_loc : location; + pmty_attributes : attributes; (* ... [@id1] [@id2] *) +} and module_type_desc = Parsetree.module_type_desc = | Pmty_ident of longident_loc @@ -801,26 +789,25 @@ | Pmty_extension of extension (* [%id] *) | Pmty_alias of longident_loc - (* (module M) *) +(* (module M) *) and functor_parameter = Parsetree.functor_parameter = | Unit (* () *) | Named of string option loc * module_type - (* (X : MT) Some X, MT - (_ : MT) None, MT *) +(* (X : MT) Some X, MT + (_ : MT) None, MT *) and signature = signature_item list -and signature_item = Parsetree.signature_item = - { - psig_desc: signature_item_desc; - psig_loc: location; - } +and signature_item = Parsetree.signature_item = { + psig_desc : signature_item_desc; + psig_loc : location; +} and signature_item_desc = Parsetree.signature_item_desc = | Psig_value of value_description - (* + (* val x: T external x: T = "s1" ... "sn" *) @@ -852,41 +839,41 @@ | Psig_attribute of attribute (* [@@@id] *) | Psig_extension of extension * attributes - (* [%%id] *) +(* [%%id] *) -and module_declaration = Parsetree.module_declaration = - { - pmd_name: string option loc; - pmd_type: module_type; - pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmd_loc: location; - } +and module_declaration = Parsetree.module_declaration = { + pmd_name : string option loc; + pmd_type : module_type; + pmd_attributes : attributes; + (* ... [@@id1] [@@id2] *) + pmd_loc : location; +} (* S : MT *) -and module_substitution = Parsetree.module_substitution = - { pms_name: string loc; - pms_manifest: longident_loc; - pms_attributes: attributes; - pms_loc: location; - } - -and module_type_declaration = Parsetree.module_type_declaration = - { - pmtd_name: string loc; - pmtd_type: module_type option; - pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmtd_loc: location; - } +and module_substitution = Parsetree.module_substitution = { + pms_name : string loc; + pms_manifest : longident_loc; + pms_attributes : attributes; + pms_loc : location; +} + +and module_type_declaration = Parsetree.module_type_declaration = { + pmtd_name : string loc; + pmtd_type : module_type option; + pmtd_attributes : attributes; + (* ... [@@id1] [@@id2] *) + pmtd_loc : location; +} (* S = MT S (abstract module type declaration, pmtd_type = None) *) -and 'a open_infos = 'a Parsetree.open_infos = - { popen_expr: 'a; - popen_override: override_flag; - popen_loc: location; - popen_attributes: attributes; - } +and 'a open_infos = 'a Parsetree.open_infos = { + popen_expr : 'a; + popen_override : override_flag; + popen_loc : location; + popen_attributes : attributes; +} and open_description = longident_loc open_infos (* open! X - popen_override = Override (silences the 'used identifier @@ -896,12 +883,11 @@ and open_declaration = module_expr open_infos -and 'a include_infos = 'a Parsetree.include_infos = - { - pincl_mod: 'a; - pincl_loc: location; - pincl_attributes: attributes; - } +and 'a include_infos = 'a Parsetree.include_infos = { + pincl_mod : 'a; + pincl_loc : location; + pincl_attributes : attributes; +} and include_description = module_type include_infos (* include MT *) @@ -920,16 +906,14 @@ | Pwith_typesubst of longident_loc * type_declaration (* with type X.t := ..., same format as [Pwith_type] *) | Pwith_modsubst of longident_loc * longident_loc - (* with module X.Y := Z *) +(* with module X.Y := Z *) (* Value expressions for the module language *) - -and module_expr = Parsetree.module_expr = - { - pmod_desc: module_expr_desc; - pmod_loc: location; - pmod_attributes: attributes; (* ... [@id1] [@id2] *) - } +and module_expr = Parsetree.module_expr = { + pmod_desc : module_expr_desc; + pmod_loc : location; + pmod_attributes : attributes; (* ... [@id1] [@id2] *) +} and module_expr_desc = Parsetree.module_expr_desc = | Pmod_ident of longident_loc @@ -945,15 +929,14 @@ | Pmod_unpack of expression (* (val E) *) | Pmod_extension of extension - (* [%id] *) +(* [%id] *) and structure = structure_item list -and structure_item = Parsetree.structure_item = - { - pstr_desc: structure_item_desc; - pstr_loc: location; - } +and structure_item = Parsetree.structure_item = { + pstr_desc : structure_item_desc; + pstr_loc : location; +} and structure_item_desc = Parsetree.structure_item_desc = | Pstr_eval of expression * attributes @@ -963,8 +946,8 @@ let rec P1 = E1 and ... and Pn = EN (flag = Recursive) *) | Pstr_primitive of value_description - (* val x: T - external x: T = "s1" ... "sn" *) + (* 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 @@ -989,43 +972,42 @@ | Pstr_attribute of attribute (* [@@@id] *) | Pstr_extension of extension * attributes - (* [%%id] *) +(* [%%id] *) -and value_binding = Parsetree.value_binding = - { - pvb_pat: pattern; - pvb_expr: expression; - pvb_attributes: attributes; - pvb_loc: location; - } - -and module_binding = Parsetree.module_binding = - { - pmb_name: string option loc; - pmb_expr: module_expr; - pmb_attributes: attributes; - pmb_loc: location; - } -(* X = ME *) +and value_binding = Parsetree.value_binding = { + pvb_pat : pattern; + pvb_expr : expression; + pvb_attributes : attributes; + pvb_loc : location; +} -(** {1 Toplevel} *) +and module_binding = Parsetree.module_binding = { + pmb_name : string option loc; + pmb_expr : module_expr; + pmb_attributes : attributes; + pmb_loc : location; +} +(* X = ME *) (* Toplevel phrases *) +(** {1 Toplevel} *) + and toplevel_phrase = Parsetree.toplevel_phrase = | Ptop_def of structure | Ptop_dir of toplevel_directive - (* #use, #load ... *) +(* #use, #load ... *) -and toplevel_directive = Parsetree.toplevel_directive = - { pdir_name : string loc; - pdir_arg : directive_argument option; - pdir_loc : location; - } -and directive_argument = Parsetree.directive_argument = - { pdira_desc : directive_argument_desc; - pdira_loc : location; - } +and toplevel_directive = Parsetree.toplevel_directive = { + pdir_name : string loc; + pdir_arg : directive_argument option; + pdir_loc : location; +} + +and directive_argument = Parsetree.directive_argument = { + pdira_desc : directive_argument_desc; + pdira_loc : location; +} and directive_argument_desc = Parsetree.directive_argument_desc = | Pdir_string of string @@ -1033,121 +1015,186 @@ | Pdir_ident of longident | Pdir_bool of bool -[@@deriving_inline traverse] +and cases = case list [@@deriving_inline traverse] + class virtual map = object (self) - method virtual bool : bool -> bool - method virtual char : char -> char - method virtual int : int -> int - method virtual list : 'a . ('a -> 'a) -> 'a list -> 'a list - method virtual option : 'a . ('a -> 'a) -> 'a option -> 'a option - method virtual string : string -> string - method position : position -> position= + method virtual bool : bool -> bool + + method virtual char : char -> char + + method virtual int : int -> int + + method virtual list : 'a. ('a -> 'a) -> 'a list -> 'a list + + method virtual option : 'a. ('a -> 'a) -> 'a option -> 'a option + + method virtual string : string -> string + + method position : position -> position = fun { pos_fname; pos_lnum; pos_bol; pos_cnum } -> let pos_fname = self#string pos_fname in let pos_lnum = self#int pos_lnum in let pos_bol = self#int pos_bol in let pos_cnum = self#int pos_cnum in { pos_fname; pos_lnum; pos_bol; pos_cnum } - method location : location -> location= + + method location : location -> location = fun { loc_start; loc_end; loc_ghost } -> let loc_start = self#position loc_start in let loc_end = self#position loc_end in let loc_ghost = self#bool loc_ghost in { loc_start; loc_end; loc_ghost } - method location_stack : location_stack -> location_stack= + + method location_stack : location_stack -> location_stack = self#list self#location - method loc : 'a . ('a -> 'a) -> 'a loc -> 'a loc= - fun _a -> - fun { txt; loc } -> - let txt = _a txt in let loc = self#location loc in { txt; loc } - method longident : longident -> longident= + + method loc : 'a. ('a -> 'a) -> 'a loc -> 'a loc = + fun _a { txt; loc } -> + let txt = _a txt in + let loc = self#location loc in + { txt; loc } + + method longident : longident -> longident = fun x -> match x with - | Lident a -> let a = self#string a in Lident a + | Lident a -> + let a = self#string a in + Lident a | Ldot (a, b) -> - let a = self#longident a in let b = self#string b in Ldot (a, b) + let a = self#longident a in + let b = self#string b in + Ldot (a, b) | Lapply (a, b) -> let a = self#longident a in - let b = self#longident b in Lapply (a, b) - method longident_loc : longident_loc -> longident_loc= + let b = self#longident b in + Lapply (a, b) + + method longident_loc : longident_loc -> longident_loc = self#loc self#longident - method rec_flag : rec_flag -> rec_flag= fun x -> x - method direction_flag : direction_flag -> direction_flag= fun x -> x - method private_flag : private_flag -> private_flag= fun x -> x - method mutable_flag : mutable_flag -> mutable_flag= fun x -> x - method virtual_flag : virtual_flag -> virtual_flag= fun x -> x - method override_flag : override_flag -> override_flag= fun x -> x - method closed_flag : closed_flag -> closed_flag= fun x -> x - method label : label -> label= self#string - method arg_label : arg_label -> arg_label= + + method rec_flag : rec_flag -> rec_flag = fun x -> x + + method direction_flag : direction_flag -> direction_flag = fun x -> x + + method private_flag : private_flag -> private_flag = fun x -> x + + method mutable_flag : mutable_flag -> mutable_flag = fun x -> x + + method virtual_flag : virtual_flag -> virtual_flag = fun x -> x + + method override_flag : override_flag -> override_flag = fun x -> x + + method closed_flag : closed_flag -> closed_flag = fun x -> x + + method label : label -> label = self#string + + method arg_label : arg_label -> arg_label = fun x -> match x with | Nolabel -> Nolabel - | Labelled a -> let a = self#string a in Labelled a - | Optional a -> let a = self#string a in Optional a - method variance : variance -> variance= fun x -> x - method constant : constant -> constant= + | Labelled a -> + let a = self#string a in + Labelled a + | Optional a -> + let a = self#string a in + Optional a + + method variance : variance -> variance = fun x -> x + + method injectivity : injectivity -> injectivity = fun x -> x + + method constant : constant -> constant = fun x -> match x with | Pconst_integer (a, b) -> let a = self#string a in - let b = self#option self#char b in Pconst_integer (a, b) - | Pconst_char a -> let a = self#char a in Pconst_char a - | Pconst_string (a, b) -> + let b = self#option self#char b in + Pconst_integer (a, b) + | Pconst_char a -> + let a = self#char a in + Pconst_char a + | Pconst_string (a, b, c) -> let a = self#string a in - let b = self#option self#string b in Pconst_string (a, b) + let b = self#location b in + let c = self#option self#string c in + Pconst_string (a, b, c) | Pconst_float (a, b) -> let a = self#string a in - let b = self#option self#char b in Pconst_float (a, b) - method attribute : attribute -> attribute= + let b = self#option self#char b in + Pconst_float (a, b) + + method attribute : attribute -> attribute = fun { attr_name; attr_payload; attr_loc } -> let attr_name = self#loc self#string attr_name in let attr_payload = self#payload attr_payload in let attr_loc = self#location attr_loc in { attr_name; attr_payload; attr_loc } - method extension : extension -> extension= + + method extension : extension -> extension = fun (a, b) -> - let a = self#loc self#string a in let b = self#payload b in (a, b) - method attributes : attributes -> attributes= self#list self#attribute - method payload : payload -> payload= + let a = self#loc self#string a in + let b = self#payload b in + (a, b) + + method attributes : attributes -> attributes = self#list self#attribute + + method payload : payload -> payload = fun x -> match x with - | PStr a -> let a = self#structure a in PStr a - | PSig a -> let a = self#signature a in PSig a - | PTyp a -> let a = self#core_type a in PTyp a + | PStr a -> + let a = self#structure a in + PStr a + | PSig a -> + let a = self#signature a in + PSig a + | PTyp a -> + let a = self#core_type a in + PTyp a | PPat (a, b) -> let a = self#pattern a in - let b = self#option self#expression b in PPat (a, b) - method core_type : core_type -> core_type= + let b = self#option self#expression b in + PPat (a, b) + + method core_type : core_type -> core_type = fun { ptyp_desc; ptyp_loc; ptyp_loc_stack; ptyp_attributes } -> let ptyp_desc = self#core_type_desc ptyp_desc in let ptyp_loc = self#location ptyp_loc in let ptyp_loc_stack = self#location_stack ptyp_loc_stack in let ptyp_attributes = self#attributes ptyp_attributes in { ptyp_desc; ptyp_loc; ptyp_loc_stack; ptyp_attributes } - method core_type_desc : core_type_desc -> core_type_desc= + + method core_type_desc : core_type_desc -> core_type_desc = fun x -> match x with | Ptyp_any -> Ptyp_any - | Ptyp_var a -> let a = self#string a in Ptyp_var a + | Ptyp_var a -> + let a = self#string a in + Ptyp_var a | Ptyp_arrow (a, b, c) -> let a = self#arg_label a in let b = self#core_type b in - let c = self#core_type c in Ptyp_arrow (a, b, c) - | Ptyp_tuple a -> let a = self#list self#core_type a in Ptyp_tuple a + let c = self#core_type c in + Ptyp_arrow (a, b, c) + | Ptyp_tuple a -> + let a = self#list self#core_type a in + Ptyp_tuple a | Ptyp_constr (a, b) -> let a = self#longident_loc a in - let b = self#list self#core_type b in Ptyp_constr (a, b) + let b = self#list self#core_type b in + Ptyp_constr (a, b) | Ptyp_object (a, b) -> let a = self#list self#object_field a in - let b = self#closed_flag b in Ptyp_object (a, b) + let b = self#closed_flag b in + Ptyp_object (a, b) | Ptyp_class (a, b) -> let a = self#longident_loc a in - let b = self#list self#core_type b in Ptyp_class (a, b) + let b = self#list self#core_type b in + Ptyp_class (a, b) | Ptyp_alias (a, b) -> let a = self#core_type a in - let b = self#string b in Ptyp_alias (a, b) + let b = self#string b in + Ptyp_alias (a, b) | Ptyp_variant (a, b, c) -> let a = self#list self#row_field a in let b = self#closed_flag b in @@ -1155,152 +1202,228 @@ Ptyp_variant (a, b, c) | Ptyp_poly (a, b) -> let a = self#list (self#loc self#string) a in - let b = self#core_type b in Ptyp_poly (a, b) - | Ptyp_package a -> let a = self#package_type a in Ptyp_package a - | Ptyp_extension a -> let a = self#extension a in Ptyp_extension a - method package_type : package_type -> package_type= + let b = self#core_type b in + Ptyp_poly (a, b) + | Ptyp_package a -> + let a = self#package_type a in + Ptyp_package a + | Ptyp_extension a -> + let a = self#extension a in + Ptyp_extension a + + method package_type : package_type -> package_type = fun (a, b) -> let a = self#longident_loc a in let b = self#list (fun (a, b) -> - let a = self#longident_loc a in - let b = self#core_type b in (a, b)) b in + let a = self#longident_loc a in + let b = self#core_type b in + (a, b)) + b + in (a, b) - method row_field : row_field -> row_field= + + method row_field : row_field -> row_field = fun { prf_desc; prf_loc; prf_attributes } -> let prf_desc = self#row_field_desc prf_desc in let prf_loc = self#location prf_loc in let prf_attributes = self#attributes prf_attributes in { prf_desc; prf_loc; prf_attributes } - method row_field_desc : row_field_desc -> row_field_desc= + + method row_field_desc : row_field_desc -> row_field_desc = fun x -> match x with | Rtag (a, b, c) -> let a = self#loc self#label a in let b = self#bool b in - let c = self#list self#core_type c in Rtag (a, b, c) - | Rinherit a -> let a = self#core_type a in Rinherit a - method object_field : object_field -> object_field= + let c = self#list self#core_type c in + Rtag (a, b, c) + | Rinherit a -> + let a = self#core_type a in + Rinherit a + + method object_field : object_field -> object_field = fun { pof_desc; pof_loc; pof_attributes } -> let pof_desc = self#object_field_desc pof_desc in let pof_loc = self#location pof_loc in let pof_attributes = self#attributes pof_attributes in { pof_desc; pof_loc; pof_attributes } - method object_field_desc : object_field_desc -> object_field_desc= + + method object_field_desc : object_field_desc -> object_field_desc = fun x -> match x with | Otag (a, b) -> let a = self#loc self#label a in - let b = self#core_type b in Otag (a, b) - | Oinherit a -> let a = self#core_type a in Oinherit a - method pattern : pattern -> pattern= + let b = self#core_type b in + Otag (a, b) + | Oinherit a -> + let a = self#core_type a in + Oinherit a + + method pattern : pattern -> pattern = fun { ppat_desc; ppat_loc; ppat_loc_stack; ppat_attributes } -> let ppat_desc = self#pattern_desc ppat_desc in let ppat_loc = self#location ppat_loc in let ppat_loc_stack = self#location_stack ppat_loc_stack in let ppat_attributes = self#attributes ppat_attributes in { ppat_desc; ppat_loc; ppat_loc_stack; ppat_attributes } - method pattern_desc : pattern_desc -> pattern_desc= + + method pattern_desc : pattern_desc -> pattern_desc = fun x -> match x with | Ppat_any -> Ppat_any - | Ppat_var a -> let a = self#loc self#string a in Ppat_var a + | Ppat_var a -> + let a = self#loc self#string a in + Ppat_var a | Ppat_alias (a, b) -> let a = self#pattern a in - let b = self#loc self#string b in Ppat_alias (a, b) - | Ppat_constant a -> let a = self#constant a in Ppat_constant a + let b = self#loc self#string b in + Ppat_alias (a, b) + | Ppat_constant a -> + let a = self#constant a in + Ppat_constant a | Ppat_interval (a, b) -> let a = self#constant a in - let b = self#constant b in Ppat_interval (a, b) - | Ppat_tuple a -> let a = self#list self#pattern a in Ppat_tuple a + let b = self#constant b in + Ppat_interval (a, b) + | Ppat_tuple a -> + let a = self#list self#pattern a in + Ppat_tuple a | Ppat_construct (a, b) -> let a = self#longident_loc a in - let b = self#option self#pattern b in Ppat_construct (a, b) + let b = self#option self#pattern b in + Ppat_construct (a, b) | Ppat_variant (a, b) -> let a = self#label a in - let b = self#option self#pattern b in Ppat_variant (a, b) + let b = self#option self#pattern b in + Ppat_variant (a, b) | Ppat_record (a, b) -> let a = self#list (fun (a, b) -> - let a = self#longident_loc a in - let b = self#pattern b in (a, b)) a in - let b = self#closed_flag b in Ppat_record (a, b) - | Ppat_array a -> let a = self#list self#pattern a in Ppat_array a + let a = self#longident_loc a in + let b = self#pattern b in + (a, b)) + a + in + let b = self#closed_flag b in + Ppat_record (a, b) + | Ppat_array a -> + let a = self#list self#pattern a in + Ppat_array a | Ppat_or (a, b) -> let a = self#pattern a in - let b = self#pattern b in Ppat_or (a, b) + let b = self#pattern b in + Ppat_or (a, b) | Ppat_constraint (a, b) -> let a = self#pattern a in - let b = self#core_type b in Ppat_constraint (a, b) - | Ppat_type a -> let a = self#longident_loc a in Ppat_type a - | Ppat_lazy a -> let a = self#pattern a in Ppat_lazy a + let b = self#core_type b in + Ppat_constraint (a, b) + | Ppat_type a -> + let a = self#longident_loc a in + Ppat_type a + | Ppat_lazy a -> + let a = self#pattern a in + Ppat_lazy a | Ppat_unpack a -> - let a = self#loc (self#option self#string) a in Ppat_unpack a - | Ppat_exception a -> let a = self#pattern a in Ppat_exception a - | Ppat_extension a -> let a = self#extension a in Ppat_extension a + let a = self#loc (self#option self#string) a in + Ppat_unpack a + | Ppat_exception a -> + let a = self#pattern a in + Ppat_exception a + | Ppat_extension a -> + let a = self#extension a in + Ppat_extension a | Ppat_open (a, b) -> let a = self#longident_loc a in - let b = self#pattern b in Ppat_open (a, b) - method expression : expression -> expression= + let b = self#pattern b in + Ppat_open (a, b) + + method expression : expression -> expression = fun { pexp_desc; pexp_loc; pexp_loc_stack; pexp_attributes } -> let pexp_desc = self#expression_desc pexp_desc in let pexp_loc = self#location pexp_loc in let pexp_loc_stack = self#location_stack pexp_loc_stack in let pexp_attributes = self#attributes pexp_attributes in { pexp_desc; pexp_loc; pexp_loc_stack; pexp_attributes } - method expression_desc : expression_desc -> expression_desc= + + method expression_desc : expression_desc -> expression_desc = fun x -> match x with - | Pexp_ident a -> let a = self#longident_loc a in Pexp_ident a - | Pexp_constant a -> let a = self#constant a in Pexp_constant a + | Pexp_ident a -> + let a = self#longident_loc a in + Pexp_ident a + | Pexp_constant a -> + let a = self#constant a in + Pexp_constant a | Pexp_let (a, b, c) -> let a = self#rec_flag a in let b = self#list self#value_binding b in - let c = self#expression c in Pexp_let (a, b, c) - | Pexp_function a -> let a = self#list self#case a in Pexp_function a + let c = self#expression c in + Pexp_let (a, b, c) + | Pexp_function a -> + let a = self#cases a in + Pexp_function a | Pexp_fun (a, b, c, d) -> let a = self#arg_label a in let b = self#option self#expression b in let c = self#pattern c in - let d = self#expression d in Pexp_fun (a, b, c, d) + let d = self#expression d in + Pexp_fun (a, b, c, d) | Pexp_apply (a, b) -> let a = self#expression a in let b = self#list (fun (a, b) -> - let a = self#arg_label a in - let b = self#expression b in (a, b)) b in + let a = self#arg_label a in + let b = self#expression b in + (a, b)) + b + in Pexp_apply (a, b) | Pexp_match (a, b) -> let a = self#expression a in - let b = self#list self#case b in Pexp_match (a, b) + let b = self#cases b in + Pexp_match (a, b) | Pexp_try (a, b) -> let a = self#expression a in - let b = self#list self#case b in Pexp_try (a, b) - | Pexp_tuple a -> let a = self#list self#expression a in Pexp_tuple a + let b = self#cases b in + Pexp_try (a, b) + | Pexp_tuple a -> + let a = self#list self#expression a in + Pexp_tuple a | Pexp_construct (a, b) -> let a = self#longident_loc a in - let b = self#option self#expression b in Pexp_construct (a, b) + let b = self#option self#expression b in + Pexp_construct (a, b) | Pexp_variant (a, b) -> let a = self#label a in - let b = self#option self#expression b in Pexp_variant (a, b) + let b = self#option self#expression b in + Pexp_variant (a, b) | Pexp_record (a, b) -> let a = self#list (fun (a, b) -> - let a = self#longident_loc a in - let b = self#expression b in (a, b)) a in - let b = self#option self#expression b in Pexp_record (a, b) + let a = self#longident_loc a in + let b = self#expression b in + (a, b)) + a + in + let b = self#option self#expression b in + Pexp_record (a, b) | Pexp_field (a, b) -> let a = self#expression a in - let b = self#longident_loc b in Pexp_field (a, b) + let b = self#longident_loc b in + Pexp_field (a, b) | Pexp_setfield (a, b, c) -> let a = self#expression a in let b = self#longident_loc b in - let c = self#expression c in Pexp_setfield (a, b, c) - | Pexp_array a -> let a = self#list self#expression a in Pexp_array a + let c = self#expression c in + Pexp_setfield (a, b, c) + | Pexp_array a -> + let a = self#list self#expression a in + Pexp_array a | Pexp_ifthenelse (a, b, c) -> let a = self#expression a in let b = self#expression b in @@ -1308,78 +1431,113 @@ Pexp_ifthenelse (a, b, c) | Pexp_sequence (a, b) -> let a = self#expression a in - let b = self#expression b in Pexp_sequence (a, b) + let b = self#expression b in + Pexp_sequence (a, b) | Pexp_while (a, b) -> let a = self#expression a in - let b = self#expression b in Pexp_while (a, b) + let b = self#expression b in + Pexp_while (a, b) | Pexp_for (a, b, c, d, e) -> let a = self#pattern a in let b = self#expression b in let c = self#expression c in let d = self#direction_flag d in - let e = self#expression e in Pexp_for (a, b, c, d, e) + let e = self#expression e in + Pexp_for (a, b, c, d, e) | Pexp_constraint (a, b) -> let a = self#expression a in - let b = self#core_type b in Pexp_constraint (a, b) + let b = self#core_type b in + Pexp_constraint (a, b) | Pexp_coerce (a, b, c) -> let a = self#expression a in let b = self#option self#core_type b in - let c = self#core_type c in Pexp_coerce (a, b, c) + let c = self#core_type c in + Pexp_coerce (a, b, c) | Pexp_send (a, b) -> let a = self#expression a in - let b = self#loc self#label b in Pexp_send (a, b) - | Pexp_new a -> let a = self#longident_loc a in Pexp_new a + let b = self#loc self#label b in + Pexp_send (a, b) + | Pexp_new a -> + let a = self#longident_loc a in + Pexp_new a | Pexp_setinstvar (a, b) -> let a = self#loc self#label a in - let b = self#expression b in Pexp_setinstvar (a, b) + let b = self#expression b in + Pexp_setinstvar (a, b) | Pexp_override a -> let a = self#list (fun (a, b) -> - let a = self#loc self#label a in - let b = self#expression b in (a, b)) a in + let a = self#loc self#label a in + let b = self#expression b in + (a, b)) + a + in Pexp_override a | Pexp_letmodule (a, b, c) -> let a = self#loc (self#option self#string) a in let b = self#module_expr b in - let c = self#expression c in Pexp_letmodule (a, b, c) + let c = self#expression c in + Pexp_letmodule (a, b, c) | Pexp_letexception (a, b) -> let a = self#extension_constructor a in - let b = self#expression b in Pexp_letexception (a, b) - | Pexp_assert a -> let a = self#expression a in Pexp_assert a - | Pexp_lazy a -> let a = self#expression a in Pexp_lazy a + let b = self#expression b in + Pexp_letexception (a, b) + | Pexp_assert a -> + let a = self#expression a in + Pexp_assert a + | Pexp_lazy a -> + let a = self#expression a in + Pexp_lazy a | Pexp_poly (a, b) -> let a = self#expression a in - let b = self#option self#core_type b in Pexp_poly (a, b) - | Pexp_object a -> let a = self#class_structure a in Pexp_object a + let b = self#option self#core_type b in + Pexp_poly (a, b) + | Pexp_object a -> + let a = self#class_structure a in + Pexp_object a | Pexp_newtype (a, b) -> let a = self#loc self#string a in - let b = self#expression b in Pexp_newtype (a, b) - | Pexp_pack a -> let a = self#module_expr a in Pexp_pack a + let b = self#expression b in + Pexp_newtype (a, b) + | Pexp_pack a -> + let a = self#module_expr a in + Pexp_pack a | Pexp_open (a, b) -> let a = self#open_declaration a in - let b = self#expression b in Pexp_open (a, b) - | Pexp_letop a -> let a = self#letop a in Pexp_letop a - | Pexp_extension a -> let a = self#extension a in Pexp_extension a + let b = self#expression b in + Pexp_open (a, b) + | Pexp_letop a -> + let a = self#letop a in + Pexp_letop a + | Pexp_extension a -> + let a = self#extension a in + Pexp_extension a | Pexp_unreachable -> Pexp_unreachable - method case : case -> case= + + method case : case -> case = fun { pc_lhs; pc_guard; pc_rhs } -> let pc_lhs = self#pattern pc_lhs in let pc_guard = self#option self#expression pc_guard in - let pc_rhs = self#expression pc_rhs in { pc_lhs; pc_guard; pc_rhs } - method letop : letop -> letop= + let pc_rhs = self#expression pc_rhs in + { pc_lhs; pc_guard; pc_rhs } + + method letop : letop -> letop = fun { let_; ands; body } -> let let_ = self#binding_op let_ in let ands = self#list self#binding_op ands in - let body = self#expression body in { let_; ands; body } - method binding_op : binding_op -> binding_op= + let body = self#expression body in + { let_; ands; body } + + method binding_op : binding_op -> binding_op = fun { pbop_op; pbop_pat; pbop_exp; pbop_loc } -> let pbop_op = self#loc self#string pbop_op in let pbop_pat = self#pattern pbop_pat in let pbop_exp = self#expression pbop_exp in let pbop_loc = self#location pbop_loc in { pbop_op; pbop_pat; pbop_exp; pbop_loc } - method value_description : value_description -> value_description= + + method value_description : value_description -> value_description = fun { pval_name; pval_type; pval_prim; pval_attributes; pval_loc } -> let pval_name = self#loc self#string pval_name in let pval_type = self#core_type pval_type in @@ -1387,23 +1545,42 @@ let pval_attributes = self#attributes pval_attributes in let pval_loc = self#location pval_loc in { pval_name; pval_type; pval_prim; pval_attributes; pval_loc } - method type_declaration : type_declaration -> type_declaration= - fun - { ptype_name; ptype_params; ptype_cstrs; ptype_kind; ptype_private; - ptype_manifest; ptype_attributes; ptype_loc } - -> + + method type_declaration : type_declaration -> type_declaration = + fun { + ptype_name; + ptype_params; + ptype_cstrs; + ptype_kind; + ptype_private; + ptype_manifest; + ptype_attributes; + ptype_loc; + } -> let ptype_name = self#loc self#string ptype_name in let ptype_params = self#list (fun (a, b) -> - let a = self#core_type a in let b = self#variance b in (a, b)) - ptype_params in + let a = self#core_type a in + let b = + (fun (a, b) -> + let a = self#variance a in + let b = self#injectivity b in + (a, b)) + b + in + (a, b)) + ptype_params + in let ptype_cstrs = self#list (fun (a, b, c) -> - let a = self#core_type a in - let b = self#core_type b in - let c = self#location c in (a, b, c)) ptype_cstrs in + let a = self#core_type a in + let b = self#core_type b in + let c = self#location c in + (a, b, c)) + ptype_cstrs + in let ptype_kind = self#type_kind ptype_kind in let ptype_private = self#private_flag ptype_private in let ptype_manifest = self#option self#core_type ptype_manifest in @@ -1417,9 +1594,10 @@ ptype_private; ptype_manifest; ptype_attributes; - ptype_loc + ptype_loc; } - method type_kind : type_kind -> type_kind= + + method type_kind : type_kind -> type_kind = fun x -> match x with | Ptype_abstract -> Ptype_abstract @@ -1427,9 +1605,11 @@ let a = self#list self#constructor_declaration a in Ptype_variant a | Ptype_record a -> - let a = self#list self#label_declaration a in Ptype_record a + let a = self#list self#label_declaration a in + Ptype_record a | Ptype_open -> Ptype_open - method label_declaration : label_declaration -> label_declaration= + + method label_declaration : label_declaration -> label_declaration = fun { pld_name; pld_mutable; pld_type; pld_loc; pld_attributes } -> let pld_name = self#loc self#string pld_name in let pld_mutable = self#mutable_flag pld_mutable in @@ -1437,8 +1617,9 @@ let pld_loc = self#location pld_loc in let pld_attributes = self#attributes pld_attributes in { pld_name; pld_mutable; pld_type; pld_loc; pld_attributes } - method constructor_declaration : - constructor_declaration -> constructor_declaration= + + method constructor_declaration + : constructor_declaration -> constructor_declaration = fun { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } -> let pcd_name = self#loc self#string pcd_name in let pcd_args = self#constructor_arguments pcd_args in @@ -1446,27 +1627,45 @@ let pcd_loc = self#location pcd_loc in let pcd_attributes = self#attributes pcd_attributes in { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } - method constructor_arguments : - constructor_arguments -> constructor_arguments= + + method constructor_arguments + : constructor_arguments -> constructor_arguments = fun x -> match x with | Pcstr_tuple a -> - let a = self#list self#core_type a in Pcstr_tuple a + let a = self#list self#core_type a in + Pcstr_tuple a | Pcstr_record a -> - let a = self#list self#label_declaration a in Pcstr_record a - method type_extension : type_extension -> type_extension= - fun - { ptyext_path; ptyext_params; ptyext_constructors; ptyext_private; - ptyext_loc; ptyext_attributes } - -> + let a = self#list self#label_declaration a in + Pcstr_record a + + method type_extension : type_extension -> type_extension = + fun { + ptyext_path; + ptyext_params; + ptyext_constructors; + ptyext_private; + ptyext_loc; + ptyext_attributes; + } -> let ptyext_path = self#longident_loc ptyext_path in let ptyext_params = self#list (fun (a, b) -> - let a = self#core_type a in let b = self#variance b in (a, b)) - ptyext_params in + let a = self#core_type a in + let b = + (fun (a, b) -> + let a = self#variance a in + let b = self#injectivity b in + (a, b)) + b + in + (a, b)) + ptyext_params + in let ptyext_constructors = - self#list self#extension_constructor ptyext_constructors in + self#list self#extension_constructor ptyext_constructors + in let ptyext_private = self#private_flag ptyext_private in let ptyext_loc = self#location ptyext_loc in let ptyext_attributes = self#attributes ptyext_attributes in @@ -1476,166 +1675,223 @@ ptyext_constructors; ptyext_private; ptyext_loc; - ptyext_attributes + ptyext_attributes; } - method extension_constructor : - extension_constructor -> extension_constructor= + + method extension_constructor + : extension_constructor -> extension_constructor = fun { pext_name; pext_kind; pext_loc; pext_attributes } -> let pext_name = self#loc self#string pext_name in let pext_kind = self#extension_constructor_kind pext_kind in let pext_loc = self#location pext_loc in let pext_attributes = self#attributes pext_attributes in { pext_name; pext_kind; pext_loc; pext_attributes } - method type_exception : type_exception -> type_exception= + + method type_exception : type_exception -> type_exception = fun { ptyexn_constructor; ptyexn_loc; ptyexn_attributes } -> let ptyexn_constructor = - self#extension_constructor ptyexn_constructor in + self#extension_constructor ptyexn_constructor + in let ptyexn_loc = self#location ptyexn_loc in let ptyexn_attributes = self#attributes ptyexn_attributes in { ptyexn_constructor; ptyexn_loc; ptyexn_attributes } - method extension_constructor_kind : - extension_constructor_kind -> extension_constructor_kind= + + method extension_constructor_kind + : extension_constructor_kind -> extension_constructor_kind = fun x -> match x with | Pext_decl (a, b) -> let a = self#constructor_arguments a in - let b = self#option self#core_type b in Pext_decl (a, b) - | Pext_rebind a -> let a = self#longident_loc a in Pext_rebind a - method class_type : class_type -> class_type= + let b = self#option self#core_type b in + Pext_decl (a, b) + | Pext_rebind a -> + let a = self#longident_loc a in + Pext_rebind a + + method class_type : class_type -> class_type = fun { pcty_desc; pcty_loc; pcty_attributes } -> let pcty_desc = self#class_type_desc pcty_desc in let pcty_loc = self#location pcty_loc in let pcty_attributes = self#attributes pcty_attributes in { pcty_desc; pcty_loc; pcty_attributes } - method class_type_desc : class_type_desc -> class_type_desc= + + method class_type_desc : class_type_desc -> class_type_desc = fun x -> match x with | Pcty_constr (a, b) -> let a = self#longident_loc a in - let b = self#list self#core_type b in Pcty_constr (a, b) + let b = self#list self#core_type b in + Pcty_constr (a, b) | Pcty_signature a -> - let a = self#class_signature a in Pcty_signature a + let a = self#class_signature a in + Pcty_signature a | Pcty_arrow (a, b, c) -> let a = self#arg_label a in let b = self#core_type b in - let c = self#class_type c in Pcty_arrow (a, b, c) - | Pcty_extension a -> let a = self#extension a in Pcty_extension a + let c = self#class_type c in + Pcty_arrow (a, b, c) + | Pcty_extension a -> + let a = self#extension a in + Pcty_extension a | Pcty_open (a, b) -> let a = self#open_description a in - let b = self#class_type b in Pcty_open (a, b) - method class_signature : class_signature -> class_signature= + let b = self#class_type b in + Pcty_open (a, b) + + method class_signature : class_signature -> class_signature = fun { pcsig_self; pcsig_fields } -> let pcsig_self = self#core_type pcsig_self in let pcsig_fields = self#list self#class_type_field pcsig_fields in { pcsig_self; pcsig_fields } - method class_type_field : class_type_field -> class_type_field= + + method class_type_field : class_type_field -> class_type_field = fun { pctf_desc; pctf_loc; pctf_attributes } -> let pctf_desc = self#class_type_field_desc pctf_desc in let pctf_loc = self#location pctf_loc in let pctf_attributes = self#attributes pctf_attributes in { pctf_desc; pctf_loc; pctf_attributes } - method class_type_field_desc : - class_type_field_desc -> class_type_field_desc= + + method class_type_field_desc + : class_type_field_desc -> class_type_field_desc = fun x -> match x with - | Pctf_inherit a -> let a = self#class_type a in Pctf_inherit a + | Pctf_inherit a -> + let a = self#class_type a in + Pctf_inherit a | Pctf_val a -> let a = (fun (a, b, c, d) -> - let a = self#loc self#label a in - let b = self#mutable_flag b in - let c = self#virtual_flag c in - let d = self#core_type d in (a, b, c, d)) a in + let a = self#loc self#label a in + let b = self#mutable_flag b in + let c = self#virtual_flag c in + let d = self#core_type d in + (a, b, c, d)) + a + in Pctf_val a | Pctf_method a -> let a = (fun (a, b, c, d) -> - let a = self#loc self#label a in - let b = self#private_flag b in - let c = self#virtual_flag c in - let d = self#core_type d in (a, b, c, d)) a in + let a = self#loc self#label a in + let b = self#private_flag b in + let c = self#virtual_flag c in + let d = self#core_type d in + (a, b, c, d)) + a + in Pctf_method a | Pctf_constraint a -> let a = (fun (a, b) -> - let a = self#core_type a in - let b = self#core_type b in (a, b)) a in + let a = self#core_type a in + let b = self#core_type b in + (a, b)) + a + in Pctf_constraint a - | Pctf_attribute a -> let a = self#attribute a in Pctf_attribute a - | Pctf_extension a -> let a = self#extension a in Pctf_extension a - method class_infos : 'a . ('a -> 'a) -> 'a class_infos -> 'a class_infos= - fun _a -> - fun - { pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes - } - -> - let pci_virt = self#virtual_flag pci_virt in - let pci_params = - self#list - (fun (a, b) -> - let a = self#core_type a in - let b = self#variance b in (a, b)) pci_params in - let pci_name = self#loc self#string pci_name in - let pci_expr = _a pci_expr in - let pci_loc = self#location pci_loc in - let pci_attributes = self#attributes pci_attributes in - { pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes - } - method class_description : class_description -> class_description= + | Pctf_attribute a -> + let a = self#attribute a in + Pctf_attribute a + | Pctf_extension a -> + let a = self#extension a in + Pctf_extension a + + method class_infos : 'a. ('a -> 'a) -> 'a class_infos -> 'a class_infos = + fun _a + { pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes } -> + let pci_virt = self#virtual_flag pci_virt in + let pci_params = + self#list + (fun (a, b) -> + let a = self#core_type a in + let b = + (fun (a, b) -> + let a = self#variance a in + let b = self#injectivity b in + (a, b)) + b + in + (a, b)) + pci_params + in + let pci_name = self#loc self#string pci_name in + let pci_expr = _a pci_expr in + let pci_loc = self#location pci_loc in + let pci_attributes = self#attributes pci_attributes in + { pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes } + + method class_description : class_description -> class_description = self#class_infos self#class_type - method class_type_declaration : - class_type_declaration -> class_type_declaration= + + method class_type_declaration + : class_type_declaration -> class_type_declaration = self#class_infos self#class_type - method class_expr : class_expr -> class_expr= + + method class_expr : class_expr -> class_expr = fun { pcl_desc; pcl_loc; pcl_attributes } -> let pcl_desc = self#class_expr_desc pcl_desc in let pcl_loc = self#location pcl_loc in let pcl_attributes = self#attributes pcl_attributes in { pcl_desc; pcl_loc; pcl_attributes } - method class_expr_desc : class_expr_desc -> class_expr_desc= + + method class_expr_desc : class_expr_desc -> class_expr_desc = fun x -> match x with | Pcl_constr (a, b) -> let a = self#longident_loc a in - let b = self#list self#core_type b in Pcl_constr (a, b) + let b = self#list self#core_type b in + Pcl_constr (a, b) | Pcl_structure a -> - let a = self#class_structure a in Pcl_structure a + let a = self#class_structure a in + Pcl_structure a | Pcl_fun (a, b, c, d) -> let a = self#arg_label a in let b = self#option self#expression b in let c = self#pattern c in - let d = self#class_expr d in Pcl_fun (a, b, c, d) + let d = self#class_expr d in + Pcl_fun (a, b, c, d) | Pcl_apply (a, b) -> let a = self#class_expr a in let b = self#list (fun (a, b) -> - let a = self#arg_label a in - let b = self#expression b in (a, b)) b in + let a = self#arg_label a in + let b = self#expression b in + (a, b)) + b + in Pcl_apply (a, b) | Pcl_let (a, b, c) -> let a = self#rec_flag a in let b = self#list self#value_binding b in - let c = self#class_expr c in Pcl_let (a, b, c) + let c = self#class_expr c in + Pcl_let (a, b, c) | Pcl_constraint (a, b) -> let a = self#class_expr a in - let b = self#class_type b in Pcl_constraint (a, b) - | Pcl_extension a -> let a = self#extension a in Pcl_extension a + let b = self#class_type b in + Pcl_constraint (a, b) + | Pcl_extension a -> + let a = self#extension a in + Pcl_extension a | Pcl_open (a, b) -> let a = self#open_description a in - let b = self#class_expr b in Pcl_open (a, b) - method class_structure : class_structure -> class_structure= + let b = self#class_expr b in + Pcl_open (a, b) + + method class_structure : class_structure -> class_structure = fun { pcstr_self; pcstr_fields } -> let pcstr_self = self#pattern pcstr_self in let pcstr_fields = self#list self#class_field pcstr_fields in { pcstr_self; pcstr_fields } - method class_field : class_field -> class_field= + + method class_field : class_field -> class_field = fun { pcf_desc; pcf_loc; pcf_attributes } -> let pcf_desc = self#class_field_desc pcf_desc in let pcf_loc = self#location pcf_loc in let pcf_attributes = self#attributes pcf_attributes in { pcf_desc; pcf_loc; pcf_attributes } - method class_field_desc : class_field_desc -> class_field_desc= + + method class_field_desc : class_field_desc -> class_field_desc = fun x -> match x with | Pcf_inherit (a, b, c) -> @@ -1646,739 +1902,1087 @@ | Pcf_val a -> let a = (fun (a, b, c) -> - let a = self#loc self#label a in - let b = self#mutable_flag b in - let c = self#class_field_kind c in (a, b, c)) a in + let a = self#loc self#label a in + let b = self#mutable_flag b in + let c = self#class_field_kind c in + (a, b, c)) + a + in Pcf_val a | Pcf_method a -> let a = (fun (a, b, c) -> - let a = self#loc self#label a in - let b = self#private_flag b in - let c = self#class_field_kind c in (a, b, c)) a in + let a = self#loc self#label a in + let b = self#private_flag b in + let c = self#class_field_kind c in + (a, b, c)) + a + in Pcf_method a | Pcf_constraint a -> let a = (fun (a, b) -> - let a = self#core_type a in - let b = self#core_type b in (a, b)) a in + let a = self#core_type a in + let b = self#core_type b in + (a, b)) + a + in Pcf_constraint a - | Pcf_initializer a -> let a = self#expression a in Pcf_initializer a - | Pcf_attribute a -> let a = self#attribute a in Pcf_attribute a - | Pcf_extension a -> let a = self#extension a in Pcf_extension a - method class_field_kind : class_field_kind -> class_field_kind= + | Pcf_initializer a -> + let a = self#expression a in + Pcf_initializer a + | Pcf_attribute a -> + let a = self#attribute a in + Pcf_attribute a + | Pcf_extension a -> + let a = self#extension a in + Pcf_extension a + + method class_field_kind : class_field_kind -> class_field_kind = fun x -> match x with - | Cfk_virtual a -> let a = self#core_type a in Cfk_virtual a + | Cfk_virtual a -> + let a = self#core_type a in + Cfk_virtual a | Cfk_concrete (a, b) -> let a = self#override_flag a in - let b = self#expression b in Cfk_concrete (a, b) - method class_declaration : class_declaration -> class_declaration= + let b = self#expression b in + Cfk_concrete (a, b) + + method class_declaration : class_declaration -> class_declaration = self#class_infos self#class_expr - method module_type : module_type -> module_type= + + method module_type : module_type -> module_type = fun { pmty_desc; pmty_loc; pmty_attributes } -> let pmty_desc = self#module_type_desc pmty_desc in let pmty_loc = self#location pmty_loc in let pmty_attributes = self#attributes pmty_attributes in { pmty_desc; pmty_loc; pmty_attributes } - method module_type_desc : module_type_desc -> module_type_desc= + + method module_type_desc : module_type_desc -> module_type_desc = fun x -> match x with - | Pmty_ident a -> let a = self#longident_loc a in Pmty_ident a - | Pmty_signature a -> let a = self#signature a in Pmty_signature a + | Pmty_ident a -> + let a = self#longident_loc a in + Pmty_ident a + | Pmty_signature a -> + let a = self#signature a in + Pmty_signature a | Pmty_functor (a, b) -> let a = self#functor_parameter a in - let b = self#module_type b in Pmty_functor (a, b) + let b = self#module_type b in + Pmty_functor (a, b) | Pmty_with (a, b) -> let a = self#module_type a in - let b = self#list self#with_constraint b in Pmty_with (a, b) - | Pmty_typeof a -> let a = self#module_expr a in Pmty_typeof a - | Pmty_extension a -> let a = self#extension a in Pmty_extension a - | Pmty_alias a -> let a = self#longident_loc a in Pmty_alias a - method functor_parameter : functor_parameter -> functor_parameter= + let b = self#list self#with_constraint b in + Pmty_with (a, b) + | Pmty_typeof a -> + let a = self#module_expr a in + Pmty_typeof a + | Pmty_extension a -> + let a = self#extension a in + Pmty_extension a + | Pmty_alias a -> + let a = self#longident_loc a in + Pmty_alias a + + method functor_parameter : functor_parameter -> functor_parameter = fun x -> match x with | Unit -> Unit | Named (a, b) -> let a = self#loc (self#option self#string) a in - let b = self#module_type b in Named (a, b) - method signature : signature -> signature= self#list self#signature_item - method signature_item : signature_item -> signature_item= + let b = self#module_type b in + Named (a, b) + + method signature : signature -> signature = self#list self#signature_item + + method signature_item : signature_item -> signature_item = fun { psig_desc; psig_loc } -> let psig_desc = self#signature_item_desc psig_desc in - let psig_loc = self#location psig_loc in { psig_desc; psig_loc } - method signature_item_desc : signature_item_desc -> signature_item_desc= + let psig_loc = self#location psig_loc in + { psig_desc; psig_loc } + + method signature_item_desc : signature_item_desc -> signature_item_desc = fun x -> match x with - | Psig_value a -> let a = self#value_description a in Psig_value a + | Psig_value a -> + let a = self#value_description a in + Psig_value a | Psig_type (a, b) -> let a = self#rec_flag a in - let b = self#list self#type_declaration b in Psig_type (a, b) + let b = self#list self#type_declaration b in + Psig_type (a, b) | Psig_typesubst a -> - let a = self#list self#type_declaration a in Psig_typesubst a - | Psig_typext a -> let a = self#type_extension a in Psig_typext a + let a = self#list self#type_declaration a in + Psig_typesubst a + | Psig_typext a -> + let a = self#type_extension a in + Psig_typext a | Psig_exception a -> - let a = self#type_exception a in Psig_exception a - | Psig_module a -> let a = self#module_declaration a in Psig_module a + let a = self#type_exception a in + Psig_exception a + | Psig_module a -> + let a = self#module_declaration a in + Psig_module a | Psig_modsubst a -> - let a = self#module_substitution a in Psig_modsubst a + let a = self#module_substitution a in + Psig_modsubst a | Psig_recmodule a -> - let a = self#list self#module_declaration a in Psig_recmodule a + let a = self#list self#module_declaration a in + Psig_recmodule a | Psig_modtype a -> - let a = self#module_type_declaration a in Psig_modtype a - | Psig_open a -> let a = self#open_description a in Psig_open a + let a = self#module_type_declaration a in + Psig_modtype a + | Psig_open a -> + let a = self#open_description a in + Psig_open a | Psig_include a -> - let a = self#include_description a in Psig_include a + let a = self#include_description a in + Psig_include a | Psig_class a -> - let a = self#list self#class_description a in Psig_class a + let a = self#list self#class_description a in + Psig_class a | Psig_class_type a -> let a = self#list self#class_type_declaration a in Psig_class_type a - | Psig_attribute a -> let a = self#attribute a in Psig_attribute a + | Psig_attribute a -> + let a = self#attribute a in + Psig_attribute a | Psig_extension (a, b) -> let a = self#extension a in - let b = self#attributes b in Psig_extension (a, b) - method module_declaration : module_declaration -> module_declaration= + let b = self#attributes b in + Psig_extension (a, b) + + method module_declaration : module_declaration -> module_declaration = fun { pmd_name; pmd_type; pmd_attributes; pmd_loc } -> let pmd_name = self#loc (self#option self#string) pmd_name in let pmd_type = self#module_type pmd_type in let pmd_attributes = self#attributes pmd_attributes in let pmd_loc = self#location pmd_loc in { pmd_name; pmd_type; pmd_attributes; pmd_loc } - method module_substitution : module_substitution -> module_substitution= + + method module_substitution : module_substitution -> module_substitution = fun { pms_name; pms_manifest; pms_attributes; pms_loc } -> let pms_name = self#loc self#string pms_name in let pms_manifest = self#longident_loc pms_manifest in let pms_attributes = self#attributes pms_attributes in let pms_loc = self#location pms_loc in { pms_name; pms_manifest; pms_attributes; pms_loc } - method module_type_declaration : - module_type_declaration -> module_type_declaration= + + method module_type_declaration + : module_type_declaration -> module_type_declaration = fun { pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc } -> let pmtd_name = self#loc self#string pmtd_name in let pmtd_type = self#option self#module_type pmtd_type in let pmtd_attributes = self#attributes pmtd_attributes in let pmtd_loc = self#location pmtd_loc in { pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc } - method open_infos : 'a . ('a -> 'a) -> 'a open_infos -> 'a open_infos= - fun _a -> - fun { popen_expr; popen_override; popen_loc; popen_attributes } -> - let popen_expr = _a popen_expr in - let popen_override = self#override_flag popen_override in - let popen_loc = self#location popen_loc in - let popen_attributes = self#attributes popen_attributes in - { popen_expr; popen_override; popen_loc; popen_attributes } - method open_description : open_description -> open_description= + + method open_infos : 'a. ('a -> 'a) -> 'a open_infos -> 'a open_infos = + fun _a { popen_expr; popen_override; popen_loc; popen_attributes } -> + let popen_expr = _a popen_expr in + let popen_override = self#override_flag popen_override in + let popen_loc = self#location popen_loc in + let popen_attributes = self#attributes popen_attributes in + { popen_expr; popen_override; popen_loc; popen_attributes } + + method open_description : open_description -> open_description = self#open_infos self#longident_loc - method open_declaration : open_declaration -> open_declaration= + + method open_declaration : open_declaration -> open_declaration = self#open_infos self#module_expr - method include_infos : - 'a . ('a -> 'a) -> 'a include_infos -> 'a include_infos= - fun _a -> - fun { pincl_mod; pincl_loc; pincl_attributes } -> - let pincl_mod = _a pincl_mod in - let pincl_loc = self#location pincl_loc in - let pincl_attributes = self#attributes pincl_attributes in - { pincl_mod; pincl_loc; pincl_attributes } - method include_description : include_description -> include_description= + + method include_infos + : 'a. ('a -> 'a) -> 'a include_infos -> 'a include_infos = + fun _a { pincl_mod; pincl_loc; pincl_attributes } -> + let pincl_mod = _a pincl_mod in + let pincl_loc = self#location pincl_loc in + let pincl_attributes = self#attributes pincl_attributes in + { pincl_mod; pincl_loc; pincl_attributes } + + method include_description : include_description -> include_description = self#include_infos self#module_type - method include_declaration : include_declaration -> include_declaration= + + method include_declaration : include_declaration -> include_declaration = self#include_infos self#module_expr - method with_constraint : with_constraint -> with_constraint= + + method with_constraint : with_constraint -> with_constraint = fun x -> match x with | Pwith_type (a, b) -> let a = self#longident_loc a in - let b = self#type_declaration b in Pwith_type (a, b) + let b = self#type_declaration b in + Pwith_type (a, b) | Pwith_module (a, b) -> let a = self#longident_loc a in - let b = self#longident_loc b in Pwith_module (a, b) + let b = self#longident_loc b in + Pwith_module (a, b) | Pwith_typesubst (a, b) -> let a = self#longident_loc a in - let b = self#type_declaration b in Pwith_typesubst (a, b) + let b = self#type_declaration b in + Pwith_typesubst (a, b) | Pwith_modsubst (a, b) -> let a = self#longident_loc a in - let b = self#longident_loc b in Pwith_modsubst (a, b) - method module_expr : module_expr -> module_expr= + let b = self#longident_loc b in + Pwith_modsubst (a, b) + + method module_expr : module_expr -> module_expr = fun { pmod_desc; pmod_loc; pmod_attributes } -> let pmod_desc = self#module_expr_desc pmod_desc in let pmod_loc = self#location pmod_loc in let pmod_attributes = self#attributes pmod_attributes in { pmod_desc; pmod_loc; pmod_attributes } - method module_expr_desc : module_expr_desc -> module_expr_desc= + + method module_expr_desc : module_expr_desc -> module_expr_desc = fun x -> match x with - | Pmod_ident a -> let a = self#longident_loc a in Pmod_ident a - | Pmod_structure a -> let a = self#structure a in Pmod_structure a + | Pmod_ident a -> + let a = self#longident_loc a in + Pmod_ident a + | Pmod_structure a -> + let a = self#structure a in + Pmod_structure a | Pmod_functor (a, b) -> let a = self#functor_parameter a in - let b = self#module_expr b in Pmod_functor (a, b) + let b = self#module_expr b in + Pmod_functor (a, b) | Pmod_apply (a, b) -> let a = self#module_expr a in - let b = self#module_expr b in Pmod_apply (a, b) + let b = self#module_expr b in + Pmod_apply (a, b) | Pmod_constraint (a, b) -> let a = self#module_expr a in - let b = self#module_type b in Pmod_constraint (a, b) - | Pmod_unpack a -> let a = self#expression a in Pmod_unpack a - | Pmod_extension a -> let a = self#extension a in Pmod_extension a - method structure : structure -> structure= self#list self#structure_item - method structure_item : structure_item -> structure_item= + let b = self#module_type b in + Pmod_constraint (a, b) + | Pmod_unpack a -> + let a = self#expression a in + Pmod_unpack a + | Pmod_extension a -> + let a = self#extension a in + Pmod_extension a + + method structure : structure -> structure = self#list self#structure_item + + method structure_item : structure_item -> structure_item = fun { pstr_desc; pstr_loc } -> let pstr_desc = self#structure_item_desc pstr_desc in - let pstr_loc = self#location pstr_loc in { pstr_desc; pstr_loc } - method structure_item_desc : structure_item_desc -> structure_item_desc= + let pstr_loc = self#location pstr_loc in + { pstr_desc; pstr_loc } + + method structure_item_desc : structure_item_desc -> structure_item_desc = fun x -> match x with | Pstr_eval (a, b) -> let a = self#expression a in - let b = self#attributes b in Pstr_eval (a, b) + let b = self#attributes b in + Pstr_eval (a, b) | Pstr_value (a, b) -> let a = self#rec_flag a in - let b = self#list self#value_binding b in Pstr_value (a, b) + let b = self#list self#value_binding b in + Pstr_value (a, b) | Pstr_primitive a -> - let a = self#value_description a in Pstr_primitive a + let a = self#value_description a in + Pstr_primitive a | Pstr_type (a, b) -> let a = self#rec_flag a in - let b = self#list self#type_declaration b in Pstr_type (a, b) - | Pstr_typext a -> let a = self#type_extension a in Pstr_typext a + let b = self#list self#type_declaration b in + Pstr_type (a, b) + | Pstr_typext a -> + let a = self#type_extension a in + Pstr_typext a | Pstr_exception a -> - let a = self#type_exception a in Pstr_exception a - | Pstr_module a -> let a = self#module_binding a in Pstr_module a + let a = self#type_exception a in + Pstr_exception a + | Pstr_module a -> + let a = self#module_binding a in + Pstr_module a | Pstr_recmodule a -> - let a = self#list self#module_binding a in Pstr_recmodule a + let a = self#list self#module_binding a in + Pstr_recmodule a | Pstr_modtype a -> - let a = self#module_type_declaration a in Pstr_modtype a - | Pstr_open a -> let a = self#open_declaration a in Pstr_open a + let a = self#module_type_declaration a in + Pstr_modtype a + | Pstr_open a -> + let a = self#open_declaration a in + Pstr_open a | Pstr_class a -> - let a = self#list self#class_declaration a in Pstr_class a + let a = self#list self#class_declaration a in + Pstr_class a | Pstr_class_type a -> let a = self#list self#class_type_declaration a in Pstr_class_type a | Pstr_include a -> - let a = self#include_declaration a in Pstr_include a - | Pstr_attribute a -> let a = self#attribute a in Pstr_attribute a + let a = self#include_declaration a in + Pstr_include a + | Pstr_attribute a -> + let a = self#attribute a in + Pstr_attribute a | Pstr_extension (a, b) -> let a = self#extension a in - let b = self#attributes b in Pstr_extension (a, b) - method value_binding : value_binding -> value_binding= + let b = self#attributes b in + Pstr_extension (a, b) + + method value_binding : value_binding -> value_binding = fun { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } -> let pvb_pat = self#pattern pvb_pat in let pvb_expr = self#expression pvb_expr in let pvb_attributes = self#attributes pvb_attributes in let pvb_loc = self#location pvb_loc in { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } - method module_binding : module_binding -> module_binding= + + method module_binding : module_binding -> module_binding = fun { pmb_name; pmb_expr; pmb_attributes; pmb_loc } -> let pmb_name = self#loc (self#option self#string) pmb_name in let pmb_expr = self#module_expr pmb_expr in let pmb_attributes = self#attributes pmb_attributes in let pmb_loc = self#location pmb_loc in { pmb_name; pmb_expr; pmb_attributes; pmb_loc } - method toplevel_phrase : toplevel_phrase -> toplevel_phrase= + + method toplevel_phrase : toplevel_phrase -> toplevel_phrase = fun x -> match x with - | Ptop_def a -> let a = self#structure a in Ptop_def a - | Ptop_dir a -> let a = self#toplevel_directive a in Ptop_dir a - method toplevel_directive : toplevel_directive -> toplevel_directive= + | Ptop_def a -> + let a = self#structure a in + Ptop_def a + | Ptop_dir a -> + let a = self#toplevel_directive a in + Ptop_dir a + + method toplevel_directive : toplevel_directive -> toplevel_directive = fun { pdir_name; pdir_arg; pdir_loc } -> let pdir_name = self#loc self#string pdir_name in let pdir_arg = self#option self#directive_argument pdir_arg in let pdir_loc = self#location pdir_loc in { pdir_name; pdir_arg; pdir_loc } - method directive_argument : directive_argument -> directive_argument= + + method directive_argument : directive_argument -> directive_argument = fun { pdira_desc; pdira_loc } -> let pdira_desc = self#directive_argument_desc pdira_desc in - let pdira_loc = self#location pdira_loc in { pdira_desc; pdira_loc } - method directive_argument_desc : - directive_argument_desc -> directive_argument_desc= + let pdira_loc = self#location pdira_loc in + { pdira_desc; pdira_loc } + + method directive_argument_desc + : directive_argument_desc -> directive_argument_desc = fun x -> match x with - | Pdir_string a -> let a = self#string a in Pdir_string a + | Pdir_string a -> + let a = self#string a in + Pdir_string a | Pdir_int (a, b) -> let a = self#string a in - let b = self#option self#char b in Pdir_int (a, b) - | Pdir_ident a -> let a = self#longident a in Pdir_ident a - | Pdir_bool a -> let a = self#bool a in Pdir_bool a + let b = self#option self#char b in + Pdir_int (a, b) + | Pdir_ident a -> + let a = self#longident a in + Pdir_ident a + | Pdir_bool a -> + let a = self#bool a in + Pdir_bool a + + method cases : cases -> cases = self#list self#case end + class virtual iter = object (self) - method virtual bool : bool -> unit - method virtual char : char -> unit - method virtual int : int -> unit - method virtual list : 'a . ('a -> unit) -> 'a list -> unit - method virtual option : 'a . ('a -> unit) -> 'a option -> unit - method virtual string : string -> unit - method position : position -> unit= + method virtual bool : bool -> unit + + method virtual char : char -> unit + + method virtual int : int -> unit + + method virtual list : 'a. ('a -> unit) -> 'a list -> unit + + method virtual option : 'a. ('a -> unit) -> 'a option -> unit + + method virtual string : string -> unit + + method position : position -> unit = fun { pos_fname; pos_lnum; pos_bol; pos_cnum } -> self#string pos_fname; self#int pos_lnum; self#int pos_bol; self#int pos_cnum - method location : location -> unit= + + method location : location -> unit = fun { loc_start; loc_end; loc_ghost } -> - self#position loc_start; self#position loc_end; self#bool loc_ghost - method location_stack : location_stack -> unit= self#list self#location - method loc : 'a . ('a -> unit) -> 'a loc -> unit= - fun _a -> fun { txt; loc } -> _a txt; self#location loc - method longident : longident -> unit= + self#position loc_start; + self#position loc_end; + self#bool loc_ghost + + method location_stack : location_stack -> unit = self#list self#location + + method loc : 'a. ('a -> unit) -> 'a loc -> unit = + fun _a { txt; loc } -> + _a txt; + self#location loc + + method longident : longident -> unit = fun x -> match x with | Lident a -> self#string a - | Ldot (a, b) -> (self#longident a; self#string b) - | Lapply (a, b) -> (self#longident a; self#longident b) - method longident_loc : longident_loc -> unit= self#loc self#longident - method rec_flag : rec_flag -> unit= fun _ -> () - method direction_flag : direction_flag -> unit= fun _ -> () - method private_flag : private_flag -> unit= fun _ -> () - method mutable_flag : mutable_flag -> unit= fun _ -> () - method virtual_flag : virtual_flag -> unit= fun _ -> () - method override_flag : override_flag -> unit= fun _ -> () - method closed_flag : closed_flag -> unit= fun _ -> () - method label : label -> unit= self#string - method arg_label : arg_label -> unit= + | Ldot (a, b) -> + self#longident a; + self#string b + | Lapply (a, b) -> + self#longident a; + self#longident b + + method longident_loc : longident_loc -> unit = self#loc self#longident + + method rec_flag : rec_flag -> unit = fun _ -> () + + method direction_flag : direction_flag -> unit = fun _ -> () + + method private_flag : private_flag -> unit = fun _ -> () + + method mutable_flag : mutable_flag -> unit = fun _ -> () + + method virtual_flag : virtual_flag -> unit = fun _ -> () + + method override_flag : override_flag -> unit = fun _ -> () + + method closed_flag : closed_flag -> unit = fun _ -> () + + method label : label -> unit = self#string + + method arg_label : arg_label -> unit = fun x -> match x with | Nolabel -> () | Labelled a -> self#string a | Optional a -> self#string a - method variance : variance -> unit= fun _ -> () - method constant : constant -> unit= + + method variance : variance -> unit = fun _ -> () + + method injectivity : injectivity -> unit = fun _ -> () + + method constant : constant -> unit = fun x -> match x with - | Pconst_integer (a, b) -> (self#string a; self#option self#char b) + | Pconst_integer (a, b) -> + self#string a; + self#option self#char b | Pconst_char a -> self#char a - | Pconst_string (a, b) -> (self#string a; self#option self#string b) - | Pconst_float (a, b) -> (self#string a; self#option self#char b) - method attribute : attribute -> unit= + | Pconst_string (a, b, c) -> + self#string a; + self#location b; + self#option self#string c + | Pconst_float (a, b) -> + self#string a; + self#option self#char b + + method attribute : attribute -> unit = fun { attr_name; attr_payload; attr_loc } -> self#loc self#string attr_name; self#payload attr_payload; self#location attr_loc - method extension : extension -> unit= - fun (a, b) -> self#loc self#string a; self#payload b - method attributes : attributes -> unit= self#list self#attribute - method payload : payload -> unit= + + method extension : extension -> unit = + fun (a, b) -> + self#loc self#string a; + self#payload b + + method attributes : attributes -> unit = self#list self#attribute + + method payload : payload -> unit = fun x -> match x with | PStr a -> self#structure a | PSig a -> self#signature a | PTyp a -> self#core_type a - | PPat (a, b) -> (self#pattern a; self#option self#expression b) - method core_type : core_type -> unit= + | PPat (a, b) -> + self#pattern a; + self#option self#expression b + + method core_type : core_type -> unit = fun { ptyp_desc; ptyp_loc; ptyp_loc_stack; ptyp_attributes } -> self#core_type_desc ptyp_desc; self#location ptyp_loc; self#location_stack ptyp_loc_stack; self#attributes ptyp_attributes - method core_type_desc : core_type_desc -> unit= + + method core_type_desc : core_type_desc -> unit = fun x -> match x with | Ptyp_any -> () | Ptyp_var a -> self#string a | Ptyp_arrow (a, b, c) -> - (self#arg_label a; self#core_type b; self#core_type c) + self#arg_label a; + self#core_type b; + self#core_type c | Ptyp_tuple a -> self#list self#core_type a | Ptyp_constr (a, b) -> - (self#longident_loc a; self#list self#core_type b) + self#longident_loc a; + self#list self#core_type b | Ptyp_object (a, b) -> - (self#list self#object_field a; self#closed_flag b) + self#list self#object_field a; + self#closed_flag b | Ptyp_class (a, b) -> - (self#longident_loc a; self#list self#core_type b) - | Ptyp_alias (a, b) -> (self#core_type a; self#string b) + self#longident_loc a; + self#list self#core_type b + | Ptyp_alias (a, b) -> + self#core_type a; + self#string b | Ptyp_variant (a, b, c) -> - (self#list self#row_field a; - self#closed_flag b; - self#option (self#list self#label) c) + self#list self#row_field a; + self#closed_flag b; + self#option (self#list self#label) c | Ptyp_poly (a, b) -> - (self#list (self#loc self#string) a; self#core_type b) + self#list (self#loc self#string) a; + self#core_type b | Ptyp_package a -> self#package_type a | Ptyp_extension a -> self#extension a - method package_type : package_type -> unit= + + method package_type : package_type -> unit = fun (a, b) -> self#longident_loc a; - self#list (fun (a, b) -> self#longident_loc a; self#core_type b) b - method row_field : row_field -> unit= + self#list + (fun (a, b) -> + self#longident_loc a; + self#core_type b) + b + + method row_field : row_field -> unit = fun { prf_desc; prf_loc; prf_attributes } -> self#row_field_desc prf_desc; self#location prf_loc; self#attributes prf_attributes - method row_field_desc : row_field_desc -> unit= + + method row_field_desc : row_field_desc -> unit = fun x -> match x with | Rtag (a, b, c) -> - (self#loc self#label a; self#bool b; self#list self#core_type c) + self#loc self#label a; + self#bool b; + self#list self#core_type c | Rinherit a -> self#core_type a - method object_field : object_field -> unit= + + method object_field : object_field -> unit = fun { pof_desc; pof_loc; pof_attributes } -> self#object_field_desc pof_desc; self#location pof_loc; self#attributes pof_attributes - method object_field_desc : object_field_desc -> unit= + + method object_field_desc : object_field_desc -> unit = fun x -> match x with - | Otag (a, b) -> (self#loc self#label a; self#core_type b) + | Otag (a, b) -> + self#loc self#label a; + self#core_type b | Oinherit a -> self#core_type a - method pattern : pattern -> unit= + + method pattern : pattern -> unit = fun { ppat_desc; ppat_loc; ppat_loc_stack; ppat_attributes } -> self#pattern_desc ppat_desc; self#location ppat_loc; self#location_stack ppat_loc_stack; self#attributes ppat_attributes - method pattern_desc : pattern_desc -> unit= + + method pattern_desc : pattern_desc -> unit = fun x -> match x with | Ppat_any -> () | Ppat_var a -> self#loc self#string a - | Ppat_alias (a, b) -> (self#pattern a; self#loc self#string b) + | Ppat_alias (a, b) -> + self#pattern a; + self#loc self#string b | Ppat_constant a -> self#constant a - | Ppat_interval (a, b) -> (self#constant a; self#constant b) + | Ppat_interval (a, b) -> + self#constant a; + self#constant b | Ppat_tuple a -> self#list self#pattern a | Ppat_construct (a, b) -> - (self#longident_loc a; self#option self#pattern b) - | Ppat_variant (a, b) -> (self#label a; self#option self#pattern b) + self#longident_loc a; + self#option self#pattern b + | Ppat_variant (a, b) -> + self#label a; + self#option self#pattern b | Ppat_record (a, b) -> - (self#list (fun (a, b) -> self#longident_loc a; self#pattern b) a; - self#closed_flag b) + self#list + (fun (a, b) -> + self#longident_loc a; + self#pattern b) + a; + self#closed_flag b | Ppat_array a -> self#list self#pattern a - | Ppat_or (a, b) -> (self#pattern a; self#pattern b) - | Ppat_constraint (a, b) -> (self#pattern a; self#core_type b) + | Ppat_or (a, b) -> + self#pattern a; + self#pattern b + | Ppat_constraint (a, b) -> + self#pattern a; + self#core_type b | Ppat_type a -> self#longident_loc a | Ppat_lazy a -> self#pattern a | Ppat_unpack a -> self#loc (self#option self#string) a | Ppat_exception a -> self#pattern a | Ppat_extension a -> self#extension a - | Ppat_open (a, b) -> (self#longident_loc a; self#pattern b) - method expression : expression -> unit= + | Ppat_open (a, b) -> + self#longident_loc a; + self#pattern b + + method expression : expression -> unit = fun { pexp_desc; pexp_loc; pexp_loc_stack; pexp_attributes } -> self#expression_desc pexp_desc; self#location pexp_loc; self#location_stack pexp_loc_stack; self#attributes pexp_attributes - method expression_desc : expression_desc -> unit= + + method expression_desc : expression_desc -> unit = fun x -> match x with | Pexp_ident a -> self#longident_loc a | Pexp_constant a -> self#constant a | Pexp_let (a, b, c) -> - (self#rec_flag a; - self#list self#value_binding b; - self#expression c) - | Pexp_function a -> self#list self#case a + self#rec_flag a; + self#list self#value_binding b; + self#expression c + | Pexp_function a -> self#cases a | Pexp_fun (a, b, c, d) -> - (self#arg_label a; - self#option self#expression b; - self#pattern c; - self#expression d) + self#arg_label a; + self#option self#expression b; + self#pattern c; + self#expression d | Pexp_apply (a, b) -> - (self#expression a; - self#list (fun (a, b) -> self#arg_label a; self#expression b) b) - | Pexp_match (a, b) -> (self#expression a; self#list self#case b) - | Pexp_try (a, b) -> (self#expression a; self#list self#case b) + self#expression a; + self#list + (fun (a, b) -> + self#arg_label a; + self#expression b) + b + | Pexp_match (a, b) -> + self#expression a; + self#cases b + | Pexp_try (a, b) -> + self#expression a; + self#cases b | Pexp_tuple a -> self#list self#expression a | Pexp_construct (a, b) -> - (self#longident_loc a; self#option self#expression b) + self#longident_loc a; + self#option self#expression b | Pexp_variant (a, b) -> - (self#label a; self#option self#expression b) + self#label a; + self#option self#expression b | Pexp_record (a, b) -> - (self#list - (fun (a, b) -> self#longident_loc a; self#expression b) a; - self#option self#expression b) - | Pexp_field (a, b) -> (self#expression a; self#longident_loc b) + self#list + (fun (a, b) -> + self#longident_loc a; + self#expression b) + a; + self#option self#expression b + | Pexp_field (a, b) -> + self#expression a; + self#longident_loc b | Pexp_setfield (a, b, c) -> - (self#expression a; self#longident_loc b; self#expression c) + self#expression a; + self#longident_loc b; + self#expression c | Pexp_array a -> self#list self#expression a | Pexp_ifthenelse (a, b, c) -> - (self#expression a; - self#expression b; - self#option self#expression c) - | Pexp_sequence (a, b) -> (self#expression a; self#expression b) - | Pexp_while (a, b) -> (self#expression a; self#expression b) + self#expression a; + self#expression b; + self#option self#expression c + | Pexp_sequence (a, b) -> + self#expression a; + self#expression b + | Pexp_while (a, b) -> + self#expression a; + self#expression b | Pexp_for (a, b, c, d, e) -> - (self#pattern a; - self#expression b; - self#expression c; - self#direction_flag d; - self#expression e) - | Pexp_constraint (a, b) -> (self#expression a; self#core_type b) + self#pattern a; + self#expression b; + self#expression c; + self#direction_flag d; + self#expression e + | Pexp_constraint (a, b) -> + self#expression a; + self#core_type b | Pexp_coerce (a, b, c) -> - (self#expression a; - self#option self#core_type b; - self#core_type c) - | Pexp_send (a, b) -> (self#expression a; self#loc self#label b) + self#expression a; + self#option self#core_type b; + self#core_type c + | Pexp_send (a, b) -> + self#expression a; + self#loc self#label b | Pexp_new a -> self#longident_loc a | Pexp_setinstvar (a, b) -> - (self#loc self#label a; self#expression b) + self#loc self#label a; + self#expression b | Pexp_override a -> self#list - (fun (a, b) -> self#loc self#label a; self#expression b) a + (fun (a, b) -> + self#loc self#label a; + self#expression b) + a | Pexp_letmodule (a, b, c) -> - (self#loc (self#option self#string) a; - self#module_expr b; - self#expression c) + self#loc (self#option self#string) a; + self#module_expr b; + self#expression c | Pexp_letexception (a, b) -> - (self#extension_constructor a; self#expression b) + self#extension_constructor a; + self#expression b | Pexp_assert a -> self#expression a | Pexp_lazy a -> self#expression a | Pexp_poly (a, b) -> - (self#expression a; self#option self#core_type b) + self#expression a; + self#option self#core_type b | Pexp_object a -> self#class_structure a - | Pexp_newtype (a, b) -> (self#loc self#string a; self#expression b) + | Pexp_newtype (a, b) -> + self#loc self#string a; + self#expression b | Pexp_pack a -> self#module_expr a - | Pexp_open (a, b) -> (self#open_declaration a; self#expression b) + | Pexp_open (a, b) -> + self#open_declaration a; + self#expression b | Pexp_letop a -> self#letop a | Pexp_extension a -> self#extension a | Pexp_unreachable -> () - method case : case -> unit= + + method case : case -> unit = fun { pc_lhs; pc_guard; pc_rhs } -> self#pattern pc_lhs; self#option self#expression pc_guard; self#expression pc_rhs - method letop : letop -> unit= + + method letop : letop -> unit = fun { let_; ands; body } -> self#binding_op let_; self#list self#binding_op ands; self#expression body - method binding_op : binding_op -> unit= + + method binding_op : binding_op -> unit = fun { pbop_op; pbop_pat; pbop_exp; pbop_loc } -> self#loc self#string pbop_op; self#pattern pbop_pat; self#expression pbop_exp; self#location pbop_loc - method value_description : value_description -> unit= + + method value_description : value_description -> unit = fun { pval_name; pval_type; pval_prim; pval_attributes; pval_loc } -> self#loc self#string pval_name; self#core_type pval_type; self#list self#string pval_prim; self#attributes pval_attributes; self#location pval_loc - method type_declaration : type_declaration -> unit= - fun - { ptype_name; ptype_params; ptype_cstrs; ptype_kind; ptype_private; - ptype_manifest; ptype_attributes; ptype_loc } - -> + + method type_declaration : type_declaration -> unit = + fun { + ptype_name; + ptype_params; + ptype_cstrs; + ptype_kind; + ptype_private; + ptype_manifest; + ptype_attributes; + ptype_loc; + } -> self#loc self#string ptype_name; - self#list (fun (a, b) -> self#core_type a; self#variance b) + self#list + (fun (a, b) -> + self#core_type a; + (fun (a, b) -> + self#variance a; + self#injectivity b) + b) ptype_params; self#list (fun (a, b, c) -> - self#core_type a; self#core_type b; self#location c) ptype_cstrs; + self#core_type a; + self#core_type b; + self#location c) + ptype_cstrs; self#type_kind ptype_kind; self#private_flag ptype_private; self#option self#core_type ptype_manifest; self#attributes ptype_attributes; self#location ptype_loc - method type_kind : type_kind -> unit= + + method type_kind : type_kind -> unit = fun x -> match x with | Ptype_abstract -> () | Ptype_variant a -> self#list self#constructor_declaration a | Ptype_record a -> self#list self#label_declaration a | Ptype_open -> () - method label_declaration : label_declaration -> unit= + + method label_declaration : label_declaration -> unit = fun { pld_name; pld_mutable; pld_type; pld_loc; pld_attributes } -> self#loc self#string pld_name; self#mutable_flag pld_mutable; self#core_type pld_type; self#location pld_loc; self#attributes pld_attributes - method constructor_declaration : constructor_declaration -> unit= + + method constructor_declaration : constructor_declaration -> unit = fun { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } -> self#loc self#string pcd_name; self#constructor_arguments pcd_args; self#option self#core_type pcd_res; self#location pcd_loc; self#attributes pcd_attributes - method constructor_arguments : constructor_arguments -> unit= + + method constructor_arguments : constructor_arguments -> unit = fun x -> match x with | Pcstr_tuple a -> self#list self#core_type a | Pcstr_record a -> self#list self#label_declaration a - method type_extension : type_extension -> unit= - fun - { ptyext_path; ptyext_params; ptyext_constructors; ptyext_private; - ptyext_loc; ptyext_attributes } - -> + + method type_extension : type_extension -> unit = + fun { + ptyext_path; + ptyext_params; + ptyext_constructors; + ptyext_private; + ptyext_loc; + ptyext_attributes; + } -> self#longident_loc ptyext_path; - self#list (fun (a, b) -> self#core_type a; self#variance b) + self#list + (fun (a, b) -> + self#core_type a; + (fun (a, b) -> + self#variance a; + self#injectivity b) + b) ptyext_params; self#list self#extension_constructor ptyext_constructors; self#private_flag ptyext_private; self#location ptyext_loc; self#attributes ptyext_attributes - method extension_constructor : extension_constructor -> unit= + + method extension_constructor : extension_constructor -> unit = fun { pext_name; pext_kind; pext_loc; pext_attributes } -> self#loc self#string pext_name; self#extension_constructor_kind pext_kind; self#location pext_loc; self#attributes pext_attributes - method type_exception : type_exception -> unit= + + method type_exception : type_exception -> unit = fun { ptyexn_constructor; ptyexn_loc; ptyexn_attributes } -> self#extension_constructor ptyexn_constructor; self#location ptyexn_loc; self#attributes ptyexn_attributes - method extension_constructor_kind : extension_constructor_kind -> unit= + + method extension_constructor_kind : extension_constructor_kind -> unit = fun x -> match x with | Pext_decl (a, b) -> - (self#constructor_arguments a; self#option self#core_type b) + self#constructor_arguments a; + self#option self#core_type b | Pext_rebind a -> self#longident_loc a - method class_type : class_type -> unit= + + method class_type : class_type -> unit = fun { pcty_desc; pcty_loc; pcty_attributes } -> self#class_type_desc pcty_desc; self#location pcty_loc; self#attributes pcty_attributes - method class_type_desc : class_type_desc -> unit= + + method class_type_desc : class_type_desc -> unit = fun x -> match x with | Pcty_constr (a, b) -> - (self#longident_loc a; self#list self#core_type b) + self#longident_loc a; + self#list self#core_type b | Pcty_signature a -> self#class_signature a | Pcty_arrow (a, b, c) -> - (self#arg_label a; self#core_type b; self#class_type c) + self#arg_label a; + self#core_type b; + self#class_type c | Pcty_extension a -> self#extension a - | Pcty_open (a, b) -> (self#open_description a; self#class_type b) - method class_signature : class_signature -> unit= + | Pcty_open (a, b) -> + self#open_description a; + self#class_type b + + method class_signature : class_signature -> unit = fun { pcsig_self; pcsig_fields } -> self#core_type pcsig_self; self#list self#class_type_field pcsig_fields - method class_type_field : class_type_field -> unit= + + method class_type_field : class_type_field -> unit = fun { pctf_desc; pctf_loc; pctf_attributes } -> self#class_type_field_desc pctf_desc; self#location pctf_loc; self#attributes pctf_attributes - method class_type_field_desc : class_type_field_desc -> unit= + + method class_type_field_desc : class_type_field_desc -> unit = fun x -> match x with | Pctf_inherit a -> self#class_type a | Pctf_val a -> - ((fun (a, b, c, d) -> - self#loc self#label a; - self#mutable_flag b; - self#virtual_flag c; - self#core_type d)) a + (fun (a, b, c, d) -> + self#loc self#label a; + self#mutable_flag b; + self#virtual_flag c; + self#core_type d) + a | Pctf_method a -> - ((fun (a, b, c, d) -> - self#loc self#label a; - self#private_flag b; - self#virtual_flag c; - self#core_type d)) a + (fun (a, b, c, d) -> + self#loc self#label a; + self#private_flag b; + self#virtual_flag c; + self#core_type d) + a | Pctf_constraint a -> - ((fun (a, b) -> self#core_type a; self#core_type b)) a + (fun (a, b) -> + self#core_type a; + self#core_type b) + a | Pctf_attribute a -> self#attribute a | Pctf_extension a -> self#extension a - method class_infos : 'a . ('a -> unit) -> 'a class_infos -> unit= - fun _a -> - fun - { pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes - } - -> - self#virtual_flag pci_virt; - self#list (fun (a, b) -> self#core_type a; self#variance b) - pci_params; - self#loc self#string pci_name; - _a pci_expr; - self#location pci_loc; - self#attributes pci_attributes - method class_description : class_description -> unit= + + method class_infos : 'a. ('a -> unit) -> 'a class_infos -> unit = + fun _a + { pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes } -> + self#virtual_flag pci_virt; + self#list + (fun (a, b) -> + self#core_type a; + (fun (a, b) -> + self#variance a; + self#injectivity b) + b) + pci_params; + self#loc self#string pci_name; + _a pci_expr; + self#location pci_loc; + self#attributes pci_attributes + + method class_description : class_description -> unit = self#class_infos self#class_type - method class_type_declaration : class_type_declaration -> unit= + + method class_type_declaration : class_type_declaration -> unit = self#class_infos self#class_type - method class_expr : class_expr -> unit= + + method class_expr : class_expr -> unit = fun { pcl_desc; pcl_loc; pcl_attributes } -> self#class_expr_desc pcl_desc; self#location pcl_loc; self#attributes pcl_attributes - method class_expr_desc : class_expr_desc -> unit= + + method class_expr_desc : class_expr_desc -> unit = fun x -> match x with | Pcl_constr (a, b) -> - (self#longident_loc a; self#list self#core_type b) + self#longident_loc a; + self#list self#core_type b | Pcl_structure a -> self#class_structure a | Pcl_fun (a, b, c, d) -> - (self#arg_label a; - self#option self#expression b; - self#pattern c; - self#class_expr d) + self#arg_label a; + self#option self#expression b; + self#pattern c; + self#class_expr d | Pcl_apply (a, b) -> - (self#class_expr a; - self#list (fun (a, b) -> self#arg_label a; self#expression b) b) + self#class_expr a; + self#list + (fun (a, b) -> + self#arg_label a; + self#expression b) + b | Pcl_let (a, b, c) -> - (self#rec_flag a; - self#list self#value_binding b; - self#class_expr c) - | Pcl_constraint (a, b) -> (self#class_expr a; self#class_type b) + self#rec_flag a; + self#list self#value_binding b; + self#class_expr c + | Pcl_constraint (a, b) -> + self#class_expr a; + self#class_type b | Pcl_extension a -> self#extension a - | Pcl_open (a, b) -> (self#open_description a; self#class_expr b) - method class_structure : class_structure -> unit= + | Pcl_open (a, b) -> + self#open_description a; + self#class_expr b + + method class_structure : class_structure -> unit = fun { pcstr_self; pcstr_fields } -> - self#pattern pcstr_self; self#list self#class_field pcstr_fields - method class_field : class_field -> unit= + self#pattern pcstr_self; + self#list self#class_field pcstr_fields + + method class_field : class_field -> unit = fun { pcf_desc; pcf_loc; pcf_attributes } -> self#class_field_desc pcf_desc; self#location pcf_loc; self#attributes pcf_attributes - method class_field_desc : class_field_desc -> unit= + + method class_field_desc : class_field_desc -> unit = fun x -> match x with | Pcf_inherit (a, b, c) -> - (self#override_flag a; - self#class_expr b; - self#option (self#loc self#string) c) + self#override_flag a; + self#class_expr b; + self#option (self#loc self#string) c | Pcf_val a -> - ((fun (a, b, c) -> - self#loc self#label a; - self#mutable_flag b; - self#class_field_kind c)) a + (fun (a, b, c) -> + self#loc self#label a; + self#mutable_flag b; + self#class_field_kind c) + a | Pcf_method a -> - ((fun (a, b, c) -> - self#loc self#label a; - self#private_flag b; - self#class_field_kind c)) a + (fun (a, b, c) -> + self#loc self#label a; + self#private_flag b; + self#class_field_kind c) + a | Pcf_constraint a -> - ((fun (a, b) -> self#core_type a; self#core_type b)) a + (fun (a, b) -> + self#core_type a; + self#core_type b) + a | Pcf_initializer a -> self#expression a | Pcf_attribute a -> self#attribute a | Pcf_extension a -> self#extension a - method class_field_kind : class_field_kind -> unit= + + method class_field_kind : class_field_kind -> unit = fun x -> match x with | Cfk_virtual a -> self#core_type a - | Cfk_concrete (a, b) -> (self#override_flag a; self#expression b) - method class_declaration : class_declaration -> unit= + | Cfk_concrete (a, b) -> + self#override_flag a; + self#expression b + + method class_declaration : class_declaration -> unit = self#class_infos self#class_expr - method module_type : module_type -> unit= + + method module_type : module_type -> unit = fun { pmty_desc; pmty_loc; pmty_attributes } -> self#module_type_desc pmty_desc; self#location pmty_loc; self#attributes pmty_attributes - method module_type_desc : module_type_desc -> unit= + + method module_type_desc : module_type_desc -> unit = fun x -> match x with | Pmty_ident a -> self#longident_loc a | Pmty_signature a -> self#signature a | Pmty_functor (a, b) -> - (self#functor_parameter a; self#module_type b) + self#functor_parameter a; + self#module_type b | Pmty_with (a, b) -> - (self#module_type a; self#list self#with_constraint b) + self#module_type a; + self#list self#with_constraint b | Pmty_typeof a -> self#module_expr a | Pmty_extension a -> self#extension a | Pmty_alias a -> self#longident_loc a - method functor_parameter : functor_parameter -> unit= + + method functor_parameter : functor_parameter -> unit = fun x -> match x with | Unit -> () | Named (a, b) -> - (self#loc (self#option self#string) a; self#module_type b) - method signature : signature -> unit= self#list self#signature_item - method signature_item : signature_item -> unit= - fun { psig_desc; psig_loc } -> - self#signature_item_desc psig_desc; self#location psig_loc - method signature_item_desc : signature_item_desc -> unit= + self#loc (self#option self#string) a; + self#module_type b + + method signature : signature -> unit = self#list self#signature_item + + method signature_item : signature_item -> unit = + fun { psig_desc; psig_loc } -> + self#signature_item_desc psig_desc; + self#location psig_loc + + method signature_item_desc : signature_item_desc -> unit = fun x -> match x with | Psig_value a -> self#value_description a | Psig_type (a, b) -> - (self#rec_flag a; self#list self#type_declaration b) + self#rec_flag a; + self#list self#type_declaration b | Psig_typesubst a -> self#list self#type_declaration a | Psig_typext a -> self#type_extension a | Psig_exception a -> self#type_exception a @@ -2391,85 +2995,115 @@ | Psig_class a -> self#list self#class_description a | Psig_class_type a -> self#list self#class_type_declaration a | Psig_attribute a -> self#attribute a - | Psig_extension (a, b) -> (self#extension a; self#attributes b) - method module_declaration : module_declaration -> unit= + | Psig_extension (a, b) -> + self#extension a; + self#attributes b + + method module_declaration : module_declaration -> unit = fun { pmd_name; pmd_type; pmd_attributes; pmd_loc } -> self#loc (self#option self#string) pmd_name; self#module_type pmd_type; self#attributes pmd_attributes; self#location pmd_loc - method module_substitution : module_substitution -> unit= + + method module_substitution : module_substitution -> unit = fun { pms_name; pms_manifest; pms_attributes; pms_loc } -> self#loc self#string pms_name; self#longident_loc pms_manifest; self#attributes pms_attributes; self#location pms_loc - method module_type_declaration : module_type_declaration -> unit= + + method module_type_declaration : module_type_declaration -> unit = fun { pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc } -> self#loc self#string pmtd_name; self#option self#module_type pmtd_type; self#attributes pmtd_attributes; self#location pmtd_loc - method open_infos : 'a . ('a -> unit) -> 'a open_infos -> unit= - fun _a -> - fun { popen_expr; popen_override; popen_loc; popen_attributes } -> - _a popen_expr; - self#override_flag popen_override; - self#location popen_loc; - self#attributes popen_attributes - method open_description : open_description -> unit= + + method open_infos : 'a. ('a -> unit) -> 'a open_infos -> unit = + fun _a { popen_expr; popen_override; popen_loc; popen_attributes } -> + _a popen_expr; + self#override_flag popen_override; + self#location popen_loc; + self#attributes popen_attributes + + method open_description : open_description -> unit = self#open_infos self#longident_loc - method open_declaration : open_declaration -> unit= + + method open_declaration : open_declaration -> unit = self#open_infos self#module_expr - method include_infos : 'a . ('a -> unit) -> 'a include_infos -> unit= - fun _a -> - fun { pincl_mod; pincl_loc; pincl_attributes } -> - _a pincl_mod; - self#location pincl_loc; - self#attributes pincl_attributes - method include_description : include_description -> unit= + + method include_infos : 'a. ('a -> unit) -> 'a include_infos -> unit = + fun _a { pincl_mod; pincl_loc; pincl_attributes } -> + _a pincl_mod; + self#location pincl_loc; + self#attributes pincl_attributes + + method include_description : include_description -> unit = self#include_infos self#module_type - method include_declaration : include_declaration -> unit= + + method include_declaration : include_declaration -> unit = self#include_infos self#module_expr - method with_constraint : with_constraint -> unit= + + method with_constraint : with_constraint -> unit = fun x -> match x with | Pwith_type (a, b) -> - (self#longident_loc a; self#type_declaration b) - | Pwith_module (a, b) -> (self#longident_loc a; self#longident_loc b) + self#longident_loc a; + self#type_declaration b + | Pwith_module (a, b) -> + self#longident_loc a; + self#longident_loc b | Pwith_typesubst (a, b) -> - (self#longident_loc a; self#type_declaration b) + self#longident_loc a; + self#type_declaration b | Pwith_modsubst (a, b) -> - (self#longident_loc a; self#longident_loc b) - method module_expr : module_expr -> unit= + self#longident_loc a; + self#longident_loc b + + method module_expr : module_expr -> unit = fun { pmod_desc; pmod_loc; pmod_attributes } -> self#module_expr_desc pmod_desc; self#location pmod_loc; self#attributes pmod_attributes - method module_expr_desc : module_expr_desc -> unit= + + method module_expr_desc : module_expr_desc -> unit = fun x -> match x with | Pmod_ident a -> self#longident_loc a | Pmod_structure a -> self#structure a | Pmod_functor (a, b) -> - (self#functor_parameter a; self#module_expr b) - | Pmod_apply (a, b) -> (self#module_expr a; self#module_expr b) - | Pmod_constraint (a, b) -> (self#module_expr a; self#module_type b) + self#functor_parameter a; + self#module_expr b + | Pmod_apply (a, b) -> + self#module_expr a; + self#module_expr b + | Pmod_constraint (a, b) -> + self#module_expr a; + self#module_type b | Pmod_unpack a -> self#expression a | Pmod_extension a -> self#extension a - method structure : structure -> unit= self#list self#structure_item - method structure_item : structure_item -> unit= + + method structure : structure -> unit = self#list self#structure_item + + method structure_item : structure_item -> unit = fun { pstr_desc; pstr_loc } -> - self#structure_item_desc pstr_desc; self#location pstr_loc - method structure_item_desc : structure_item_desc -> unit= + self#structure_item_desc pstr_desc; + self#location pstr_loc + + method structure_item_desc : structure_item_desc -> unit = fun x -> match x with - | Pstr_eval (a, b) -> (self#expression a; self#attributes b) + | Pstr_eval (a, b) -> + self#expression a; + self#attributes b | Pstr_value (a, b) -> - (self#rec_flag a; self#list self#value_binding b) + self#rec_flag a; + self#list self#value_binding b | Pstr_primitive a -> self#value_description a | Pstr_type (a, b) -> - (self#rec_flag a; self#list self#type_declaration b) + self#rec_flag a; + self#list self#type_declaration b | Pstr_typext a -> self#type_extension a | Pstr_exception a -> self#type_exception a | Pstr_module a -> self#module_binding a @@ -2480,2571 +3114,2962 @@ | Pstr_class_type a -> self#list self#class_type_declaration a | Pstr_include a -> self#include_declaration a | Pstr_attribute a -> self#attribute a - | Pstr_extension (a, b) -> (self#extension a; self#attributes b) - method value_binding : value_binding -> unit= + | Pstr_extension (a, b) -> + self#extension a; + self#attributes b + + method value_binding : value_binding -> unit = fun { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } -> self#pattern pvb_pat; self#expression pvb_expr; self#attributes pvb_attributes; self#location pvb_loc - method module_binding : module_binding -> unit= + + method module_binding : module_binding -> unit = fun { pmb_name; pmb_expr; pmb_attributes; pmb_loc } -> self#loc (self#option self#string) pmb_name; self#module_expr pmb_expr; self#attributes pmb_attributes; self#location pmb_loc - method toplevel_phrase : toplevel_phrase -> unit= + + method toplevel_phrase : toplevel_phrase -> unit = fun x -> match x with | Ptop_def a -> self#structure a | Ptop_dir a -> self#toplevel_directive a - method toplevel_directive : toplevel_directive -> unit= + + method toplevel_directive : toplevel_directive -> unit = fun { pdir_name; pdir_arg; pdir_loc } -> self#loc self#string pdir_name; self#option self#directive_argument pdir_arg; self#location pdir_loc - method directive_argument : directive_argument -> unit= + + method directive_argument : directive_argument -> unit = fun { pdira_desc; pdira_loc } -> - self#directive_argument_desc pdira_desc; self#location pdira_loc - method directive_argument_desc : directive_argument_desc -> unit= + self#directive_argument_desc pdira_desc; + self#location pdira_loc + + method directive_argument_desc : directive_argument_desc -> unit = fun x -> match x with | Pdir_string a -> self#string a - | Pdir_int (a, b) -> (self#string a; self#option self#char b) + | Pdir_int (a, b) -> + self#string a; + self#option self#char b | Pdir_ident a -> self#longident a | Pdir_bool a -> self#bool a + + method cases : cases -> unit = self#list self#case end + class virtual ['acc] fold = object (self) - method virtual bool : bool -> 'acc -> 'acc - method virtual char : char -> 'acc -> 'acc - method virtual int : int -> 'acc -> 'acc - method virtual list : - 'a . ('a -> 'acc -> 'acc) -> 'a list -> 'acc -> 'acc - method virtual option : - 'a . ('a -> 'acc -> 'acc) -> 'a option -> 'acc -> 'acc - method virtual string : string -> 'acc -> 'acc - method position : position -> 'acc -> 'acc= - fun { pos_fname; pos_lnum; pos_bol; pos_cnum } -> - fun acc -> - let acc = self#string pos_fname acc in - let acc = self#int pos_lnum acc in - let acc = self#int pos_bol acc in - let acc = self#int pos_cnum acc in acc - method location : location -> 'acc -> 'acc= - fun { loc_start; loc_end; loc_ghost } -> - fun acc -> - let acc = self#position loc_start acc in - let acc = self#position loc_end acc in - let acc = self#bool loc_ghost acc in acc - method location_stack : location_stack -> 'acc -> 'acc= + method virtual bool : bool -> 'acc -> 'acc + + method virtual char : char -> 'acc -> 'acc + + method virtual int : int -> 'acc -> 'acc + + method virtual list : 'a. ('a -> 'acc -> 'acc) -> 'a list -> 'acc -> 'acc + + method virtual option + : 'a. ('a -> 'acc -> 'acc) -> 'a option -> 'acc -> 'acc + + method virtual string : string -> 'acc -> 'acc + + method position : position -> 'acc -> 'acc = + fun { pos_fname; pos_lnum; pos_bol; pos_cnum } acc -> + let acc = self#string pos_fname acc in + let acc = self#int pos_lnum acc in + let acc = self#int pos_bol acc in + let acc = self#int pos_cnum acc in + acc + + method location : location -> 'acc -> 'acc = + fun { loc_start; loc_end; loc_ghost } acc -> + let acc = self#position loc_start acc in + let acc = self#position loc_end acc in + let acc = self#bool loc_ghost acc in + acc + + method location_stack : location_stack -> 'acc -> 'acc = self#list self#location - method loc : 'a . ('a -> 'acc -> 'acc) -> 'a loc -> 'acc -> 'acc= - fun _a -> - fun { txt; loc } -> - fun acc -> - let acc = _a txt acc in let acc = self#location loc acc in acc - method longident : longident -> 'acc -> 'acc= - fun x -> - fun acc -> - match x with - | Lident a -> self#string a acc - | Ldot (a, b) -> - let acc = self#longident a acc in - let acc = self#string b acc in acc - | Lapply (a, b) -> - let acc = self#longident a acc in - let acc = self#longident b acc in acc - method longident_loc : longident_loc -> 'acc -> 'acc= + + method loc : 'a. ('a -> 'acc -> 'acc) -> 'a loc -> 'acc -> 'acc = + fun _a { txt; loc } acc -> + let acc = _a txt acc in + let acc = self#location loc acc in + acc + + method longident : longident -> 'acc -> 'acc = + fun x acc -> + match x with + | Lident a -> self#string a acc + | Ldot (a, b) -> + let acc = self#longident a acc in + let acc = self#string b acc in + acc + | Lapply (a, b) -> + let acc = self#longident a acc in + let acc = self#longident b acc in + acc + + method longident_loc : longident_loc -> 'acc -> 'acc = self#loc self#longident - method rec_flag : rec_flag -> 'acc -> 'acc= fun _ -> fun acc -> acc - method direction_flag : direction_flag -> 'acc -> 'acc= - fun _ -> fun acc -> acc - method private_flag : private_flag -> 'acc -> 'acc= - fun _ -> fun acc -> acc - method mutable_flag : mutable_flag -> 'acc -> 'acc= - fun _ -> fun acc -> acc - method virtual_flag : virtual_flag -> 'acc -> 'acc= - fun _ -> fun acc -> acc - method override_flag : override_flag -> 'acc -> 'acc= - fun _ -> fun acc -> acc - method closed_flag : closed_flag -> 'acc -> 'acc= fun _ -> fun acc -> acc - method label : label -> 'acc -> 'acc= self#string - method arg_label : arg_label -> 'acc -> 'acc= - fun x -> - fun acc -> - match x with - | Nolabel -> acc - | Labelled a -> self#string a acc - | Optional a -> self#string a acc - method variance : variance -> 'acc -> 'acc= fun _ -> fun acc -> acc - method constant : constant -> 'acc -> 'acc= - fun x -> - fun acc -> - match x with - | Pconst_integer (a, b) -> - let acc = self#string a acc in - let acc = self#option self#char b acc in acc - | Pconst_char a -> self#char a acc - | Pconst_string (a, b) -> - let acc = self#string a acc in - let acc = self#option self#string b acc in acc - | Pconst_float (a, b) -> - let acc = self#string a acc in - let acc = self#option self#char b acc in acc - method attribute : attribute -> 'acc -> 'acc= - fun { attr_name; attr_payload; attr_loc } -> - fun acc -> - let acc = self#loc self#string attr_name acc in - let acc = self#payload attr_payload acc in - let acc = self#location attr_loc acc in acc - method extension : extension -> 'acc -> 'acc= - fun (a, b) -> - fun acc -> - let acc = self#loc self#string a acc in - let acc = self#payload b acc in acc - method attributes : attributes -> 'acc -> 'acc= self#list self#attribute - method payload : payload -> 'acc -> 'acc= - fun x -> - fun acc -> - match x with - | PStr a -> self#structure a acc - | PSig a -> self#signature a acc - | PTyp a -> self#core_type a acc - | PPat (a, b) -> - let acc = self#pattern a acc in - let acc = self#option self#expression b acc in acc - method core_type : core_type -> 'acc -> 'acc= - fun { ptyp_desc; ptyp_loc; ptyp_loc_stack; ptyp_attributes } -> - fun acc -> - let acc = self#core_type_desc ptyp_desc acc in - let acc = self#location ptyp_loc acc in - let acc = self#location_stack ptyp_loc_stack acc in - let acc = self#attributes ptyp_attributes acc in acc - method core_type_desc : core_type_desc -> 'acc -> 'acc= - fun x -> - fun acc -> - match x with - | Ptyp_any -> acc - | Ptyp_var a -> self#string a acc - | Ptyp_arrow (a, b, c) -> - let acc = self#arg_label a acc in - let acc = self#core_type b acc in - let acc = self#core_type c acc in acc - | Ptyp_tuple a -> self#list self#core_type a acc - | Ptyp_constr (a, b) -> - let acc = self#longident_loc a acc in - let acc = self#list self#core_type b acc in acc - | Ptyp_object (a, b) -> - let acc = self#list self#object_field a acc in - let acc = self#closed_flag b acc in acc - | Ptyp_class (a, b) -> + + method rec_flag : rec_flag -> 'acc -> 'acc = fun _ acc -> acc + + method direction_flag : direction_flag -> 'acc -> 'acc = fun _ acc -> acc + + method private_flag : private_flag -> 'acc -> 'acc = fun _ acc -> acc + + method mutable_flag : mutable_flag -> 'acc -> 'acc = fun _ acc -> acc + + method virtual_flag : virtual_flag -> 'acc -> 'acc = fun _ acc -> acc + + method override_flag : override_flag -> 'acc -> 'acc = fun _ acc -> acc + + method closed_flag : closed_flag -> 'acc -> 'acc = fun _ acc -> acc + + method label : label -> 'acc -> 'acc = self#string + + method arg_label : arg_label -> 'acc -> 'acc = + fun x acc -> + match x with + | Nolabel -> acc + | Labelled a -> self#string a acc + | Optional a -> self#string a acc + + method variance : variance -> 'acc -> 'acc = fun _ acc -> acc + + method injectivity : injectivity -> 'acc -> 'acc = fun _ acc -> acc + + method constant : constant -> 'acc -> 'acc = + fun x acc -> + match x with + | Pconst_integer (a, b) -> + let acc = self#string a acc in + let acc = self#option self#char b acc in + acc + | Pconst_char a -> self#char a acc + | Pconst_string (a, b, c) -> + let acc = self#string a acc in + let acc = self#location b acc in + let acc = self#option self#string c acc in + acc + | Pconst_float (a, b) -> + let acc = self#string a acc in + let acc = self#option self#char b acc in + acc + + method attribute : attribute -> 'acc -> 'acc = + fun { attr_name; attr_payload; attr_loc } acc -> + let acc = self#loc self#string attr_name acc in + let acc = self#payload attr_payload acc in + let acc = self#location attr_loc acc in + acc + + method extension : extension -> 'acc -> 'acc = + fun (a, b) acc -> + let acc = self#loc self#string a acc in + let acc = self#payload b acc in + acc + + method attributes : attributes -> 'acc -> 'acc = self#list self#attribute + + method payload : payload -> 'acc -> 'acc = + fun x acc -> + match x with + | PStr a -> self#structure a acc + | PSig a -> self#signature a acc + | PTyp a -> self#core_type a acc + | PPat (a, b) -> + let acc = self#pattern a acc in + let acc = self#option self#expression b acc in + acc + + method core_type : core_type -> 'acc -> 'acc = + fun { ptyp_desc; ptyp_loc; ptyp_loc_stack; ptyp_attributes } acc -> + let acc = self#core_type_desc ptyp_desc acc in + let acc = self#location ptyp_loc acc in + let acc = self#location_stack ptyp_loc_stack acc in + let acc = self#attributes ptyp_attributes acc in + acc + + method core_type_desc : core_type_desc -> 'acc -> 'acc = + fun x acc -> + match x with + | Ptyp_any -> acc + | Ptyp_var a -> self#string a acc + | Ptyp_arrow (a, b, c) -> + let acc = self#arg_label a acc in + let acc = self#core_type b acc in + let acc = self#core_type c acc in + acc + | Ptyp_tuple a -> self#list self#core_type a acc + | Ptyp_constr (a, b) -> + let acc = self#longident_loc a acc in + let acc = self#list self#core_type b acc in + acc + | Ptyp_object (a, b) -> + let acc = self#list self#object_field a acc in + let acc = self#closed_flag b acc in + acc + | Ptyp_class (a, b) -> + let acc = self#longident_loc a acc in + let acc = self#list self#core_type b acc in + acc + | Ptyp_alias (a, b) -> + let acc = self#core_type a acc in + let acc = self#string b acc in + acc + | Ptyp_variant (a, b, c) -> + let acc = self#list self#row_field a acc in + let acc = self#closed_flag b acc in + let acc = self#option (self#list self#label) c acc in + acc + | Ptyp_poly (a, b) -> + let acc = self#list (self#loc self#string) a acc in + let acc = self#core_type b acc in + acc + | Ptyp_package a -> self#package_type a acc + | Ptyp_extension a -> self#extension a acc + + method package_type : package_type -> 'acc -> 'acc = + fun (a, b) acc -> + let acc = self#longident_loc a acc in + let acc = + self#list + (fun (a, b) acc -> let acc = self#longident_loc a acc in - let acc = self#list self#core_type b acc in acc - | Ptyp_alias (a, b) -> - let acc = self#core_type a acc in - let acc = self#string b acc in acc - | Ptyp_variant (a, b, c) -> - let acc = self#list self#row_field a acc in - let acc = self#closed_flag b acc in - let acc = self#option (self#list self#label) c acc in acc - | Ptyp_poly (a, b) -> - let acc = self#list (self#loc self#string) a acc in - let acc = self#core_type b acc in acc - | Ptyp_package a -> self#package_type a acc - | Ptyp_extension a -> self#extension a acc - method package_type : package_type -> 'acc -> 'acc= - fun (a, b) -> - fun acc -> - let acc = self#longident_loc a acc in - let acc = + let acc = self#core_type b acc in + acc) + b acc + in + acc + + method row_field : row_field -> 'acc -> 'acc = + fun { prf_desc; prf_loc; prf_attributes } acc -> + let acc = self#row_field_desc prf_desc acc in + let acc = self#location prf_loc acc in + let acc = self#attributes prf_attributes acc in + acc + + method row_field_desc : row_field_desc -> 'acc -> 'acc = + fun x acc -> + match x with + | Rtag (a, b, c) -> + let acc = self#loc self#label a acc in + let acc = self#bool b acc in + let acc = self#list self#core_type c acc in + acc + | Rinherit a -> self#core_type a acc + + method object_field : object_field -> 'acc -> 'acc = + fun { pof_desc; pof_loc; pof_attributes } acc -> + let acc = self#object_field_desc pof_desc acc in + let acc = self#location pof_loc acc in + let acc = self#attributes pof_attributes acc in + acc + + method object_field_desc : object_field_desc -> 'acc -> 'acc = + fun x acc -> + match x with + | Otag (a, b) -> + let acc = self#loc self#label a acc in + let acc = self#core_type b acc in + acc + | Oinherit a -> self#core_type a acc + + method pattern : pattern -> 'acc -> 'acc = + fun { ppat_desc; ppat_loc; ppat_loc_stack; ppat_attributes } acc -> + let acc = self#pattern_desc ppat_desc acc in + let acc = self#location ppat_loc acc in + let acc = self#location_stack ppat_loc_stack acc in + let acc = self#attributes ppat_attributes acc in + acc + + method pattern_desc : pattern_desc -> 'acc -> 'acc = + fun x acc -> + match x with + | Ppat_any -> acc + | Ppat_var a -> self#loc self#string a acc + | Ppat_alias (a, b) -> + let acc = self#pattern a acc in + let acc = self#loc self#string b acc in + acc + | Ppat_constant a -> self#constant a acc + | Ppat_interval (a, b) -> + let acc = self#constant a acc in + let acc = self#constant b acc in + acc + | Ppat_tuple a -> self#list self#pattern a acc + | Ppat_construct (a, b) -> + let acc = self#longident_loc a acc in + let acc = self#option self#pattern b acc in + acc + | Ppat_variant (a, b) -> + let acc = self#label a acc in + let acc = self#option self#pattern b acc in + acc + | Ppat_record (a, b) -> + let acc = + self#list + (fun (a, b) acc -> + let acc = self#longident_loc a acc in + let acc = self#pattern b acc in + acc) + a acc + in + let acc = self#closed_flag b acc in + acc + | Ppat_array a -> self#list self#pattern a acc + | Ppat_or (a, b) -> + let acc = self#pattern a acc in + let acc = self#pattern b acc in + acc + | Ppat_constraint (a, b) -> + let acc = self#pattern a acc in + let acc = self#core_type b acc in + acc + | Ppat_type a -> self#longident_loc a acc + | Ppat_lazy a -> self#pattern a acc + | Ppat_unpack a -> self#loc (self#option self#string) a acc + | Ppat_exception a -> self#pattern a acc + | Ppat_extension a -> self#extension a acc + | Ppat_open (a, b) -> + let acc = self#longident_loc a acc in + let acc = self#pattern b acc in + acc + + method expression : expression -> 'acc -> 'acc = + fun { pexp_desc; pexp_loc; pexp_loc_stack; pexp_attributes } acc -> + let acc = self#expression_desc pexp_desc acc in + let acc = self#location pexp_loc acc in + let acc = self#location_stack pexp_loc_stack acc in + let acc = self#attributes pexp_attributes acc in + acc + + method expression_desc : expression_desc -> 'acc -> 'acc = + fun x acc -> + match x with + | Pexp_ident a -> self#longident_loc a acc + | Pexp_constant a -> self#constant a acc + | Pexp_let (a, b, c) -> + let acc = self#rec_flag a acc in + let acc = self#list self#value_binding b acc in + let acc = self#expression c acc in + acc + | Pexp_function a -> self#cases a acc + | Pexp_fun (a, b, c, d) -> + let acc = self#arg_label a acc in + let acc = self#option self#expression b acc in + let acc = self#pattern c acc in + let acc = self#expression d acc in + acc + | Pexp_apply (a, b) -> + let acc = self#expression a acc in + let acc = + self#list + (fun (a, b) acc -> + let acc = self#arg_label a acc in + let acc = self#expression b acc in + acc) + b acc + in + acc + | Pexp_match (a, b) -> + let acc = self#expression a acc in + let acc = self#cases b acc in + acc + | Pexp_try (a, b) -> + let acc = self#expression a acc in + let acc = self#cases b acc in + acc + | Pexp_tuple a -> self#list self#expression a acc + | Pexp_construct (a, b) -> + let acc = self#longident_loc a acc in + let acc = self#option self#expression b acc in + acc + | Pexp_variant (a, b) -> + let acc = self#label a acc in + let acc = self#option self#expression b acc in + acc + | Pexp_record (a, b) -> + let acc = + self#list + (fun (a, b) acc -> + let acc = self#longident_loc a acc in + let acc = self#expression b acc in + acc) + a acc + in + let acc = self#option self#expression b acc in + acc + | Pexp_field (a, b) -> + let acc = self#expression a acc in + let acc = self#longident_loc b acc in + acc + | Pexp_setfield (a, b, c) -> + let acc = self#expression a acc in + let acc = self#longident_loc b acc in + let acc = self#expression c acc in + acc + | Pexp_array a -> self#list self#expression a acc + | Pexp_ifthenelse (a, b, c) -> + let acc = self#expression a acc in + let acc = self#expression b acc in + let acc = self#option self#expression c acc in + acc + | Pexp_sequence (a, b) -> + let acc = self#expression a acc in + let acc = self#expression b acc in + acc + | Pexp_while (a, b) -> + let acc = self#expression a acc in + let acc = self#expression b acc in + acc + | Pexp_for (a, b, c, d, e) -> + let acc = self#pattern a acc in + let acc = self#expression b acc in + let acc = self#expression c acc in + let acc = self#direction_flag d acc in + let acc = self#expression e acc in + acc + | Pexp_constraint (a, b) -> + let acc = self#expression a acc in + let acc = self#core_type b acc in + acc + | Pexp_coerce (a, b, c) -> + let acc = self#expression a acc in + let acc = self#option self#core_type b acc in + let acc = self#core_type c acc in + acc + | Pexp_send (a, b) -> + let acc = self#expression a acc in + let acc = self#loc self#label b acc in + acc + | Pexp_new a -> self#longident_loc a acc + | Pexp_setinstvar (a, b) -> + let acc = self#loc self#label a acc in + let acc = self#expression b acc in + acc + | Pexp_override a -> self#list - (fun (a, b) -> - fun acc -> - let acc = self#longident_loc a acc in - let acc = self#core_type b acc in acc) b acc in - acc - method row_field : row_field -> 'acc -> 'acc= - fun { prf_desc; prf_loc; prf_attributes } -> - fun acc -> - let acc = self#row_field_desc prf_desc acc in - let acc = self#location prf_loc acc in - let acc = self#attributes prf_attributes acc in acc - method row_field_desc : row_field_desc -> 'acc -> 'acc= - fun x -> - fun acc -> - match x with - | Rtag (a, b, c) -> - let acc = self#loc self#label a acc in - let acc = self#bool b acc in - let acc = self#list self#core_type c acc in acc - | Rinherit a -> self#core_type a acc - method object_field : object_field -> 'acc -> 'acc= - fun { pof_desc; pof_loc; pof_attributes } -> - fun acc -> - let acc = self#object_field_desc pof_desc acc in - let acc = self#location pof_loc acc in - let acc = self#attributes pof_attributes acc in acc - method object_field_desc : object_field_desc -> 'acc -> 'acc= - fun x -> - fun acc -> - match x with - | Otag (a, b) -> - let acc = self#loc self#label a acc in - let acc = self#core_type b acc in acc - | Oinherit a -> self#core_type a acc - method pattern : pattern -> 'acc -> 'acc= - fun { ppat_desc; ppat_loc; ppat_loc_stack; ppat_attributes } -> - fun acc -> - let acc = self#pattern_desc ppat_desc acc in - let acc = self#location ppat_loc acc in - let acc = self#location_stack ppat_loc_stack acc in - let acc = self#attributes ppat_attributes acc in acc - method pattern_desc : pattern_desc -> 'acc -> 'acc= - fun x -> - fun acc -> - match x with - | Ppat_any -> acc - | Ppat_var a -> self#loc self#string a acc - | Ppat_alias (a, b) -> - let acc = self#pattern a acc in - let acc = self#loc self#string b acc in acc - | Ppat_constant a -> self#constant a acc - | Ppat_interval (a, b) -> - let acc = self#constant a acc in - let acc = self#constant b acc in acc - | Ppat_tuple a -> self#list self#pattern a acc - | Ppat_construct (a, b) -> - let acc = self#longident_loc a acc in - let acc = self#option self#pattern b acc in acc - | Ppat_variant (a, b) -> - let acc = self#label a acc in - let acc = self#option self#pattern b acc in acc - | Ppat_record (a, b) -> - let acc = - self#list - (fun (a, b) -> - fun acc -> - let acc = self#longident_loc a acc in - let acc = self#pattern b acc in acc) a acc in - let acc = self#closed_flag b acc in acc - | Ppat_array a -> self#list self#pattern a acc - | Ppat_or (a, b) -> - let acc = self#pattern a acc in - let acc = self#pattern b acc in acc - | Ppat_constraint (a, b) -> - let acc = self#pattern a acc in - let acc = self#core_type b acc in acc - | Ppat_type a -> self#longident_loc a acc - | Ppat_lazy a -> self#pattern a acc - | Ppat_unpack a -> self#loc (self#option self#string) a acc - | Ppat_exception a -> self#pattern a acc - | Ppat_extension a -> self#extension a acc - | Ppat_open (a, b) -> - let acc = self#longident_loc a acc in - let acc = self#pattern b acc in acc - method expression : expression -> 'acc -> 'acc= - fun { pexp_desc; pexp_loc; pexp_loc_stack; pexp_attributes } -> - fun acc -> - let acc = self#expression_desc pexp_desc acc in - let acc = self#location pexp_loc acc in - let acc = self#location_stack pexp_loc_stack acc in - let acc = self#attributes pexp_attributes acc in acc - method expression_desc : expression_desc -> 'acc -> 'acc= - fun x -> - fun acc -> - match x with - | Pexp_ident a -> self#longident_loc a acc - | Pexp_constant a -> self#constant a acc - | Pexp_let (a, b, c) -> - let acc = self#rec_flag a acc in - let acc = self#list self#value_binding b acc in - let acc = self#expression c acc in acc - | Pexp_function a -> self#list self#case a acc - | Pexp_fun (a, b, c, d) -> - let acc = self#arg_label a acc in - let acc = self#option self#expression b acc in - let acc = self#pattern c acc in - let acc = self#expression d acc in acc - | Pexp_apply (a, b) -> - let acc = self#expression a acc in + (fun (a, b) acc -> + let acc = self#loc self#label a acc in + let acc = self#expression b acc in + acc) + a acc + | Pexp_letmodule (a, b, c) -> + let acc = self#loc (self#option self#string) a acc in + let acc = self#module_expr b acc in + let acc = self#expression c acc in + acc + | Pexp_letexception (a, b) -> + let acc = self#extension_constructor a acc in + let acc = self#expression b acc in + acc + | Pexp_assert a -> self#expression a acc + | Pexp_lazy a -> self#expression a acc + | Pexp_poly (a, b) -> + let acc = self#expression a acc in + let acc = self#option self#core_type b acc in + acc + | Pexp_object a -> self#class_structure a acc + | Pexp_newtype (a, b) -> + let acc = self#loc self#string a acc in + let acc = self#expression b acc in + acc + | Pexp_pack a -> self#module_expr a acc + | Pexp_open (a, b) -> + let acc = self#open_declaration a acc in + let acc = self#expression b acc in + acc + | Pexp_letop a -> self#letop a acc + | Pexp_extension a -> self#extension a acc + | Pexp_unreachable -> acc + + method case : case -> 'acc -> 'acc = + fun { pc_lhs; pc_guard; pc_rhs } acc -> + let acc = self#pattern pc_lhs acc in + let acc = self#option self#expression pc_guard acc in + let acc = self#expression pc_rhs acc in + acc + + method letop : letop -> 'acc -> 'acc = + fun { let_; ands; body } acc -> + let acc = self#binding_op let_ acc in + let acc = self#list self#binding_op ands acc in + let acc = self#expression body acc in + acc + + method binding_op : binding_op -> 'acc -> 'acc = + fun { pbop_op; pbop_pat; pbop_exp; pbop_loc } acc -> + let acc = self#loc self#string pbop_op acc in + let acc = self#pattern pbop_pat acc in + let acc = self#expression pbop_exp acc in + let acc = self#location pbop_loc acc in + acc + + method value_description : value_description -> 'acc -> 'acc = + fun { pval_name; pval_type; pval_prim; pval_attributes; pval_loc } acc -> + let acc = self#loc self#string pval_name acc in + let acc = self#core_type pval_type acc in + let acc = self#list self#string pval_prim acc in + let acc = self#attributes pval_attributes acc in + let acc = self#location pval_loc acc in + acc + + method type_declaration : type_declaration -> 'acc -> 'acc = + fun { + ptype_name; + ptype_params; + ptype_cstrs; + ptype_kind; + ptype_private; + ptype_manifest; + ptype_attributes; + ptype_loc; + } acc -> + let acc = self#loc self#string ptype_name acc in + let acc = + self#list + (fun (a, b) acc -> + let acc = self#core_type a acc in let acc = - self#list - (fun (a, b) -> - fun acc -> - let acc = self#arg_label a acc in - let acc = self#expression b acc in acc) b acc in - acc - | Pexp_match (a, b) -> - let acc = self#expression a acc in - let acc = self#list self#case b acc in acc - | Pexp_try (a, b) -> - let acc = self#expression a acc in - let acc = self#list self#case b acc in acc - | Pexp_tuple a -> self#list self#expression a acc - | Pexp_construct (a, b) -> - let acc = self#longident_loc a acc in - let acc = self#option self#expression b acc in acc - | Pexp_variant (a, b) -> - let acc = self#label a acc in - let acc = self#option self#expression b acc in acc - | Pexp_record (a, b) -> + (fun (a, b) acc -> + let acc = self#variance a acc in + let acc = self#injectivity b acc in + acc) + b acc + in + acc) + ptype_params acc + in + let acc = + self#list + (fun (a, b, c) acc -> + let acc = self#core_type a acc in + let acc = self#core_type b acc in + let acc = self#location c acc in + acc) + ptype_cstrs acc + in + let acc = self#type_kind ptype_kind acc in + let acc = self#private_flag ptype_private acc in + let acc = self#option self#core_type ptype_manifest acc in + let acc = self#attributes ptype_attributes acc in + let acc = self#location ptype_loc acc in + acc + + method type_kind : type_kind -> 'acc -> 'acc = + fun x acc -> + match x with + | Ptype_abstract -> acc + | Ptype_variant a -> self#list self#constructor_declaration a acc + | Ptype_record a -> self#list self#label_declaration a acc + | Ptype_open -> acc + + method label_declaration : label_declaration -> 'acc -> 'acc = + fun { pld_name; pld_mutable; pld_type; pld_loc; pld_attributes } acc -> + let acc = self#loc self#string pld_name acc in + let acc = self#mutable_flag pld_mutable acc in + let acc = self#core_type pld_type acc in + let acc = self#location pld_loc acc in + let acc = self#attributes pld_attributes acc in + acc + + method constructor_declaration : constructor_declaration -> 'acc -> 'acc = + fun { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } acc -> + let acc = self#loc self#string pcd_name acc in + let acc = self#constructor_arguments pcd_args acc in + let acc = self#option self#core_type pcd_res acc in + let acc = self#location pcd_loc acc in + let acc = self#attributes pcd_attributes acc in + acc + + method constructor_arguments : constructor_arguments -> 'acc -> 'acc = + fun x acc -> + match x with + | Pcstr_tuple a -> self#list self#core_type a acc + | Pcstr_record a -> self#list self#label_declaration a acc + + method type_extension : type_extension -> 'acc -> 'acc = + fun { + ptyext_path; + ptyext_params; + ptyext_constructors; + ptyext_private; + ptyext_loc; + ptyext_attributes; + } acc -> + let acc = self#longident_loc ptyext_path acc in + let acc = + self#list + (fun (a, b) acc -> + let acc = self#core_type a acc in let acc = - self#list - (fun (a, b) -> - fun acc -> - let acc = self#longident_loc a acc in - let acc = self#expression b acc in acc) a acc in - let acc = self#option self#expression b acc in acc - | Pexp_field (a, b) -> - let acc = self#expression a acc in - let acc = self#longident_loc b acc in acc - | Pexp_setfield (a, b, c) -> - let acc = self#expression a acc in - let acc = self#longident_loc b acc in - let acc = self#expression c acc in acc - | Pexp_array a -> self#list self#expression a acc - | Pexp_ifthenelse (a, b, c) -> - let acc = self#expression a acc in - let acc = self#expression b acc in - let acc = self#option self#expression c acc in acc - | Pexp_sequence (a, b) -> - let acc = self#expression a acc in - let acc = self#expression b acc in acc - | Pexp_while (a, b) -> - let acc = self#expression a acc in - let acc = self#expression b acc in acc - | Pexp_for (a, b, c, d, e) -> - let acc = self#pattern a acc in - let acc = self#expression b acc in - let acc = self#expression c acc in - let acc = self#direction_flag d acc in - let acc = self#expression e acc in acc - | Pexp_constraint (a, b) -> - let acc = self#expression a acc in - let acc = self#core_type b acc in acc - | Pexp_coerce (a, b, c) -> - let acc = self#expression a acc in - let acc = self#option self#core_type b acc in - let acc = self#core_type c acc in acc - | Pexp_send (a, b) -> - let acc = self#expression a acc in - let acc = self#loc self#label b acc in acc - | Pexp_new a -> self#longident_loc a acc - | Pexp_setinstvar (a, b) -> + (fun (a, b) acc -> + let acc = self#variance a acc in + let acc = self#injectivity b acc in + acc) + b acc + in + acc) + ptyext_params acc + in + let acc = + self#list self#extension_constructor ptyext_constructors acc + in + let acc = self#private_flag ptyext_private acc in + let acc = self#location ptyext_loc acc in + let acc = self#attributes ptyext_attributes acc in + acc + + method extension_constructor : extension_constructor -> 'acc -> 'acc = + fun { pext_name; pext_kind; pext_loc; pext_attributes } acc -> + let acc = self#loc self#string pext_name acc in + let acc = self#extension_constructor_kind pext_kind acc in + let acc = self#location pext_loc acc in + let acc = self#attributes pext_attributes acc in + acc + + method type_exception : type_exception -> 'acc -> 'acc = + fun { ptyexn_constructor; ptyexn_loc; ptyexn_attributes } acc -> + let acc = self#extension_constructor ptyexn_constructor acc in + let acc = self#location ptyexn_loc acc in + let acc = self#attributes ptyexn_attributes acc in + acc + + method extension_constructor_kind + : extension_constructor_kind -> 'acc -> 'acc = + fun x acc -> + match x with + | Pext_decl (a, b) -> + let acc = self#constructor_arguments a acc in + let acc = self#option self#core_type b acc in + acc + | Pext_rebind a -> self#longident_loc a acc + + method class_type : class_type -> 'acc -> 'acc = + fun { pcty_desc; pcty_loc; pcty_attributes } acc -> + let acc = self#class_type_desc pcty_desc acc in + let acc = self#location pcty_loc acc in + let acc = self#attributes pcty_attributes acc in + acc + + method class_type_desc : class_type_desc -> 'acc -> 'acc = + fun x acc -> + match x with + | Pcty_constr (a, b) -> + let acc = self#longident_loc a acc in + let acc = self#list self#core_type b acc in + acc + | Pcty_signature a -> self#class_signature a acc + | Pcty_arrow (a, b, c) -> + let acc = self#arg_label a acc in + let acc = self#core_type b acc in + let acc = self#class_type c acc in + acc + | Pcty_extension a -> self#extension a acc + | Pcty_open (a, b) -> + let acc = self#open_description a acc in + let acc = self#class_type b acc in + acc + + method class_signature : class_signature -> 'acc -> 'acc = + fun { pcsig_self; pcsig_fields } acc -> + let acc = self#core_type pcsig_self acc in + let acc = self#list self#class_type_field pcsig_fields acc in + acc + + method class_type_field : class_type_field -> 'acc -> 'acc = + fun { pctf_desc; pctf_loc; pctf_attributes } acc -> + let acc = self#class_type_field_desc pctf_desc acc in + let acc = self#location pctf_loc acc in + let acc = self#attributes pctf_attributes acc in + acc + + method class_type_field_desc : class_type_field_desc -> 'acc -> 'acc = + fun x acc -> + match x with + | Pctf_inherit a -> self#class_type a acc + | Pctf_val a -> + (fun (a, b, c, d) acc -> let acc = self#loc self#label a acc in - let acc = self#expression b acc in acc - | Pexp_override a -> - self#list - (fun (a, b) -> - fun acc -> - let acc = self#loc self#label a acc in - let acc = self#expression b acc in acc) a acc - | Pexp_letmodule (a, b, c) -> - let acc = self#loc (self#option self#string) a acc in - let acc = self#module_expr b acc in - let acc = self#expression c acc in acc - | Pexp_letexception (a, b) -> - let acc = self#extension_constructor a acc in - let acc = self#expression b acc in acc - | Pexp_assert a -> self#expression a acc - | Pexp_lazy a -> self#expression a acc - | Pexp_poly (a, b) -> - let acc = self#expression a acc in - let acc = self#option self#core_type b acc in acc - | Pexp_object a -> self#class_structure a acc - | Pexp_newtype (a, b) -> - let acc = self#loc self#string a acc in - let acc = self#expression b acc in acc - | Pexp_pack a -> self#module_expr a acc - | Pexp_open (a, b) -> - let acc = self#open_declaration a acc in - let acc = self#expression b acc in acc - | Pexp_letop a -> self#letop a acc - | Pexp_extension a -> self#extension a acc - | Pexp_unreachable -> acc - method case : case -> 'acc -> 'acc= - fun { pc_lhs; pc_guard; pc_rhs } -> - fun acc -> - let acc = self#pattern pc_lhs acc in - let acc = self#option self#expression pc_guard acc in - let acc = self#expression pc_rhs acc in acc - method letop : letop -> 'acc -> 'acc= - fun { let_; ands; body } -> - fun acc -> - let acc = self#binding_op let_ acc in - let acc = self#list self#binding_op ands acc in - let acc = self#expression body acc in acc - method binding_op : binding_op -> 'acc -> 'acc= - fun { pbop_op; pbop_pat; pbop_exp; pbop_loc } -> - fun acc -> - let acc = self#loc self#string pbop_op acc in - let acc = self#pattern pbop_pat acc in - let acc = self#expression pbop_exp acc in - let acc = self#location pbop_loc acc in acc - method value_description : value_description -> 'acc -> 'acc= - fun { pval_name; pval_type; pval_prim; pval_attributes; pval_loc } -> - fun acc -> - let acc = self#loc self#string pval_name acc in - let acc = self#core_type pval_type acc in - let acc = self#list self#string pval_prim acc in - let acc = self#attributes pval_attributes acc in - let acc = self#location pval_loc acc in acc - method type_declaration : type_declaration -> 'acc -> 'acc= - fun - { ptype_name; ptype_params; ptype_cstrs; ptype_kind; ptype_private; - ptype_manifest; ptype_attributes; ptype_loc } - -> - fun acc -> - let acc = self#loc self#string ptype_name acc in - let acc = - self#list - (fun (a, b) -> - fun acc -> - let acc = self#core_type a acc in - let acc = self#variance b acc in acc) ptype_params acc in - let acc = - self#list - (fun (a, b, c) -> - fun acc -> - let acc = self#core_type a acc in - let acc = self#core_type b acc in - let acc = self#location c acc in acc) ptype_cstrs acc in - let acc = self#type_kind ptype_kind acc in - let acc = self#private_flag ptype_private acc in - let acc = self#option self#core_type ptype_manifest acc in - let acc = self#attributes ptype_attributes acc in - let acc = self#location ptype_loc acc in acc - method type_kind : type_kind -> 'acc -> 'acc= - fun x -> - fun acc -> - match x with - | Ptype_abstract -> acc - | Ptype_variant a -> self#list self#constructor_declaration a acc - | Ptype_record a -> self#list self#label_declaration a acc - | Ptype_open -> acc - method label_declaration : label_declaration -> 'acc -> 'acc= - fun { pld_name; pld_mutable; pld_type; pld_loc; pld_attributes } -> - fun acc -> - let acc = self#loc self#string pld_name acc in - let acc = self#mutable_flag pld_mutable acc in - let acc = self#core_type pld_type acc in - let acc = self#location pld_loc acc in - let acc = self#attributes pld_attributes acc in acc - method constructor_declaration : constructor_declaration -> 'acc -> 'acc= - fun { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } -> - fun acc -> - let acc = self#loc self#string pcd_name acc in - let acc = self#constructor_arguments pcd_args acc in - let acc = self#option self#core_type pcd_res acc in - let acc = self#location pcd_loc acc in - let acc = self#attributes pcd_attributes acc in acc - method constructor_arguments : constructor_arguments -> 'acc -> 'acc= - fun x -> - fun acc -> - match x with - | Pcstr_tuple a -> self#list self#core_type a acc - | Pcstr_record a -> self#list self#label_declaration a acc - method type_extension : type_extension -> 'acc -> 'acc= - fun - { ptyext_path; ptyext_params; ptyext_constructors; ptyext_private; - ptyext_loc; ptyext_attributes } - -> - fun acc -> - let acc = self#longident_loc ptyext_path acc in - let acc = - self#list - (fun (a, b) -> - fun acc -> - let acc = self#core_type a acc in - let acc = self#variance b acc in acc) ptyext_params acc in - let acc = - self#list self#extension_constructor ptyext_constructors acc in - let acc = self#private_flag ptyext_private acc in - let acc = self#location ptyext_loc acc in - let acc = self#attributes ptyext_attributes acc in acc - method extension_constructor : extension_constructor -> 'acc -> 'acc= - fun { pext_name; pext_kind; pext_loc; pext_attributes } -> - fun acc -> - let acc = self#loc self#string pext_name acc in - let acc = self#extension_constructor_kind pext_kind acc in - let acc = self#location pext_loc acc in - let acc = self#attributes pext_attributes acc in acc - method type_exception : type_exception -> 'acc -> 'acc= - fun { ptyexn_constructor; ptyexn_loc; ptyexn_attributes } -> - fun acc -> - let acc = self#extension_constructor ptyexn_constructor acc in - let acc = self#location ptyexn_loc acc in - let acc = self#attributes ptyexn_attributes acc in acc - method extension_constructor_kind : - extension_constructor_kind -> 'acc -> 'acc= - fun x -> - fun acc -> - match x with - | Pext_decl (a, b) -> - let acc = self#constructor_arguments a acc in - let acc = self#option self#core_type b acc in acc - | Pext_rebind a -> self#longident_loc a acc - method class_type : class_type -> 'acc -> 'acc= - fun { pcty_desc; pcty_loc; pcty_attributes } -> - fun acc -> - let acc = self#class_type_desc pcty_desc acc in - let acc = self#location pcty_loc acc in - let acc = self#attributes pcty_attributes acc in acc - method class_type_desc : class_type_desc -> 'acc -> 'acc= - fun x -> - fun acc -> - match x with - | Pcty_constr (a, b) -> - let acc = self#longident_loc a acc in - let acc = self#list self#core_type b acc in acc - | Pcty_signature a -> self#class_signature a acc - | Pcty_arrow (a, b, c) -> - let acc = self#arg_label a acc in + let acc = self#mutable_flag b acc in + let acc = self#virtual_flag c acc in + let acc = self#core_type d acc in + acc) + a acc + | Pctf_method a -> + (fun (a, b, c, d) acc -> + let acc = self#loc self#label a acc in + let acc = self#private_flag b acc in + let acc = self#virtual_flag c acc in + let acc = self#core_type d acc in + acc) + a acc + | Pctf_constraint a -> + (fun (a, b) acc -> + let acc = self#core_type a acc in let acc = self#core_type b acc in - let acc = self#class_type c acc in acc - | Pcty_extension a -> self#extension a acc - | Pcty_open (a, b) -> - let acc = self#open_description a acc in - let acc = self#class_type b acc in acc - method class_signature : class_signature -> 'acc -> 'acc= - fun { pcsig_self; pcsig_fields } -> - fun acc -> - let acc = self#core_type pcsig_self acc in - let acc = self#list self#class_type_field pcsig_fields acc in acc - method class_type_field : class_type_field -> 'acc -> 'acc= - fun { pctf_desc; pctf_loc; pctf_attributes } -> - fun acc -> - let acc = self#class_type_field_desc pctf_desc acc in - let acc = self#location pctf_loc acc in - let acc = self#attributes pctf_attributes acc in acc - method class_type_field_desc : class_type_field_desc -> 'acc -> 'acc= - fun x -> - fun acc -> - match x with - | Pctf_inherit a -> self#class_type a acc - | Pctf_val a -> - ((fun (a, b, c, d) -> - fun acc -> - let acc = self#loc self#label a acc in - let acc = self#mutable_flag b acc in - let acc = self#virtual_flag c acc in - let acc = self#core_type d acc in acc)) a acc - | Pctf_method a -> - ((fun (a, b, c, d) -> - fun acc -> - let acc = self#loc self#label a acc in - let acc = self#private_flag b acc in - let acc = self#virtual_flag c acc in - let acc = self#core_type d acc in acc)) a acc - | Pctf_constraint a -> - ((fun (a, b) -> - fun acc -> - let acc = self#core_type a acc in - let acc = self#core_type b acc in acc)) a acc - | Pctf_attribute a -> self#attribute a acc - | Pctf_extension a -> self#extension a acc - method class_infos : - 'a . ('a -> 'acc -> 'acc) -> 'a class_infos -> 'acc -> 'acc= - fun _a -> - fun - { pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes - } - -> - fun acc -> - let acc = self#virtual_flag pci_virt acc in - let acc = - self#list - (fun (a, b) -> - fun acc -> - let acc = self#core_type a acc in - let acc = self#variance b acc in acc) pci_params acc in - let acc = self#loc self#string pci_name acc in - let acc = _a pci_expr acc in - let acc = self#location pci_loc acc in - let acc = self#attributes pci_attributes acc in acc - method class_description : class_description -> 'acc -> 'acc= + acc) + a acc + | Pctf_attribute a -> self#attribute a acc + | Pctf_extension a -> self#extension a acc + + method class_infos + : 'a. ('a -> 'acc -> 'acc) -> 'a class_infos -> 'acc -> 'acc = + fun _a + { pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes } + acc -> + let acc = self#virtual_flag pci_virt acc in + let acc = + self#list + (fun (a, b) acc -> + let acc = self#core_type a acc in + let acc = + (fun (a, b) acc -> + let acc = self#variance a acc in + let acc = self#injectivity b acc in + acc) + b acc + in + acc) + pci_params acc + in + let acc = self#loc self#string pci_name acc in + let acc = _a pci_expr acc in + let acc = self#location pci_loc acc in + let acc = self#attributes pci_attributes acc in + acc + + method class_description : class_description -> 'acc -> 'acc = self#class_infos self#class_type - method class_type_declaration : class_type_declaration -> 'acc -> 'acc= + + method class_type_declaration : class_type_declaration -> 'acc -> 'acc = self#class_infos self#class_type - method class_expr : class_expr -> 'acc -> 'acc= - fun { pcl_desc; pcl_loc; pcl_attributes } -> - fun acc -> - let acc = self#class_expr_desc pcl_desc acc in - let acc = self#location pcl_loc acc in - let acc = self#attributes pcl_attributes acc in acc - method class_expr_desc : class_expr_desc -> 'acc -> 'acc= - fun x -> - fun acc -> - match x with - | Pcl_constr (a, b) -> - let acc = self#longident_loc a acc in - let acc = self#list self#core_type b acc in acc - | Pcl_structure a -> self#class_structure a acc - | Pcl_fun (a, b, c, d) -> - let acc = self#arg_label a acc in - let acc = self#option self#expression b acc in - let acc = self#pattern c acc in - let acc = self#class_expr d acc in acc - | Pcl_apply (a, b) -> - let acc = self#class_expr a acc in - let acc = - self#list - (fun (a, b) -> - fun acc -> - let acc = self#arg_label a acc in - let acc = self#expression b acc in acc) b acc in - acc - | Pcl_let (a, b, c) -> - let acc = self#rec_flag a acc in - let acc = self#list self#value_binding b acc in - let acc = self#class_expr c acc in acc - | Pcl_constraint (a, b) -> - let acc = self#class_expr a acc in - let acc = self#class_type b acc in acc - | Pcl_extension a -> self#extension a acc - | Pcl_open (a, b) -> - let acc = self#open_description a acc in - let acc = self#class_expr b acc in acc - method class_structure : class_structure -> 'acc -> 'acc= - fun { pcstr_self; pcstr_fields } -> - fun acc -> - let acc = self#pattern pcstr_self acc in - let acc = self#list self#class_field pcstr_fields acc in acc - method class_field : class_field -> 'acc -> 'acc= - fun { pcf_desc; pcf_loc; pcf_attributes } -> - fun acc -> - let acc = self#class_field_desc pcf_desc acc in - let acc = self#location pcf_loc acc in - let acc = self#attributes pcf_attributes acc in acc - method class_field_desc : class_field_desc -> 'acc -> 'acc= - fun x -> - fun acc -> - match x with - | Pcf_inherit (a, b, c) -> - let acc = self#override_flag a acc in - let acc = self#class_expr b acc in - let acc = self#option (self#loc self#string) c acc in acc - | Pcf_val a -> - ((fun (a, b, c) -> - fun acc -> - let acc = self#loc self#label a acc in - let acc = self#mutable_flag b acc in - let acc = self#class_field_kind c acc in acc)) a acc - | Pcf_method a -> - ((fun (a, b, c) -> - fun acc -> - let acc = self#loc self#label a acc in - let acc = self#private_flag b acc in - let acc = self#class_field_kind c acc in acc)) a acc - | Pcf_constraint a -> - ((fun (a, b) -> - fun acc -> - let acc = self#core_type a acc in - let acc = self#core_type b acc in acc)) a acc - | Pcf_initializer a -> self#expression a acc - | Pcf_attribute a -> self#attribute a acc - | Pcf_extension a -> self#extension a acc - method class_field_kind : class_field_kind -> 'acc -> 'acc= - fun x -> - fun acc -> - match x with - | Cfk_virtual a -> self#core_type a acc - | Cfk_concrete (a, b) -> - let acc = self#override_flag a acc in - let acc = self#expression b acc in acc - method class_declaration : class_declaration -> 'acc -> 'acc= + + method class_expr : class_expr -> 'acc -> 'acc = + fun { pcl_desc; pcl_loc; pcl_attributes } acc -> + let acc = self#class_expr_desc pcl_desc acc in + let acc = self#location pcl_loc acc in + let acc = self#attributes pcl_attributes acc in + acc + + method class_expr_desc : class_expr_desc -> 'acc -> 'acc = + fun x acc -> + match x with + | Pcl_constr (a, b) -> + let acc = self#longident_loc a acc in + let acc = self#list self#core_type b acc in + acc + | Pcl_structure a -> self#class_structure a acc + | Pcl_fun (a, b, c, d) -> + let acc = self#arg_label a acc in + let acc = self#option self#expression b acc in + let acc = self#pattern c acc in + let acc = self#class_expr d acc in + acc + | Pcl_apply (a, b) -> + let acc = self#class_expr a acc in + let acc = + self#list + (fun (a, b) acc -> + let acc = self#arg_label a acc in + let acc = self#expression b acc in + acc) + b acc + in + acc + | Pcl_let (a, b, c) -> + let acc = self#rec_flag a acc in + let acc = self#list self#value_binding b acc in + let acc = self#class_expr c acc in + acc + | Pcl_constraint (a, b) -> + let acc = self#class_expr a acc in + let acc = self#class_type b acc in + acc + | Pcl_extension a -> self#extension a acc + | Pcl_open (a, b) -> + let acc = self#open_description a acc in + let acc = self#class_expr b acc in + acc + + method class_structure : class_structure -> 'acc -> 'acc = + fun { pcstr_self; pcstr_fields } acc -> + let acc = self#pattern pcstr_self acc in + let acc = self#list self#class_field pcstr_fields acc in + acc + + method class_field : class_field -> 'acc -> 'acc = + fun { pcf_desc; pcf_loc; pcf_attributes } acc -> + let acc = self#class_field_desc pcf_desc acc in + let acc = self#location pcf_loc acc in + let acc = self#attributes pcf_attributes acc in + acc + + method class_field_desc : class_field_desc -> 'acc -> 'acc = + fun x acc -> + match x with + | Pcf_inherit (a, b, c) -> + let acc = self#override_flag a acc in + let acc = self#class_expr b acc in + let acc = self#option (self#loc self#string) c acc in + acc + | Pcf_val a -> + (fun (a, b, c) acc -> + let acc = self#loc self#label a acc in + let acc = self#mutable_flag b acc in + let acc = self#class_field_kind c acc in + acc) + a acc + | Pcf_method a -> + (fun (a, b, c) acc -> + let acc = self#loc self#label a acc in + let acc = self#private_flag b acc in + let acc = self#class_field_kind c acc in + acc) + a acc + | Pcf_constraint a -> + (fun (a, b) acc -> + let acc = self#core_type a acc in + let acc = self#core_type b acc in + acc) + a acc + | Pcf_initializer a -> self#expression a acc + | Pcf_attribute a -> self#attribute a acc + | Pcf_extension a -> self#extension a acc + + method class_field_kind : class_field_kind -> 'acc -> 'acc = + fun x acc -> + match x with + | Cfk_virtual a -> self#core_type a acc + | Cfk_concrete (a, b) -> + let acc = self#override_flag a acc in + let acc = self#expression b acc in + acc + + method class_declaration : class_declaration -> 'acc -> 'acc = self#class_infos self#class_expr - method module_type : module_type -> 'acc -> 'acc= - fun { pmty_desc; pmty_loc; pmty_attributes } -> - fun acc -> - let acc = self#module_type_desc pmty_desc acc in - let acc = self#location pmty_loc acc in - let acc = self#attributes pmty_attributes acc in acc - method module_type_desc : module_type_desc -> 'acc -> 'acc= - fun x -> - fun acc -> - match x with - | Pmty_ident a -> self#longident_loc a acc - | Pmty_signature a -> self#signature a acc - | Pmty_functor (a, b) -> - let acc = self#functor_parameter a acc in - let acc = self#module_type b acc in acc - | Pmty_with (a, b) -> - let acc = self#module_type a acc in - let acc = self#list self#with_constraint b acc in acc - | Pmty_typeof a -> self#module_expr a acc - | Pmty_extension a -> self#extension a acc - | Pmty_alias a -> self#longident_loc a acc - method functor_parameter : functor_parameter -> 'acc -> 'acc= - fun x -> - fun acc -> - match x with - | Unit -> acc - | Named (a, b) -> - let acc = self#loc (self#option self#string) a acc in - let acc = self#module_type b acc in acc - method signature : signature -> 'acc -> 'acc= - self#list self#signature_item - method signature_item : signature_item -> 'acc -> 'acc= - fun { psig_desc; psig_loc } -> - fun acc -> - let acc = self#signature_item_desc psig_desc acc in - let acc = self#location psig_loc acc in acc - method signature_item_desc : signature_item_desc -> 'acc -> 'acc= - fun x -> - fun acc -> - match x with - | Psig_value a -> self#value_description a acc - | Psig_type (a, b) -> - let acc = self#rec_flag a acc in - let acc = self#list self#type_declaration b acc in acc - | Psig_typesubst a -> self#list self#type_declaration a acc - | Psig_typext a -> self#type_extension a acc - | Psig_exception a -> self#type_exception a acc - | Psig_module a -> self#module_declaration a acc - | Psig_modsubst a -> self#module_substitution a acc - | Psig_recmodule a -> self#list self#module_declaration a acc - | Psig_modtype a -> self#module_type_declaration a acc - | Psig_open a -> self#open_description a acc - | Psig_include a -> self#include_description a acc - | Psig_class a -> self#list self#class_description a acc - | Psig_class_type a -> self#list self#class_type_declaration a acc - | Psig_attribute a -> self#attribute a acc - | Psig_extension (a, b) -> - let acc = self#extension a acc in - let acc = self#attributes b acc in acc - method module_declaration : module_declaration -> 'acc -> 'acc= - fun { pmd_name; pmd_type; pmd_attributes; pmd_loc } -> - fun acc -> - let acc = self#loc (self#option self#string) pmd_name acc in - let acc = self#module_type pmd_type acc in - let acc = self#attributes pmd_attributes acc in - let acc = self#location pmd_loc acc in acc - method module_substitution : module_substitution -> 'acc -> 'acc= - fun { pms_name; pms_manifest; pms_attributes; pms_loc } -> - fun acc -> - let acc = self#loc self#string pms_name acc in - let acc = self#longident_loc pms_manifest acc in - let acc = self#attributes pms_attributes acc in - let acc = self#location pms_loc acc in acc - method module_type_declaration : module_type_declaration -> 'acc -> 'acc= - fun { pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc } -> - fun acc -> - let acc = self#loc self#string pmtd_name acc in - let acc = self#option self#module_type pmtd_type acc in - let acc = self#attributes pmtd_attributes acc in - let acc = self#location pmtd_loc acc in acc - method open_infos : - 'a . ('a -> 'acc -> 'acc) -> 'a open_infos -> 'acc -> 'acc= - fun _a -> - fun { popen_expr; popen_override; popen_loc; popen_attributes } -> - fun acc -> - let acc = _a popen_expr acc in - let acc = self#override_flag popen_override acc in - let acc = self#location popen_loc acc in - let acc = self#attributes popen_attributes acc in acc - method open_description : open_description -> 'acc -> 'acc= + + method module_type : module_type -> 'acc -> 'acc = + fun { pmty_desc; pmty_loc; pmty_attributes } acc -> + let acc = self#module_type_desc pmty_desc acc in + let acc = self#location pmty_loc acc in + let acc = self#attributes pmty_attributes acc in + acc + + method module_type_desc : module_type_desc -> 'acc -> 'acc = + fun x acc -> + match x with + | Pmty_ident a -> self#longident_loc a acc + | Pmty_signature a -> self#signature a acc + | Pmty_functor (a, b) -> + let acc = self#functor_parameter a acc in + let acc = self#module_type b acc in + acc + | Pmty_with (a, b) -> + let acc = self#module_type a acc in + let acc = self#list self#with_constraint b acc in + acc + | Pmty_typeof a -> self#module_expr a acc + | Pmty_extension a -> self#extension a acc + | Pmty_alias a -> self#longident_loc a acc + + method functor_parameter : functor_parameter -> 'acc -> 'acc = + fun x acc -> + match x with + | Unit -> acc + | Named (a, b) -> + let acc = self#loc (self#option self#string) a acc in + let acc = self#module_type b acc in + acc + + method signature : signature -> 'acc -> 'acc = self#list self#signature_item + + method signature_item : signature_item -> 'acc -> 'acc = + fun { psig_desc; psig_loc } acc -> + let acc = self#signature_item_desc psig_desc acc in + let acc = self#location psig_loc acc in + acc + + method signature_item_desc : signature_item_desc -> 'acc -> 'acc = + fun x acc -> + match x with + | Psig_value a -> self#value_description a acc + | Psig_type (a, b) -> + let acc = self#rec_flag a acc in + let acc = self#list self#type_declaration b acc in + acc + | Psig_typesubst a -> self#list self#type_declaration a acc + | Psig_typext a -> self#type_extension a acc + | Psig_exception a -> self#type_exception a acc + | Psig_module a -> self#module_declaration a acc + | Psig_modsubst a -> self#module_substitution a acc + | Psig_recmodule a -> self#list self#module_declaration a acc + | Psig_modtype a -> self#module_type_declaration a acc + | Psig_open a -> self#open_description a acc + | Psig_include a -> self#include_description a acc + | Psig_class a -> self#list self#class_description a acc + | Psig_class_type a -> self#list self#class_type_declaration a acc + | Psig_attribute a -> self#attribute a acc + | Psig_extension (a, b) -> + let acc = self#extension a acc in + let acc = self#attributes b acc in + acc + + method module_declaration : module_declaration -> 'acc -> 'acc = + fun { pmd_name; pmd_type; pmd_attributes; pmd_loc } acc -> + let acc = self#loc (self#option self#string) pmd_name acc in + let acc = self#module_type pmd_type acc in + let acc = self#attributes pmd_attributes acc in + let acc = self#location pmd_loc acc in + acc + + method module_substitution : module_substitution -> 'acc -> 'acc = + fun { pms_name; pms_manifest; pms_attributes; pms_loc } acc -> + let acc = self#loc self#string pms_name acc in + let acc = self#longident_loc pms_manifest acc in + let acc = self#attributes pms_attributes acc in + let acc = self#location pms_loc acc in + acc + + method module_type_declaration : module_type_declaration -> 'acc -> 'acc = + fun { pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc } acc -> + let acc = self#loc self#string pmtd_name acc in + let acc = self#option self#module_type pmtd_type acc in + let acc = self#attributes pmtd_attributes acc in + let acc = self#location pmtd_loc acc in + acc + + method open_infos + : 'a. ('a -> 'acc -> 'acc) -> 'a open_infos -> 'acc -> 'acc = + fun _a { popen_expr; popen_override; popen_loc; popen_attributes } acc -> + let acc = _a popen_expr acc in + let acc = self#override_flag popen_override acc in + let acc = self#location popen_loc acc in + let acc = self#attributes popen_attributes acc in + acc + + method open_description : open_description -> 'acc -> 'acc = self#open_infos self#longident_loc - method open_declaration : open_declaration -> 'acc -> 'acc= + + method open_declaration : open_declaration -> 'acc -> 'acc = self#open_infos self#module_expr - method include_infos : - 'a . ('a -> 'acc -> 'acc) -> 'a include_infos -> 'acc -> 'acc= - fun _a -> - fun { pincl_mod; pincl_loc; pincl_attributes } -> - fun acc -> - let acc = _a pincl_mod acc in - let acc = self#location pincl_loc acc in - let acc = self#attributes pincl_attributes acc in acc - method include_description : include_description -> 'acc -> 'acc= + + method include_infos + : 'a. ('a -> 'acc -> 'acc) -> 'a include_infos -> 'acc -> 'acc = + fun _a { pincl_mod; pincl_loc; pincl_attributes } acc -> + let acc = _a pincl_mod acc in + let acc = self#location pincl_loc acc in + let acc = self#attributes pincl_attributes acc in + acc + + method include_description : include_description -> 'acc -> 'acc = self#include_infos self#module_type - method include_declaration : include_declaration -> 'acc -> 'acc= + + method include_declaration : include_declaration -> 'acc -> 'acc = self#include_infos self#module_expr - method with_constraint : with_constraint -> 'acc -> 'acc= - fun x -> - fun acc -> - match x with - | Pwith_type (a, b) -> - let acc = self#longident_loc a acc in - let acc = self#type_declaration b acc in acc - | Pwith_module (a, b) -> - let acc = self#longident_loc a acc in - let acc = self#longident_loc b acc in acc - | Pwith_typesubst (a, b) -> - let acc = self#longident_loc a acc in - let acc = self#type_declaration b acc in acc - | Pwith_modsubst (a, b) -> - let acc = self#longident_loc a acc in - let acc = self#longident_loc b acc in acc - method module_expr : module_expr -> 'acc -> 'acc= - fun { pmod_desc; pmod_loc; pmod_attributes } -> - fun acc -> - let acc = self#module_expr_desc pmod_desc acc in - let acc = self#location pmod_loc acc in - let acc = self#attributes pmod_attributes acc in acc - method module_expr_desc : module_expr_desc -> 'acc -> 'acc= - fun x -> - fun acc -> - match x with - | Pmod_ident a -> self#longident_loc a acc - | Pmod_structure a -> self#structure a acc - | Pmod_functor (a, b) -> - let acc = self#functor_parameter a acc in - let acc = self#module_expr b acc in acc - | Pmod_apply (a, b) -> - let acc = self#module_expr a acc in - let acc = self#module_expr b acc in acc - | Pmod_constraint (a, b) -> - let acc = self#module_expr a acc in - let acc = self#module_type b acc in acc - | Pmod_unpack a -> self#expression a acc - | Pmod_extension a -> self#extension a acc - method structure : structure -> 'acc -> 'acc= - self#list self#structure_item - method structure_item : structure_item -> 'acc -> 'acc= - fun { pstr_desc; pstr_loc } -> - fun acc -> - let acc = self#structure_item_desc pstr_desc acc in - let acc = self#location pstr_loc acc in acc - method structure_item_desc : structure_item_desc -> 'acc -> 'acc= - fun x -> - fun acc -> - match x with - | Pstr_eval (a, b) -> - let acc = self#expression a acc in - let acc = self#attributes b acc in acc - | Pstr_value (a, b) -> - let acc = self#rec_flag a acc in - let acc = self#list self#value_binding b acc in acc - | Pstr_primitive a -> self#value_description a acc - | Pstr_type (a, b) -> - let acc = self#rec_flag a acc in - let acc = self#list self#type_declaration b acc in acc - | Pstr_typext a -> self#type_extension a acc - | Pstr_exception a -> self#type_exception a acc - | Pstr_module a -> self#module_binding a acc - | Pstr_recmodule a -> self#list self#module_binding a acc - | Pstr_modtype a -> self#module_type_declaration a acc - | Pstr_open a -> self#open_declaration a acc - | Pstr_class a -> self#list self#class_declaration a acc - | Pstr_class_type a -> self#list self#class_type_declaration a acc - | Pstr_include a -> self#include_declaration a acc - | Pstr_attribute a -> self#attribute a acc - | Pstr_extension (a, b) -> - let acc = self#extension a acc in - let acc = self#attributes b acc in acc - method value_binding : value_binding -> 'acc -> 'acc= - fun { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } -> - fun acc -> - let acc = self#pattern pvb_pat acc in - let acc = self#expression pvb_expr acc in - let acc = self#attributes pvb_attributes acc in - let acc = self#location pvb_loc acc in acc - method module_binding : module_binding -> 'acc -> 'acc= - fun { pmb_name; pmb_expr; pmb_attributes; pmb_loc } -> - fun acc -> - let acc = self#loc (self#option self#string) pmb_name acc in - let acc = self#module_expr pmb_expr acc in - let acc = self#attributes pmb_attributes acc in - let acc = self#location pmb_loc acc in acc - method toplevel_phrase : toplevel_phrase -> 'acc -> 'acc= - fun x -> - fun acc -> - match x with - | Ptop_def a -> self#structure a acc - | Ptop_dir a -> self#toplevel_directive a acc - method toplevel_directive : toplevel_directive -> 'acc -> 'acc= - fun { pdir_name; pdir_arg; pdir_loc } -> - fun acc -> - let acc = self#loc self#string pdir_name acc in - let acc = self#option self#directive_argument pdir_arg acc in - let acc = self#location pdir_loc acc in acc - method directive_argument : directive_argument -> 'acc -> 'acc= - fun { pdira_desc; pdira_loc } -> - fun acc -> - let acc = self#directive_argument_desc pdira_desc acc in - let acc = self#location pdira_loc acc in acc - method directive_argument_desc : directive_argument_desc -> 'acc -> 'acc= - fun x -> - fun acc -> - match x with - | Pdir_string a -> self#string a acc - | Pdir_int (a, b) -> - let acc = self#string a acc in - let acc = self#option self#char b acc in acc - | Pdir_ident a -> self#longident a acc - | Pdir_bool a -> self#bool a acc + + method with_constraint : with_constraint -> 'acc -> 'acc = + fun x acc -> + match x with + | Pwith_type (a, b) -> + let acc = self#longident_loc a acc in + let acc = self#type_declaration b acc in + acc + | Pwith_module (a, b) -> + let acc = self#longident_loc a acc in + let acc = self#longident_loc b acc in + acc + | Pwith_typesubst (a, b) -> + let acc = self#longident_loc a acc in + let acc = self#type_declaration b acc in + acc + | Pwith_modsubst (a, b) -> + let acc = self#longident_loc a acc in + let acc = self#longident_loc b acc in + acc + + method module_expr : module_expr -> 'acc -> 'acc = + fun { pmod_desc; pmod_loc; pmod_attributes } acc -> + let acc = self#module_expr_desc pmod_desc acc in + let acc = self#location pmod_loc acc in + let acc = self#attributes pmod_attributes acc in + acc + + method module_expr_desc : module_expr_desc -> 'acc -> 'acc = + fun x acc -> + match x with + | Pmod_ident a -> self#longident_loc a acc + | Pmod_structure a -> self#structure a acc + | Pmod_functor (a, b) -> + let acc = self#functor_parameter a acc in + let acc = self#module_expr b acc in + acc + | Pmod_apply (a, b) -> + let acc = self#module_expr a acc in + let acc = self#module_expr b acc in + acc + | Pmod_constraint (a, b) -> + let acc = self#module_expr a acc in + let acc = self#module_type b acc in + acc + | Pmod_unpack a -> self#expression a acc + | Pmod_extension a -> self#extension a acc + + method structure : structure -> 'acc -> 'acc = self#list self#structure_item + + method structure_item : structure_item -> 'acc -> 'acc = + fun { pstr_desc; pstr_loc } acc -> + let acc = self#structure_item_desc pstr_desc acc in + let acc = self#location pstr_loc acc in + acc + + method structure_item_desc : structure_item_desc -> 'acc -> 'acc = + fun x acc -> + match x with + | Pstr_eval (a, b) -> + let acc = self#expression a acc in + let acc = self#attributes b acc in + acc + | Pstr_value (a, b) -> + let acc = self#rec_flag a acc in + let acc = self#list self#value_binding b acc in + acc + | Pstr_primitive a -> self#value_description a acc + | Pstr_type (a, b) -> + let acc = self#rec_flag a acc in + let acc = self#list self#type_declaration b acc in + acc + | Pstr_typext a -> self#type_extension a acc + | Pstr_exception a -> self#type_exception a acc + | Pstr_module a -> self#module_binding a acc + | Pstr_recmodule a -> self#list self#module_binding a acc + | Pstr_modtype a -> self#module_type_declaration a acc + | Pstr_open a -> self#open_declaration a acc + | Pstr_class a -> self#list self#class_declaration a acc + | Pstr_class_type a -> self#list self#class_type_declaration a acc + | Pstr_include a -> self#include_declaration a acc + | Pstr_attribute a -> self#attribute a acc + | Pstr_extension (a, b) -> + let acc = self#extension a acc in + let acc = self#attributes b acc in + acc + + method value_binding : value_binding -> 'acc -> 'acc = + fun { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } acc -> + let acc = self#pattern pvb_pat acc in + let acc = self#expression pvb_expr acc in + let acc = self#attributes pvb_attributes acc in + let acc = self#location pvb_loc acc in + acc + + method module_binding : module_binding -> 'acc -> 'acc = + fun { pmb_name; pmb_expr; pmb_attributes; pmb_loc } acc -> + let acc = self#loc (self#option self#string) pmb_name acc in + let acc = self#module_expr pmb_expr acc in + let acc = self#attributes pmb_attributes acc in + let acc = self#location pmb_loc acc in + acc + + method toplevel_phrase : toplevel_phrase -> 'acc -> 'acc = + fun x acc -> + match x with + | Ptop_def a -> self#structure a acc + | Ptop_dir a -> self#toplevel_directive a acc + + method toplevel_directive : toplevel_directive -> 'acc -> 'acc = + fun { pdir_name; pdir_arg; pdir_loc } acc -> + let acc = self#loc self#string pdir_name acc in + let acc = self#option self#directive_argument pdir_arg acc in + let acc = self#location pdir_loc acc in + acc + + method directive_argument : directive_argument -> 'acc -> 'acc = + fun { pdira_desc; pdira_loc } acc -> + let acc = self#directive_argument_desc pdira_desc acc in + let acc = self#location pdira_loc acc in + acc + + method directive_argument_desc : directive_argument_desc -> 'acc -> 'acc = + fun x acc -> + match x with + | Pdir_string a -> self#string a acc + | Pdir_int (a, b) -> + let acc = self#string a acc in + let acc = self#option self#char b acc in + acc + | Pdir_ident a -> self#longident a acc + | Pdir_bool a -> self#bool a acc + + method cases : cases -> 'acc -> 'acc = self#list self#case end + class virtual ['acc] fold_map = object (self) - method virtual bool : bool -> 'acc -> (bool * 'acc) - method virtual char : char -> 'acc -> (char * 'acc) - method virtual int : int -> 'acc -> (int * 'acc) - method virtual list : - 'a . ('a -> 'acc -> ('a * 'acc)) -> 'a list -> 'acc -> ('a list * 'acc) - method virtual option : - 'a . - ('a -> 'acc -> ('a * 'acc)) -> - 'a option -> 'acc -> ('a option * 'acc) - method virtual string : string -> 'acc -> (string * 'acc) - method position : position -> 'acc -> (position * 'acc)= - fun { pos_fname; pos_lnum; pos_bol; pos_cnum } -> - fun acc -> - let (pos_fname, acc) = self#string pos_fname acc in - let (pos_lnum, acc) = self#int pos_lnum acc in - let (pos_bol, acc) = self#int pos_bol acc in - let (pos_cnum, acc) = self#int pos_cnum acc in - ({ pos_fname; pos_lnum; pos_bol; pos_cnum }, acc) - method location : location -> 'acc -> (location * 'acc)= - fun { loc_start; loc_end; loc_ghost } -> - fun acc -> - let (loc_start, acc) = self#position loc_start acc in - let (loc_end, acc) = self#position loc_end acc in - let (loc_ghost, acc) = self#bool loc_ghost acc in - ({ loc_start; loc_end; loc_ghost }, acc) - method location_stack : - location_stack -> 'acc -> (location_stack * 'acc)= + method virtual bool : bool -> 'acc -> bool * 'acc + + method virtual char : char -> 'acc -> char * 'acc + + method virtual int : int -> 'acc -> int * 'acc + + method virtual list + : 'a. ('a -> 'acc -> 'a * 'acc) -> 'a list -> 'acc -> 'a list * 'acc + + method virtual option + : 'a. ('a -> 'acc -> 'a * 'acc) -> 'a option -> 'acc -> 'a option * 'acc + + method virtual string : string -> 'acc -> string * 'acc + + method position : position -> 'acc -> position * 'acc = + fun { pos_fname; pos_lnum; pos_bol; pos_cnum } acc -> + let pos_fname, acc = self#string pos_fname acc in + let pos_lnum, acc = self#int pos_lnum acc in + let pos_bol, acc = self#int pos_bol acc in + let pos_cnum, acc = self#int pos_cnum acc in + ({ pos_fname; pos_lnum; pos_bol; pos_cnum }, acc) + + method location : location -> 'acc -> location * 'acc = + fun { loc_start; loc_end; loc_ghost } acc -> + let loc_start, acc = self#position loc_start acc in + let loc_end, acc = self#position loc_end acc in + let loc_ghost, acc = self#bool loc_ghost acc in + ({ loc_start; loc_end; loc_ghost }, acc) + + method location_stack : location_stack -> 'acc -> location_stack * 'acc = self#list self#location - method loc : - 'a . ('a -> 'acc -> ('a * 'acc)) -> 'a loc -> 'acc -> ('a loc * 'acc)= - fun _a -> - fun { txt; loc } -> - fun acc -> - let (txt, acc) = _a txt acc in - let (loc, acc) = self#location loc acc in ({ txt; loc }, acc) - method longident : longident -> 'acc -> (longident * 'acc)= - fun x -> - fun acc -> - match x with - | Lident a -> let (a, acc) = self#string a acc in ((Lident a), acc) - | Ldot (a, b) -> - let (a, acc) = self#longident a acc in - let (b, acc) = self#string b acc in ((Ldot (a, b)), acc) - | Lapply (a, b) -> - let (a, acc) = self#longident a acc in - let (b, acc) = self#longident b acc in ((Lapply (a, b)), acc) - method longident_loc : longident_loc -> 'acc -> (longident_loc * 'acc)= + + method loc + : 'a. ('a -> 'acc -> 'a * 'acc) -> 'a loc -> 'acc -> 'a loc * 'acc = + fun _a { txt; loc } acc -> + let txt, acc = _a txt acc in + let loc, acc = self#location loc acc in + ({ txt; loc }, acc) + + method longident : longident -> 'acc -> longident * 'acc = + fun x acc -> + match x with + | Lident a -> + let a, acc = self#string a acc in + (Lident a, acc) + | Ldot (a, b) -> + let a, acc = self#longident a acc in + let b, acc = self#string b acc in + (Ldot (a, b), acc) + | Lapply (a, b) -> + let a, acc = self#longident a acc in + let b, acc = self#longident b acc in + (Lapply (a, b), acc) + + method longident_loc : longident_loc -> 'acc -> longident_loc * 'acc = self#loc self#longident - method rec_flag : rec_flag -> 'acc -> (rec_flag * 'acc)= - fun x -> fun acc -> (x, acc) - method direction_flag : - direction_flag -> 'acc -> (direction_flag * 'acc)= - fun x -> fun acc -> (x, acc) - method private_flag : private_flag -> 'acc -> (private_flag * 'acc)= - fun x -> fun acc -> (x, acc) - method mutable_flag : mutable_flag -> 'acc -> (mutable_flag * 'acc)= - fun x -> fun acc -> (x, acc) - method virtual_flag : virtual_flag -> 'acc -> (virtual_flag * 'acc)= - fun x -> fun acc -> (x, acc) - method override_flag : override_flag -> 'acc -> (override_flag * 'acc)= - fun x -> fun acc -> (x, acc) - method closed_flag : closed_flag -> 'acc -> (closed_flag * 'acc)= - fun x -> fun acc -> (x, acc) - method label : label -> 'acc -> (label * 'acc)= self#string - method arg_label : arg_label -> 'acc -> (arg_label * 'acc)= - fun x -> - fun acc -> - match x with - | Nolabel -> (Nolabel, acc) - | Labelled a -> - let (a, acc) = self#string a acc in ((Labelled a), acc) - | Optional a -> - let (a, acc) = self#string a acc in ((Optional a), acc) - method variance : variance -> 'acc -> (variance * 'acc)= - fun x -> fun acc -> (x, acc) - method constant : constant -> 'acc -> (constant * 'acc)= - fun x -> - fun acc -> - match x with - | Pconst_integer (a, b) -> - let (a, acc) = self#string a acc in - let (b, acc) = self#option self#char b acc in - ((Pconst_integer (a, b)), acc) - | Pconst_char a -> - let (a, acc) = self#char a acc in ((Pconst_char a), acc) - | Pconst_string (a, b) -> - let (a, acc) = self#string a acc in - let (b, acc) = self#option self#string b acc in - ((Pconst_string (a, b)), acc) - | Pconst_float (a, b) -> - let (a, acc) = self#string a acc in - let (b, acc) = self#option self#char b acc in - ((Pconst_float (a, b)), acc) - method attribute : attribute -> 'acc -> (attribute * 'acc)= - fun { attr_name; attr_payload; attr_loc } -> - fun acc -> - let (attr_name, acc) = self#loc self#string attr_name acc in - let (attr_payload, acc) = self#payload attr_payload acc in - let (attr_loc, acc) = self#location attr_loc acc in - ({ attr_name; attr_payload; attr_loc }, acc) - method extension : extension -> 'acc -> (extension * 'acc)= - fun (a, b) -> - fun acc -> - let (a, acc) = self#loc self#string a acc in - let (b, acc) = self#payload b acc in ((a, b), acc) - method attributes : attributes -> 'acc -> (attributes * 'acc)= + + method rec_flag : rec_flag -> 'acc -> rec_flag * 'acc = fun x acc -> (x, acc) + + method direction_flag : direction_flag -> 'acc -> direction_flag * 'acc = + fun x acc -> (x, acc) + + method private_flag : private_flag -> 'acc -> private_flag * 'acc = + fun x acc -> (x, acc) + + method mutable_flag : mutable_flag -> 'acc -> mutable_flag * 'acc = + fun x acc -> (x, acc) + + method virtual_flag : virtual_flag -> 'acc -> virtual_flag * 'acc = + fun x acc -> (x, acc) + + method override_flag : override_flag -> 'acc -> override_flag * 'acc = + fun x acc -> (x, acc) + + method closed_flag : closed_flag -> 'acc -> closed_flag * 'acc = + fun x acc -> (x, acc) + + method label : label -> 'acc -> label * 'acc = self#string + + method arg_label : arg_label -> 'acc -> arg_label * 'acc = + fun x acc -> + match x with + | Nolabel -> (Nolabel, acc) + | Labelled a -> + let a, acc = self#string a acc in + (Labelled a, acc) + | Optional a -> + let a, acc = self#string a acc in + (Optional a, acc) + + method variance : variance -> 'acc -> variance * 'acc = fun x acc -> (x, acc) + + method injectivity : injectivity -> 'acc -> injectivity * 'acc = + fun x acc -> (x, acc) + + method constant : constant -> 'acc -> constant * 'acc = + fun x acc -> + match x with + | Pconst_integer (a, b) -> + let a, acc = self#string a acc in + let b, acc = self#option self#char b acc in + (Pconst_integer (a, b), acc) + | Pconst_char a -> + let a, acc = self#char a acc in + (Pconst_char a, acc) + | Pconst_string (a, b, c) -> + let a, acc = self#string a acc in + let b, acc = self#location b acc in + let c, acc = self#option self#string c acc in + (Pconst_string (a, b, c), acc) + | Pconst_float (a, b) -> + let a, acc = self#string a acc in + let b, acc = self#option self#char b acc in + (Pconst_float (a, b), acc) + + method attribute : attribute -> 'acc -> attribute * 'acc = + fun { attr_name; attr_payload; attr_loc } acc -> + let attr_name, acc = self#loc self#string attr_name acc in + let attr_payload, acc = self#payload attr_payload acc in + let attr_loc, acc = self#location attr_loc acc in + ({ attr_name; attr_payload; attr_loc }, acc) + + method extension : extension -> 'acc -> extension * 'acc = + fun (a, b) acc -> + let a, acc = self#loc self#string a acc in + let b, acc = self#payload b acc in + ((a, b), acc) + + method attributes : attributes -> 'acc -> attributes * 'acc = self#list self#attribute - method payload : payload -> 'acc -> (payload * 'acc)= - fun x -> - fun acc -> - match x with - | PStr a -> let (a, acc) = self#structure a acc in ((PStr a), acc) - | PSig a -> let (a, acc) = self#signature a acc in ((PSig a), acc) - | PTyp a -> let (a, acc) = self#core_type a acc in ((PTyp a), acc) - | PPat (a, b) -> - let (a, acc) = self#pattern a acc in - let (b, acc) = self#option self#expression b acc in - ((PPat (a, b)), acc) - method core_type : core_type -> 'acc -> (core_type * 'acc)= - fun { ptyp_desc; ptyp_loc; ptyp_loc_stack; ptyp_attributes } -> - fun acc -> - let (ptyp_desc, acc) = self#core_type_desc ptyp_desc acc in - let (ptyp_loc, acc) = self#location ptyp_loc acc in - let (ptyp_loc_stack, acc) = self#location_stack ptyp_loc_stack acc in - let (ptyp_attributes, acc) = self#attributes ptyp_attributes acc in - ({ ptyp_desc; ptyp_loc; ptyp_loc_stack; ptyp_attributes }, acc) - method core_type_desc : - core_type_desc -> 'acc -> (core_type_desc * 'acc)= - fun x -> - fun acc -> - match x with - | Ptyp_any -> (Ptyp_any, acc) - | Ptyp_var a -> - let (a, acc) = self#string a acc in ((Ptyp_var a), acc) - | Ptyp_arrow (a, b, c) -> - let (a, acc) = self#arg_label a acc in - let (b, acc) = self#core_type b acc in - let (c, acc) = self#core_type c acc in - ((Ptyp_arrow (a, b, c)), acc) - | Ptyp_tuple a -> - let (a, acc) = self#list self#core_type a acc in - ((Ptyp_tuple a), acc) - | Ptyp_constr (a, b) -> - let (a, acc) = self#longident_loc a acc in - let (b, acc) = self#list self#core_type b acc in - ((Ptyp_constr (a, b)), acc) - | Ptyp_object (a, b) -> - let (a, acc) = self#list self#object_field a acc in - let (b, acc) = self#closed_flag b acc in - ((Ptyp_object (a, b)), acc) - | Ptyp_class (a, b) -> - let (a, acc) = self#longident_loc a acc in - let (b, acc) = self#list self#core_type b acc in - ((Ptyp_class (a, b)), acc) - | Ptyp_alias (a, b) -> - let (a, acc) = self#core_type a acc in - let (b, acc) = self#string b acc in ((Ptyp_alias (a, b)), acc) - | Ptyp_variant (a, b, c) -> - let (a, acc) = self#list self#row_field a acc in - let (b, acc) = self#closed_flag b acc in - let (c, acc) = self#option (self#list self#label) c acc in - ((Ptyp_variant (a, b, c)), acc) - | Ptyp_poly (a, b) -> - let (a, acc) = self#list (self#loc self#string) a acc in - let (b, acc) = self#core_type b acc in - ((Ptyp_poly (a, b)), acc) - | Ptyp_package a -> - let (a, acc) = self#package_type a acc in - ((Ptyp_package a), acc) - | Ptyp_extension a -> - let (a, acc) = self#extension a acc in - ((Ptyp_extension a), acc) - method package_type : package_type -> 'acc -> (package_type * 'acc)= - fun (a, b) -> - fun acc -> - let (a, acc) = self#longident_loc a acc in - let (b, acc) = - self#list - (fun (a, b) -> - fun acc -> - let (a, acc) = self#longident_loc a acc in - let (b, acc) = self#core_type b acc in ((a, b), acc)) b - acc in - ((a, b), acc) - method row_field : row_field -> 'acc -> (row_field * 'acc)= - fun { prf_desc; prf_loc; prf_attributes } -> - fun acc -> - let (prf_desc, acc) = self#row_field_desc prf_desc acc in - let (prf_loc, acc) = self#location prf_loc acc in - let (prf_attributes, acc) = self#attributes prf_attributes acc in - ({ prf_desc; prf_loc; prf_attributes }, acc) - method row_field_desc : - row_field_desc -> 'acc -> (row_field_desc * 'acc)= - fun x -> - fun acc -> - match x with - | Rtag (a, b, c) -> - let (a, acc) = self#loc self#label a acc in - let (b, acc) = self#bool b acc in - let (c, acc) = self#list self#core_type c acc in - ((Rtag (a, b, c)), acc) - | Rinherit a -> - let (a, acc) = self#core_type a acc in ((Rinherit a), acc) - method object_field : object_field -> 'acc -> (object_field * 'acc)= - fun { pof_desc; pof_loc; pof_attributes } -> - fun acc -> - let (pof_desc, acc) = self#object_field_desc pof_desc acc in - let (pof_loc, acc) = self#location pof_loc acc in - let (pof_attributes, acc) = self#attributes pof_attributes acc in - ({ pof_desc; pof_loc; pof_attributes }, acc) - method object_field_desc : - object_field_desc -> 'acc -> (object_field_desc * 'acc)= - fun x -> - fun acc -> - match x with - | Otag (a, b) -> - let (a, acc) = self#loc self#label a acc in - let (b, acc) = self#core_type b acc in ((Otag (a, b)), acc) - | Oinherit a -> - let (a, acc) = self#core_type a acc in ((Oinherit a), acc) - method pattern : pattern -> 'acc -> (pattern * 'acc)= - fun { ppat_desc; ppat_loc; ppat_loc_stack; ppat_attributes } -> - fun acc -> - let (ppat_desc, acc) = self#pattern_desc ppat_desc acc in - let (ppat_loc, acc) = self#location ppat_loc acc in - let (ppat_loc_stack, acc) = self#location_stack ppat_loc_stack acc in - let (ppat_attributes, acc) = self#attributes ppat_attributes acc in - ({ ppat_desc; ppat_loc; ppat_loc_stack; ppat_attributes }, acc) - method pattern_desc : pattern_desc -> 'acc -> (pattern_desc * 'acc)= - fun x -> - fun acc -> - match x with - | Ppat_any -> (Ppat_any, acc) - | Ppat_var a -> - let (a, acc) = self#loc self#string a acc in - ((Ppat_var a), acc) - | Ppat_alias (a, b) -> - let (a, acc) = self#pattern a acc in - let (b, acc) = self#loc self#string b acc in - ((Ppat_alias (a, b)), acc) - | Ppat_constant a -> - let (a, acc) = self#constant a acc in ((Ppat_constant a), acc) - | Ppat_interval (a, b) -> - let (a, acc) = self#constant a acc in - let (b, acc) = self#constant b acc in - ((Ppat_interval (a, b)), acc) - | Ppat_tuple a -> - let (a, acc) = self#list self#pattern a acc in - ((Ppat_tuple a), acc) - | Ppat_construct (a, b) -> - let (a, acc) = self#longident_loc a acc in - let (b, acc) = self#option self#pattern b acc in - ((Ppat_construct (a, b)), acc) - | Ppat_variant (a, b) -> - let (a, acc) = self#label a acc in - let (b, acc) = self#option self#pattern b acc in - ((Ppat_variant (a, b)), acc) - | Ppat_record (a, b) -> - let (a, acc) = - self#list - (fun (a, b) -> - fun acc -> - let (a, acc) = self#longident_loc a acc in - let (b, acc) = self#pattern b acc in ((a, b), acc)) a - acc in - let (b, acc) = self#closed_flag b acc in - ((Ppat_record (a, b)), acc) - | Ppat_array a -> - let (a, acc) = self#list self#pattern a acc in - ((Ppat_array a), acc) - | Ppat_or (a, b) -> - let (a, acc) = self#pattern a acc in - let (b, acc) = self#pattern b acc in ((Ppat_or (a, b)), acc) - | Ppat_constraint (a, b) -> - let (a, acc) = self#pattern a acc in - let (b, acc) = self#core_type b acc in - ((Ppat_constraint (a, b)), acc) - | Ppat_type a -> - let (a, acc) = self#longident_loc a acc in ((Ppat_type a), acc) - | Ppat_lazy a -> - let (a, acc) = self#pattern a acc in ((Ppat_lazy a), acc) - | Ppat_unpack a -> - let (a, acc) = self#loc (self#option self#string) a acc in - ((Ppat_unpack a), acc) - | Ppat_exception a -> - let (a, acc) = self#pattern a acc in ((Ppat_exception a), acc) - | Ppat_extension a -> - let (a, acc) = self#extension a acc in - ((Ppat_extension a), acc) - | Ppat_open (a, b) -> - let (a, acc) = self#longident_loc a acc in - let (b, acc) = self#pattern b acc in ((Ppat_open (a, b)), acc) - method expression : expression -> 'acc -> (expression * 'acc)= - fun { pexp_desc; pexp_loc; pexp_loc_stack; pexp_attributes } -> - fun acc -> - let (pexp_desc, acc) = self#expression_desc pexp_desc acc in - let (pexp_loc, acc) = self#location pexp_loc acc in - let (pexp_loc_stack, acc) = self#location_stack pexp_loc_stack acc in - let (pexp_attributes, acc) = self#attributes pexp_attributes acc in - ({ pexp_desc; pexp_loc; pexp_loc_stack; pexp_attributes }, acc) - method expression_desc : - expression_desc -> 'acc -> (expression_desc * 'acc)= - fun x -> - fun acc -> - match x with - | Pexp_ident a -> - let (a, acc) = self#longident_loc a acc in - ((Pexp_ident a), acc) - | Pexp_constant a -> - let (a, acc) = self#constant a acc in ((Pexp_constant a), acc) - | Pexp_let (a, b, c) -> - let (a, acc) = self#rec_flag a acc in - let (b, acc) = self#list self#value_binding b acc in - let (c, acc) = self#expression c acc in - ((Pexp_let (a, b, c)), acc) - | Pexp_function a -> - let (a, acc) = self#list self#case a acc in - ((Pexp_function a), acc) - | Pexp_fun (a, b, c, d) -> - let (a, acc) = self#arg_label a acc in - let (b, acc) = self#option self#expression b acc in - let (c, acc) = self#pattern c acc in - let (d, acc) = self#expression d acc in - ((Pexp_fun (a, b, c, d)), acc) - | Pexp_apply (a, b) -> - let (a, acc) = self#expression a acc in - let (b, acc) = - self#list - (fun (a, b) -> - fun acc -> - let (a, acc) = self#arg_label a acc in - let (b, acc) = self#expression b acc in ((a, b), acc)) - b acc in - ((Pexp_apply (a, b)), acc) - | Pexp_match (a, b) -> - let (a, acc) = self#expression a acc in - let (b, acc) = self#list self#case b acc in - ((Pexp_match (a, b)), acc) - | Pexp_try (a, b) -> - let (a, acc) = self#expression a acc in - let (b, acc) = self#list self#case b acc in - ((Pexp_try (a, b)), acc) - | Pexp_tuple a -> - let (a, acc) = self#list self#expression a acc in - ((Pexp_tuple a), acc) - | Pexp_construct (a, b) -> - let (a, acc) = self#longident_loc a acc in - let (b, acc) = self#option self#expression b acc in - ((Pexp_construct (a, b)), acc) - | Pexp_variant (a, b) -> - let (a, acc) = self#label a acc in - let (b, acc) = self#option self#expression b acc in - ((Pexp_variant (a, b)), acc) - | Pexp_record (a, b) -> - let (a, acc) = - self#list - (fun (a, b) -> - fun acc -> - let (a, acc) = self#longident_loc a acc in - let (b, acc) = self#expression b acc in ((a, b), acc)) - a acc in - let (b, acc) = self#option self#expression b acc in - ((Pexp_record (a, b)), acc) - | Pexp_field (a, b) -> - let (a, acc) = self#expression a acc in - let (b, acc) = self#longident_loc b acc in - ((Pexp_field (a, b)), acc) - | Pexp_setfield (a, b, c) -> - let (a, acc) = self#expression a acc in - let (b, acc) = self#longident_loc b acc in - let (c, acc) = self#expression c acc in - ((Pexp_setfield (a, b, c)), acc) - | Pexp_array a -> - let (a, acc) = self#list self#expression a acc in - ((Pexp_array a), acc) - | Pexp_ifthenelse (a, b, c) -> - let (a, acc) = self#expression a acc in - let (b, acc) = self#expression b acc in - let (c, acc) = self#option self#expression c acc in - ((Pexp_ifthenelse (a, b, c)), acc) - | Pexp_sequence (a, b) -> - let (a, acc) = self#expression a acc in - let (b, acc) = self#expression b acc in - ((Pexp_sequence (a, b)), acc) - | Pexp_while (a, b) -> - let (a, acc) = self#expression a acc in - let (b, acc) = self#expression b acc in - ((Pexp_while (a, b)), acc) - | Pexp_for (a, b, c, d, e) -> - let (a, acc) = self#pattern a acc in - let (b, acc) = self#expression b acc in - let (c, acc) = self#expression c acc in - let (d, acc) = self#direction_flag d acc in - let (e, acc) = self#expression e acc in - ((Pexp_for (a, b, c, d, e)), acc) - | Pexp_constraint (a, b) -> - let (a, acc) = self#expression a acc in - let (b, acc) = self#core_type b acc in - ((Pexp_constraint (a, b)), acc) - | Pexp_coerce (a, b, c) -> - let (a, acc) = self#expression a acc in - let (b, acc) = self#option self#core_type b acc in - let (c, acc) = self#core_type c acc in - ((Pexp_coerce (a, b, c)), acc) - | Pexp_send (a, b) -> - let (a, acc) = self#expression a acc in - let (b, acc) = self#loc self#label b acc in - ((Pexp_send (a, b)), acc) - | Pexp_new a -> - let (a, acc) = self#longident_loc a acc in ((Pexp_new a), acc) - | Pexp_setinstvar (a, b) -> - let (a, acc) = self#loc self#label a acc in - let (b, acc) = self#expression b acc in - ((Pexp_setinstvar (a, b)), acc) - | Pexp_override a -> - let (a, acc) = - self#list - (fun (a, b) -> - fun acc -> - let (a, acc) = self#loc self#label a acc in - let (b, acc) = self#expression b acc in ((a, b), acc)) - a acc in - ((Pexp_override a), acc) - | Pexp_letmodule (a, b, c) -> - let (a, acc) = self#loc (self#option self#string) a acc in - let (b, acc) = self#module_expr b acc in - let (c, acc) = self#expression c acc in - ((Pexp_letmodule (a, b, c)), acc) - | Pexp_letexception (a, b) -> - let (a, acc) = self#extension_constructor a acc in - let (b, acc) = self#expression b acc in - ((Pexp_letexception (a, b)), acc) - | Pexp_assert a -> - let (a, acc) = self#expression a acc in ((Pexp_assert a), acc) - | Pexp_lazy a -> - let (a, acc) = self#expression a acc in ((Pexp_lazy a), acc) - | Pexp_poly (a, b) -> - let (a, acc) = self#expression a acc in - let (b, acc) = self#option self#core_type b acc in - ((Pexp_poly (a, b)), acc) - | Pexp_object a -> - let (a, acc) = self#class_structure a acc in - ((Pexp_object a), acc) - | Pexp_newtype (a, b) -> - let (a, acc) = self#loc self#string a acc in - let (b, acc) = self#expression b acc in - ((Pexp_newtype (a, b)), acc) - | Pexp_pack a -> - let (a, acc) = self#module_expr a acc in ((Pexp_pack a), acc) - | Pexp_open (a, b) -> - let (a, acc) = self#open_declaration a acc in - let (b, acc) = self#expression b acc in - ((Pexp_open (a, b)), acc) - | Pexp_letop a -> - let (a, acc) = self#letop a acc in ((Pexp_letop a), acc) - | Pexp_extension a -> - let (a, acc) = self#extension a acc in - ((Pexp_extension a), acc) - | Pexp_unreachable -> (Pexp_unreachable, acc) - method case : case -> 'acc -> (case * 'acc)= - fun { pc_lhs; pc_guard; pc_rhs } -> - fun acc -> - let (pc_lhs, acc) = self#pattern pc_lhs acc in - let (pc_guard, acc) = self#option self#expression pc_guard acc in - let (pc_rhs, acc) = self#expression pc_rhs acc in - ({ pc_lhs; pc_guard; pc_rhs }, acc) - method letop : letop -> 'acc -> (letop * 'acc)= - fun { let_; ands; body } -> - fun acc -> - let (let_, acc) = self#binding_op let_ acc in - let (ands, acc) = self#list self#binding_op ands acc in - let (body, acc) = self#expression body acc in - ({ let_; ands; body }, acc) - method binding_op : binding_op -> 'acc -> (binding_op * 'acc)= - fun { pbop_op; pbop_pat; pbop_exp; pbop_loc } -> - fun acc -> - let (pbop_op, acc) = self#loc self#string pbop_op acc in - let (pbop_pat, acc) = self#pattern pbop_pat acc in - let (pbop_exp, acc) = self#expression pbop_exp acc in - let (pbop_loc, acc) = self#location pbop_loc acc in - ({ pbop_op; pbop_pat; pbop_exp; pbop_loc }, acc) - method value_description : - value_description -> 'acc -> (value_description * 'acc)= - fun { pval_name; pval_type; pval_prim; pval_attributes; pval_loc } -> - fun acc -> - let (pval_name, acc) = self#loc self#string pval_name acc in - let (pval_type, acc) = self#core_type pval_type acc in - let (pval_prim, acc) = self#list self#string pval_prim acc in - let (pval_attributes, acc) = self#attributes pval_attributes acc in - let (pval_loc, acc) = self#location pval_loc acc in - ({ pval_name; pval_type; pval_prim; pval_attributes; pval_loc }, - acc) - method type_declaration : - type_declaration -> 'acc -> (type_declaration * 'acc)= - fun - { ptype_name; ptype_params; ptype_cstrs; ptype_kind; ptype_private; - ptype_manifest; ptype_attributes; ptype_loc } - -> - fun acc -> - let (ptype_name, acc) = self#loc self#string ptype_name acc in - let (ptype_params, acc) = - self#list - (fun (a, b) -> - fun acc -> - let (a, acc) = self#core_type a acc in - let (b, acc) = self#variance b acc in ((a, b), acc)) - ptype_params acc in - let (ptype_cstrs, acc) = - self#list - (fun (a, b, c) -> - fun acc -> - let (a, acc) = self#core_type a acc in - let (b, acc) = self#core_type b acc in - let (c, acc) = self#location c acc in ((a, b, c), acc)) - ptype_cstrs acc in - let (ptype_kind, acc) = self#type_kind ptype_kind acc in - let (ptype_private, acc) = self#private_flag ptype_private acc in - let (ptype_manifest, acc) = - self#option self#core_type ptype_manifest acc in - let (ptype_attributes, acc) = self#attributes ptype_attributes acc in - let (ptype_loc, acc) = self#location ptype_loc acc in - ({ - ptype_name; - ptype_params; - ptype_cstrs; - ptype_kind; - ptype_private; - ptype_manifest; - ptype_attributes; - ptype_loc - }, acc) - method type_kind : type_kind -> 'acc -> (type_kind * 'acc)= - fun x -> - fun acc -> - match x with - | Ptype_abstract -> (Ptype_abstract, acc) - | Ptype_variant a -> - let (a, acc) = self#list self#constructor_declaration a acc in - ((Ptype_variant a), acc) - | Ptype_record a -> - let (a, acc) = self#list self#label_declaration a acc in - ((Ptype_record a), acc) - | Ptype_open -> (Ptype_open, acc) - method label_declaration : - label_declaration -> 'acc -> (label_declaration * 'acc)= - fun { pld_name; pld_mutable; pld_type; pld_loc; pld_attributes } -> - fun acc -> - let (pld_name, acc) = self#loc self#string pld_name acc in - let (pld_mutable, acc) = self#mutable_flag pld_mutable acc in - let (pld_type, acc) = self#core_type pld_type acc in - let (pld_loc, acc) = self#location pld_loc acc in - let (pld_attributes, acc) = self#attributes pld_attributes acc in - ({ pld_name; pld_mutable; pld_type; pld_loc; pld_attributes }, acc) - method constructor_declaration : - constructor_declaration -> 'acc -> (constructor_declaration * 'acc)= - fun { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } -> - fun acc -> - let (pcd_name, acc) = self#loc self#string pcd_name acc in - let (pcd_args, acc) = self#constructor_arguments pcd_args acc in - let (pcd_res, acc) = self#option self#core_type pcd_res acc in - let (pcd_loc, acc) = self#location pcd_loc acc in - let (pcd_attributes, acc) = self#attributes pcd_attributes acc in - ({ pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes }, acc) - method constructor_arguments : - constructor_arguments -> 'acc -> (constructor_arguments * 'acc)= - fun x -> - fun acc -> - match x with - | Pcstr_tuple a -> - let (a, acc) = self#list self#core_type a acc in - ((Pcstr_tuple a), acc) - | Pcstr_record a -> - let (a, acc) = self#list self#label_declaration a acc in - ((Pcstr_record a), acc) - method type_extension : - type_extension -> 'acc -> (type_extension * 'acc)= - fun - { ptyext_path; ptyext_params; ptyext_constructors; ptyext_private; - ptyext_loc; ptyext_attributes } - -> - fun acc -> - let (ptyext_path, acc) = self#longident_loc ptyext_path acc in - let (ptyext_params, acc) = - self#list - (fun (a, b) -> - fun acc -> - let (a, acc) = self#core_type a acc in - let (b, acc) = self#variance b acc in ((a, b), acc)) - ptyext_params acc in - let (ptyext_constructors, acc) = - self#list self#extension_constructor ptyext_constructors acc in - let (ptyext_private, acc) = self#private_flag ptyext_private acc in - let (ptyext_loc, acc) = self#location ptyext_loc acc in - let (ptyext_attributes, acc) = - self#attributes ptyext_attributes acc in - ({ - ptyext_path; - ptyext_params; - ptyext_constructors; - ptyext_private; - ptyext_loc; - ptyext_attributes - }, acc) - method extension_constructor : - extension_constructor -> 'acc -> (extension_constructor * 'acc)= - fun { pext_name; pext_kind; pext_loc; pext_attributes } -> - fun acc -> - let (pext_name, acc) = self#loc self#string pext_name acc in - let (pext_kind, acc) = - self#extension_constructor_kind pext_kind acc in - let (pext_loc, acc) = self#location pext_loc acc in - let (pext_attributes, acc) = self#attributes pext_attributes acc in - ({ pext_name; pext_kind; pext_loc; pext_attributes }, acc) - method type_exception : - type_exception -> 'acc -> (type_exception * 'acc)= - fun { ptyexn_constructor; ptyexn_loc; ptyexn_attributes } -> - fun acc -> - let (ptyexn_constructor, acc) = - self#extension_constructor ptyexn_constructor acc in - let (ptyexn_loc, acc) = self#location ptyexn_loc acc in - let (ptyexn_attributes, acc) = - self#attributes ptyexn_attributes acc in - ({ ptyexn_constructor; ptyexn_loc; ptyexn_attributes }, acc) - method extension_constructor_kind : - extension_constructor_kind -> - 'acc -> (extension_constructor_kind * 'acc)= - fun x -> - fun acc -> - match x with - | Pext_decl (a, b) -> - let (a, acc) = self#constructor_arguments a acc in - let (b, acc) = self#option self#core_type b acc in - ((Pext_decl (a, b)), acc) - | Pext_rebind a -> - let (a, acc) = self#longident_loc a acc in - ((Pext_rebind a), acc) - method class_type : class_type -> 'acc -> (class_type * 'acc)= - fun { pcty_desc; pcty_loc; pcty_attributes } -> - fun acc -> - let (pcty_desc, acc) = self#class_type_desc pcty_desc acc in - let (pcty_loc, acc) = self#location pcty_loc acc in - let (pcty_attributes, acc) = self#attributes pcty_attributes acc in - ({ pcty_desc; pcty_loc; pcty_attributes }, acc) - method class_type_desc : - class_type_desc -> 'acc -> (class_type_desc * 'acc)= - fun x -> - fun acc -> - match x with - | Pcty_constr (a, b) -> - let (a, acc) = self#longident_loc a acc in - let (b, acc) = self#list self#core_type b acc in - ((Pcty_constr (a, b)), acc) - | Pcty_signature a -> - let (a, acc) = self#class_signature a acc in - ((Pcty_signature a), acc) - | Pcty_arrow (a, b, c) -> - let (a, acc) = self#arg_label a acc in - let (b, acc) = self#core_type b acc in - let (c, acc) = self#class_type c acc in - ((Pcty_arrow (a, b, c)), acc) - | Pcty_extension a -> - let (a, acc) = self#extension a acc in - ((Pcty_extension a), acc) - | Pcty_open (a, b) -> - let (a, acc) = self#open_description a acc in - let (b, acc) = self#class_type b acc in - ((Pcty_open (a, b)), acc) - method class_signature : - class_signature -> 'acc -> (class_signature * 'acc)= - fun { pcsig_self; pcsig_fields } -> - fun acc -> - let (pcsig_self, acc) = self#core_type pcsig_self acc in - let (pcsig_fields, acc) = - self#list self#class_type_field pcsig_fields acc in - ({ pcsig_self; pcsig_fields }, acc) - method class_type_field : - class_type_field -> 'acc -> (class_type_field * 'acc)= - fun { pctf_desc; pctf_loc; pctf_attributes } -> - fun acc -> - let (pctf_desc, acc) = self#class_type_field_desc pctf_desc acc in - let (pctf_loc, acc) = self#location pctf_loc acc in - let (pctf_attributes, acc) = self#attributes pctf_attributes acc in - ({ pctf_desc; pctf_loc; pctf_attributes }, acc) - method class_type_field_desc : - class_type_field_desc -> 'acc -> (class_type_field_desc * 'acc)= - fun x -> - fun acc -> - match x with - | Pctf_inherit a -> - let (a, acc) = self#class_type a acc in ((Pctf_inherit a), acc) - | Pctf_val a -> - let (a, acc) = - (fun (a, b, c, d) -> - fun acc -> - let (a, acc) = self#loc self#label a acc in - let (b, acc) = self#mutable_flag b acc in - let (c, acc) = self#virtual_flag c acc in - let (d, acc) = self#core_type d acc in - ((a, b, c, d), acc)) a acc in - ((Pctf_val a), acc) - | Pctf_method a -> - let (a, acc) = - (fun (a, b, c, d) -> - fun acc -> - let (a, acc) = self#loc self#label a acc in - let (b, acc) = self#private_flag b acc in - let (c, acc) = self#virtual_flag c acc in - let (d, acc) = self#core_type d acc in - ((a, b, c, d), acc)) a acc in - ((Pctf_method a), acc) - | Pctf_constraint a -> - let (a, acc) = - (fun (a, b) -> - fun acc -> - let (a, acc) = self#core_type a acc in - let (b, acc) = self#core_type b acc in ((a, b), acc)) a - acc in - ((Pctf_constraint a), acc) - | Pctf_attribute a -> - let (a, acc) = self#attribute a acc in - ((Pctf_attribute a), acc) - | Pctf_extension a -> - let (a, acc) = self#extension a acc in - ((Pctf_extension a), acc) - method class_infos : - 'a . - ('a -> 'acc -> ('a * 'acc)) -> - 'a class_infos -> 'acc -> ('a class_infos * 'acc)= - fun _a -> - fun - { pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes - } - -> - fun acc -> - let (pci_virt, acc) = self#virtual_flag pci_virt acc in - let (pci_params, acc) = + + method payload : payload -> 'acc -> payload * 'acc = + fun x acc -> + match x with + | PStr a -> + let a, acc = self#structure a acc in + (PStr a, acc) + | PSig a -> + let a, acc = self#signature a acc in + (PSig a, acc) + | PTyp a -> + let a, acc = self#core_type a acc in + (PTyp a, acc) + | PPat (a, b) -> + let a, acc = self#pattern a acc in + let b, acc = self#option self#expression b acc in + (PPat (a, b), acc) + + method core_type : core_type -> 'acc -> core_type * 'acc = + fun { ptyp_desc; ptyp_loc; ptyp_loc_stack; ptyp_attributes } acc -> + let ptyp_desc, acc = self#core_type_desc ptyp_desc acc in + let ptyp_loc, acc = self#location ptyp_loc acc in + let ptyp_loc_stack, acc = self#location_stack ptyp_loc_stack acc in + let ptyp_attributes, acc = self#attributes ptyp_attributes acc in + ({ ptyp_desc; ptyp_loc; ptyp_loc_stack; ptyp_attributes }, acc) + + method core_type_desc : core_type_desc -> 'acc -> core_type_desc * 'acc = + fun x acc -> + match x with + | Ptyp_any -> (Ptyp_any, acc) + | Ptyp_var a -> + let a, acc = self#string a acc in + (Ptyp_var a, acc) + | Ptyp_arrow (a, b, c) -> + let a, acc = self#arg_label a acc in + let b, acc = self#core_type b acc in + let c, acc = self#core_type c acc in + (Ptyp_arrow (a, b, c), acc) + | Ptyp_tuple a -> + let a, acc = self#list self#core_type a acc in + (Ptyp_tuple a, acc) + | Ptyp_constr (a, b) -> + let a, acc = self#longident_loc a acc in + let b, acc = self#list self#core_type b acc in + (Ptyp_constr (a, b), acc) + | Ptyp_object (a, b) -> + let a, acc = self#list self#object_field a acc in + let b, acc = self#closed_flag b acc in + (Ptyp_object (a, b), acc) + | Ptyp_class (a, b) -> + let a, acc = self#longident_loc a acc in + let b, acc = self#list self#core_type b acc in + (Ptyp_class (a, b), acc) + | Ptyp_alias (a, b) -> + let a, acc = self#core_type a acc in + let b, acc = self#string b acc in + (Ptyp_alias (a, b), acc) + | Ptyp_variant (a, b, c) -> + let a, acc = self#list self#row_field a acc in + let b, acc = self#closed_flag b acc in + let c, acc = self#option (self#list self#label) c acc in + (Ptyp_variant (a, b, c), acc) + | Ptyp_poly (a, b) -> + let a, acc = self#list (self#loc self#string) a acc in + let b, acc = self#core_type b acc in + (Ptyp_poly (a, b), acc) + | Ptyp_package a -> + let a, acc = self#package_type a acc in + (Ptyp_package a, acc) + | Ptyp_extension a -> + let a, acc = self#extension a acc in + (Ptyp_extension a, acc) + + method package_type : package_type -> 'acc -> package_type * 'acc = + fun (a, b) acc -> + let a, acc = self#longident_loc a acc in + let b, acc = + self#list + (fun (a, b) acc -> + let a, acc = self#longident_loc a acc in + let b, acc = self#core_type b acc in + ((a, b), acc)) + b acc + in + ((a, b), acc) + + method row_field : row_field -> 'acc -> row_field * 'acc = + fun { prf_desc; prf_loc; prf_attributes } acc -> + let prf_desc, acc = self#row_field_desc prf_desc acc in + let prf_loc, acc = self#location prf_loc acc in + let prf_attributes, acc = self#attributes prf_attributes acc in + ({ prf_desc; prf_loc; prf_attributes }, acc) + + method row_field_desc : row_field_desc -> 'acc -> row_field_desc * 'acc = + fun x acc -> + match x with + | Rtag (a, b, c) -> + let a, acc = self#loc self#label a acc in + let b, acc = self#bool b acc in + let c, acc = self#list self#core_type c acc in + (Rtag (a, b, c), acc) + | Rinherit a -> + let a, acc = self#core_type a acc in + (Rinherit a, acc) + + method object_field : object_field -> 'acc -> object_field * 'acc = + fun { pof_desc; pof_loc; pof_attributes } acc -> + let pof_desc, acc = self#object_field_desc pof_desc acc in + let pof_loc, acc = self#location pof_loc acc in + let pof_attributes, acc = self#attributes pof_attributes acc in + ({ pof_desc; pof_loc; pof_attributes }, acc) + + method object_field_desc + : object_field_desc -> 'acc -> object_field_desc * 'acc = + fun x acc -> + match x with + | Otag (a, b) -> + let a, acc = self#loc self#label a acc in + let b, acc = self#core_type b acc in + (Otag (a, b), acc) + | Oinherit a -> + let a, acc = self#core_type a acc in + (Oinherit a, acc) + + method pattern : pattern -> 'acc -> pattern * 'acc = + fun { ppat_desc; ppat_loc; ppat_loc_stack; ppat_attributes } acc -> + let ppat_desc, acc = self#pattern_desc ppat_desc acc in + let ppat_loc, acc = self#location ppat_loc acc in + let ppat_loc_stack, acc = self#location_stack ppat_loc_stack acc in + let ppat_attributes, acc = self#attributes ppat_attributes acc in + ({ ppat_desc; ppat_loc; ppat_loc_stack; ppat_attributes }, acc) + + method pattern_desc : pattern_desc -> 'acc -> pattern_desc * 'acc = + fun x acc -> + match x with + | Ppat_any -> (Ppat_any, acc) + | Ppat_var a -> + let a, acc = self#loc self#string a acc in + (Ppat_var a, acc) + | Ppat_alias (a, b) -> + let a, acc = self#pattern a acc in + let b, acc = self#loc self#string b acc in + (Ppat_alias (a, b), acc) + | Ppat_constant a -> + let a, acc = self#constant a acc in + (Ppat_constant a, acc) + | Ppat_interval (a, b) -> + let a, acc = self#constant a acc in + let b, acc = self#constant b acc in + (Ppat_interval (a, b), acc) + | Ppat_tuple a -> + let a, acc = self#list self#pattern a acc in + (Ppat_tuple a, acc) + | Ppat_construct (a, b) -> + let a, acc = self#longident_loc a acc in + let b, acc = self#option self#pattern b acc in + (Ppat_construct (a, b), acc) + | Ppat_variant (a, b) -> + let a, acc = self#label a acc in + let b, acc = self#option self#pattern b acc in + (Ppat_variant (a, b), acc) + | Ppat_record (a, b) -> + let a, acc = self#list - (fun (a, b) -> - fun acc -> - let (a, acc) = self#core_type a acc in - let (b, acc) = self#variance b acc in ((a, b), acc)) - pci_params acc in - let (pci_name, acc) = self#loc self#string pci_name acc in - let (pci_expr, acc) = _a pci_expr acc in - let (pci_loc, acc) = self#location pci_loc acc in - let (pci_attributes, acc) = self#attributes pci_attributes acc in - ({ - pci_virt; - pci_params; - pci_name; - pci_expr; - pci_loc; - pci_attributes - }, acc) - method class_description : - class_description -> 'acc -> (class_description * 'acc)= + (fun (a, b) acc -> + let a, acc = self#longident_loc a acc in + let b, acc = self#pattern b acc in + ((a, b), acc)) + a acc + in + let b, acc = self#closed_flag b acc in + (Ppat_record (a, b), acc) + | Ppat_array a -> + let a, acc = self#list self#pattern a acc in + (Ppat_array a, acc) + | Ppat_or (a, b) -> + let a, acc = self#pattern a acc in + let b, acc = self#pattern b acc in + (Ppat_or (a, b), acc) + | Ppat_constraint (a, b) -> + let a, acc = self#pattern a acc in + let b, acc = self#core_type b acc in + (Ppat_constraint (a, b), acc) + | Ppat_type a -> + let a, acc = self#longident_loc a acc in + (Ppat_type a, acc) + | Ppat_lazy a -> + let a, acc = self#pattern a acc in + (Ppat_lazy a, acc) + | Ppat_unpack a -> + let a, acc = self#loc (self#option self#string) a acc in + (Ppat_unpack a, acc) + | Ppat_exception a -> + let a, acc = self#pattern a acc in + (Ppat_exception a, acc) + | Ppat_extension a -> + let a, acc = self#extension a acc in + (Ppat_extension a, acc) + | Ppat_open (a, b) -> + let a, acc = self#longident_loc a acc in + let b, acc = self#pattern b acc in + (Ppat_open (a, b), acc) + + method expression : expression -> 'acc -> expression * 'acc = + fun { pexp_desc; pexp_loc; pexp_loc_stack; pexp_attributes } acc -> + let pexp_desc, acc = self#expression_desc pexp_desc acc in + let pexp_loc, acc = self#location pexp_loc acc in + let pexp_loc_stack, acc = self#location_stack pexp_loc_stack acc in + let pexp_attributes, acc = self#attributes pexp_attributes acc in + ({ pexp_desc; pexp_loc; pexp_loc_stack; pexp_attributes }, acc) + + method expression_desc : expression_desc -> 'acc -> expression_desc * 'acc = + fun x acc -> + match x with + | Pexp_ident a -> + let a, acc = self#longident_loc a acc in + (Pexp_ident a, acc) + | Pexp_constant a -> + let a, acc = self#constant a acc in + (Pexp_constant a, acc) + | Pexp_let (a, b, c) -> + let a, acc = self#rec_flag a acc in + let b, acc = self#list self#value_binding b acc in + let c, acc = self#expression c acc in + (Pexp_let (a, b, c), acc) + | Pexp_function a -> + let a, acc = self#cases a acc in + (Pexp_function a, acc) + | Pexp_fun (a, b, c, d) -> + let a, acc = self#arg_label a acc in + let b, acc = self#option self#expression b acc in + let c, acc = self#pattern c acc in + let d, acc = self#expression d acc in + (Pexp_fun (a, b, c, d), acc) + | Pexp_apply (a, b) -> + let a, acc = self#expression a acc in + let b, acc = + self#list + (fun (a, b) acc -> + let a, acc = self#arg_label a acc in + let b, acc = self#expression b acc in + ((a, b), acc)) + b acc + in + (Pexp_apply (a, b), acc) + | Pexp_match (a, b) -> + let a, acc = self#expression a acc in + let b, acc = self#cases b acc in + (Pexp_match (a, b), acc) + | Pexp_try (a, b) -> + let a, acc = self#expression a acc in + let b, acc = self#cases b acc in + (Pexp_try (a, b), acc) + | Pexp_tuple a -> + let a, acc = self#list self#expression a acc in + (Pexp_tuple a, acc) + | Pexp_construct (a, b) -> + let a, acc = self#longident_loc a acc in + let b, acc = self#option self#expression b acc in + (Pexp_construct (a, b), acc) + | Pexp_variant (a, b) -> + let a, acc = self#label a acc in + let b, acc = self#option self#expression b acc in + (Pexp_variant (a, b), acc) + | Pexp_record (a, b) -> + let a, acc = + self#list + (fun (a, b) acc -> + let a, acc = self#longident_loc a acc in + let b, acc = self#expression b acc in + ((a, b), acc)) + a acc + in + let b, acc = self#option self#expression b acc in + (Pexp_record (a, b), acc) + | Pexp_field (a, b) -> + let a, acc = self#expression a acc in + let b, acc = self#longident_loc b acc in + (Pexp_field (a, b), acc) + | Pexp_setfield (a, b, c) -> + let a, acc = self#expression a acc in + let b, acc = self#longident_loc b acc in + let c, acc = self#expression c acc in + (Pexp_setfield (a, b, c), acc) + | Pexp_array a -> + let a, acc = self#list self#expression a acc in + (Pexp_array a, acc) + | Pexp_ifthenelse (a, b, c) -> + let a, acc = self#expression a acc in + let b, acc = self#expression b acc in + let c, acc = self#option self#expression c acc in + (Pexp_ifthenelse (a, b, c), acc) + | Pexp_sequence (a, b) -> + let a, acc = self#expression a acc in + let b, acc = self#expression b acc in + (Pexp_sequence (a, b), acc) + | Pexp_while (a, b) -> + let a, acc = self#expression a acc in + let b, acc = self#expression b acc in + (Pexp_while (a, b), acc) + | Pexp_for (a, b, c, d, e) -> + let a, acc = self#pattern a acc in + let b, acc = self#expression b acc in + let c, acc = self#expression c acc in + let d, acc = self#direction_flag d acc in + let e, acc = self#expression e acc in + (Pexp_for (a, b, c, d, e), acc) + | Pexp_constraint (a, b) -> + let a, acc = self#expression a acc in + let b, acc = self#core_type b acc in + (Pexp_constraint (a, b), acc) + | Pexp_coerce (a, b, c) -> + let a, acc = self#expression a acc in + let b, acc = self#option self#core_type b acc in + let c, acc = self#core_type c acc in + (Pexp_coerce (a, b, c), acc) + | Pexp_send (a, b) -> + let a, acc = self#expression a acc in + let b, acc = self#loc self#label b acc in + (Pexp_send (a, b), acc) + | Pexp_new a -> + let a, acc = self#longident_loc a acc in + (Pexp_new a, acc) + | Pexp_setinstvar (a, b) -> + let a, acc = self#loc self#label a acc in + let b, acc = self#expression b acc in + (Pexp_setinstvar (a, b), acc) + | Pexp_override a -> + let a, acc = + self#list + (fun (a, b) acc -> + let a, acc = self#loc self#label a acc in + let b, acc = self#expression b acc in + ((a, b), acc)) + a acc + in + (Pexp_override a, acc) + | Pexp_letmodule (a, b, c) -> + let a, acc = self#loc (self#option self#string) a acc in + let b, acc = self#module_expr b acc in + let c, acc = self#expression c acc in + (Pexp_letmodule (a, b, c), acc) + | Pexp_letexception (a, b) -> + let a, acc = self#extension_constructor a acc in + let b, acc = self#expression b acc in + (Pexp_letexception (a, b), acc) + | Pexp_assert a -> + let a, acc = self#expression a acc in + (Pexp_assert a, acc) + | Pexp_lazy a -> + let a, acc = self#expression a acc in + (Pexp_lazy a, acc) + | Pexp_poly (a, b) -> + let a, acc = self#expression a acc in + let b, acc = self#option self#core_type b acc in + (Pexp_poly (a, b), acc) + | Pexp_object a -> + let a, acc = self#class_structure a acc in + (Pexp_object a, acc) + | Pexp_newtype (a, b) -> + let a, acc = self#loc self#string a acc in + let b, acc = self#expression b acc in + (Pexp_newtype (a, b), acc) + | Pexp_pack a -> + let a, acc = self#module_expr a acc in + (Pexp_pack a, acc) + | Pexp_open (a, b) -> + let a, acc = self#open_declaration a acc in + let b, acc = self#expression b acc in + (Pexp_open (a, b), acc) + | Pexp_letop a -> + let a, acc = self#letop a acc in + (Pexp_letop a, acc) + | Pexp_extension a -> + let a, acc = self#extension a acc in + (Pexp_extension a, acc) + | Pexp_unreachable -> (Pexp_unreachable, acc) + + method case : case -> 'acc -> case * 'acc = + fun { pc_lhs; pc_guard; pc_rhs } acc -> + let pc_lhs, acc = self#pattern pc_lhs acc in + let pc_guard, acc = self#option self#expression pc_guard acc in + let pc_rhs, acc = self#expression pc_rhs acc in + ({ pc_lhs; pc_guard; pc_rhs }, acc) + + method letop : letop -> 'acc -> letop * 'acc = + fun { let_; ands; body } acc -> + let let_, acc = self#binding_op let_ acc in + let ands, acc = self#list self#binding_op ands acc in + let body, acc = self#expression body acc in + ({ let_; ands; body }, acc) + + method binding_op : binding_op -> 'acc -> binding_op * 'acc = + fun { pbop_op; pbop_pat; pbop_exp; pbop_loc } acc -> + let pbop_op, acc = self#loc self#string pbop_op acc in + let pbop_pat, acc = self#pattern pbop_pat acc in + let pbop_exp, acc = self#expression pbop_exp acc in + let pbop_loc, acc = self#location pbop_loc acc in + ({ pbop_op; pbop_pat; pbop_exp; pbop_loc }, acc) + + method value_description + : value_description -> 'acc -> value_description * 'acc = + fun { pval_name; pval_type; pval_prim; pval_attributes; pval_loc } acc -> + let pval_name, acc = self#loc self#string pval_name acc in + let pval_type, acc = self#core_type pval_type acc in + let pval_prim, acc = self#list self#string pval_prim acc in + let pval_attributes, acc = self#attributes pval_attributes acc in + let pval_loc, acc = self#location pval_loc acc in + ({ pval_name; pval_type; pval_prim; pval_attributes; pval_loc }, acc) + + method type_declaration + : type_declaration -> 'acc -> type_declaration * 'acc = + fun { + ptype_name; + ptype_params; + ptype_cstrs; + ptype_kind; + ptype_private; + ptype_manifest; + ptype_attributes; + ptype_loc; + } acc -> + let ptype_name, acc = self#loc self#string ptype_name acc in + let ptype_params, acc = + self#list + (fun (a, b) acc -> + let a, acc = self#core_type a acc in + let b, acc = + (fun (a, b) acc -> + let a, acc = self#variance a acc in + let b, acc = self#injectivity b acc in + ((a, b), acc)) + b acc + in + ((a, b), acc)) + ptype_params acc + in + let ptype_cstrs, acc = + self#list + (fun (a, b, c) acc -> + let a, acc = self#core_type a acc in + let b, acc = self#core_type b acc in + let c, acc = self#location c acc in + ((a, b, c), acc)) + ptype_cstrs acc + in + let ptype_kind, acc = self#type_kind ptype_kind acc in + let ptype_private, acc = self#private_flag ptype_private acc in + let ptype_manifest, acc = + self#option self#core_type ptype_manifest acc + in + let ptype_attributes, acc = self#attributes ptype_attributes acc in + let ptype_loc, acc = self#location ptype_loc acc in + ( { + ptype_name; + ptype_params; + ptype_cstrs; + ptype_kind; + ptype_private; + ptype_manifest; + ptype_attributes; + ptype_loc; + }, + acc ) + + method type_kind : type_kind -> 'acc -> type_kind * 'acc = + fun x acc -> + match x with + | Ptype_abstract -> (Ptype_abstract, acc) + | Ptype_variant a -> + let a, acc = self#list self#constructor_declaration a acc in + (Ptype_variant a, acc) + | Ptype_record a -> + let a, acc = self#list self#label_declaration a acc in + (Ptype_record a, acc) + | Ptype_open -> (Ptype_open, acc) + + method label_declaration + : label_declaration -> 'acc -> label_declaration * 'acc = + fun { pld_name; pld_mutable; pld_type; pld_loc; pld_attributes } acc -> + let pld_name, acc = self#loc self#string pld_name acc in + let pld_mutable, acc = self#mutable_flag pld_mutable acc in + let pld_type, acc = self#core_type pld_type acc in + let pld_loc, acc = self#location pld_loc acc in + let pld_attributes, acc = self#attributes pld_attributes acc in + ({ pld_name; pld_mutable; pld_type; pld_loc; pld_attributes }, acc) + + method constructor_declaration + : constructor_declaration -> 'acc -> constructor_declaration * 'acc = + fun { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } acc -> + let pcd_name, acc = self#loc self#string pcd_name acc in + let pcd_args, acc = self#constructor_arguments pcd_args acc in + let pcd_res, acc = self#option self#core_type pcd_res acc in + let pcd_loc, acc = self#location pcd_loc acc in + let pcd_attributes, acc = self#attributes pcd_attributes acc in + ({ pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes }, acc) + + method constructor_arguments + : constructor_arguments -> 'acc -> constructor_arguments * 'acc = + fun x acc -> + match x with + | Pcstr_tuple a -> + let a, acc = self#list self#core_type a acc in + (Pcstr_tuple a, acc) + | Pcstr_record a -> + let a, acc = self#list self#label_declaration a acc in + (Pcstr_record a, acc) + + method type_extension : type_extension -> 'acc -> type_extension * 'acc = + fun { + ptyext_path; + ptyext_params; + ptyext_constructors; + ptyext_private; + ptyext_loc; + ptyext_attributes; + } acc -> + let ptyext_path, acc = self#longident_loc ptyext_path acc in + let ptyext_params, acc = + self#list + (fun (a, b) acc -> + let a, acc = self#core_type a acc in + let b, acc = + (fun (a, b) acc -> + let a, acc = self#variance a acc in + let b, acc = self#injectivity b acc in + ((a, b), acc)) + b acc + in + ((a, b), acc)) + ptyext_params acc + in + let ptyext_constructors, acc = + self#list self#extension_constructor ptyext_constructors acc + in + let ptyext_private, acc = self#private_flag ptyext_private acc in + let ptyext_loc, acc = self#location ptyext_loc acc in + let ptyext_attributes, acc = self#attributes ptyext_attributes acc in + ( { + ptyext_path; + ptyext_params; + ptyext_constructors; + ptyext_private; + ptyext_loc; + ptyext_attributes; + }, + acc ) + + method extension_constructor + : extension_constructor -> 'acc -> extension_constructor * 'acc = + fun { pext_name; pext_kind; pext_loc; pext_attributes } acc -> + let pext_name, acc = self#loc self#string pext_name acc in + let pext_kind, acc = self#extension_constructor_kind pext_kind acc in + let pext_loc, acc = self#location pext_loc acc in + let pext_attributes, acc = self#attributes pext_attributes acc in + ({ pext_name; pext_kind; pext_loc; pext_attributes }, acc) + + method type_exception : type_exception -> 'acc -> type_exception * 'acc = + fun { ptyexn_constructor; ptyexn_loc; ptyexn_attributes } acc -> + let ptyexn_constructor, acc = + self#extension_constructor ptyexn_constructor acc + in + let ptyexn_loc, acc = self#location ptyexn_loc acc in + let ptyexn_attributes, acc = self#attributes ptyexn_attributes acc in + ({ ptyexn_constructor; ptyexn_loc; ptyexn_attributes }, acc) + + method extension_constructor_kind + : extension_constructor_kind -> + 'acc -> + extension_constructor_kind * 'acc = + fun x acc -> + match x with + | Pext_decl (a, b) -> + let a, acc = self#constructor_arguments a acc in + let b, acc = self#option self#core_type b acc in + (Pext_decl (a, b), acc) + | Pext_rebind a -> + let a, acc = self#longident_loc a acc in + (Pext_rebind a, acc) + + method class_type : class_type -> 'acc -> class_type * 'acc = + fun { pcty_desc; pcty_loc; pcty_attributes } acc -> + let pcty_desc, acc = self#class_type_desc pcty_desc acc in + let pcty_loc, acc = self#location pcty_loc acc in + let pcty_attributes, acc = self#attributes pcty_attributes acc in + ({ pcty_desc; pcty_loc; pcty_attributes }, acc) + + method class_type_desc : class_type_desc -> 'acc -> class_type_desc * 'acc = + fun x acc -> + match x with + | Pcty_constr (a, b) -> + let a, acc = self#longident_loc a acc in + let b, acc = self#list self#core_type b acc in + (Pcty_constr (a, b), acc) + | Pcty_signature a -> + let a, acc = self#class_signature a acc in + (Pcty_signature a, acc) + | Pcty_arrow (a, b, c) -> + let a, acc = self#arg_label a acc in + let b, acc = self#core_type b acc in + let c, acc = self#class_type c acc in + (Pcty_arrow (a, b, c), acc) + | Pcty_extension a -> + let a, acc = self#extension a acc in + (Pcty_extension a, acc) + | Pcty_open (a, b) -> + let a, acc = self#open_description a acc in + let b, acc = self#class_type b acc in + (Pcty_open (a, b), acc) + + method class_signature : class_signature -> 'acc -> class_signature * 'acc = + fun { pcsig_self; pcsig_fields } acc -> + let pcsig_self, acc = self#core_type pcsig_self acc in + let pcsig_fields, acc = + self#list self#class_type_field pcsig_fields acc + in + ({ pcsig_self; pcsig_fields }, acc) + + method class_type_field + : class_type_field -> 'acc -> class_type_field * 'acc = + fun { pctf_desc; pctf_loc; pctf_attributes } acc -> + let pctf_desc, acc = self#class_type_field_desc pctf_desc acc in + let pctf_loc, acc = self#location pctf_loc acc in + let pctf_attributes, acc = self#attributes pctf_attributes acc in + ({ pctf_desc; pctf_loc; pctf_attributes }, acc) + + method class_type_field_desc + : class_type_field_desc -> 'acc -> class_type_field_desc * 'acc = + fun x acc -> + match x with + | Pctf_inherit a -> + let a, acc = self#class_type a acc in + (Pctf_inherit a, acc) + | Pctf_val a -> + let a, acc = + (fun (a, b, c, d) acc -> + let a, acc = self#loc self#label a acc in + let b, acc = self#mutable_flag b acc in + let c, acc = self#virtual_flag c acc in + let d, acc = self#core_type d acc in + ((a, b, c, d), acc)) + a acc + in + (Pctf_val a, acc) + | Pctf_method a -> + let a, acc = + (fun (a, b, c, d) acc -> + let a, acc = self#loc self#label a acc in + let b, acc = self#private_flag b acc in + let c, acc = self#virtual_flag c acc in + let d, acc = self#core_type d acc in + ((a, b, c, d), acc)) + a acc + in + (Pctf_method a, acc) + | Pctf_constraint a -> + let a, acc = + (fun (a, b) acc -> + let a, acc = self#core_type a acc in + let b, acc = self#core_type b acc in + ((a, b), acc)) + a acc + in + (Pctf_constraint a, acc) + | Pctf_attribute a -> + let a, acc = self#attribute a acc in + (Pctf_attribute a, acc) + | Pctf_extension a -> + let a, acc = self#extension a acc in + (Pctf_extension a, acc) + + method class_infos + : 'a. + ('a -> 'acc -> 'a * 'acc) -> + 'a class_infos -> + 'acc -> + 'a class_infos * 'acc = + fun _a + { pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes } + acc -> + let pci_virt, acc = self#virtual_flag pci_virt acc in + let pci_params, acc = + self#list + (fun (a, b) acc -> + let a, acc = self#core_type a acc in + let b, acc = + (fun (a, b) acc -> + let a, acc = self#variance a acc in + let b, acc = self#injectivity b acc in + ((a, b), acc)) + b acc + in + ((a, b), acc)) + pci_params acc + in + let pci_name, acc = self#loc self#string pci_name acc in + let pci_expr, acc = _a pci_expr acc in + let pci_loc, acc = self#location pci_loc acc in + let pci_attributes, acc = self#attributes pci_attributes acc in + ( { pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes }, + acc ) + + method class_description + : class_description -> 'acc -> class_description * 'acc = self#class_infos self#class_type - method class_type_declaration : - class_type_declaration -> 'acc -> (class_type_declaration * 'acc)= + + method class_type_declaration + : class_type_declaration -> 'acc -> class_type_declaration * 'acc = self#class_infos self#class_type - method class_expr : class_expr -> 'acc -> (class_expr * 'acc)= - fun { pcl_desc; pcl_loc; pcl_attributes } -> - fun acc -> - let (pcl_desc, acc) = self#class_expr_desc pcl_desc acc in - let (pcl_loc, acc) = self#location pcl_loc acc in - let (pcl_attributes, acc) = self#attributes pcl_attributes acc in - ({ pcl_desc; pcl_loc; pcl_attributes }, acc) - method class_expr_desc : - class_expr_desc -> 'acc -> (class_expr_desc * 'acc)= - fun x -> - fun acc -> - match x with - | Pcl_constr (a, b) -> - let (a, acc) = self#longident_loc a acc in - let (b, acc) = self#list self#core_type b acc in - ((Pcl_constr (a, b)), acc) - | Pcl_structure a -> - let (a, acc) = self#class_structure a acc in - ((Pcl_structure a), acc) - | Pcl_fun (a, b, c, d) -> - let (a, acc) = self#arg_label a acc in - let (b, acc) = self#option self#expression b acc in - let (c, acc) = self#pattern c acc in - let (d, acc) = self#class_expr d acc in - ((Pcl_fun (a, b, c, d)), acc) - | Pcl_apply (a, b) -> - let (a, acc) = self#class_expr a acc in - let (b, acc) = - self#list - (fun (a, b) -> - fun acc -> - let (a, acc) = self#arg_label a acc in - let (b, acc) = self#expression b acc in ((a, b), acc)) - b acc in - ((Pcl_apply (a, b)), acc) - | Pcl_let (a, b, c) -> - let (a, acc) = self#rec_flag a acc in - let (b, acc) = self#list self#value_binding b acc in - let (c, acc) = self#class_expr c acc in - ((Pcl_let (a, b, c)), acc) - | Pcl_constraint (a, b) -> - let (a, acc) = self#class_expr a acc in - let (b, acc) = self#class_type b acc in - ((Pcl_constraint (a, b)), acc) - | Pcl_extension a -> - let (a, acc) = self#extension a acc in ((Pcl_extension a), acc) - | Pcl_open (a, b) -> - let (a, acc) = self#open_description a acc in - let (b, acc) = self#class_expr b acc in - ((Pcl_open (a, b)), acc) - method class_structure : - class_structure -> 'acc -> (class_structure * 'acc)= - fun { pcstr_self; pcstr_fields } -> - fun acc -> - let (pcstr_self, acc) = self#pattern pcstr_self acc in - let (pcstr_fields, acc) = - self#list self#class_field pcstr_fields acc in - ({ pcstr_self; pcstr_fields }, acc) - method class_field : class_field -> 'acc -> (class_field * 'acc)= - fun { pcf_desc; pcf_loc; pcf_attributes } -> - fun acc -> - let (pcf_desc, acc) = self#class_field_desc pcf_desc acc in - let (pcf_loc, acc) = self#location pcf_loc acc in - let (pcf_attributes, acc) = self#attributes pcf_attributes acc in - ({ pcf_desc; pcf_loc; pcf_attributes }, acc) - method class_field_desc : - class_field_desc -> 'acc -> (class_field_desc * 'acc)= - fun x -> - fun acc -> - match x with - | Pcf_inherit (a, b, c) -> - let (a, acc) = self#override_flag a acc in - let (b, acc) = self#class_expr b acc in - let (c, acc) = self#option (self#loc self#string) c acc in - ((Pcf_inherit (a, b, c)), acc) - | Pcf_val a -> - let (a, acc) = - (fun (a, b, c) -> - fun acc -> - let (a, acc) = self#loc self#label a acc in - let (b, acc) = self#mutable_flag b acc in - let (c, acc) = self#class_field_kind c acc in - ((a, b, c), acc)) a acc in - ((Pcf_val a), acc) - | Pcf_method a -> - let (a, acc) = - (fun (a, b, c) -> - fun acc -> - let (a, acc) = self#loc self#label a acc in - let (b, acc) = self#private_flag b acc in - let (c, acc) = self#class_field_kind c acc in - ((a, b, c), acc)) a acc in - ((Pcf_method a), acc) - | Pcf_constraint a -> - let (a, acc) = - (fun (a, b) -> - fun acc -> - let (a, acc) = self#core_type a acc in - let (b, acc) = self#core_type b acc in ((a, b), acc)) a - acc in - ((Pcf_constraint a), acc) - | Pcf_initializer a -> - let (a, acc) = self#expression a acc in - ((Pcf_initializer a), acc) - | Pcf_attribute a -> - let (a, acc) = self#attribute a acc in ((Pcf_attribute a), acc) - | Pcf_extension a -> - let (a, acc) = self#extension a acc in ((Pcf_extension a), acc) - method class_field_kind : - class_field_kind -> 'acc -> (class_field_kind * 'acc)= - fun x -> - fun acc -> - match x with - | Cfk_virtual a -> - let (a, acc) = self#core_type a acc in ((Cfk_virtual a), acc) - | Cfk_concrete (a, b) -> - let (a, acc) = self#override_flag a acc in - let (b, acc) = self#expression b acc in - ((Cfk_concrete (a, b)), acc) - method class_declaration : - class_declaration -> 'acc -> (class_declaration * 'acc)= + + method class_expr : class_expr -> 'acc -> class_expr * 'acc = + fun { pcl_desc; pcl_loc; pcl_attributes } acc -> + let pcl_desc, acc = self#class_expr_desc pcl_desc acc in + let pcl_loc, acc = self#location pcl_loc acc in + let pcl_attributes, acc = self#attributes pcl_attributes acc in + ({ pcl_desc; pcl_loc; pcl_attributes }, acc) + + method class_expr_desc : class_expr_desc -> 'acc -> class_expr_desc * 'acc = + fun x acc -> + match x with + | Pcl_constr (a, b) -> + let a, acc = self#longident_loc a acc in + let b, acc = self#list self#core_type b acc in + (Pcl_constr (a, b), acc) + | Pcl_structure a -> + let a, acc = self#class_structure a acc in + (Pcl_structure a, acc) + | Pcl_fun (a, b, c, d) -> + let a, acc = self#arg_label a acc in + let b, acc = self#option self#expression b acc in + let c, acc = self#pattern c acc in + let d, acc = self#class_expr d acc in + (Pcl_fun (a, b, c, d), acc) + | Pcl_apply (a, b) -> + let a, acc = self#class_expr a acc in + let b, acc = + self#list + (fun (a, b) acc -> + let a, acc = self#arg_label a acc in + let b, acc = self#expression b acc in + ((a, b), acc)) + b acc + in + (Pcl_apply (a, b), acc) + | Pcl_let (a, b, c) -> + let a, acc = self#rec_flag a acc in + let b, acc = self#list self#value_binding b acc in + let c, acc = self#class_expr c acc in + (Pcl_let (a, b, c), acc) + | Pcl_constraint (a, b) -> + let a, acc = self#class_expr a acc in + let b, acc = self#class_type b acc in + (Pcl_constraint (a, b), acc) + | Pcl_extension a -> + let a, acc = self#extension a acc in + (Pcl_extension a, acc) + | Pcl_open (a, b) -> + let a, acc = self#open_description a acc in + let b, acc = self#class_expr b acc in + (Pcl_open (a, b), acc) + + method class_structure : class_structure -> 'acc -> class_structure * 'acc = + fun { pcstr_self; pcstr_fields } acc -> + let pcstr_self, acc = self#pattern pcstr_self acc in + let pcstr_fields, acc = self#list self#class_field pcstr_fields acc in + ({ pcstr_self; pcstr_fields }, acc) + + method class_field : class_field -> 'acc -> class_field * 'acc = + fun { pcf_desc; pcf_loc; pcf_attributes } acc -> + let pcf_desc, acc = self#class_field_desc pcf_desc acc in + let pcf_loc, acc = self#location pcf_loc acc in + let pcf_attributes, acc = self#attributes pcf_attributes acc in + ({ pcf_desc; pcf_loc; pcf_attributes }, acc) + + method class_field_desc + : class_field_desc -> 'acc -> class_field_desc * 'acc = + fun x acc -> + match x with + | Pcf_inherit (a, b, c) -> + let a, acc = self#override_flag a acc in + let b, acc = self#class_expr b acc in + let c, acc = self#option (self#loc self#string) c acc in + (Pcf_inherit (a, b, c), acc) + | Pcf_val a -> + let a, acc = + (fun (a, b, c) acc -> + let a, acc = self#loc self#label a acc in + let b, acc = self#mutable_flag b acc in + let c, acc = self#class_field_kind c acc in + ((a, b, c), acc)) + a acc + in + (Pcf_val a, acc) + | Pcf_method a -> + let a, acc = + (fun (a, b, c) acc -> + let a, acc = self#loc self#label a acc in + let b, acc = self#private_flag b acc in + let c, acc = self#class_field_kind c acc in + ((a, b, c), acc)) + a acc + in + (Pcf_method a, acc) + | Pcf_constraint a -> + let a, acc = + (fun (a, b) acc -> + let a, acc = self#core_type a acc in + let b, acc = self#core_type b acc in + ((a, b), acc)) + a acc + in + (Pcf_constraint a, acc) + | Pcf_initializer a -> + let a, acc = self#expression a acc in + (Pcf_initializer a, acc) + | Pcf_attribute a -> + let a, acc = self#attribute a acc in + (Pcf_attribute a, acc) + | Pcf_extension a -> + let a, acc = self#extension a acc in + (Pcf_extension a, acc) + + method class_field_kind + : class_field_kind -> 'acc -> class_field_kind * 'acc = + fun x acc -> + match x with + | Cfk_virtual a -> + let a, acc = self#core_type a acc in + (Cfk_virtual a, acc) + | Cfk_concrete (a, b) -> + let a, acc = self#override_flag a acc in + let b, acc = self#expression b acc in + (Cfk_concrete (a, b), acc) + + method class_declaration + : class_declaration -> 'acc -> class_declaration * 'acc = self#class_infos self#class_expr - method module_type : module_type -> 'acc -> (module_type * 'acc)= - fun { pmty_desc; pmty_loc; pmty_attributes } -> - fun acc -> - let (pmty_desc, acc) = self#module_type_desc pmty_desc acc in - let (pmty_loc, acc) = self#location pmty_loc acc in - let (pmty_attributes, acc) = self#attributes pmty_attributes acc in - ({ pmty_desc; pmty_loc; pmty_attributes }, acc) - method module_type_desc : - module_type_desc -> 'acc -> (module_type_desc * 'acc)= - fun x -> - fun acc -> - match x with - | Pmty_ident a -> - let (a, acc) = self#longident_loc a acc in - ((Pmty_ident a), acc) - | Pmty_signature a -> - let (a, acc) = self#signature a acc in - ((Pmty_signature a), acc) - | Pmty_functor (a, b) -> - let (a, acc) = self#functor_parameter a acc in - let (b, acc) = self#module_type b acc in - ((Pmty_functor (a, b)), acc) - | Pmty_with (a, b) -> - let (a, acc) = self#module_type a acc in - let (b, acc) = self#list self#with_constraint b acc in - ((Pmty_with (a, b)), acc) - | Pmty_typeof a -> - let (a, acc) = self#module_expr a acc in ((Pmty_typeof a), acc) - | Pmty_extension a -> - let (a, acc) = self#extension a acc in - ((Pmty_extension a), acc) - | Pmty_alias a -> - let (a, acc) = self#longident_loc a acc in - ((Pmty_alias a), acc) - method functor_parameter : - functor_parameter -> 'acc -> (functor_parameter * 'acc)= - fun x -> - fun acc -> - match x with - | Unit -> (Unit, acc) - | Named (a, b) -> - let (a, acc) = self#loc (self#option self#string) a acc in - let (b, acc) = self#module_type b acc in ((Named (a, b)), acc) - method signature : signature -> 'acc -> (signature * 'acc)= + + method module_type : module_type -> 'acc -> module_type * 'acc = + fun { pmty_desc; pmty_loc; pmty_attributes } acc -> + let pmty_desc, acc = self#module_type_desc pmty_desc acc in + let pmty_loc, acc = self#location pmty_loc acc in + let pmty_attributes, acc = self#attributes pmty_attributes acc in + ({ pmty_desc; pmty_loc; pmty_attributes }, acc) + + method module_type_desc + : module_type_desc -> 'acc -> module_type_desc * 'acc = + fun x acc -> + match x with + | Pmty_ident a -> + let a, acc = self#longident_loc a acc in + (Pmty_ident a, acc) + | Pmty_signature a -> + let a, acc = self#signature a acc in + (Pmty_signature a, acc) + | Pmty_functor (a, b) -> + let a, acc = self#functor_parameter a acc in + let b, acc = self#module_type b acc in + (Pmty_functor (a, b), acc) + | Pmty_with (a, b) -> + let a, acc = self#module_type a acc in + let b, acc = self#list self#with_constraint b acc in + (Pmty_with (a, b), acc) + | Pmty_typeof a -> + let a, acc = self#module_expr a acc in + (Pmty_typeof a, acc) + | Pmty_extension a -> + let a, acc = self#extension a acc in + (Pmty_extension a, acc) + | Pmty_alias a -> + let a, acc = self#longident_loc a acc in + (Pmty_alias a, acc) + + method functor_parameter + : functor_parameter -> 'acc -> functor_parameter * 'acc = + fun x acc -> + match x with + | Unit -> (Unit, acc) + | Named (a, b) -> + let a, acc = self#loc (self#option self#string) a acc in + let b, acc = self#module_type b acc in + (Named (a, b), acc) + + method signature : signature -> 'acc -> signature * 'acc = self#list self#signature_item - method signature_item : - signature_item -> 'acc -> (signature_item * 'acc)= - fun { psig_desc; psig_loc } -> - fun acc -> - let (psig_desc, acc) = self#signature_item_desc psig_desc acc in - let (psig_loc, acc) = self#location psig_loc acc in - ({ psig_desc; psig_loc }, acc) - method signature_item_desc : - signature_item_desc -> 'acc -> (signature_item_desc * 'acc)= - fun x -> - fun acc -> - match x with - | Psig_value a -> - let (a, acc) = self#value_description a acc in - ((Psig_value a), acc) - | Psig_type (a, b) -> - let (a, acc) = self#rec_flag a acc in - let (b, acc) = self#list self#type_declaration b acc in - ((Psig_type (a, b)), acc) - | Psig_typesubst a -> - let (a, acc) = self#list self#type_declaration a acc in - ((Psig_typesubst a), acc) - | Psig_typext a -> - let (a, acc) = self#type_extension a acc in - ((Psig_typext a), acc) - | Psig_exception a -> - let (a, acc) = self#type_exception a acc in - ((Psig_exception a), acc) - | Psig_module a -> - let (a, acc) = self#module_declaration a acc in - ((Psig_module a), acc) - | Psig_modsubst a -> - let (a, acc) = self#module_substitution a acc in - ((Psig_modsubst a), acc) - | Psig_recmodule a -> - let (a, acc) = self#list self#module_declaration a acc in - ((Psig_recmodule a), acc) - | Psig_modtype a -> - let (a, acc) = self#module_type_declaration a acc in - ((Psig_modtype a), acc) - | Psig_open a -> - let (a, acc) = self#open_description a acc in - ((Psig_open a), acc) - | Psig_include a -> - let (a, acc) = self#include_description a acc in - ((Psig_include a), acc) - | Psig_class a -> - let (a, acc) = self#list self#class_description a acc in - ((Psig_class a), acc) - | Psig_class_type a -> - let (a, acc) = self#list self#class_type_declaration a acc in - ((Psig_class_type a), acc) - | Psig_attribute a -> - let (a, acc) = self#attribute a acc in - ((Psig_attribute a), acc) - | Psig_extension (a, b) -> - let (a, acc) = self#extension a acc in - let (b, acc) = self#attributes b acc in - ((Psig_extension (a, b)), acc) - method module_declaration : - module_declaration -> 'acc -> (module_declaration * 'acc)= - fun { pmd_name; pmd_type; pmd_attributes; pmd_loc } -> - fun acc -> - let (pmd_name, acc) = - self#loc (self#option self#string) pmd_name acc in - let (pmd_type, acc) = self#module_type pmd_type acc in - let (pmd_attributes, acc) = self#attributes pmd_attributes acc in - let (pmd_loc, acc) = self#location pmd_loc acc in - ({ pmd_name; pmd_type; pmd_attributes; pmd_loc }, acc) - method module_substitution : - module_substitution -> 'acc -> (module_substitution * 'acc)= - fun { pms_name; pms_manifest; pms_attributes; pms_loc } -> - fun acc -> - let (pms_name, acc) = self#loc self#string pms_name acc in - let (pms_manifest, acc) = self#longident_loc pms_manifest acc in - let (pms_attributes, acc) = self#attributes pms_attributes acc in - let (pms_loc, acc) = self#location pms_loc acc in - ({ pms_name; pms_manifest; pms_attributes; pms_loc }, acc) - method module_type_declaration : - module_type_declaration -> 'acc -> (module_type_declaration * 'acc)= - fun { pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc } -> - fun acc -> - let (pmtd_name, acc) = self#loc self#string pmtd_name acc in - let (pmtd_type, acc) = self#option self#module_type pmtd_type acc in - let (pmtd_attributes, acc) = self#attributes pmtd_attributes acc in - let (pmtd_loc, acc) = self#location pmtd_loc acc in - ({ pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc }, acc) - method open_infos : - 'a . - ('a -> 'acc -> ('a * 'acc)) -> - 'a open_infos -> 'acc -> ('a open_infos * 'acc)= - fun _a -> - fun { popen_expr; popen_override; popen_loc; popen_attributes } -> - fun acc -> - let (popen_expr, acc) = _a popen_expr acc in - let (popen_override, acc) = self#override_flag popen_override acc in - let (popen_loc, acc) = self#location popen_loc acc in - let (popen_attributes, acc) = - self#attributes popen_attributes acc in - ({ popen_expr; popen_override; popen_loc; popen_attributes }, - acc) - method open_description : - open_description -> 'acc -> (open_description * 'acc)= + + method signature_item : signature_item -> 'acc -> signature_item * 'acc = + fun { psig_desc; psig_loc } acc -> + let psig_desc, acc = self#signature_item_desc psig_desc acc in + let psig_loc, acc = self#location psig_loc acc in + ({ psig_desc; psig_loc }, acc) + + method signature_item_desc + : signature_item_desc -> 'acc -> signature_item_desc * 'acc = + fun x acc -> + match x with + | Psig_value a -> + let a, acc = self#value_description a acc in + (Psig_value a, acc) + | Psig_type (a, b) -> + let a, acc = self#rec_flag a acc in + let b, acc = self#list self#type_declaration b acc in + (Psig_type (a, b), acc) + | Psig_typesubst a -> + let a, acc = self#list self#type_declaration a acc in + (Psig_typesubst a, acc) + | Psig_typext a -> + let a, acc = self#type_extension a acc in + (Psig_typext a, acc) + | Psig_exception a -> + let a, acc = self#type_exception a acc in + (Psig_exception a, acc) + | Psig_module a -> + let a, acc = self#module_declaration a acc in + (Psig_module a, acc) + | Psig_modsubst a -> + let a, acc = self#module_substitution a acc in + (Psig_modsubst a, acc) + | Psig_recmodule a -> + let a, acc = self#list self#module_declaration a acc in + (Psig_recmodule a, acc) + | Psig_modtype a -> + let a, acc = self#module_type_declaration a acc in + (Psig_modtype a, acc) + | Psig_open a -> + let a, acc = self#open_description a acc in + (Psig_open a, acc) + | Psig_include a -> + let a, acc = self#include_description a acc in + (Psig_include a, acc) + | Psig_class a -> + let a, acc = self#list self#class_description a acc in + (Psig_class a, acc) + | Psig_class_type a -> + let a, acc = self#list self#class_type_declaration a acc in + (Psig_class_type a, acc) + | Psig_attribute a -> + let a, acc = self#attribute a acc in + (Psig_attribute a, acc) + | Psig_extension (a, b) -> + let a, acc = self#extension a acc in + let b, acc = self#attributes b acc in + (Psig_extension (a, b), acc) + + method module_declaration + : module_declaration -> 'acc -> module_declaration * 'acc = + fun { pmd_name; pmd_type; pmd_attributes; pmd_loc } acc -> + let pmd_name, acc = self#loc (self#option self#string) pmd_name acc in + let pmd_type, acc = self#module_type pmd_type acc in + let pmd_attributes, acc = self#attributes pmd_attributes acc in + let pmd_loc, acc = self#location pmd_loc acc in + ({ pmd_name; pmd_type; pmd_attributes; pmd_loc }, acc) + + method module_substitution + : module_substitution -> 'acc -> module_substitution * 'acc = + fun { pms_name; pms_manifest; pms_attributes; pms_loc } acc -> + let pms_name, acc = self#loc self#string pms_name acc in + let pms_manifest, acc = self#longident_loc pms_manifest acc in + let pms_attributes, acc = self#attributes pms_attributes acc in + let pms_loc, acc = self#location pms_loc acc in + ({ pms_name; pms_manifest; pms_attributes; pms_loc }, acc) + + method module_type_declaration + : module_type_declaration -> 'acc -> module_type_declaration * 'acc = + fun { pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc } acc -> + let pmtd_name, acc = self#loc self#string pmtd_name acc in + let pmtd_type, acc = self#option self#module_type pmtd_type acc in + let pmtd_attributes, acc = self#attributes pmtd_attributes acc in + let pmtd_loc, acc = self#location pmtd_loc acc in + ({ pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc }, acc) + + method open_infos + : 'a. + ('a -> 'acc -> 'a * 'acc) -> + 'a open_infos -> + 'acc -> + 'a open_infos * 'acc = + fun _a { popen_expr; popen_override; popen_loc; popen_attributes } acc -> + let popen_expr, acc = _a popen_expr acc in + let popen_override, acc = self#override_flag popen_override acc in + let popen_loc, acc = self#location popen_loc acc in + let popen_attributes, acc = self#attributes popen_attributes acc in + ({ popen_expr; popen_override; popen_loc; popen_attributes }, acc) + + method open_description + : open_description -> 'acc -> open_description * 'acc = self#open_infos self#longident_loc - method open_declaration : - open_declaration -> 'acc -> (open_declaration * 'acc)= + + method open_declaration + : open_declaration -> 'acc -> open_declaration * 'acc = self#open_infos self#module_expr - method include_infos : - 'a . - ('a -> 'acc -> ('a * 'acc)) -> - 'a include_infos -> 'acc -> ('a include_infos * 'acc)= - fun _a -> - fun { pincl_mod; pincl_loc; pincl_attributes } -> - fun acc -> - let (pincl_mod, acc) = _a pincl_mod acc in - let (pincl_loc, acc) = self#location pincl_loc acc in - let (pincl_attributes, acc) = - self#attributes pincl_attributes acc in - ({ pincl_mod; pincl_loc; pincl_attributes }, acc) - method include_description : - include_description -> 'acc -> (include_description * 'acc)= + + method include_infos + : 'a. + ('a -> 'acc -> 'a * 'acc) -> + 'a include_infos -> + 'acc -> + 'a include_infos * 'acc = + fun _a { pincl_mod; pincl_loc; pincl_attributes } acc -> + let pincl_mod, acc = _a pincl_mod acc in + let pincl_loc, acc = self#location pincl_loc acc in + let pincl_attributes, acc = self#attributes pincl_attributes acc in + ({ pincl_mod; pincl_loc; pincl_attributes }, acc) + + method include_description + : include_description -> 'acc -> include_description * 'acc = self#include_infos self#module_type - method include_declaration : - include_declaration -> 'acc -> (include_declaration * 'acc)= + + method include_declaration + : include_declaration -> 'acc -> include_declaration * 'acc = self#include_infos self#module_expr - method with_constraint : - with_constraint -> 'acc -> (with_constraint * 'acc)= - fun x -> - fun acc -> - match x with - | Pwith_type (a, b) -> - let (a, acc) = self#longident_loc a acc in - let (b, acc) = self#type_declaration b acc in - ((Pwith_type (a, b)), acc) - | Pwith_module (a, b) -> - let (a, acc) = self#longident_loc a acc in - let (b, acc) = self#longident_loc b acc in - ((Pwith_module (a, b)), acc) - | Pwith_typesubst (a, b) -> - let (a, acc) = self#longident_loc a acc in - let (b, acc) = self#type_declaration b acc in - ((Pwith_typesubst (a, b)), acc) - | Pwith_modsubst (a, b) -> - let (a, acc) = self#longident_loc a acc in - let (b, acc) = self#longident_loc b acc in - ((Pwith_modsubst (a, b)), acc) - method module_expr : module_expr -> 'acc -> (module_expr * 'acc)= - fun { pmod_desc; pmod_loc; pmod_attributes } -> - fun acc -> - let (pmod_desc, acc) = self#module_expr_desc pmod_desc acc in - let (pmod_loc, acc) = self#location pmod_loc acc in - let (pmod_attributes, acc) = self#attributes pmod_attributes acc in - ({ pmod_desc; pmod_loc; pmod_attributes }, acc) - method module_expr_desc : - module_expr_desc -> 'acc -> (module_expr_desc * 'acc)= - fun x -> - fun acc -> - match x with - | Pmod_ident a -> - let (a, acc) = self#longident_loc a acc in - ((Pmod_ident a), acc) - | Pmod_structure a -> - let (a, acc) = self#structure a acc in - ((Pmod_structure a), acc) - | Pmod_functor (a, b) -> - let (a, acc) = self#functor_parameter a acc in - let (b, acc) = self#module_expr b acc in - ((Pmod_functor (a, b)), acc) - | Pmod_apply (a, b) -> - let (a, acc) = self#module_expr a acc in - let (b, acc) = self#module_expr b acc in - ((Pmod_apply (a, b)), acc) - | Pmod_constraint (a, b) -> - let (a, acc) = self#module_expr a acc in - let (b, acc) = self#module_type b acc in - ((Pmod_constraint (a, b)), acc) - | Pmod_unpack a -> - let (a, acc) = self#expression a acc in ((Pmod_unpack a), acc) - | Pmod_extension a -> - let (a, acc) = self#extension a acc in - ((Pmod_extension a), acc) - method structure : structure -> 'acc -> (structure * 'acc)= + + method with_constraint : with_constraint -> 'acc -> with_constraint * 'acc = + fun x acc -> + match x with + | Pwith_type (a, b) -> + let a, acc = self#longident_loc a acc in + let b, acc = self#type_declaration b acc in + (Pwith_type (a, b), acc) + | Pwith_module (a, b) -> + let a, acc = self#longident_loc a acc in + let b, acc = self#longident_loc b acc in + (Pwith_module (a, b), acc) + | Pwith_typesubst (a, b) -> + let a, acc = self#longident_loc a acc in + let b, acc = self#type_declaration b acc in + (Pwith_typesubst (a, b), acc) + | Pwith_modsubst (a, b) -> + let a, acc = self#longident_loc a acc in + let b, acc = self#longident_loc b acc in + (Pwith_modsubst (a, b), acc) + + method module_expr : module_expr -> 'acc -> module_expr * 'acc = + fun { pmod_desc; pmod_loc; pmod_attributes } acc -> + let pmod_desc, acc = self#module_expr_desc pmod_desc acc in + let pmod_loc, acc = self#location pmod_loc acc in + let pmod_attributes, acc = self#attributes pmod_attributes acc in + ({ pmod_desc; pmod_loc; pmod_attributes }, acc) + + method module_expr_desc + : module_expr_desc -> 'acc -> module_expr_desc * 'acc = + fun x acc -> + match x with + | Pmod_ident a -> + let a, acc = self#longident_loc a acc in + (Pmod_ident a, acc) + | Pmod_structure a -> + let a, acc = self#structure a acc in + (Pmod_structure a, acc) + | Pmod_functor (a, b) -> + let a, acc = self#functor_parameter a acc in + let b, acc = self#module_expr b acc in + (Pmod_functor (a, b), acc) + | Pmod_apply (a, b) -> + let a, acc = self#module_expr a acc in + let b, acc = self#module_expr b acc in + (Pmod_apply (a, b), acc) + | Pmod_constraint (a, b) -> + let a, acc = self#module_expr a acc in + let b, acc = self#module_type b acc in + (Pmod_constraint (a, b), acc) + | Pmod_unpack a -> + let a, acc = self#expression a acc in + (Pmod_unpack a, acc) + | Pmod_extension a -> + let a, acc = self#extension a acc in + (Pmod_extension a, acc) + + method structure : structure -> 'acc -> structure * 'acc = self#list self#structure_item - method structure_item : - structure_item -> 'acc -> (structure_item * 'acc)= - fun { pstr_desc; pstr_loc } -> - fun acc -> - let (pstr_desc, acc) = self#structure_item_desc pstr_desc acc in - let (pstr_loc, acc) = self#location pstr_loc acc in - ({ pstr_desc; pstr_loc }, acc) - method structure_item_desc : - structure_item_desc -> 'acc -> (structure_item_desc * 'acc)= - fun x -> - fun acc -> - match x with - | Pstr_eval (a, b) -> - let (a, acc) = self#expression a acc in - let (b, acc) = self#attributes b acc in - ((Pstr_eval (a, b)), acc) - | Pstr_value (a, b) -> - let (a, acc) = self#rec_flag a acc in - let (b, acc) = self#list self#value_binding b acc in - ((Pstr_value (a, b)), acc) - | Pstr_primitive a -> - let (a, acc) = self#value_description a acc in - ((Pstr_primitive a), acc) - | Pstr_type (a, b) -> - let (a, acc) = self#rec_flag a acc in - let (b, acc) = self#list self#type_declaration b acc in - ((Pstr_type (a, b)), acc) - | Pstr_typext a -> - let (a, acc) = self#type_extension a acc in - ((Pstr_typext a), acc) - | Pstr_exception a -> - let (a, acc) = self#type_exception a acc in - ((Pstr_exception a), acc) - | Pstr_module a -> - let (a, acc) = self#module_binding a acc in - ((Pstr_module a), acc) - | Pstr_recmodule a -> - let (a, acc) = self#list self#module_binding a acc in - ((Pstr_recmodule a), acc) - | Pstr_modtype a -> - let (a, acc) = self#module_type_declaration a acc in - ((Pstr_modtype a), acc) - | Pstr_open a -> - let (a, acc) = self#open_declaration a acc in - ((Pstr_open a), acc) - | Pstr_class a -> - let (a, acc) = self#list self#class_declaration a acc in - ((Pstr_class a), acc) - | Pstr_class_type a -> - let (a, acc) = self#list self#class_type_declaration a acc in - ((Pstr_class_type a), acc) - | Pstr_include a -> - let (a, acc) = self#include_declaration a acc in - ((Pstr_include a), acc) - | Pstr_attribute a -> - let (a, acc) = self#attribute a acc in - ((Pstr_attribute a), acc) - | Pstr_extension (a, b) -> - let (a, acc) = self#extension a acc in - let (b, acc) = self#attributes b acc in - ((Pstr_extension (a, b)), acc) - method value_binding : value_binding -> 'acc -> (value_binding * 'acc)= - fun { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } -> - fun acc -> - let (pvb_pat, acc) = self#pattern pvb_pat acc in - let (pvb_expr, acc) = self#expression pvb_expr acc in - let (pvb_attributes, acc) = self#attributes pvb_attributes acc in - let (pvb_loc, acc) = self#location pvb_loc acc in - ({ pvb_pat; pvb_expr; pvb_attributes; pvb_loc }, acc) - method module_binding : - module_binding -> 'acc -> (module_binding * 'acc)= - fun { pmb_name; pmb_expr; pmb_attributes; pmb_loc } -> - fun acc -> - let (pmb_name, acc) = - self#loc (self#option self#string) pmb_name acc in - let (pmb_expr, acc) = self#module_expr pmb_expr acc in - let (pmb_attributes, acc) = self#attributes pmb_attributes acc in - let (pmb_loc, acc) = self#location pmb_loc acc in - ({ pmb_name; pmb_expr; pmb_attributes; pmb_loc }, acc) - method toplevel_phrase : - toplevel_phrase -> 'acc -> (toplevel_phrase * 'acc)= - fun x -> - fun acc -> - match x with - | Ptop_def a -> - let (a, acc) = self#structure a acc in ((Ptop_def a), acc) - | Ptop_dir a -> - let (a, acc) = self#toplevel_directive a acc in - ((Ptop_dir a), acc) - method toplevel_directive : - toplevel_directive -> 'acc -> (toplevel_directive * 'acc)= - fun { pdir_name; pdir_arg; pdir_loc } -> - fun acc -> - let (pdir_name, acc) = self#loc self#string pdir_name acc in - let (pdir_arg, acc) = - self#option self#directive_argument pdir_arg acc in - let (pdir_loc, acc) = self#location pdir_loc acc in - ({ pdir_name; pdir_arg; pdir_loc }, acc) - method directive_argument : - directive_argument -> 'acc -> (directive_argument * 'acc)= - fun { pdira_desc; pdira_loc } -> - fun acc -> - let (pdira_desc, acc) = self#directive_argument_desc pdira_desc acc in - let (pdira_loc, acc) = self#location pdira_loc acc in - ({ pdira_desc; pdira_loc }, acc) - method directive_argument_desc : - directive_argument_desc -> 'acc -> (directive_argument_desc * 'acc)= - fun x -> - fun acc -> - match x with - | Pdir_string a -> - let (a, acc) = self#string a acc in ((Pdir_string a), acc) - | Pdir_int (a, b) -> - let (a, acc) = self#string a acc in - let (b, acc) = self#option self#char b acc in - ((Pdir_int (a, b)), acc) - | Pdir_ident a -> - let (a, acc) = self#longident a acc in ((Pdir_ident a), acc) - | Pdir_bool a -> - let (a, acc) = self#bool a acc in ((Pdir_bool a), acc) + + method structure_item : structure_item -> 'acc -> structure_item * 'acc = + fun { pstr_desc; pstr_loc } acc -> + let pstr_desc, acc = self#structure_item_desc pstr_desc acc in + let pstr_loc, acc = self#location pstr_loc acc in + ({ pstr_desc; pstr_loc }, acc) + + method structure_item_desc + : structure_item_desc -> 'acc -> structure_item_desc * 'acc = + fun x acc -> + match x with + | Pstr_eval (a, b) -> + let a, acc = self#expression a acc in + let b, acc = self#attributes b acc in + (Pstr_eval (a, b), acc) + | Pstr_value (a, b) -> + let a, acc = self#rec_flag a acc in + let b, acc = self#list self#value_binding b acc in + (Pstr_value (a, b), acc) + | Pstr_primitive a -> + let a, acc = self#value_description a acc in + (Pstr_primitive a, acc) + | Pstr_type (a, b) -> + let a, acc = self#rec_flag a acc in + let b, acc = self#list self#type_declaration b acc in + (Pstr_type (a, b), acc) + | Pstr_typext a -> + let a, acc = self#type_extension a acc in + (Pstr_typext a, acc) + | Pstr_exception a -> + let a, acc = self#type_exception a acc in + (Pstr_exception a, acc) + | Pstr_module a -> + let a, acc = self#module_binding a acc in + (Pstr_module a, acc) + | Pstr_recmodule a -> + let a, acc = self#list self#module_binding a acc in + (Pstr_recmodule a, acc) + | Pstr_modtype a -> + let a, acc = self#module_type_declaration a acc in + (Pstr_modtype a, acc) + | Pstr_open a -> + let a, acc = self#open_declaration a acc in + (Pstr_open a, acc) + | Pstr_class a -> + let a, acc = self#list self#class_declaration a acc in + (Pstr_class a, acc) + | Pstr_class_type a -> + let a, acc = self#list self#class_type_declaration a acc in + (Pstr_class_type a, acc) + | Pstr_include a -> + let a, acc = self#include_declaration a acc in + (Pstr_include a, acc) + | Pstr_attribute a -> + let a, acc = self#attribute a acc in + (Pstr_attribute a, acc) + | Pstr_extension (a, b) -> + let a, acc = self#extension a acc in + let b, acc = self#attributes b acc in + (Pstr_extension (a, b), acc) + + method value_binding : value_binding -> 'acc -> value_binding * 'acc = + fun { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } acc -> + let pvb_pat, acc = self#pattern pvb_pat acc in + let pvb_expr, acc = self#expression pvb_expr acc in + let pvb_attributes, acc = self#attributes pvb_attributes acc in + let pvb_loc, acc = self#location pvb_loc acc in + ({ pvb_pat; pvb_expr; pvb_attributes; pvb_loc }, acc) + + method module_binding : module_binding -> 'acc -> module_binding * 'acc = + fun { pmb_name; pmb_expr; pmb_attributes; pmb_loc } acc -> + let pmb_name, acc = self#loc (self#option self#string) pmb_name acc in + let pmb_expr, acc = self#module_expr pmb_expr acc in + let pmb_attributes, acc = self#attributes pmb_attributes acc in + let pmb_loc, acc = self#location pmb_loc acc in + ({ pmb_name; pmb_expr; pmb_attributes; pmb_loc }, acc) + + method toplevel_phrase : toplevel_phrase -> 'acc -> toplevel_phrase * 'acc = + fun x acc -> + match x with + | Ptop_def a -> + let a, acc = self#structure a acc in + (Ptop_def a, acc) + | Ptop_dir a -> + let a, acc = self#toplevel_directive a acc in + (Ptop_dir a, acc) + + method toplevel_directive + : toplevel_directive -> 'acc -> toplevel_directive * 'acc = + fun { pdir_name; pdir_arg; pdir_loc } acc -> + let pdir_name, acc = self#loc self#string pdir_name acc in + let pdir_arg, acc = self#option self#directive_argument pdir_arg acc in + let pdir_loc, acc = self#location pdir_loc acc in + ({ pdir_name; pdir_arg; pdir_loc }, acc) + + method directive_argument + : directive_argument -> 'acc -> directive_argument * 'acc = + fun { pdira_desc; pdira_loc } acc -> + let pdira_desc, acc = self#directive_argument_desc pdira_desc acc in + let pdira_loc, acc = self#location pdira_loc acc in + ({ pdira_desc; pdira_loc }, acc) + + method directive_argument_desc + : directive_argument_desc -> 'acc -> directive_argument_desc * 'acc = + fun x acc -> + match x with + | Pdir_string a -> + let a, acc = self#string a acc in + (Pdir_string a, acc) + | Pdir_int (a, b) -> + let a, acc = self#string a acc in + let b, acc = self#option self#char b acc in + (Pdir_int (a, b), acc) + | Pdir_ident a -> + let a, acc = self#longident a acc in + (Pdir_ident a, acc) + | Pdir_bool a -> + let a, acc = self#bool a acc in + (Pdir_bool a, acc) + + method cases : cases -> 'acc -> cases * 'acc = self#list self#case end + class virtual ['ctx] map_with_context = object (self) - method virtual bool : 'ctx -> bool -> bool - method virtual char : 'ctx -> char -> char - method virtual int : 'ctx -> int -> int - method virtual list : - 'a . ('ctx -> 'a -> 'a) -> 'ctx -> 'a list -> 'a list - method virtual option : - 'a . ('ctx -> 'a -> 'a) -> 'ctx -> 'a option -> 'a option - method virtual string : 'ctx -> string -> string - method position : 'ctx -> position -> position= - fun ctx -> - fun { pos_fname; pos_lnum; pos_bol; pos_cnum } -> - let pos_fname = self#string ctx pos_fname in - let pos_lnum = self#int ctx pos_lnum in - let pos_bol = self#int ctx pos_bol in - let pos_cnum = self#int ctx pos_cnum in - { pos_fname; pos_lnum; pos_bol; pos_cnum } - method location : 'ctx -> location -> location= - fun ctx -> - fun { loc_start; loc_end; loc_ghost } -> - let loc_start = self#position ctx loc_start in - let loc_end = self#position ctx loc_end in - let loc_ghost = self#bool ctx loc_ghost in - { loc_start; loc_end; loc_ghost } - method location_stack : 'ctx -> location_stack -> location_stack= + method virtual bool : 'ctx -> bool -> bool + + method virtual char : 'ctx -> char -> char + + method virtual int : 'ctx -> int -> int + + method virtual list : 'a. ('ctx -> 'a -> 'a) -> 'ctx -> 'a list -> 'a list + + method virtual option + : 'a. ('ctx -> 'a -> 'a) -> 'ctx -> 'a option -> 'a option + + method virtual string : 'ctx -> string -> string + + method position : 'ctx -> position -> position = + fun ctx { pos_fname; pos_lnum; pos_bol; pos_cnum } -> + let pos_fname = self#string ctx pos_fname in + let pos_lnum = self#int ctx pos_lnum in + let pos_bol = self#int ctx pos_bol in + let pos_cnum = self#int ctx pos_cnum in + { pos_fname; pos_lnum; pos_bol; pos_cnum } + + method location : 'ctx -> location -> location = + fun ctx { loc_start; loc_end; loc_ghost } -> + let loc_start = self#position ctx loc_start in + let loc_end = self#position ctx loc_end in + let loc_ghost = self#bool ctx loc_ghost in + { loc_start; loc_end; loc_ghost } + + method location_stack : 'ctx -> location_stack -> location_stack = self#list self#location - method loc : 'a . ('ctx -> 'a -> 'a) -> 'ctx -> 'a loc -> 'a loc= - fun _a -> - fun ctx -> - fun { txt; loc } -> - let txt = _a ctx txt in - let loc = self#location ctx loc in { txt; loc } - method longident : 'ctx -> longident -> longident= - fun ctx -> - fun x -> - match x with - | Lident a -> let a = self#string ctx a in Lident a - | Ldot (a, b) -> - let a = self#longident ctx a in - let b = self#string ctx b in Ldot (a, b) - | Lapply (a, b) -> - let a = self#longident ctx a in - let b = self#longident ctx b in Lapply (a, b) - method longident_loc : 'ctx -> longident_loc -> longident_loc= + + method loc : 'a. ('ctx -> 'a -> 'a) -> 'ctx -> 'a loc -> 'a loc = + fun _a ctx { txt; loc } -> + let txt = _a ctx txt in + let loc = self#location ctx loc in + { txt; loc } + + method longident : 'ctx -> longident -> longident = + fun ctx x -> + match x with + | Lident a -> + let a = self#string ctx a in + Lident a + | Ldot (a, b) -> + let a = self#longident ctx a in + let b = self#string ctx b in + Ldot (a, b) + | Lapply (a, b) -> + let a = self#longident ctx a in + let b = self#longident ctx b in + Lapply (a, b) + + method longident_loc : 'ctx -> longident_loc -> longident_loc = self#loc self#longident - method rec_flag : 'ctx -> rec_flag -> rec_flag= fun _ctx -> fun x -> x - method direction_flag : 'ctx -> direction_flag -> direction_flag= - fun _ctx -> fun x -> x - method private_flag : 'ctx -> private_flag -> private_flag= - fun _ctx -> fun x -> x - method mutable_flag : 'ctx -> mutable_flag -> mutable_flag= - fun _ctx -> fun x -> x - method virtual_flag : 'ctx -> virtual_flag -> virtual_flag= - fun _ctx -> fun x -> x - method override_flag : 'ctx -> override_flag -> override_flag= - fun _ctx -> fun x -> x - method closed_flag : 'ctx -> closed_flag -> closed_flag= - fun _ctx -> fun x -> x - method label : 'ctx -> label -> label= self#string - method arg_label : 'ctx -> arg_label -> arg_label= - fun ctx -> - fun x -> - match x with - | Nolabel -> Nolabel - | Labelled a -> let a = self#string ctx a in Labelled a - | Optional a -> let a = self#string ctx a in Optional a - method variance : 'ctx -> variance -> variance= fun _ctx -> fun x -> x - method constant : 'ctx -> constant -> constant= - fun ctx -> - fun x -> - match x with - | Pconst_integer (a, b) -> - let a = self#string ctx a in - let b = self#option self#char ctx b in Pconst_integer (a, b) - | Pconst_char a -> let a = self#char ctx a in Pconst_char a - | Pconst_string (a, b) -> - let a = self#string ctx a in - let b = self#option self#string ctx b in Pconst_string (a, b) - | Pconst_float (a, b) -> - let a = self#string ctx a in - let b = self#option self#char ctx b in Pconst_float (a, b) - method attribute : 'ctx -> attribute -> attribute= - fun ctx -> - fun { attr_name; attr_payload; attr_loc } -> - let attr_name = self#loc self#string ctx attr_name in - let attr_payload = self#payload ctx attr_payload in - let attr_loc = self#location ctx attr_loc in - { attr_name; attr_payload; attr_loc } - method extension : 'ctx -> extension -> extension= - fun ctx -> - fun (a, b) -> - let a = self#loc self#string ctx a in - let b = self#payload ctx b in (a, b) - method attributes : 'ctx -> attributes -> attributes= + + method rec_flag : 'ctx -> rec_flag -> rec_flag = fun _ctx x -> x + + method direction_flag : 'ctx -> direction_flag -> direction_flag = + fun _ctx x -> x + + method private_flag : 'ctx -> private_flag -> private_flag = fun _ctx x -> x + + method mutable_flag : 'ctx -> mutable_flag -> mutable_flag = fun _ctx x -> x + + method virtual_flag : 'ctx -> virtual_flag -> virtual_flag = fun _ctx x -> x + + method override_flag : 'ctx -> override_flag -> override_flag = + fun _ctx x -> x + + method closed_flag : 'ctx -> closed_flag -> closed_flag = fun _ctx x -> x + + method label : 'ctx -> label -> label = self#string + + method arg_label : 'ctx -> arg_label -> arg_label = + fun ctx x -> + match x with + | Nolabel -> Nolabel + | Labelled a -> + let a = self#string ctx a in + Labelled a + | Optional a -> + let a = self#string ctx a in + Optional a + + method variance : 'ctx -> variance -> variance = fun _ctx x -> x + + method injectivity : 'ctx -> injectivity -> injectivity = fun _ctx x -> x + + method constant : 'ctx -> constant -> constant = + fun ctx x -> + match x with + | Pconst_integer (a, b) -> + let a = self#string ctx a in + let b = self#option self#char ctx b in + Pconst_integer (a, b) + | Pconst_char a -> + let a = self#char ctx a in + Pconst_char a + | Pconst_string (a, b, c) -> + let a = self#string ctx a in + let b = self#location ctx b in + let c = self#option self#string ctx c in + Pconst_string (a, b, c) + | Pconst_float (a, b) -> + let a = self#string ctx a in + let b = self#option self#char ctx b in + Pconst_float (a, b) + + method attribute : 'ctx -> attribute -> attribute = + fun ctx { attr_name; attr_payload; attr_loc } -> + let attr_name = self#loc self#string ctx attr_name in + let attr_payload = self#payload ctx attr_payload in + let attr_loc = self#location ctx attr_loc in + { attr_name; attr_payload; attr_loc } + + method extension : 'ctx -> extension -> extension = + fun ctx (a, b) -> + let a = self#loc self#string ctx a in + let b = self#payload ctx b in + (a, b) + + method attributes : 'ctx -> attributes -> attributes = self#list self#attribute - method payload : 'ctx -> payload -> payload= - fun ctx -> - fun x -> - match x with - | PStr a -> let a = self#structure ctx a in PStr a - | PSig a -> let a = self#signature ctx a in PSig a - | PTyp a -> let a = self#core_type ctx a in PTyp a - | PPat (a, b) -> - let a = self#pattern ctx a in - let b = self#option self#expression ctx b in PPat (a, b) - method core_type : 'ctx -> core_type -> core_type= - fun ctx -> - fun { ptyp_desc; ptyp_loc; ptyp_loc_stack; ptyp_attributes } -> - let ptyp_desc = self#core_type_desc ctx ptyp_desc in - let ptyp_loc = self#location ctx ptyp_loc in - let ptyp_loc_stack = self#location_stack ctx ptyp_loc_stack in - let ptyp_attributes = self#attributes ctx ptyp_attributes in - { ptyp_desc; ptyp_loc; ptyp_loc_stack; ptyp_attributes } - method core_type_desc : 'ctx -> core_type_desc -> core_type_desc= - fun ctx -> - fun x -> - match x with - | Ptyp_any -> Ptyp_any - | Ptyp_var a -> let a = self#string ctx a in Ptyp_var a - | Ptyp_arrow (a, b, c) -> - let a = self#arg_label ctx a in - let b = self#core_type ctx b in - let c = self#core_type ctx c in Ptyp_arrow (a, b, c) - | Ptyp_tuple a -> - let a = self#list self#core_type ctx a in Ptyp_tuple a - | Ptyp_constr (a, b) -> - let a = self#longident_loc ctx a in - let b = self#list self#core_type ctx b in Ptyp_constr (a, b) - | Ptyp_object (a, b) -> - let a = self#list self#object_field ctx a in - let b = self#closed_flag ctx b in Ptyp_object (a, b) - | Ptyp_class (a, b) -> - let a = self#longident_loc ctx a in - let b = self#list self#core_type ctx b in Ptyp_class (a, b) - | Ptyp_alias (a, b) -> - let a = self#core_type ctx a in - let b = self#string ctx b in Ptyp_alias (a, b) - | Ptyp_variant (a, b, c) -> - let a = self#list self#row_field ctx a in - let b = self#closed_flag ctx b in - let c = self#option (self#list self#label) ctx c in - Ptyp_variant (a, b, c) - | Ptyp_poly (a, b) -> - let a = self#list (self#loc self#string) ctx a in - let b = self#core_type ctx b in Ptyp_poly (a, b) - | Ptyp_package a -> - let a = self#package_type ctx a in Ptyp_package a - | Ptyp_extension a -> - let a = self#extension ctx a in Ptyp_extension a - method package_type : 'ctx -> package_type -> package_type= - fun ctx -> - fun (a, b) -> - let a = self#longident_loc ctx a in - let b = - self#list - (fun ctx -> - fun (a, b) -> - let a = self#longident_loc ctx a in - let b = self#core_type ctx b in (a, b)) ctx b in - (a, b) - method row_field : 'ctx -> row_field -> row_field= - fun ctx -> - fun { prf_desc; prf_loc; prf_attributes } -> - let prf_desc = self#row_field_desc ctx prf_desc in - let prf_loc = self#location ctx prf_loc in - let prf_attributes = self#attributes ctx prf_attributes in - { prf_desc; prf_loc; prf_attributes } - method row_field_desc : 'ctx -> row_field_desc -> row_field_desc= - fun ctx -> - fun x -> - match x with - | Rtag (a, b, c) -> - let a = self#loc self#label ctx a in - let b = self#bool ctx b in - let c = self#list self#core_type ctx c in Rtag (a, b, c) - | Rinherit a -> let a = self#core_type ctx a in Rinherit a - method object_field : 'ctx -> object_field -> object_field= - fun ctx -> - fun { pof_desc; pof_loc; pof_attributes } -> - let pof_desc = self#object_field_desc ctx pof_desc in - let pof_loc = self#location ctx pof_loc in - let pof_attributes = self#attributes ctx pof_attributes in - { pof_desc; pof_loc; pof_attributes } - method object_field_desc : - 'ctx -> object_field_desc -> object_field_desc= - fun ctx -> - fun x -> - match x with - | Otag (a, b) -> - let a = self#loc self#label ctx a in - let b = self#core_type ctx b in Otag (a, b) - | Oinherit a -> let a = self#core_type ctx a in Oinherit a - method pattern : 'ctx -> pattern -> pattern= - fun ctx -> - fun { ppat_desc; ppat_loc; ppat_loc_stack; ppat_attributes } -> - let ppat_desc = self#pattern_desc ctx ppat_desc in - let ppat_loc = self#location ctx ppat_loc in - let ppat_loc_stack = self#location_stack ctx ppat_loc_stack in - let ppat_attributes = self#attributes ctx ppat_attributes in - { ppat_desc; ppat_loc; ppat_loc_stack; ppat_attributes } - method pattern_desc : 'ctx -> pattern_desc -> pattern_desc= - fun ctx -> - fun x -> - match x with - | Ppat_any -> Ppat_any - | Ppat_var a -> let a = self#loc self#string ctx a in Ppat_var a - | Ppat_alias (a, b) -> - let a = self#pattern ctx a in - let b = self#loc self#string ctx b in Ppat_alias (a, b) - | Ppat_constant a -> let a = self#constant ctx a in Ppat_constant a - | Ppat_interval (a, b) -> - let a = self#constant ctx a in - let b = self#constant ctx b in Ppat_interval (a, b) - | Ppat_tuple a -> - let a = self#list self#pattern ctx a in Ppat_tuple a - | Ppat_construct (a, b) -> - let a = self#longident_loc ctx a in - let b = self#option self#pattern ctx b in Ppat_construct (a, b) - | Ppat_variant (a, b) -> - let a = self#label ctx a in - let b = self#option self#pattern ctx b in Ppat_variant (a, b) - | Ppat_record (a, b) -> - let a = - self#list - (fun ctx -> - fun (a, b) -> - let a = self#longident_loc ctx a in - let b = self#pattern ctx b in (a, b)) ctx a in - let b = self#closed_flag ctx b in Ppat_record (a, b) - | Ppat_array a -> - let a = self#list self#pattern ctx a in Ppat_array a - | Ppat_or (a, b) -> - let a = self#pattern ctx a in - let b = self#pattern ctx b in Ppat_or (a, b) - | Ppat_constraint (a, b) -> - let a = self#pattern ctx a in - let b = self#core_type ctx b in Ppat_constraint (a, b) - | Ppat_type a -> let a = self#longident_loc ctx a in Ppat_type a - | Ppat_lazy a -> let a = self#pattern ctx a in Ppat_lazy a - | Ppat_unpack a -> - let a = self#loc (self#option self#string) ctx a in - Ppat_unpack a - | Ppat_exception a -> - let a = self#pattern ctx a in Ppat_exception a - | Ppat_extension a -> - let a = self#extension ctx a in Ppat_extension a - | Ppat_open (a, b) -> - let a = self#longident_loc ctx a in - let b = self#pattern ctx b in Ppat_open (a, b) - method expression : 'ctx -> expression -> expression= - fun ctx -> - fun { pexp_desc; pexp_loc; pexp_loc_stack; pexp_attributes } -> - let pexp_desc = self#expression_desc ctx pexp_desc in - let pexp_loc = self#location ctx pexp_loc in - let pexp_loc_stack = self#location_stack ctx pexp_loc_stack in - let pexp_attributes = self#attributes ctx pexp_attributes in - { pexp_desc; pexp_loc; pexp_loc_stack; pexp_attributes } - method expression_desc : 'ctx -> expression_desc -> expression_desc= - fun ctx -> - fun x -> - match x with - | Pexp_ident a -> let a = self#longident_loc ctx a in Pexp_ident a - | Pexp_constant a -> let a = self#constant ctx a in Pexp_constant a - | Pexp_let (a, b, c) -> - let a = self#rec_flag ctx a in - let b = self#list self#value_binding ctx b in - let c = self#expression ctx c in Pexp_let (a, b, c) - | Pexp_function a -> - let a = self#list self#case ctx a in Pexp_function a - | Pexp_fun (a, b, c, d) -> - let a = self#arg_label ctx a in - let b = self#option self#expression ctx b in - let c = self#pattern ctx c in - let d = self#expression ctx d in Pexp_fun (a, b, c, d) - | Pexp_apply (a, b) -> - let a = self#expression ctx a in - let b = - self#list - (fun ctx -> - fun (a, b) -> - let a = self#arg_label ctx a in - let b = self#expression ctx b in (a, b)) ctx b in - Pexp_apply (a, b) - | Pexp_match (a, b) -> - let a = self#expression ctx a in - let b = self#list self#case ctx b in Pexp_match (a, b) - | Pexp_try (a, b) -> - let a = self#expression ctx a in - let b = self#list self#case ctx b in Pexp_try (a, b) - | Pexp_tuple a -> - let a = self#list self#expression ctx a in Pexp_tuple a - | Pexp_construct (a, b) -> + + method payload : 'ctx -> payload -> payload = + fun ctx x -> + match x with + | PStr a -> + let a = self#structure ctx a in + PStr a + | PSig a -> + let a = self#signature ctx a in + PSig a + | PTyp a -> + let a = self#core_type ctx a in + PTyp a + | PPat (a, b) -> + let a = self#pattern ctx a in + let b = self#option self#expression ctx b in + PPat (a, b) + + method core_type : 'ctx -> core_type -> core_type = + fun ctx { ptyp_desc; ptyp_loc; ptyp_loc_stack; ptyp_attributes } -> + let ptyp_desc = self#core_type_desc ctx ptyp_desc in + let ptyp_loc = self#location ctx ptyp_loc in + let ptyp_loc_stack = self#location_stack ctx ptyp_loc_stack in + let ptyp_attributes = self#attributes ctx ptyp_attributes in + { ptyp_desc; ptyp_loc; ptyp_loc_stack; ptyp_attributes } + + method core_type_desc : 'ctx -> core_type_desc -> core_type_desc = + fun ctx x -> + match x with + | Ptyp_any -> Ptyp_any + | Ptyp_var a -> + let a = self#string ctx a in + Ptyp_var a + | Ptyp_arrow (a, b, c) -> + let a = self#arg_label ctx a in + let b = self#core_type ctx b in + let c = self#core_type ctx c in + Ptyp_arrow (a, b, c) + | Ptyp_tuple a -> + let a = self#list self#core_type ctx a in + Ptyp_tuple a + | Ptyp_constr (a, b) -> + let a = self#longident_loc ctx a in + let b = self#list self#core_type ctx b in + Ptyp_constr (a, b) + | Ptyp_object (a, b) -> + let a = self#list self#object_field ctx a in + let b = self#closed_flag ctx b in + Ptyp_object (a, b) + | Ptyp_class (a, b) -> + let a = self#longident_loc ctx a in + let b = self#list self#core_type ctx b in + Ptyp_class (a, b) + | Ptyp_alias (a, b) -> + let a = self#core_type ctx a in + let b = self#string ctx b in + Ptyp_alias (a, b) + | Ptyp_variant (a, b, c) -> + let a = self#list self#row_field ctx a in + let b = self#closed_flag ctx b in + let c = self#option (self#list self#label) ctx c in + Ptyp_variant (a, b, c) + | Ptyp_poly (a, b) -> + let a = self#list (self#loc self#string) ctx a in + let b = self#core_type ctx b in + Ptyp_poly (a, b) + | Ptyp_package a -> + let a = self#package_type ctx a in + Ptyp_package a + | Ptyp_extension a -> + let a = self#extension ctx a in + Ptyp_extension a + + method package_type : 'ctx -> package_type -> package_type = + fun ctx (a, b) -> + let a = self#longident_loc ctx a in + let b = + self#list + (fun ctx (a, b) -> let a = self#longident_loc ctx a in - let b = self#option self#expression ctx b in - Pexp_construct (a, b) - | Pexp_variant (a, b) -> - let a = self#label ctx a in - let b = self#option self#expression ctx b in - Pexp_variant (a, b) - | Pexp_record (a, b) -> - let a = - self#list - (fun ctx -> - fun (a, b) -> - let a = self#longident_loc ctx a in - let b = self#expression ctx b in (a, b)) ctx a in - let b = self#option self#expression ctx b in Pexp_record (a, b) - | Pexp_field (a, b) -> - let a = self#expression ctx a in - let b = self#longident_loc ctx b in Pexp_field (a, b) - | Pexp_setfield (a, b, c) -> - let a = self#expression ctx a in - let b = self#longident_loc ctx b in - let c = self#expression ctx c in Pexp_setfield (a, b, c) - | Pexp_array a -> - let a = self#list self#expression ctx a in Pexp_array a - | Pexp_ifthenelse (a, b, c) -> - let a = self#expression ctx a in - let b = self#expression ctx b in - let c = self#option self#expression ctx c in - Pexp_ifthenelse (a, b, c) - | Pexp_sequence (a, b) -> - let a = self#expression ctx a in - let b = self#expression ctx b in Pexp_sequence (a, b) - | Pexp_while (a, b) -> - let a = self#expression ctx a in - let b = self#expression ctx b in Pexp_while (a, b) - | Pexp_for (a, b, c, d, e) -> - let a = self#pattern ctx a in - let b = self#expression ctx b in - let c = self#expression ctx c in - let d = self#direction_flag ctx d in - let e = self#expression ctx e in Pexp_for (a, b, c, d, e) - | Pexp_constraint (a, b) -> - let a = self#expression ctx a in - let b = self#core_type ctx b in Pexp_constraint (a, b) - | Pexp_coerce (a, b, c) -> - let a = self#expression ctx a in - let b = self#option self#core_type ctx b in - let c = self#core_type ctx c in Pexp_coerce (a, b, c) - | Pexp_send (a, b) -> - let a = self#expression ctx a in - let b = self#loc self#label ctx b in Pexp_send (a, b) - | Pexp_new a -> let a = self#longident_loc ctx a in Pexp_new a - | Pexp_setinstvar (a, b) -> - let a = self#loc self#label ctx a in - let b = self#expression ctx b in Pexp_setinstvar (a, b) - | Pexp_override a -> - let a = - self#list - (fun ctx -> - fun (a, b) -> - let a = self#loc self#label ctx a in - let b = self#expression ctx b in (a, b)) ctx a in - Pexp_override a - | Pexp_letmodule (a, b, c) -> - let a = self#loc (self#option self#string) ctx a in - let b = self#module_expr ctx b in - let c = self#expression ctx c in Pexp_letmodule (a, b, c) - | Pexp_letexception (a, b) -> - let a = self#extension_constructor ctx a in - let b = self#expression ctx b in Pexp_letexception (a, b) - | Pexp_assert a -> let a = self#expression ctx a in Pexp_assert a - | Pexp_lazy a -> let a = self#expression ctx a in Pexp_lazy a - | Pexp_poly (a, b) -> - let a = self#expression ctx a in - let b = self#option self#core_type ctx b in Pexp_poly (a, b) - | Pexp_object a -> - let a = self#class_structure ctx a in Pexp_object a - | Pexp_newtype (a, b) -> - let a = self#loc self#string ctx a in - let b = self#expression ctx b in Pexp_newtype (a, b) - | Pexp_pack a -> let a = self#module_expr ctx a in Pexp_pack a - | Pexp_open (a, b) -> - let a = self#open_declaration ctx a in - let b = self#expression ctx b in Pexp_open (a, b) - | Pexp_letop a -> let a = self#letop ctx a in Pexp_letop a - | Pexp_extension a -> - let a = self#extension ctx a in Pexp_extension a - | Pexp_unreachable -> Pexp_unreachable - method case : 'ctx -> case -> case= - fun ctx -> - fun { pc_lhs; pc_guard; pc_rhs } -> - let pc_lhs = self#pattern ctx pc_lhs in - let pc_guard = self#option self#expression ctx pc_guard in - let pc_rhs = self#expression ctx pc_rhs in - { pc_lhs; pc_guard; pc_rhs } - method letop : 'ctx -> letop -> letop= - fun ctx -> - fun { let_; ands; body } -> - let let_ = self#binding_op ctx let_ in - let ands = self#list self#binding_op ctx ands in - let body = self#expression ctx body in { let_; ands; body } - method binding_op : 'ctx -> binding_op -> binding_op= - fun ctx -> - fun { pbop_op; pbop_pat; pbop_exp; pbop_loc } -> - let pbop_op = self#loc self#string ctx pbop_op in - let pbop_pat = self#pattern ctx pbop_pat in - let pbop_exp = self#expression ctx pbop_exp in - let pbop_loc = self#location ctx pbop_loc in - { pbop_op; pbop_pat; pbop_exp; pbop_loc } - method value_description : - 'ctx -> value_description -> value_description= - fun ctx -> - fun { pval_name; pval_type; pval_prim; pval_attributes; pval_loc } -> - let pval_name = self#loc self#string ctx pval_name in - let pval_type = self#core_type ctx pval_type in - let pval_prim = self#list self#string ctx pval_prim in - let pval_attributes = self#attributes ctx pval_attributes in - let pval_loc = self#location ctx pval_loc in - { pval_name; pval_type; pval_prim; pval_attributes; pval_loc } - method type_declaration : 'ctx -> type_declaration -> type_declaration= - fun ctx -> - fun - { ptype_name; ptype_params; ptype_cstrs; ptype_kind; ptype_private; - ptype_manifest; ptype_attributes; ptype_loc } - -> - let ptype_name = self#loc self#string ctx ptype_name in - let ptype_params = - self#list - (fun ctx -> - fun (a, b) -> - let a = self#core_type ctx a in - let b = self#variance ctx b in (a, b)) ctx ptype_params in - let ptype_cstrs = - self#list - (fun ctx -> - fun (a, b, c) -> - let a = self#core_type ctx a in - let b = self#core_type ctx b in - let c = self#location ctx c in (a, b, c)) ctx ptype_cstrs in - let ptype_kind = self#type_kind ctx ptype_kind in - let ptype_private = self#private_flag ctx ptype_private in - let ptype_manifest = self#option self#core_type ctx ptype_manifest in - let ptype_attributes = self#attributes ctx ptype_attributes in - let ptype_loc = self#location ctx ptype_loc in + let b = self#core_type ctx b in + (a, b)) + ctx b + in + (a, b) + + method row_field : 'ctx -> row_field -> row_field = + fun ctx { prf_desc; prf_loc; prf_attributes } -> + let prf_desc = self#row_field_desc ctx prf_desc in + let prf_loc = self#location ctx prf_loc in + let prf_attributes = self#attributes ctx prf_attributes in + { prf_desc; prf_loc; prf_attributes } + + method row_field_desc : 'ctx -> row_field_desc -> row_field_desc = + fun ctx x -> + match x with + | Rtag (a, b, c) -> + let a = self#loc self#label ctx a in + let b = self#bool ctx b in + let c = self#list self#core_type ctx c in + Rtag (a, b, c) + | Rinherit a -> + let a = self#core_type ctx a in + Rinherit a + + method object_field : 'ctx -> object_field -> object_field = + fun ctx { pof_desc; pof_loc; pof_attributes } -> + let pof_desc = self#object_field_desc ctx pof_desc in + let pof_loc = self#location ctx pof_loc in + let pof_attributes = self#attributes ctx pof_attributes in + { pof_desc; pof_loc; pof_attributes } + + method object_field_desc : 'ctx -> object_field_desc -> object_field_desc = + fun ctx x -> + match x with + | Otag (a, b) -> + let a = self#loc self#label ctx a in + let b = self#core_type ctx b in + Otag (a, b) + | Oinherit a -> + let a = self#core_type ctx a in + Oinherit a + + method pattern : 'ctx -> pattern -> pattern = + fun ctx { ppat_desc; ppat_loc; ppat_loc_stack; ppat_attributes } -> + let ppat_desc = self#pattern_desc ctx ppat_desc in + let ppat_loc = self#location ctx ppat_loc in + let ppat_loc_stack = self#location_stack ctx ppat_loc_stack in + let ppat_attributes = self#attributes ctx ppat_attributes in + { ppat_desc; ppat_loc; ppat_loc_stack; ppat_attributes } + + method pattern_desc : 'ctx -> pattern_desc -> pattern_desc = + fun ctx x -> + match x with + | Ppat_any -> Ppat_any + | Ppat_var a -> + let a = self#loc self#string ctx a in + Ppat_var a + | Ppat_alias (a, b) -> + let a = self#pattern ctx a in + let b = self#loc self#string ctx b in + Ppat_alias (a, b) + | Ppat_constant a -> + let a = self#constant ctx a in + Ppat_constant a + | Ppat_interval (a, b) -> + let a = self#constant ctx a in + let b = self#constant ctx b in + Ppat_interval (a, b) + | Ppat_tuple a -> + let a = self#list self#pattern ctx a in + Ppat_tuple a + | Ppat_construct (a, b) -> + let a = self#longident_loc ctx a in + let b = self#option self#pattern ctx b in + Ppat_construct (a, b) + | Ppat_variant (a, b) -> + let a = self#label ctx a in + let b = self#option self#pattern ctx b in + Ppat_variant (a, b) + | Ppat_record (a, b) -> + let a = + self#list + (fun ctx (a, b) -> + let a = self#longident_loc ctx a in + let b = self#pattern ctx b in + (a, b)) + ctx a + in + let b = self#closed_flag ctx b in + Ppat_record (a, b) + | Ppat_array a -> + let a = self#list self#pattern ctx a in + Ppat_array a + | Ppat_or (a, b) -> + let a = self#pattern ctx a in + let b = self#pattern ctx b in + Ppat_or (a, b) + | Ppat_constraint (a, b) -> + let a = self#pattern ctx a in + let b = self#core_type ctx b in + Ppat_constraint (a, b) + | Ppat_type a -> + let a = self#longident_loc ctx a in + Ppat_type a + | Ppat_lazy a -> + let a = self#pattern ctx a in + Ppat_lazy a + | Ppat_unpack a -> + let a = self#loc (self#option self#string) ctx a in + Ppat_unpack a + | Ppat_exception a -> + let a = self#pattern ctx a in + Ppat_exception a + | Ppat_extension a -> + let a = self#extension ctx a in + Ppat_extension a + | Ppat_open (a, b) -> + let a = self#longident_loc ctx a in + let b = self#pattern ctx b in + Ppat_open (a, b) + + method expression : 'ctx -> expression -> expression = + fun ctx { pexp_desc; pexp_loc; pexp_loc_stack; pexp_attributes } -> + let pexp_desc = self#expression_desc ctx pexp_desc in + let pexp_loc = self#location ctx pexp_loc in + let pexp_loc_stack = self#location_stack ctx pexp_loc_stack in + let pexp_attributes = self#attributes ctx pexp_attributes in + { pexp_desc; pexp_loc; pexp_loc_stack; pexp_attributes } + + method expression_desc : 'ctx -> expression_desc -> expression_desc = + fun ctx x -> + match x with + | Pexp_ident a -> + let a = self#longident_loc ctx a in + Pexp_ident a + | Pexp_constant a -> + let a = self#constant ctx a in + Pexp_constant a + | Pexp_let (a, b, c) -> + let a = self#rec_flag ctx a in + let b = self#list self#value_binding ctx b in + let c = self#expression ctx c in + Pexp_let (a, b, c) + | Pexp_function a -> + let a = self#cases ctx a in + Pexp_function a + | Pexp_fun (a, b, c, d) -> + let a = self#arg_label ctx a in + let b = self#option self#expression ctx b in + let c = self#pattern ctx c in + let d = self#expression ctx d in + Pexp_fun (a, b, c, d) + | Pexp_apply (a, b) -> + let a = self#expression ctx a in + let b = + self#list + (fun ctx (a, b) -> + let a = self#arg_label ctx a in + let b = self#expression ctx b in + (a, b)) + ctx b + in + Pexp_apply (a, b) + | Pexp_match (a, b) -> + let a = self#expression ctx a in + let b = self#cases ctx b in + Pexp_match (a, b) + | Pexp_try (a, b) -> + let a = self#expression ctx a in + let b = self#cases ctx b in + Pexp_try (a, b) + | Pexp_tuple a -> + let a = self#list self#expression ctx a in + Pexp_tuple a + | Pexp_construct (a, b) -> + let a = self#longident_loc ctx a in + let b = self#option self#expression ctx b in + Pexp_construct (a, b) + | Pexp_variant (a, b) -> + let a = self#label ctx a in + let b = self#option self#expression ctx b in + Pexp_variant (a, b) + | Pexp_record (a, b) -> + let a = + self#list + (fun ctx (a, b) -> + let a = self#longident_loc ctx a in + let b = self#expression ctx b in + (a, b)) + ctx a + in + let b = self#option self#expression ctx b in + Pexp_record (a, b) + | Pexp_field (a, b) -> + let a = self#expression ctx a in + let b = self#longident_loc ctx b in + Pexp_field (a, b) + | Pexp_setfield (a, b, c) -> + let a = self#expression ctx a in + let b = self#longident_loc ctx b in + let c = self#expression ctx c in + Pexp_setfield (a, b, c) + | Pexp_array a -> + let a = self#list self#expression ctx a in + Pexp_array a + | Pexp_ifthenelse (a, b, c) -> + let a = self#expression ctx a in + let b = self#expression ctx b in + let c = self#option self#expression ctx c in + Pexp_ifthenelse (a, b, c) + | Pexp_sequence (a, b) -> + let a = self#expression ctx a in + let b = self#expression ctx b in + Pexp_sequence (a, b) + | Pexp_while (a, b) -> + let a = self#expression ctx a in + let b = self#expression ctx b in + Pexp_while (a, b) + | Pexp_for (a, b, c, d, e) -> + let a = self#pattern ctx a in + let b = self#expression ctx b in + let c = self#expression ctx c in + let d = self#direction_flag ctx d in + let e = self#expression ctx e in + Pexp_for (a, b, c, d, e) + | Pexp_constraint (a, b) -> + let a = self#expression ctx a in + let b = self#core_type ctx b in + Pexp_constraint (a, b) + | Pexp_coerce (a, b, c) -> + let a = self#expression ctx a in + let b = self#option self#core_type ctx b in + let c = self#core_type ctx c in + Pexp_coerce (a, b, c) + | Pexp_send (a, b) -> + let a = self#expression ctx a in + let b = self#loc self#label ctx b in + Pexp_send (a, b) + | Pexp_new a -> + let a = self#longident_loc ctx a in + Pexp_new a + | Pexp_setinstvar (a, b) -> + let a = self#loc self#label ctx a in + let b = self#expression ctx b in + Pexp_setinstvar (a, b) + | Pexp_override a -> + let a = + self#list + (fun ctx (a, b) -> + let a = self#loc self#label ctx a in + let b = self#expression ctx b in + (a, b)) + ctx a + in + Pexp_override a + | Pexp_letmodule (a, b, c) -> + let a = self#loc (self#option self#string) ctx a in + let b = self#module_expr ctx b in + let c = self#expression ctx c in + Pexp_letmodule (a, b, c) + | Pexp_letexception (a, b) -> + let a = self#extension_constructor ctx a in + let b = self#expression ctx b in + Pexp_letexception (a, b) + | Pexp_assert a -> + let a = self#expression ctx a in + Pexp_assert a + | Pexp_lazy a -> + let a = self#expression ctx a in + Pexp_lazy a + | Pexp_poly (a, b) -> + let a = self#expression ctx a in + let b = self#option self#core_type ctx b in + Pexp_poly (a, b) + | Pexp_object a -> + let a = self#class_structure ctx a in + Pexp_object a + | Pexp_newtype (a, b) -> + let a = self#loc self#string ctx a in + let b = self#expression ctx b in + Pexp_newtype (a, b) + | Pexp_pack a -> + let a = self#module_expr ctx a in + Pexp_pack a + | Pexp_open (a, b) -> + let a = self#open_declaration ctx a in + let b = self#expression ctx b in + Pexp_open (a, b) + | Pexp_letop a -> + let a = self#letop ctx a in + Pexp_letop a + | Pexp_extension a -> + let a = self#extension ctx a in + Pexp_extension a + | Pexp_unreachable -> Pexp_unreachable + + method case : 'ctx -> case -> case = + fun ctx { pc_lhs; pc_guard; pc_rhs } -> + let pc_lhs = self#pattern ctx pc_lhs in + let pc_guard = self#option self#expression ctx pc_guard in + let pc_rhs = self#expression ctx pc_rhs in + { pc_lhs; pc_guard; pc_rhs } + + method letop : 'ctx -> letop -> letop = + fun ctx { let_; ands; body } -> + let let_ = self#binding_op ctx let_ in + let ands = self#list self#binding_op ctx ands in + let body = self#expression ctx body in + { let_; ands; body } + + method binding_op : 'ctx -> binding_op -> binding_op = + fun ctx { pbop_op; pbop_pat; pbop_exp; pbop_loc } -> + let pbop_op = self#loc self#string ctx pbop_op in + let pbop_pat = self#pattern ctx pbop_pat in + let pbop_exp = self#expression ctx pbop_exp in + let pbop_loc = self#location ctx pbop_loc in + { pbop_op; pbop_pat; pbop_exp; pbop_loc } + + method value_description : 'ctx -> value_description -> value_description = + fun ctx { pval_name; pval_type; pval_prim; pval_attributes; pval_loc } -> + let pval_name = self#loc self#string ctx pval_name in + let pval_type = self#core_type ctx pval_type in + let pval_prim = self#list self#string ctx pval_prim in + let pval_attributes = self#attributes ctx pval_attributes in + let pval_loc = self#location ctx pval_loc in + { pval_name; pval_type; pval_prim; pval_attributes; pval_loc } + + method type_declaration : 'ctx -> type_declaration -> type_declaration = + fun ctx { ptype_name; ptype_params; @@ -5053,1056 +6078,1361 @@ ptype_private; ptype_manifest; ptype_attributes; - ptype_loc - } - method type_kind : 'ctx -> type_kind -> type_kind= - fun ctx -> - fun x -> - match x with - | Ptype_abstract -> Ptype_abstract - | Ptype_variant a -> - let a = self#list self#constructor_declaration ctx a in - Ptype_variant a - | Ptype_record a -> - let a = self#list self#label_declaration ctx a in - Ptype_record a - | Ptype_open -> Ptype_open - method label_declaration : - 'ctx -> label_declaration -> label_declaration= - fun ctx -> - fun { pld_name; pld_mutable; pld_type; pld_loc; pld_attributes } -> - let pld_name = self#loc self#string ctx pld_name in - let pld_mutable = self#mutable_flag ctx pld_mutable in - let pld_type = self#core_type ctx pld_type in - let pld_loc = self#location ctx pld_loc in - let pld_attributes = self#attributes ctx pld_attributes in - { pld_name; pld_mutable; pld_type; pld_loc; pld_attributes } - method constructor_declaration : - 'ctx -> constructor_declaration -> constructor_declaration= - fun ctx -> - fun { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } -> - let pcd_name = self#loc self#string ctx pcd_name in - let pcd_args = self#constructor_arguments ctx pcd_args in - let pcd_res = self#option self#core_type ctx pcd_res in - let pcd_loc = self#location ctx pcd_loc in - let pcd_attributes = self#attributes ctx pcd_attributes in - { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } - method constructor_arguments : - 'ctx -> constructor_arguments -> constructor_arguments= - fun ctx -> - fun x -> - match x with - | Pcstr_tuple a -> - let a = self#list self#core_type ctx a in Pcstr_tuple a - | Pcstr_record a -> - let a = self#list self#label_declaration ctx a in - Pcstr_record a - method type_extension : 'ctx -> type_extension -> type_extension= - fun ctx -> - fun - { ptyext_path; ptyext_params; ptyext_constructors; ptyext_private; - ptyext_loc; ptyext_attributes } - -> - let ptyext_path = self#longident_loc ctx ptyext_path in - let ptyext_params = - self#list - (fun ctx -> - fun (a, b) -> - let a = self#core_type ctx a in - let b = self#variance ctx b in (a, b)) ctx ptyext_params in - let ptyext_constructors = - self#list self#extension_constructor ctx ptyext_constructors in - let ptyext_private = self#private_flag ctx ptyext_private in - let ptyext_loc = self#location ctx ptyext_loc in - let ptyext_attributes = self#attributes ctx ptyext_attributes in + ptype_loc; + } -> + let ptype_name = self#loc self#string ctx ptype_name in + let ptype_params = + self#list + (fun ctx (a, b) -> + let a = self#core_type ctx a in + let b = + (fun ctx (a, b) -> + let a = self#variance ctx a in + let b = self#injectivity ctx b in + (a, b)) + ctx b + in + (a, b)) + ctx ptype_params + in + let ptype_cstrs = + self#list + (fun ctx (a, b, c) -> + let a = self#core_type ctx a in + let b = self#core_type ctx b in + let c = self#location ctx c in + (a, b, c)) + ctx ptype_cstrs + in + let ptype_kind = self#type_kind ctx ptype_kind in + let ptype_private = self#private_flag ctx ptype_private in + let ptype_manifest = self#option self#core_type ctx ptype_manifest in + let ptype_attributes = self#attributes ctx ptype_attributes in + let ptype_loc = self#location ctx ptype_loc in + { + ptype_name; + ptype_params; + ptype_cstrs; + ptype_kind; + ptype_private; + ptype_manifest; + ptype_attributes; + ptype_loc; + } + + method type_kind : 'ctx -> type_kind -> type_kind = + fun ctx x -> + match x with + | Ptype_abstract -> Ptype_abstract + | Ptype_variant a -> + let a = self#list self#constructor_declaration ctx a in + Ptype_variant a + | Ptype_record a -> + let a = self#list self#label_declaration ctx a in + Ptype_record a + | Ptype_open -> Ptype_open + + method label_declaration : 'ctx -> label_declaration -> label_declaration = + fun ctx { pld_name; pld_mutable; pld_type; pld_loc; pld_attributes } -> + let pld_name = self#loc self#string ctx pld_name in + let pld_mutable = self#mutable_flag ctx pld_mutable in + let pld_type = self#core_type ctx pld_type in + let pld_loc = self#location ctx pld_loc in + let pld_attributes = self#attributes ctx pld_attributes in + { pld_name; pld_mutable; pld_type; pld_loc; pld_attributes } + + method constructor_declaration + : 'ctx -> constructor_declaration -> constructor_declaration = + fun ctx { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } -> + let pcd_name = self#loc self#string ctx pcd_name in + let pcd_args = self#constructor_arguments ctx pcd_args in + let pcd_res = self#option self#core_type ctx pcd_res in + let pcd_loc = self#location ctx pcd_loc in + let pcd_attributes = self#attributes ctx pcd_attributes in + { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } + + method constructor_arguments + : 'ctx -> constructor_arguments -> constructor_arguments = + fun ctx x -> + match x with + | Pcstr_tuple a -> + let a = self#list self#core_type ctx a in + Pcstr_tuple a + | Pcstr_record a -> + let a = self#list self#label_declaration ctx a in + Pcstr_record a + + method type_extension : 'ctx -> type_extension -> type_extension = + fun ctx { ptyext_path; ptyext_params; ptyext_constructors; ptyext_private; ptyext_loc; - ptyext_attributes - } - method extension_constructor : - 'ctx -> extension_constructor -> extension_constructor= - fun ctx -> - fun { pext_name; pext_kind; pext_loc; pext_attributes } -> - let pext_name = self#loc self#string ctx pext_name in - let pext_kind = self#extension_constructor_kind ctx pext_kind in - let pext_loc = self#location ctx pext_loc in - let pext_attributes = self#attributes ctx pext_attributes in - { pext_name; pext_kind; pext_loc; pext_attributes } - method type_exception : 'ctx -> type_exception -> type_exception= - fun ctx -> - fun { ptyexn_constructor; ptyexn_loc; ptyexn_attributes } -> - let ptyexn_constructor = - self#extension_constructor ctx ptyexn_constructor in - let ptyexn_loc = self#location ctx ptyexn_loc in - let ptyexn_attributes = self#attributes ctx ptyexn_attributes in - { ptyexn_constructor; ptyexn_loc; ptyexn_attributes } - method extension_constructor_kind : - 'ctx -> extension_constructor_kind -> extension_constructor_kind= - fun ctx -> - fun x -> - match x with - | Pext_decl (a, b) -> - let a = self#constructor_arguments ctx a in - let b = self#option self#core_type ctx b in Pext_decl (a, b) - | Pext_rebind a -> - let a = self#longident_loc ctx a in Pext_rebind a - method class_type : 'ctx -> class_type -> class_type= - fun ctx -> - fun { pcty_desc; pcty_loc; pcty_attributes } -> - let pcty_desc = self#class_type_desc ctx pcty_desc in - let pcty_loc = self#location ctx pcty_loc in - let pcty_attributes = self#attributes ctx pcty_attributes in - { pcty_desc; pcty_loc; pcty_attributes } - method class_type_desc : 'ctx -> class_type_desc -> class_type_desc= - fun ctx -> - fun x -> - match x with - | Pcty_constr (a, b) -> - let a = self#longident_loc ctx a in - let b = self#list self#core_type ctx b in Pcty_constr (a, b) - | Pcty_signature a -> - let a = self#class_signature ctx a in Pcty_signature a - | Pcty_arrow (a, b, c) -> - let a = self#arg_label ctx a in - let b = self#core_type ctx b in - let c = self#class_type ctx c in Pcty_arrow (a, b, c) - | Pcty_extension a -> - let a = self#extension ctx a in Pcty_extension a - | Pcty_open (a, b) -> - let a = self#open_description ctx a in - let b = self#class_type ctx b in Pcty_open (a, b) - method class_signature : 'ctx -> class_signature -> class_signature= - fun ctx -> - fun { pcsig_self; pcsig_fields } -> - let pcsig_self = self#core_type ctx pcsig_self in - let pcsig_fields = self#list self#class_type_field ctx pcsig_fields in - { pcsig_self; pcsig_fields } - method class_type_field : 'ctx -> class_type_field -> class_type_field= - fun ctx -> - fun { pctf_desc; pctf_loc; pctf_attributes } -> - let pctf_desc = self#class_type_field_desc ctx pctf_desc in - let pctf_loc = self#location ctx pctf_loc in - let pctf_attributes = self#attributes ctx pctf_attributes in - { pctf_desc; pctf_loc; pctf_attributes } - method class_type_field_desc : - 'ctx -> class_type_field_desc -> class_type_field_desc= - fun ctx -> - fun x -> - match x with - | Pctf_inherit a -> let a = self#class_type ctx a in Pctf_inherit a - | Pctf_val a -> - let a = - (fun ctx -> - fun (a, b, c, d) -> - let a = self#loc self#label ctx a in - let b = self#mutable_flag ctx b in - let c = self#virtual_flag ctx c in - let d = self#core_type ctx d in (a, b, c, d)) ctx a in - Pctf_val a - | Pctf_method a -> - let a = - (fun ctx -> - fun (a, b, c, d) -> - let a = self#loc self#label ctx a in - let b = self#private_flag ctx b in - let c = self#virtual_flag ctx c in - let d = self#core_type ctx d in (a, b, c, d)) ctx a in - Pctf_method a - | Pctf_constraint a -> - let a = - (fun ctx -> - fun (a, b) -> - let a = self#core_type ctx a in - let b = self#core_type ctx b in (a, b)) ctx a in - Pctf_constraint a - | Pctf_attribute a -> - let a = self#attribute ctx a in Pctf_attribute a - | Pctf_extension a -> - let a = self#extension ctx a in Pctf_extension a - method class_infos : - 'a . ('ctx -> 'a -> 'a) -> 'ctx -> 'a class_infos -> 'a class_infos= - fun _a -> - fun ctx -> - fun - { pci_virt; pci_params; pci_name; pci_expr; pci_loc; - pci_attributes } - -> - let pci_virt = self#virtual_flag ctx pci_virt in - let pci_params = - self#list - (fun ctx -> - fun (a, b) -> - let a = self#core_type ctx a in - let b = self#variance ctx b in (a, b)) ctx pci_params in - let pci_name = self#loc self#string ctx pci_name in - let pci_expr = _a ctx pci_expr in - let pci_loc = self#location ctx pci_loc in - let pci_attributes = self#attributes ctx pci_attributes in - { - pci_virt; - pci_params; - pci_name; - pci_expr; - pci_loc; - pci_attributes - } - method class_description : - 'ctx -> class_description -> class_description= + ptyext_attributes; + } -> + let ptyext_path = self#longident_loc ctx ptyext_path in + let ptyext_params = + self#list + (fun ctx (a, b) -> + let a = self#core_type ctx a in + let b = + (fun ctx (a, b) -> + let a = self#variance ctx a in + let b = self#injectivity ctx b in + (a, b)) + ctx b + in + (a, b)) + ctx ptyext_params + in + let ptyext_constructors = + self#list self#extension_constructor ctx ptyext_constructors + in + let ptyext_private = self#private_flag ctx ptyext_private in + let ptyext_loc = self#location ctx ptyext_loc in + let ptyext_attributes = self#attributes ctx ptyext_attributes in + { + ptyext_path; + ptyext_params; + ptyext_constructors; + ptyext_private; + ptyext_loc; + ptyext_attributes; + } + + method extension_constructor + : 'ctx -> extension_constructor -> extension_constructor = + fun ctx { pext_name; pext_kind; pext_loc; pext_attributes } -> + let pext_name = self#loc self#string ctx pext_name in + let pext_kind = self#extension_constructor_kind ctx pext_kind in + let pext_loc = self#location ctx pext_loc in + let pext_attributes = self#attributes ctx pext_attributes in + { pext_name; pext_kind; pext_loc; pext_attributes } + + method type_exception : 'ctx -> type_exception -> type_exception = + fun ctx { ptyexn_constructor; ptyexn_loc; ptyexn_attributes } -> + let ptyexn_constructor = + self#extension_constructor ctx ptyexn_constructor + in + let ptyexn_loc = self#location ctx ptyexn_loc in + let ptyexn_attributes = self#attributes ctx ptyexn_attributes in + { ptyexn_constructor; ptyexn_loc; ptyexn_attributes } + + method extension_constructor_kind + : 'ctx -> extension_constructor_kind -> extension_constructor_kind = + fun ctx x -> + match x with + | Pext_decl (a, b) -> + let a = self#constructor_arguments ctx a in + let b = self#option self#core_type ctx b in + Pext_decl (a, b) + | Pext_rebind a -> + let a = self#longident_loc ctx a in + Pext_rebind a + + method class_type : 'ctx -> class_type -> class_type = + fun ctx { pcty_desc; pcty_loc; pcty_attributes } -> + let pcty_desc = self#class_type_desc ctx pcty_desc in + let pcty_loc = self#location ctx pcty_loc in + let pcty_attributes = self#attributes ctx pcty_attributes in + { pcty_desc; pcty_loc; pcty_attributes } + + method class_type_desc : 'ctx -> class_type_desc -> class_type_desc = + fun ctx x -> + match x with + | Pcty_constr (a, b) -> + let a = self#longident_loc ctx a in + let b = self#list self#core_type ctx b in + Pcty_constr (a, b) + | Pcty_signature a -> + let a = self#class_signature ctx a in + Pcty_signature a + | Pcty_arrow (a, b, c) -> + let a = self#arg_label ctx a in + let b = self#core_type ctx b in + let c = self#class_type ctx c in + Pcty_arrow (a, b, c) + | Pcty_extension a -> + let a = self#extension ctx a in + Pcty_extension a + | Pcty_open (a, b) -> + let a = self#open_description ctx a in + let b = self#class_type ctx b in + Pcty_open (a, b) + + method class_signature : 'ctx -> class_signature -> class_signature = + fun ctx { pcsig_self; pcsig_fields } -> + let pcsig_self = self#core_type ctx pcsig_self in + let pcsig_fields = self#list self#class_type_field ctx pcsig_fields in + { pcsig_self; pcsig_fields } + + method class_type_field : 'ctx -> class_type_field -> class_type_field = + fun ctx { pctf_desc; pctf_loc; pctf_attributes } -> + let pctf_desc = self#class_type_field_desc ctx pctf_desc in + let pctf_loc = self#location ctx pctf_loc in + let pctf_attributes = self#attributes ctx pctf_attributes in + { pctf_desc; pctf_loc; pctf_attributes } + + method class_type_field_desc + : 'ctx -> class_type_field_desc -> class_type_field_desc = + fun ctx x -> + match x with + | Pctf_inherit a -> + let a = self#class_type ctx a in + Pctf_inherit a + | Pctf_val a -> + let a = + (fun ctx (a, b, c, d) -> + let a = self#loc self#label ctx a in + let b = self#mutable_flag ctx b in + let c = self#virtual_flag ctx c in + let d = self#core_type ctx d in + (a, b, c, d)) + ctx a + in + Pctf_val a + | Pctf_method a -> + let a = + (fun ctx (a, b, c, d) -> + let a = self#loc self#label ctx a in + let b = self#private_flag ctx b in + let c = self#virtual_flag ctx c in + let d = self#core_type ctx d in + (a, b, c, d)) + ctx a + in + Pctf_method a + | Pctf_constraint a -> + let a = + (fun ctx (a, b) -> + let a = self#core_type ctx a in + let b = self#core_type ctx b in + (a, b)) + ctx a + in + Pctf_constraint a + | Pctf_attribute a -> + let a = self#attribute ctx a in + Pctf_attribute a + | Pctf_extension a -> + let a = self#extension ctx a in + Pctf_extension a + + method class_infos + : 'a. ('ctx -> 'a -> 'a) -> 'ctx -> 'a class_infos -> 'a class_infos = + fun _a ctx + { pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes } -> + let pci_virt = self#virtual_flag ctx pci_virt in + let pci_params = + self#list + (fun ctx (a, b) -> + let a = self#core_type ctx a in + let b = + (fun ctx (a, b) -> + let a = self#variance ctx a in + let b = self#injectivity ctx b in + (a, b)) + ctx b + in + (a, b)) + ctx pci_params + in + let pci_name = self#loc self#string ctx pci_name in + let pci_expr = _a ctx pci_expr in + let pci_loc = self#location ctx pci_loc in + let pci_attributes = self#attributes ctx pci_attributes in + { pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes } + + method class_description : 'ctx -> class_description -> class_description = self#class_infos self#class_type - method class_type_declaration : - 'ctx -> class_type_declaration -> class_type_declaration= + + method class_type_declaration + : 'ctx -> class_type_declaration -> class_type_declaration = self#class_infos self#class_type - method class_expr : 'ctx -> class_expr -> class_expr= - fun ctx -> - fun { pcl_desc; pcl_loc; pcl_attributes } -> - let pcl_desc = self#class_expr_desc ctx pcl_desc in - let pcl_loc = self#location ctx pcl_loc in - let pcl_attributes = self#attributes ctx pcl_attributes in - { pcl_desc; pcl_loc; pcl_attributes } - method class_expr_desc : 'ctx -> class_expr_desc -> class_expr_desc= - fun ctx -> - fun x -> - match x with - | Pcl_constr (a, b) -> - let a = self#longident_loc ctx a in - let b = self#list self#core_type ctx b in Pcl_constr (a, b) - | Pcl_structure a -> - let a = self#class_structure ctx a in Pcl_structure a - | Pcl_fun (a, b, c, d) -> - let a = self#arg_label ctx a in - let b = self#option self#expression ctx b in - let c = self#pattern ctx c in - let d = self#class_expr ctx d in Pcl_fun (a, b, c, d) - | Pcl_apply (a, b) -> - let a = self#class_expr ctx a in - let b = - self#list - (fun ctx -> - fun (a, b) -> - let a = self#arg_label ctx a in - let b = self#expression ctx b in (a, b)) ctx b in - Pcl_apply (a, b) - | Pcl_let (a, b, c) -> - let a = self#rec_flag ctx a in - let b = self#list self#value_binding ctx b in - let c = self#class_expr ctx c in Pcl_let (a, b, c) - | Pcl_constraint (a, b) -> - let a = self#class_expr ctx a in - let b = self#class_type ctx b in Pcl_constraint (a, b) - | Pcl_extension a -> - let a = self#extension ctx a in Pcl_extension a - | Pcl_open (a, b) -> - let a = self#open_description ctx a in - let b = self#class_expr ctx b in Pcl_open (a, b) - method class_structure : 'ctx -> class_structure -> class_structure= - fun ctx -> - fun { pcstr_self; pcstr_fields } -> - let pcstr_self = self#pattern ctx pcstr_self in - let pcstr_fields = self#list self#class_field ctx pcstr_fields in - { pcstr_self; pcstr_fields } - method class_field : 'ctx -> class_field -> class_field= - fun ctx -> - fun { pcf_desc; pcf_loc; pcf_attributes } -> - let pcf_desc = self#class_field_desc ctx pcf_desc in - let pcf_loc = self#location ctx pcf_loc in - let pcf_attributes = self#attributes ctx pcf_attributes in - { pcf_desc; pcf_loc; pcf_attributes } - method class_field_desc : 'ctx -> class_field_desc -> class_field_desc= - fun ctx -> - fun x -> - match x with - | Pcf_inherit (a, b, c) -> - let a = self#override_flag ctx a in - let b = self#class_expr ctx b in - let c = self#option (self#loc self#string) ctx c in - Pcf_inherit (a, b, c) - | Pcf_val a -> - let a = - (fun ctx -> - fun (a, b, c) -> - let a = self#loc self#label ctx a in - let b = self#mutable_flag ctx b in - let c = self#class_field_kind ctx c in (a, b, c)) ctx a in - Pcf_val a - | Pcf_method a -> - let a = - (fun ctx -> - fun (a, b, c) -> - let a = self#loc self#label ctx a in - let b = self#private_flag ctx b in - let c = self#class_field_kind ctx c in (a, b, c)) ctx a in - Pcf_method a - | Pcf_constraint a -> - let a = - (fun ctx -> - fun (a, b) -> - let a = self#core_type ctx a in - let b = self#core_type ctx b in (a, b)) ctx a in - Pcf_constraint a - | Pcf_initializer a -> - let a = self#expression ctx a in Pcf_initializer a - | Pcf_attribute a -> - let a = self#attribute ctx a in Pcf_attribute a - | Pcf_extension a -> - let a = self#extension ctx a in Pcf_extension a - method class_field_kind : 'ctx -> class_field_kind -> class_field_kind= - fun ctx -> - fun x -> - match x with - | Cfk_virtual a -> let a = self#core_type ctx a in Cfk_virtual a - | Cfk_concrete (a, b) -> - let a = self#override_flag ctx a in - let b = self#expression ctx b in Cfk_concrete (a, b) - method class_declaration : - 'ctx -> class_declaration -> class_declaration= + + method class_expr : 'ctx -> class_expr -> class_expr = + fun ctx { pcl_desc; pcl_loc; pcl_attributes } -> + let pcl_desc = self#class_expr_desc ctx pcl_desc in + let pcl_loc = self#location ctx pcl_loc in + let pcl_attributes = self#attributes ctx pcl_attributes in + { pcl_desc; pcl_loc; pcl_attributes } + + method class_expr_desc : 'ctx -> class_expr_desc -> class_expr_desc = + fun ctx x -> + match x with + | Pcl_constr (a, b) -> + let a = self#longident_loc ctx a in + let b = self#list self#core_type ctx b in + Pcl_constr (a, b) + | Pcl_structure a -> + let a = self#class_structure ctx a in + Pcl_structure a + | Pcl_fun (a, b, c, d) -> + let a = self#arg_label ctx a in + let b = self#option self#expression ctx b in + let c = self#pattern ctx c in + let d = self#class_expr ctx d in + Pcl_fun (a, b, c, d) + | Pcl_apply (a, b) -> + let a = self#class_expr ctx a in + let b = + self#list + (fun ctx (a, b) -> + let a = self#arg_label ctx a in + let b = self#expression ctx b in + (a, b)) + ctx b + in + Pcl_apply (a, b) + | Pcl_let (a, b, c) -> + let a = self#rec_flag ctx a in + let b = self#list self#value_binding ctx b in + let c = self#class_expr ctx c in + Pcl_let (a, b, c) + | Pcl_constraint (a, b) -> + let a = self#class_expr ctx a in + let b = self#class_type ctx b in + Pcl_constraint (a, b) + | Pcl_extension a -> + let a = self#extension ctx a in + Pcl_extension a + | Pcl_open (a, b) -> + let a = self#open_description ctx a in + let b = self#class_expr ctx b in + Pcl_open (a, b) + + method class_structure : 'ctx -> class_structure -> class_structure = + fun ctx { pcstr_self; pcstr_fields } -> + let pcstr_self = self#pattern ctx pcstr_self in + let pcstr_fields = self#list self#class_field ctx pcstr_fields in + { pcstr_self; pcstr_fields } + + method class_field : 'ctx -> class_field -> class_field = + fun ctx { pcf_desc; pcf_loc; pcf_attributes } -> + let pcf_desc = self#class_field_desc ctx pcf_desc in + let pcf_loc = self#location ctx pcf_loc in + let pcf_attributes = self#attributes ctx pcf_attributes in + { pcf_desc; pcf_loc; pcf_attributes } + + method class_field_desc : 'ctx -> class_field_desc -> class_field_desc = + fun ctx x -> + match x with + | Pcf_inherit (a, b, c) -> + let a = self#override_flag ctx a in + let b = self#class_expr ctx b in + let c = self#option (self#loc self#string) ctx c in + Pcf_inherit (a, b, c) + | Pcf_val a -> + let a = + (fun ctx (a, b, c) -> + let a = self#loc self#label ctx a in + let b = self#mutable_flag ctx b in + let c = self#class_field_kind ctx c in + (a, b, c)) + ctx a + in + Pcf_val a + | Pcf_method a -> + let a = + (fun ctx (a, b, c) -> + let a = self#loc self#label ctx a in + let b = self#private_flag ctx b in + let c = self#class_field_kind ctx c in + (a, b, c)) + ctx a + in + Pcf_method a + | Pcf_constraint a -> + let a = + (fun ctx (a, b) -> + let a = self#core_type ctx a in + let b = self#core_type ctx b in + (a, b)) + ctx a + in + Pcf_constraint a + | Pcf_initializer a -> + let a = self#expression ctx a in + Pcf_initializer a + | Pcf_attribute a -> + let a = self#attribute ctx a in + Pcf_attribute a + | Pcf_extension a -> + let a = self#extension ctx a in + Pcf_extension a + + method class_field_kind : 'ctx -> class_field_kind -> class_field_kind = + fun ctx x -> + match x with + | Cfk_virtual a -> + let a = self#core_type ctx a in + Cfk_virtual a + | Cfk_concrete (a, b) -> + let a = self#override_flag ctx a in + let b = self#expression ctx b in + Cfk_concrete (a, b) + + method class_declaration : 'ctx -> class_declaration -> class_declaration = self#class_infos self#class_expr - method module_type : 'ctx -> module_type -> module_type= - fun ctx -> - fun { pmty_desc; pmty_loc; pmty_attributes } -> - let pmty_desc = self#module_type_desc ctx pmty_desc in - let pmty_loc = self#location ctx pmty_loc in - let pmty_attributes = self#attributes ctx pmty_attributes in - { pmty_desc; pmty_loc; pmty_attributes } - method module_type_desc : 'ctx -> module_type_desc -> module_type_desc= - fun ctx -> - fun x -> - match x with - | Pmty_ident a -> let a = self#longident_loc ctx a in Pmty_ident a - | Pmty_signature a -> - let a = self#signature ctx a in Pmty_signature a - | Pmty_functor (a, b) -> - let a = self#functor_parameter ctx a in - let b = self#module_type ctx b in Pmty_functor (a, b) - | Pmty_with (a, b) -> - let a = self#module_type ctx a in - let b = self#list self#with_constraint ctx b in - Pmty_with (a, b) - | Pmty_typeof a -> let a = self#module_expr ctx a in Pmty_typeof a - | Pmty_extension a -> - let a = self#extension ctx a in Pmty_extension a - | Pmty_alias a -> let a = self#longident_loc ctx a in Pmty_alias a - method functor_parameter : - 'ctx -> functor_parameter -> functor_parameter= - fun ctx -> - fun x -> - match x with - | Unit -> Unit - | Named (a, b) -> - let a = self#loc (self#option self#string) ctx a in - let b = self#module_type ctx b in Named (a, b) - method signature : 'ctx -> signature -> signature= + + method module_type : 'ctx -> module_type -> module_type = + fun ctx { pmty_desc; pmty_loc; pmty_attributes } -> + let pmty_desc = self#module_type_desc ctx pmty_desc in + let pmty_loc = self#location ctx pmty_loc in + let pmty_attributes = self#attributes ctx pmty_attributes in + { pmty_desc; pmty_loc; pmty_attributes } + + method module_type_desc : 'ctx -> module_type_desc -> module_type_desc = + fun ctx x -> + match x with + | Pmty_ident a -> + let a = self#longident_loc ctx a in + Pmty_ident a + | Pmty_signature a -> + let a = self#signature ctx a in + Pmty_signature a + | Pmty_functor (a, b) -> + let a = self#functor_parameter ctx a in + let b = self#module_type ctx b in + Pmty_functor (a, b) + | Pmty_with (a, b) -> + let a = self#module_type ctx a in + let b = self#list self#with_constraint ctx b in + Pmty_with (a, b) + | Pmty_typeof a -> + let a = self#module_expr ctx a in + Pmty_typeof a + | Pmty_extension a -> + let a = self#extension ctx a in + Pmty_extension a + | Pmty_alias a -> + let a = self#longident_loc ctx a in + Pmty_alias a + + method functor_parameter : 'ctx -> functor_parameter -> functor_parameter = + fun ctx x -> + match x with + | Unit -> Unit + | Named (a, b) -> + let a = self#loc (self#option self#string) ctx a in + let b = self#module_type ctx b in + Named (a, b) + + method signature : 'ctx -> signature -> signature = self#list self#signature_item - method signature_item : 'ctx -> signature_item -> signature_item= - fun ctx -> - fun { psig_desc; psig_loc } -> - let psig_desc = self#signature_item_desc ctx psig_desc in - let psig_loc = self#location ctx psig_loc in - { psig_desc; psig_loc } - method signature_item_desc : - 'ctx -> signature_item_desc -> signature_item_desc= - fun ctx -> - fun x -> - match x with - | Psig_value a -> - let a = self#value_description ctx a in Psig_value a - | Psig_type (a, b) -> - let a = self#rec_flag ctx a in - let b = self#list self#type_declaration ctx b in - Psig_type (a, b) - | Psig_typesubst a -> - let a = self#list self#type_declaration ctx a in - Psig_typesubst a - | Psig_typext a -> - let a = self#type_extension ctx a in Psig_typext a - | Psig_exception a -> - let a = self#type_exception ctx a in Psig_exception a - | Psig_module a -> - let a = self#module_declaration ctx a in Psig_module a - | Psig_modsubst a -> - let a = self#module_substitution ctx a in Psig_modsubst a - | Psig_recmodule a -> - let a = self#list self#module_declaration ctx a in - Psig_recmodule a - | Psig_modtype a -> - let a = self#module_type_declaration ctx a in Psig_modtype a - | Psig_open a -> let a = self#open_description ctx a in Psig_open a - | Psig_include a -> - let a = self#include_description ctx a in Psig_include a - | Psig_class a -> - let a = self#list self#class_description ctx a in Psig_class a - | Psig_class_type a -> - let a = self#list self#class_type_declaration ctx a in - Psig_class_type a - | Psig_attribute a -> - let a = self#attribute ctx a in Psig_attribute a - | Psig_extension (a, b) -> - let a = self#extension ctx a in - let b = self#attributes ctx b in Psig_extension (a, b) - method module_declaration : - 'ctx -> module_declaration -> module_declaration= - fun ctx -> - fun { pmd_name; pmd_type; pmd_attributes; pmd_loc } -> - let pmd_name = self#loc (self#option self#string) ctx pmd_name in - let pmd_type = self#module_type ctx pmd_type in - let pmd_attributes = self#attributes ctx pmd_attributes in - let pmd_loc = self#location ctx pmd_loc in - { pmd_name; pmd_type; pmd_attributes; pmd_loc } - method module_substitution : - 'ctx -> module_substitution -> module_substitution= - fun ctx -> - fun { pms_name; pms_manifest; pms_attributes; pms_loc } -> - let pms_name = self#loc self#string ctx pms_name in - let pms_manifest = self#longident_loc ctx pms_manifest in - let pms_attributes = self#attributes ctx pms_attributes in - let pms_loc = self#location ctx pms_loc in - { pms_name; pms_manifest; pms_attributes; pms_loc } - method module_type_declaration : - 'ctx -> module_type_declaration -> module_type_declaration= - fun ctx -> - fun { pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc } -> - let pmtd_name = self#loc self#string ctx pmtd_name in - let pmtd_type = self#option self#module_type ctx pmtd_type in - let pmtd_attributes = self#attributes ctx pmtd_attributes in - let pmtd_loc = self#location ctx pmtd_loc in - { pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc } - method open_infos : - 'a . ('ctx -> 'a -> 'a) -> 'ctx -> 'a open_infos -> 'a open_infos= - fun _a -> - fun ctx -> - fun { popen_expr; popen_override; popen_loc; popen_attributes } -> - let popen_expr = _a ctx popen_expr in - let popen_override = self#override_flag ctx popen_override in - let popen_loc = self#location ctx popen_loc in - let popen_attributes = self#attributes ctx popen_attributes in - { popen_expr; popen_override; popen_loc; popen_attributes } - method open_description : 'ctx -> open_description -> open_description= + + method signature_item : 'ctx -> signature_item -> signature_item = + fun ctx { psig_desc; psig_loc } -> + let psig_desc = self#signature_item_desc ctx psig_desc in + let psig_loc = self#location ctx psig_loc in + { psig_desc; psig_loc } + + method signature_item_desc + : 'ctx -> signature_item_desc -> signature_item_desc = + fun ctx x -> + match x with + | Psig_value a -> + let a = self#value_description ctx a in + Psig_value a + | Psig_type (a, b) -> + let a = self#rec_flag ctx a in + let b = self#list self#type_declaration ctx b in + Psig_type (a, b) + | Psig_typesubst a -> + let a = self#list self#type_declaration ctx a in + Psig_typesubst a + | Psig_typext a -> + let a = self#type_extension ctx a in + Psig_typext a + | Psig_exception a -> + let a = self#type_exception ctx a in + Psig_exception a + | Psig_module a -> + let a = self#module_declaration ctx a in + Psig_module a + | Psig_modsubst a -> + let a = self#module_substitution ctx a in + Psig_modsubst a + | Psig_recmodule a -> + let a = self#list self#module_declaration ctx a in + Psig_recmodule a + | Psig_modtype a -> + let a = self#module_type_declaration ctx a in + Psig_modtype a + | Psig_open a -> + let a = self#open_description ctx a in + Psig_open a + | Psig_include a -> + let a = self#include_description ctx a in + Psig_include a + | Psig_class a -> + let a = self#list self#class_description ctx a in + Psig_class a + | Psig_class_type a -> + let a = self#list self#class_type_declaration ctx a in + Psig_class_type a + | Psig_attribute a -> + let a = self#attribute ctx a in + Psig_attribute a + | Psig_extension (a, b) -> + let a = self#extension ctx a in + let b = self#attributes ctx b in + Psig_extension (a, b) + + method module_declaration : 'ctx -> module_declaration -> module_declaration + = + fun ctx { pmd_name; pmd_type; pmd_attributes; pmd_loc } -> + let pmd_name = self#loc (self#option self#string) ctx pmd_name in + let pmd_type = self#module_type ctx pmd_type in + let pmd_attributes = self#attributes ctx pmd_attributes in + let pmd_loc = self#location ctx pmd_loc in + { pmd_name; pmd_type; pmd_attributes; pmd_loc } + + method module_substitution + : 'ctx -> module_substitution -> module_substitution = + fun ctx { pms_name; pms_manifest; pms_attributes; pms_loc } -> + let pms_name = self#loc self#string ctx pms_name in + let pms_manifest = self#longident_loc ctx pms_manifest in + let pms_attributes = self#attributes ctx pms_attributes in + let pms_loc = self#location ctx pms_loc in + { pms_name; pms_manifest; pms_attributes; pms_loc } + + method module_type_declaration + : 'ctx -> module_type_declaration -> module_type_declaration = + fun ctx { pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc } -> + let pmtd_name = self#loc self#string ctx pmtd_name in + let pmtd_type = self#option self#module_type ctx pmtd_type in + let pmtd_attributes = self#attributes ctx pmtd_attributes in + let pmtd_loc = self#location ctx pmtd_loc in + { pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc } + + method open_infos + : 'a. ('ctx -> 'a -> 'a) -> 'ctx -> 'a open_infos -> 'a open_infos = + fun _a ctx { popen_expr; popen_override; popen_loc; popen_attributes } -> + let popen_expr = _a ctx popen_expr in + let popen_override = self#override_flag ctx popen_override in + let popen_loc = self#location ctx popen_loc in + let popen_attributes = self#attributes ctx popen_attributes in + { popen_expr; popen_override; popen_loc; popen_attributes } + + method open_description : 'ctx -> open_description -> open_description = self#open_infos self#longident_loc - method open_declaration : 'ctx -> open_declaration -> open_declaration= + + method open_declaration : 'ctx -> open_declaration -> open_declaration = self#open_infos self#module_expr - method include_infos : - 'a . ('ctx -> 'a -> 'a) -> 'ctx -> 'a include_infos -> 'a include_infos= - fun _a -> - fun ctx -> - fun { pincl_mod; pincl_loc; pincl_attributes } -> - let pincl_mod = _a ctx pincl_mod in - let pincl_loc = self#location ctx pincl_loc in - let pincl_attributes = self#attributes ctx pincl_attributes in - { pincl_mod; pincl_loc; pincl_attributes } - method include_description : - 'ctx -> include_description -> include_description= + + method include_infos + : 'a. ('ctx -> 'a -> 'a) -> 'ctx -> 'a include_infos -> 'a include_infos + = + fun _a ctx { pincl_mod; pincl_loc; pincl_attributes } -> + let pincl_mod = _a ctx pincl_mod in + let pincl_loc = self#location ctx pincl_loc in + let pincl_attributes = self#attributes ctx pincl_attributes in + { pincl_mod; pincl_loc; pincl_attributes } + + method include_description + : 'ctx -> include_description -> include_description = self#include_infos self#module_type - method include_declaration : - 'ctx -> include_declaration -> include_declaration= + + method include_declaration + : 'ctx -> include_declaration -> include_declaration = self#include_infos self#module_expr - method with_constraint : 'ctx -> with_constraint -> with_constraint= - fun ctx -> - fun x -> - match x with - | Pwith_type (a, b) -> - let a = self#longident_loc ctx a in - let b = self#type_declaration ctx b in Pwith_type (a, b) - | Pwith_module (a, b) -> - let a = self#longident_loc ctx a in - let b = self#longident_loc ctx b in Pwith_module (a, b) - | Pwith_typesubst (a, b) -> - let a = self#longident_loc ctx a in - let b = self#type_declaration ctx b in Pwith_typesubst (a, b) - | Pwith_modsubst (a, b) -> - let a = self#longident_loc ctx a in - let b = self#longident_loc ctx b in Pwith_modsubst (a, b) - method module_expr : 'ctx -> module_expr -> module_expr= - fun ctx -> - fun { pmod_desc; pmod_loc; pmod_attributes } -> - let pmod_desc = self#module_expr_desc ctx pmod_desc in - let pmod_loc = self#location ctx pmod_loc in - let pmod_attributes = self#attributes ctx pmod_attributes in - { pmod_desc; pmod_loc; pmod_attributes } - method module_expr_desc : 'ctx -> module_expr_desc -> module_expr_desc= - fun ctx -> - fun x -> - match x with - | Pmod_ident a -> let a = self#longident_loc ctx a in Pmod_ident a - | Pmod_structure a -> - let a = self#structure ctx a in Pmod_structure a - | Pmod_functor (a, b) -> - let a = self#functor_parameter ctx a in - let b = self#module_expr ctx b in Pmod_functor (a, b) - | Pmod_apply (a, b) -> - let a = self#module_expr ctx a in - let b = self#module_expr ctx b in Pmod_apply (a, b) - | Pmod_constraint (a, b) -> - let a = self#module_expr ctx a in - let b = self#module_type ctx b in Pmod_constraint (a, b) - | Pmod_unpack a -> let a = self#expression ctx a in Pmod_unpack a - | Pmod_extension a -> - let a = self#extension ctx a in Pmod_extension a - method structure : 'ctx -> structure -> structure= + + method with_constraint : 'ctx -> with_constraint -> with_constraint = + fun ctx x -> + match x with + | Pwith_type (a, b) -> + let a = self#longident_loc ctx a in + let b = self#type_declaration ctx b in + Pwith_type (a, b) + | Pwith_module (a, b) -> + let a = self#longident_loc ctx a in + let b = self#longident_loc ctx b in + Pwith_module (a, b) + | Pwith_typesubst (a, b) -> + let a = self#longident_loc ctx a in + let b = self#type_declaration ctx b in + Pwith_typesubst (a, b) + | Pwith_modsubst (a, b) -> + let a = self#longident_loc ctx a in + let b = self#longident_loc ctx b in + Pwith_modsubst (a, b) + + method module_expr : 'ctx -> module_expr -> module_expr = + fun ctx { pmod_desc; pmod_loc; pmod_attributes } -> + let pmod_desc = self#module_expr_desc ctx pmod_desc in + let pmod_loc = self#location ctx pmod_loc in + let pmod_attributes = self#attributes ctx pmod_attributes in + { pmod_desc; pmod_loc; pmod_attributes } + + method module_expr_desc : 'ctx -> module_expr_desc -> module_expr_desc = + fun ctx x -> + match x with + | Pmod_ident a -> + let a = self#longident_loc ctx a in + Pmod_ident a + | Pmod_structure a -> + let a = self#structure ctx a in + Pmod_structure a + | Pmod_functor (a, b) -> + let a = self#functor_parameter ctx a in + let b = self#module_expr ctx b in + Pmod_functor (a, b) + | Pmod_apply (a, b) -> + let a = self#module_expr ctx a in + let b = self#module_expr ctx b in + Pmod_apply (a, b) + | Pmod_constraint (a, b) -> + let a = self#module_expr ctx a in + let b = self#module_type ctx b in + Pmod_constraint (a, b) + | Pmod_unpack a -> + let a = self#expression ctx a in + Pmod_unpack a + | Pmod_extension a -> + let a = self#extension ctx a in + Pmod_extension a + + method structure : 'ctx -> structure -> structure = self#list self#structure_item - method structure_item : 'ctx -> structure_item -> structure_item= - fun ctx -> - fun { pstr_desc; pstr_loc } -> - let pstr_desc = self#structure_item_desc ctx pstr_desc in - let pstr_loc = self#location ctx pstr_loc in - { pstr_desc; pstr_loc } - method structure_item_desc : - 'ctx -> structure_item_desc -> structure_item_desc= - fun ctx -> - fun x -> - match x with - | Pstr_eval (a, b) -> - let a = self#expression ctx a in - let b = self#attributes ctx b in Pstr_eval (a, b) - | Pstr_value (a, b) -> - let a = self#rec_flag ctx a in - let b = self#list self#value_binding ctx b in Pstr_value (a, b) - | Pstr_primitive a -> - let a = self#value_description ctx a in Pstr_primitive a - | Pstr_type (a, b) -> - let a = self#rec_flag ctx a in - let b = self#list self#type_declaration ctx b in - Pstr_type (a, b) - | Pstr_typext a -> - let a = self#type_extension ctx a in Pstr_typext a - | Pstr_exception a -> - let a = self#type_exception ctx a in Pstr_exception a - | Pstr_module a -> - let a = self#module_binding ctx a in Pstr_module a - | Pstr_recmodule a -> - let a = self#list self#module_binding ctx a in Pstr_recmodule a - | Pstr_modtype a -> - let a = self#module_type_declaration ctx a in Pstr_modtype a - | Pstr_open a -> let a = self#open_declaration ctx a in Pstr_open a - | Pstr_class a -> - let a = self#list self#class_declaration ctx a in Pstr_class a - | Pstr_class_type a -> - let a = self#list self#class_type_declaration ctx a in - Pstr_class_type a - | Pstr_include a -> - let a = self#include_declaration ctx a in Pstr_include a - | Pstr_attribute a -> - let a = self#attribute ctx a in Pstr_attribute a - | Pstr_extension (a, b) -> - let a = self#extension ctx a in - let b = self#attributes ctx b in Pstr_extension (a, b) - method value_binding : 'ctx -> value_binding -> value_binding= - fun ctx -> - fun { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } -> - let pvb_pat = self#pattern ctx pvb_pat in - let pvb_expr = self#expression ctx pvb_expr in - let pvb_attributes = self#attributes ctx pvb_attributes in - let pvb_loc = self#location ctx pvb_loc in - { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } - method module_binding : 'ctx -> module_binding -> module_binding= - fun ctx -> - fun { pmb_name; pmb_expr; pmb_attributes; pmb_loc } -> - let pmb_name = self#loc (self#option self#string) ctx pmb_name in - let pmb_expr = self#module_expr ctx pmb_expr in - let pmb_attributes = self#attributes ctx pmb_attributes in - let pmb_loc = self#location ctx pmb_loc in - { pmb_name; pmb_expr; pmb_attributes; pmb_loc } - method toplevel_phrase : 'ctx -> toplevel_phrase -> toplevel_phrase= - fun ctx -> - fun x -> - match x with - | Ptop_def a -> let a = self#structure ctx a in Ptop_def a - | Ptop_dir a -> let a = self#toplevel_directive ctx a in Ptop_dir a - method toplevel_directive : - 'ctx -> toplevel_directive -> toplevel_directive= - fun ctx -> - fun { pdir_name; pdir_arg; pdir_loc } -> - let pdir_name = self#loc self#string ctx pdir_name in - let pdir_arg = self#option self#directive_argument ctx pdir_arg in - let pdir_loc = self#location ctx pdir_loc in - { pdir_name; pdir_arg; pdir_loc } - method directive_argument : - 'ctx -> directive_argument -> directive_argument= - fun ctx -> - fun { pdira_desc; pdira_loc } -> - let pdira_desc = self#directive_argument_desc ctx pdira_desc in - let pdira_loc = self#location ctx pdira_loc in - { pdira_desc; pdira_loc } - method directive_argument_desc : - 'ctx -> directive_argument_desc -> directive_argument_desc= - fun ctx -> - fun x -> - match x with - | Pdir_string a -> let a = self#string ctx a in Pdir_string a - | Pdir_int (a, b) -> - let a = self#string ctx a in - let b = self#option self#char ctx b in Pdir_int (a, b) - | Pdir_ident a -> let a = self#longident ctx a in Pdir_ident a - | Pdir_bool a -> let a = self#bool ctx a in Pdir_bool a + + method structure_item : 'ctx -> structure_item -> structure_item = + fun ctx { pstr_desc; pstr_loc } -> + let pstr_desc = self#structure_item_desc ctx pstr_desc in + let pstr_loc = self#location ctx pstr_loc in + { pstr_desc; pstr_loc } + + method structure_item_desc + : 'ctx -> structure_item_desc -> structure_item_desc = + fun ctx x -> + match x with + | Pstr_eval (a, b) -> + let a = self#expression ctx a in + let b = self#attributes ctx b in + Pstr_eval (a, b) + | Pstr_value (a, b) -> + let a = self#rec_flag ctx a in + let b = self#list self#value_binding ctx b in + Pstr_value (a, b) + | Pstr_primitive a -> + let a = self#value_description ctx a in + Pstr_primitive a + | Pstr_type (a, b) -> + let a = self#rec_flag ctx a in + let b = self#list self#type_declaration ctx b in + Pstr_type (a, b) + | Pstr_typext a -> + let a = self#type_extension ctx a in + Pstr_typext a + | Pstr_exception a -> + let a = self#type_exception ctx a in + Pstr_exception a + | Pstr_module a -> + let a = self#module_binding ctx a in + Pstr_module a + | Pstr_recmodule a -> + let a = self#list self#module_binding ctx a in + Pstr_recmodule a + | Pstr_modtype a -> + let a = self#module_type_declaration ctx a in + Pstr_modtype a + | Pstr_open a -> + let a = self#open_declaration ctx a in + Pstr_open a + | Pstr_class a -> + let a = self#list self#class_declaration ctx a in + Pstr_class a + | Pstr_class_type a -> + let a = self#list self#class_type_declaration ctx a in + Pstr_class_type a + | Pstr_include a -> + let a = self#include_declaration ctx a in + Pstr_include a + | Pstr_attribute a -> + let a = self#attribute ctx a in + Pstr_attribute a + | Pstr_extension (a, b) -> + let a = self#extension ctx a in + let b = self#attributes ctx b in + Pstr_extension (a, b) + + method value_binding : 'ctx -> value_binding -> value_binding = + fun ctx { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } -> + let pvb_pat = self#pattern ctx pvb_pat in + let pvb_expr = self#expression ctx pvb_expr in + let pvb_attributes = self#attributes ctx pvb_attributes in + let pvb_loc = self#location ctx pvb_loc in + { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } + + method module_binding : 'ctx -> module_binding -> module_binding = + fun ctx { pmb_name; pmb_expr; pmb_attributes; pmb_loc } -> + let pmb_name = self#loc (self#option self#string) ctx pmb_name in + let pmb_expr = self#module_expr ctx pmb_expr in + let pmb_attributes = self#attributes ctx pmb_attributes in + let pmb_loc = self#location ctx pmb_loc in + { pmb_name; pmb_expr; pmb_attributes; pmb_loc } + + method toplevel_phrase : 'ctx -> toplevel_phrase -> toplevel_phrase = + fun ctx x -> + match x with + | Ptop_def a -> + let a = self#structure ctx a in + Ptop_def a + | Ptop_dir a -> + let a = self#toplevel_directive ctx a in + Ptop_dir a + + method toplevel_directive : 'ctx -> toplevel_directive -> toplevel_directive + = + fun ctx { pdir_name; pdir_arg; pdir_loc } -> + let pdir_name = self#loc self#string ctx pdir_name in + let pdir_arg = self#option self#directive_argument ctx pdir_arg in + let pdir_loc = self#location ctx pdir_loc in + { pdir_name; pdir_arg; pdir_loc } + + method directive_argument : 'ctx -> directive_argument -> directive_argument + = + fun ctx { pdira_desc; pdira_loc } -> + let pdira_desc = self#directive_argument_desc ctx pdira_desc in + let pdira_loc = self#location ctx pdira_loc in + { pdira_desc; pdira_loc } + + method directive_argument_desc + : 'ctx -> directive_argument_desc -> directive_argument_desc = + fun ctx x -> + match x with + | Pdir_string a -> + let a = self#string ctx a in + Pdir_string a + | Pdir_int (a, b) -> + let a = self#string ctx a in + let b = self#option self#char ctx b in + Pdir_int (a, b) + | Pdir_ident a -> + let a = self#longident ctx a in + Pdir_ident a + | Pdir_bool a -> + let a = self#bool ctx a in + Pdir_bool a + + method cases : 'ctx -> cases -> cases = self#list self#case end + class virtual ['res] lift = object (self) - method virtual record : (string * 'res) list -> 'res - method virtual constr : string -> 'res list -> 'rest - method virtual tuple : 'res list -> 'res - method virtual bool : bool -> 'res - method virtual char : char -> 'res - method virtual int : int -> 'res - method virtual list : 'a . ('a -> 'res) -> 'a list -> 'res - method virtual option : 'a . ('a -> 'res) -> 'a option -> 'res - method virtual string : string -> 'res - method position : position -> 'res= + method virtual record : (string * 'res) list -> 'res + + method virtual constr : string -> 'res list -> 'res + + method virtual tuple : 'res list -> 'res + + method virtual bool : bool -> 'res + + method virtual char : char -> 'res + + method virtual int : int -> 'res + + method virtual list : 'a. ('a -> 'res) -> 'a list -> 'res + + method virtual option : 'a. ('a -> 'res) -> 'a option -> 'res + + method virtual string : string -> 'res + + method position : position -> 'res = fun { pos_fname; pos_lnum; pos_bol; pos_cnum } -> let pos_fname = self#string pos_fname in let pos_lnum = self#int pos_lnum in let pos_bol = self#int pos_bol in let pos_cnum = self#int pos_cnum in self#record - [("pos_fname", pos_fname); - ("pos_lnum", pos_lnum); - ("pos_bol", pos_bol); - ("pos_cnum", pos_cnum)] - method location : location -> 'res= + [ + ("pos_fname", pos_fname); + ("pos_lnum", pos_lnum); + ("pos_bol", pos_bol); + ("pos_cnum", pos_cnum); + ] + + method location : location -> 'res = fun { loc_start; loc_end; loc_ghost } -> let loc_start = self#position loc_start in let loc_end = self#position loc_end in let loc_ghost = self#bool loc_ghost in self#record - [("loc_start", loc_start); - ("loc_end", loc_end); - ("loc_ghost", loc_ghost)] - method location_stack : location_stack -> 'res= self#list self#location - method loc : 'a . ('a -> 'res) -> 'a loc -> 'res= - fun _a -> - fun { txt; loc } -> - let txt = _a txt in - let loc = self#location loc in - self#record [("txt", txt); ("loc", loc)] - method longident : longident -> 'res= + [ + ("loc_start", loc_start); + ("loc_end", loc_end); + ("loc_ghost", loc_ghost); + ] + + method location_stack : location_stack -> 'res = self#list self#location + + method loc : 'a. ('a -> 'res) -> 'a loc -> 'res = + fun _a { txt; loc } -> + let txt = _a txt in + let loc = self#location loc in + self#record [ ("txt", txt); ("loc", loc) ] + + method longident : longident -> 'res = fun x -> match x with - | Lident a -> let a = self#string a in self#constr "Lident" [a] + | Lident a -> + let a = self#string a in + self#constr "Lident" [ a ] | Ldot (a, b) -> let a = self#longident a in - let b = self#string b in self#constr "Ldot" [a; b] + let b = self#string b in + self#constr "Ldot" [ a; b ] | Lapply (a, b) -> let a = self#longident a in - let b = self#longident b in self#constr "Lapply" [a; b] - method longident_loc : longident_loc -> 'res= self#loc self#longident - method rec_flag : rec_flag -> 'res= + let b = self#longident b in + self#constr "Lapply" [ a; b ] + + method longident_loc : longident_loc -> 'res = self#loc self#longident + + method rec_flag : rec_flag -> 'res = fun x -> match x with | Nonrecursive -> self#constr "Nonrecursive" [] | Recursive -> self#constr "Recursive" [] - method direction_flag : direction_flag -> 'res= + + method direction_flag : direction_flag -> 'res = fun x -> match x with | Upto -> self#constr "Upto" [] | Downto -> self#constr "Downto" [] - method private_flag : private_flag -> 'res= + + method private_flag : private_flag -> 'res = fun x -> match x with | Private -> self#constr "Private" [] | Public -> self#constr "Public" [] - method mutable_flag : mutable_flag -> 'res= + + method mutable_flag : mutable_flag -> 'res = fun x -> match x with | Immutable -> self#constr "Immutable" [] | Mutable -> self#constr "Mutable" [] - method virtual_flag : virtual_flag -> 'res= + + method virtual_flag : virtual_flag -> 'res = fun x -> match x with | Virtual -> self#constr "Virtual" [] | Concrete -> self#constr "Concrete" [] - method override_flag : override_flag -> 'res= + + method override_flag : override_flag -> 'res = fun x -> match x with | Override -> self#constr "Override" [] | Fresh -> self#constr "Fresh" [] - method closed_flag : closed_flag -> 'res= + + method closed_flag : closed_flag -> 'res = fun x -> match x with | Closed -> self#constr "Closed" [] | Open -> self#constr "Open" [] - method label : label -> 'res= self#string - method arg_label : arg_label -> 'res= + + method label : label -> 'res = self#string + + method arg_label : arg_label -> 'res = fun x -> match x with | Nolabel -> self#constr "Nolabel" [] - | Labelled a -> let a = self#string a in self#constr "Labelled" [a] - | Optional a -> let a = self#string a in self#constr "Optional" [a] - method variance : variance -> 'res= + | Labelled a -> + let a = self#string a in + self#constr "Labelled" [ a ] + | Optional a -> + let a = self#string a in + self#constr "Optional" [ a ] + + method variance : variance -> 'res = fun x -> match x with | Covariant -> self#constr "Covariant" [] | Contravariant -> self#constr "Contravariant" [] - | Invariant -> self#constr "Invariant" [] - method constant : constant -> 'res= + | NoVariance -> self#constr "NoVariance" [] + + method injectivity : injectivity -> 'res = + fun x -> + match x with + | Injective -> self#constr "Injective" [] + | NoInjectivity -> self#constr "NoInjectivity" [] + + method constant : constant -> 'res = fun x -> match x with | Pconst_integer (a, b) -> let a = self#string a in let b = self#option self#char b in - self#constr "Pconst_integer" [a; b] + self#constr "Pconst_integer" [ a; b ] | Pconst_char a -> - let a = self#char a in self#constr "Pconst_char" [a] - | Pconst_string (a, b) -> + let a = self#char a in + self#constr "Pconst_char" [ a ] + | Pconst_string (a, b, c) -> let a = self#string a in - let b = self#option self#string b in - self#constr "Pconst_string" [a; b] + let b = self#location b in + let c = self#option self#string c in + self#constr "Pconst_string" [ a; b; c ] | Pconst_float (a, b) -> let a = self#string a in let b = self#option self#char b in - self#constr "Pconst_float" [a; b] - method attribute : attribute -> 'res= + self#constr "Pconst_float" [ a; b ] + + method attribute : attribute -> 'res = fun { attr_name; attr_payload; attr_loc } -> let attr_name = self#loc self#string attr_name in let attr_payload = self#payload attr_payload in let attr_loc = self#location attr_loc in self#record - [("attr_name", attr_name); - ("attr_payload", attr_payload); - ("attr_loc", attr_loc)] - method extension : extension -> 'res= + [ + ("attr_name", attr_name); + ("attr_payload", attr_payload); + ("attr_loc", attr_loc); + ] + + method extension : extension -> 'res = fun (a, b) -> let a = self#loc self#string a in - let b = self#payload b in self#tuple [a; b] - method attributes : attributes -> 'res= self#list self#attribute - method payload : payload -> 'res= + let b = self#payload b in + self#tuple [ a; b ] + + method attributes : attributes -> 'res = self#list self#attribute + + method payload : payload -> 'res = fun x -> match x with - | PStr a -> let a = self#structure a in self#constr "PStr" [a] - | PSig a -> let a = self#signature a in self#constr "PSig" [a] - | PTyp a -> let a = self#core_type a in self#constr "PTyp" [a] + | PStr a -> + let a = self#structure a in + self#constr "PStr" [ a ] + | PSig a -> + let a = self#signature a in + self#constr "PSig" [ a ] + | PTyp a -> + let a = self#core_type a in + self#constr "PTyp" [ a ] | PPat (a, b) -> let a = self#pattern a in let b = self#option self#expression b in - self#constr "PPat" [a; b] - method core_type : core_type -> 'res= + self#constr "PPat" [ a; b ] + + method core_type : core_type -> 'res = fun { ptyp_desc; ptyp_loc; ptyp_loc_stack; ptyp_attributes } -> let ptyp_desc = self#core_type_desc ptyp_desc in let ptyp_loc = self#location ptyp_loc in let ptyp_loc_stack = self#location_stack ptyp_loc_stack in let ptyp_attributes = self#attributes ptyp_attributes in self#record - [("ptyp_desc", ptyp_desc); - ("ptyp_loc", ptyp_loc); - ("ptyp_loc_stack", ptyp_loc_stack); - ("ptyp_attributes", ptyp_attributes)] - method core_type_desc : core_type_desc -> 'res= + [ + ("ptyp_desc", ptyp_desc); + ("ptyp_loc", ptyp_loc); + ("ptyp_loc_stack", ptyp_loc_stack); + ("ptyp_attributes", ptyp_attributes); + ] + + method core_type_desc : core_type_desc -> 'res = fun x -> match x with | Ptyp_any -> self#constr "Ptyp_any" [] - | Ptyp_var a -> let a = self#string a in self#constr "Ptyp_var" [a] + | Ptyp_var a -> + let a = self#string a in + self#constr "Ptyp_var" [ a ] | Ptyp_arrow (a, b, c) -> let a = self#arg_label a in let b = self#core_type b in - let c = self#core_type c in self#constr "Ptyp_arrow" [a; b; c] + let c = self#core_type c in + self#constr "Ptyp_arrow" [ a; b; c ] | Ptyp_tuple a -> let a = self#list self#core_type a in - self#constr "Ptyp_tuple" [a] + self#constr "Ptyp_tuple" [ a ] | Ptyp_constr (a, b) -> let a = self#longident_loc a in let b = self#list self#core_type b in - self#constr "Ptyp_constr" [a; b] + self#constr "Ptyp_constr" [ a; b ] | Ptyp_object (a, b) -> let a = self#list self#object_field a in - let b = self#closed_flag b in self#constr "Ptyp_object" [a; b] + let b = self#closed_flag b in + self#constr "Ptyp_object" [ a; b ] | Ptyp_class (a, b) -> let a = self#longident_loc a in let b = self#list self#core_type b in - self#constr "Ptyp_class" [a; b] + self#constr "Ptyp_class" [ a; b ] | Ptyp_alias (a, b) -> let a = self#core_type a in - let b = self#string b in self#constr "Ptyp_alias" [a; b] + let b = self#string b in + self#constr "Ptyp_alias" [ a; b ] | Ptyp_variant (a, b, c) -> let a = self#list self#row_field a in let b = self#closed_flag b in let c = self#option (self#list self#label) c in - self#constr "Ptyp_variant" [a; b; c] + self#constr "Ptyp_variant" [ a; b; c ] | Ptyp_poly (a, b) -> let a = self#list (self#loc self#string) a in - let b = self#core_type b in self#constr "Ptyp_poly" [a; b] + let b = self#core_type b in + self#constr "Ptyp_poly" [ a; b ] | Ptyp_package a -> - let a = self#package_type a in self#constr "Ptyp_package" [a] + let a = self#package_type a in + self#constr "Ptyp_package" [ a ] | Ptyp_extension a -> - let a = self#extension a in self#constr "Ptyp_extension" [a] - method package_type : package_type -> 'res= + let a = self#extension a in + self#constr "Ptyp_extension" [ a ] + + method package_type : package_type -> 'res = fun (a, b) -> let a = self#longident_loc a in let b = self#list (fun (a, b) -> - let a = self#longident_loc a in - let b = self#core_type b in self#tuple [a; b]) b in - self#tuple [a; b] - method row_field : row_field -> 'res= + let a = self#longident_loc a in + let b = self#core_type b in + self#tuple [ a; b ]) + b + in + self#tuple [ a; b ] + + method row_field : row_field -> 'res = fun { prf_desc; prf_loc; prf_attributes } -> let prf_desc = self#row_field_desc prf_desc in let prf_loc = self#location prf_loc in let prf_attributes = self#attributes prf_attributes in self#record - [("prf_desc", prf_desc); - ("prf_loc", prf_loc); - ("prf_attributes", prf_attributes)] - method row_field_desc : row_field_desc -> 'res= + [ + ("prf_desc", prf_desc); + ("prf_loc", prf_loc); + ("prf_attributes", prf_attributes); + ] + + method row_field_desc : row_field_desc -> 'res = fun x -> match x with | Rtag (a, b, c) -> let a = self#loc self#label a in let b = self#bool b in let c = self#list self#core_type c in - self#constr "Rtag" [a; b; c] + self#constr "Rtag" [ a; b; c ] | Rinherit a -> - let a = self#core_type a in self#constr "Rinherit" [a] - method object_field : object_field -> 'res= + let a = self#core_type a in + self#constr "Rinherit" [ a ] + + method object_field : object_field -> 'res = fun { pof_desc; pof_loc; pof_attributes } -> let pof_desc = self#object_field_desc pof_desc in let pof_loc = self#location pof_loc in let pof_attributes = self#attributes pof_attributes in self#record - [("pof_desc", pof_desc); - ("pof_loc", pof_loc); - ("pof_attributes", pof_attributes)] - method object_field_desc : object_field_desc -> 'res= + [ + ("pof_desc", pof_desc); + ("pof_loc", pof_loc); + ("pof_attributes", pof_attributes); + ] + + method object_field_desc : object_field_desc -> 'res = fun x -> match x with | Otag (a, b) -> let a = self#loc self#label a in - let b = self#core_type b in self#constr "Otag" [a; b] + let b = self#core_type b in + self#constr "Otag" [ a; b ] | Oinherit a -> - let a = self#core_type a in self#constr "Oinherit" [a] - method pattern : pattern -> 'res= + let a = self#core_type a in + self#constr "Oinherit" [ a ] + + method pattern : pattern -> 'res = fun { ppat_desc; ppat_loc; ppat_loc_stack; ppat_attributes } -> let ppat_desc = self#pattern_desc ppat_desc in let ppat_loc = self#location ppat_loc in let ppat_loc_stack = self#location_stack ppat_loc_stack in let ppat_attributes = self#attributes ppat_attributes in self#record - [("ppat_desc", ppat_desc); - ("ppat_loc", ppat_loc); - ("ppat_loc_stack", ppat_loc_stack); - ("ppat_attributes", ppat_attributes)] - method pattern_desc : pattern_desc -> 'res= + [ + ("ppat_desc", ppat_desc); + ("ppat_loc", ppat_loc); + ("ppat_loc_stack", ppat_loc_stack); + ("ppat_attributes", ppat_attributes); + ] + + method pattern_desc : pattern_desc -> 'res = fun x -> match x with | Ppat_any -> self#constr "Ppat_any" [] | Ppat_var a -> - let a = self#loc self#string a in self#constr "Ppat_var" [a] + let a = self#loc self#string a in + self#constr "Ppat_var" [ a ] | Ppat_alias (a, b) -> let a = self#pattern a in - let b = self#loc self#string b in self#constr "Ppat_alias" [a; b] + let b = self#loc self#string b in + self#constr "Ppat_alias" [ a; b ] | Ppat_constant a -> - let a = self#constant a in self#constr "Ppat_constant" [a] + let a = self#constant a in + self#constr "Ppat_constant" [ a ] | Ppat_interval (a, b) -> let a = self#constant a in - let b = self#constant b in self#constr "Ppat_interval" [a; b] + let b = self#constant b in + self#constr "Ppat_interval" [ a; b ] | Ppat_tuple a -> - let a = self#list self#pattern a in self#constr "Ppat_tuple" [a] + let a = self#list self#pattern a in + self#constr "Ppat_tuple" [ a ] | Ppat_construct (a, b) -> let a = self#longident_loc a in let b = self#option self#pattern b in - self#constr "Ppat_construct" [a; b] + self#constr "Ppat_construct" [ a; b ] | Ppat_variant (a, b) -> let a = self#label a in let b = self#option self#pattern b in - self#constr "Ppat_variant" [a; b] + self#constr "Ppat_variant" [ a; b ] | Ppat_record (a, b) -> let a = self#list (fun (a, b) -> - let a = self#longident_loc a in - let b = self#pattern b in self#tuple [a; b]) a in - let b = self#closed_flag b in self#constr "Ppat_record" [a; b] + let a = self#longident_loc a in + let b = self#pattern b in + self#tuple [ a; b ]) + a + in + let b = self#closed_flag b in + self#constr "Ppat_record" [ a; b ] | Ppat_array a -> - let a = self#list self#pattern a in self#constr "Ppat_array" [a] + let a = self#list self#pattern a in + self#constr "Ppat_array" [ a ] | Ppat_or (a, b) -> let a = self#pattern a in - let b = self#pattern b in self#constr "Ppat_or" [a; b] + let b = self#pattern b in + self#constr "Ppat_or" [ a; b ] | Ppat_constraint (a, b) -> let a = self#pattern a in - let b = self#core_type b in self#constr "Ppat_constraint" [a; b] + let b = self#core_type b in + self#constr "Ppat_constraint" [ a; b ] | Ppat_type a -> - let a = self#longident_loc a in self#constr "Ppat_type" [a] + let a = self#longident_loc a in + self#constr "Ppat_type" [ a ] | Ppat_lazy a -> - let a = self#pattern a in self#constr "Ppat_lazy" [a] + let a = self#pattern a in + self#constr "Ppat_lazy" [ a ] | Ppat_unpack a -> let a = self#loc (self#option self#string) a in - self#constr "Ppat_unpack" [a] + self#constr "Ppat_unpack" [ a ] | Ppat_exception a -> - let a = self#pattern a in self#constr "Ppat_exception" [a] + let a = self#pattern a in + self#constr "Ppat_exception" [ a ] | Ppat_extension a -> - let a = self#extension a in self#constr "Ppat_extension" [a] + let a = self#extension a in + self#constr "Ppat_extension" [ a ] | Ppat_open (a, b) -> let a = self#longident_loc a in - let b = self#pattern b in self#constr "Ppat_open" [a; b] - method expression : expression -> 'res= + let b = self#pattern b in + self#constr "Ppat_open" [ a; b ] + + method expression : expression -> 'res = fun { pexp_desc; pexp_loc; pexp_loc_stack; pexp_attributes } -> let pexp_desc = self#expression_desc pexp_desc in let pexp_loc = self#location pexp_loc in let pexp_loc_stack = self#location_stack pexp_loc_stack in let pexp_attributes = self#attributes pexp_attributes in self#record - [("pexp_desc", pexp_desc); - ("pexp_loc", pexp_loc); - ("pexp_loc_stack", pexp_loc_stack); - ("pexp_attributes", pexp_attributes)] - method expression_desc : expression_desc -> 'res= + [ + ("pexp_desc", pexp_desc); + ("pexp_loc", pexp_loc); + ("pexp_loc_stack", pexp_loc_stack); + ("pexp_attributes", pexp_attributes); + ] + + method expression_desc : expression_desc -> 'res = fun x -> match x with | Pexp_ident a -> - let a = self#longident_loc a in self#constr "Pexp_ident" [a] + let a = self#longident_loc a in + self#constr "Pexp_ident" [ a ] | Pexp_constant a -> - let a = self#constant a in self#constr "Pexp_constant" [a] + let a = self#constant a in + self#constr "Pexp_constant" [ a ] | Pexp_let (a, b, c) -> let a = self#rec_flag a in let b = self#list self#value_binding b in - let c = self#expression c in self#constr "Pexp_let" [a; b; c] + let c = self#expression c in + self#constr "Pexp_let" [ a; b; c ] | Pexp_function a -> - let a = self#list self#case a in self#constr "Pexp_function" [a] + let a = self#cases a in + self#constr "Pexp_function" [ a ] | Pexp_fun (a, b, c, d) -> let a = self#arg_label a in let b = self#option self#expression b in let c = self#pattern c in - let d = self#expression d in self#constr "Pexp_fun" [a; b; c; d] + let d = self#expression d in + self#constr "Pexp_fun" [ a; b; c; d ] | Pexp_apply (a, b) -> let a = self#expression a in let b = self#list (fun (a, b) -> - let a = self#arg_label a in - let b = self#expression b in self#tuple [a; b]) b in - self#constr "Pexp_apply" [a; b] + let a = self#arg_label a in + let b = self#expression b in + self#tuple [ a; b ]) + b + in + self#constr "Pexp_apply" [ a; b ] | Pexp_match (a, b) -> let a = self#expression a in - let b = self#list self#case b in self#constr "Pexp_match" [a; b] + let b = self#cases b in + self#constr "Pexp_match" [ a; b ] | Pexp_try (a, b) -> let a = self#expression a in - let b = self#list self#case b in self#constr "Pexp_try" [a; b] + let b = self#cases b in + self#constr "Pexp_try" [ a; b ] | Pexp_tuple a -> let a = self#list self#expression a in - self#constr "Pexp_tuple" [a] + self#constr "Pexp_tuple" [ a ] | Pexp_construct (a, b) -> let a = self#longident_loc a in let b = self#option self#expression b in - self#constr "Pexp_construct" [a; b] + self#constr "Pexp_construct" [ a; b ] | Pexp_variant (a, b) -> let a = self#label a in let b = self#option self#expression b in - self#constr "Pexp_variant" [a; b] + self#constr "Pexp_variant" [ a; b ] | Pexp_record (a, b) -> let a = self#list (fun (a, b) -> - let a = self#longident_loc a in - let b = self#expression b in self#tuple [a; b]) a in + let a = self#longident_loc a in + let b = self#expression b in + self#tuple [ a; b ]) + a + in let b = self#option self#expression b in - self#constr "Pexp_record" [a; b] + self#constr "Pexp_record" [ a; b ] | Pexp_field (a, b) -> let a = self#expression a in - let b = self#longident_loc b in self#constr "Pexp_field" [a; b] + let b = self#longident_loc b in + self#constr "Pexp_field" [ a; b ] | Pexp_setfield (a, b, c) -> let a = self#expression a in let b = self#longident_loc b in let c = self#expression c in - self#constr "Pexp_setfield" [a; b; c] + self#constr "Pexp_setfield" [ a; b; c ] | Pexp_array a -> let a = self#list self#expression a in - self#constr "Pexp_array" [a] + self#constr "Pexp_array" [ a ] | Pexp_ifthenelse (a, b, c) -> let a = self#expression a in let b = self#expression b in let c = self#option self#expression c in - self#constr "Pexp_ifthenelse" [a; b; c] + self#constr "Pexp_ifthenelse" [ a; b; c ] | Pexp_sequence (a, b) -> let a = self#expression a in - let b = self#expression b in self#constr "Pexp_sequence" [a; b] + let b = self#expression b in + self#constr "Pexp_sequence" [ a; b ] | Pexp_while (a, b) -> let a = self#expression a in - let b = self#expression b in self#constr "Pexp_while" [a; b] + let b = self#expression b in + self#constr "Pexp_while" [ a; b ] | Pexp_for (a, b, c, d, e) -> let a = self#pattern a in let b = self#expression b in let c = self#expression c in let d = self#direction_flag d in let e = self#expression e in - self#constr "Pexp_for" [a; b; c; d; e] + self#constr "Pexp_for" [ a; b; c; d; e ] | Pexp_constraint (a, b) -> let a = self#expression a in - let b = self#core_type b in self#constr "Pexp_constraint" [a; b] + let b = self#core_type b in + self#constr "Pexp_constraint" [ a; b ] | Pexp_coerce (a, b, c) -> let a = self#expression a in let b = self#option self#core_type b in - let c = self#core_type c in self#constr "Pexp_coerce" [a; b; c] + let c = self#core_type c in + self#constr "Pexp_coerce" [ a; b; c ] | Pexp_send (a, b) -> let a = self#expression a in - let b = self#loc self#label b in self#constr "Pexp_send" [a; b] + let b = self#loc self#label b in + self#constr "Pexp_send" [ a; b ] | Pexp_new a -> - let a = self#longident_loc a in self#constr "Pexp_new" [a] + let a = self#longident_loc a in + self#constr "Pexp_new" [ a ] | Pexp_setinstvar (a, b) -> let a = self#loc self#label a in - let b = self#expression b in self#constr "Pexp_setinstvar" [a; b] + let b = self#expression b in + self#constr "Pexp_setinstvar" [ a; b ] | Pexp_override a -> let a = self#list (fun (a, b) -> - let a = self#loc self#label a in - let b = self#expression b in self#tuple [a; b]) a in - self#constr "Pexp_override" [a] + let a = self#loc self#label a in + let b = self#expression b in + self#tuple [ a; b ]) + a + in + self#constr "Pexp_override" [ a ] | Pexp_letmodule (a, b, c) -> let a = self#loc (self#option self#string) a in let b = self#module_expr b in let c = self#expression c in - self#constr "Pexp_letmodule" [a; b; c] + self#constr "Pexp_letmodule" [ a; b; c ] | Pexp_letexception (a, b) -> let a = self#extension_constructor a in let b = self#expression b in - self#constr "Pexp_letexception" [a; b] + self#constr "Pexp_letexception" [ a; b ] | Pexp_assert a -> - let a = self#expression a in self#constr "Pexp_assert" [a] + let a = self#expression a in + self#constr "Pexp_assert" [ a ] | Pexp_lazy a -> - let a = self#expression a in self#constr "Pexp_lazy" [a] + let a = self#expression a in + self#constr "Pexp_lazy" [ a ] | Pexp_poly (a, b) -> let a = self#expression a in let b = self#option self#core_type b in - self#constr "Pexp_poly" [a; b] + self#constr "Pexp_poly" [ a; b ] | Pexp_object a -> - let a = self#class_structure a in self#constr "Pexp_object" [a] + let a = self#class_structure a in + self#constr "Pexp_object" [ a ] | Pexp_newtype (a, b) -> let a = self#loc self#string a in - let b = self#expression b in self#constr "Pexp_newtype" [a; b] + let b = self#expression b in + self#constr "Pexp_newtype" [ a; b ] | Pexp_pack a -> - let a = self#module_expr a in self#constr "Pexp_pack" [a] + let a = self#module_expr a in + self#constr "Pexp_pack" [ a ] | Pexp_open (a, b) -> let a = self#open_declaration a in - let b = self#expression b in self#constr "Pexp_open" [a; b] + let b = self#expression b in + self#constr "Pexp_open" [ a; b ] | Pexp_letop a -> - let a = self#letop a in self#constr "Pexp_letop" [a] + let a = self#letop a in + self#constr "Pexp_letop" [ a ] | Pexp_extension a -> - let a = self#extension a in self#constr "Pexp_extension" [a] + let a = self#extension a in + self#constr "Pexp_extension" [ a ] | Pexp_unreachable -> self#constr "Pexp_unreachable" [] - method case : case -> 'res= + + method case : case -> 'res = fun { pc_lhs; pc_guard; pc_rhs } -> let pc_lhs = self#pattern pc_lhs in let pc_guard = self#option self#expression pc_guard in let pc_rhs = self#expression pc_rhs in self#record - [("pc_lhs", pc_lhs); ("pc_guard", pc_guard); ("pc_rhs", pc_rhs)] - method letop : letop -> 'res= + [ ("pc_lhs", pc_lhs); ("pc_guard", pc_guard); ("pc_rhs", pc_rhs) ] + + method letop : letop -> 'res = fun { let_; ands; body } -> let let_ = self#binding_op let_ in let ands = self#list self#binding_op ands in let body = self#expression body in - self#record [("let_", let_); ("ands", ands); ("body", body)] - method binding_op : binding_op -> 'res= + self#record [ ("let_", let_); ("ands", ands); ("body", body) ] + + method binding_op : binding_op -> 'res = fun { pbop_op; pbop_pat; pbop_exp; pbop_loc } -> let pbop_op = self#loc self#string pbop_op in let pbop_pat = self#pattern pbop_pat in let pbop_exp = self#expression pbop_exp in let pbop_loc = self#location pbop_loc in self#record - [("pbop_op", pbop_op); - ("pbop_pat", pbop_pat); - ("pbop_exp", pbop_exp); - ("pbop_loc", pbop_loc)] - method value_description : value_description -> 'res= + [ + ("pbop_op", pbop_op); + ("pbop_pat", pbop_pat); + ("pbop_exp", pbop_exp); + ("pbop_loc", pbop_loc); + ] + + method value_description : value_description -> 'res = fun { pval_name; pval_type; pval_prim; pval_attributes; pval_loc } -> let pval_name = self#loc self#string pval_name in let pval_type = self#core_type pval_type in @@ -6110,54 +7440,79 @@ let pval_attributes = self#attributes pval_attributes in let pval_loc = self#location pval_loc in self#record - [("pval_name", pval_name); - ("pval_type", pval_type); - ("pval_prim", pval_prim); - ("pval_attributes", pval_attributes); - ("pval_loc", pval_loc)] - method type_declaration : type_declaration -> 'res= - fun - { ptype_name; ptype_params; ptype_cstrs; ptype_kind; ptype_private; - ptype_manifest; ptype_attributes; ptype_loc } - -> + [ + ("pval_name", pval_name); + ("pval_type", pval_type); + ("pval_prim", pval_prim); + ("pval_attributes", pval_attributes); + ("pval_loc", pval_loc); + ] + + method type_declaration : type_declaration -> 'res = + fun { + ptype_name; + ptype_params; + ptype_cstrs; + ptype_kind; + ptype_private; + ptype_manifest; + ptype_attributes; + ptype_loc; + } -> let ptype_name = self#loc self#string ptype_name in let ptype_params = self#list (fun (a, b) -> - let a = self#core_type a in - let b = self#variance b in self#tuple [a; b]) ptype_params in + let a = self#core_type a in + let b = + (fun (a, b) -> + let a = self#variance a in + let b = self#injectivity b in + self#tuple [ a; b ]) + b + in + self#tuple [ a; b ]) + ptype_params + in let ptype_cstrs = self#list (fun (a, b, c) -> - let a = self#core_type a in - let b = self#core_type b in - let c = self#location c in self#tuple [a; b; c]) ptype_cstrs in + let a = self#core_type a in + let b = self#core_type b in + let c = self#location c in + self#tuple [ a; b; c ]) + ptype_cstrs + in let ptype_kind = self#type_kind ptype_kind in let ptype_private = self#private_flag ptype_private in let ptype_manifest = self#option self#core_type ptype_manifest in let ptype_attributes = self#attributes ptype_attributes in let ptype_loc = self#location ptype_loc in self#record - [("ptype_name", ptype_name); - ("ptype_params", ptype_params); - ("ptype_cstrs", ptype_cstrs); - ("ptype_kind", ptype_kind); - ("ptype_private", ptype_private); - ("ptype_manifest", ptype_manifest); - ("ptype_attributes", ptype_attributes); - ("ptype_loc", ptype_loc)] - method type_kind : type_kind -> 'res= + [ + ("ptype_name", ptype_name); + ("ptype_params", ptype_params); + ("ptype_cstrs", ptype_cstrs); + ("ptype_kind", ptype_kind); + ("ptype_private", ptype_private); + ("ptype_manifest", ptype_manifest); + ("ptype_attributes", ptype_attributes); + ("ptype_loc", ptype_loc); + ] + + method type_kind : type_kind -> 'res = fun x -> match x with | Ptype_abstract -> self#constr "Ptype_abstract" [] | Ptype_variant a -> let a = self#list self#constructor_declaration a in - self#constr "Ptype_variant" [a] + self#constr "Ptype_variant" [ a ] | Ptype_record a -> let a = self#list self#label_declaration a in - self#constr "Ptype_record" [a] + self#constr "Ptype_record" [ a ] | Ptype_open -> self#constr "Ptype_open" [] - method label_declaration : label_declaration -> 'res= + + method label_declaration : label_declaration -> 'res = fun { pld_name; pld_mutable; pld_type; pld_loc; pld_attributes } -> let pld_name = self#loc self#string pld_name in let pld_mutable = self#mutable_flag pld_mutable in @@ -6165,12 +7520,15 @@ let pld_loc = self#location pld_loc in let pld_attributes = self#attributes pld_attributes in self#record - [("pld_name", pld_name); - ("pld_mutable", pld_mutable); - ("pld_type", pld_type); - ("pld_loc", pld_loc); - ("pld_attributes", pld_attributes)] - method constructor_declaration : constructor_declaration -> 'res= + [ + ("pld_name", pld_name); + ("pld_mutable", pld_mutable); + ("pld_type", pld_type); + ("pld_loc", pld_loc); + ("pld_attributes", pld_attributes); + ] + + method constructor_declaration : constructor_declaration -> 'res = fun { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } -> let pcd_name = self#loc self#string pcd_name in let pcd_args = self#constructor_arguments pcd_args in @@ -6178,577 +7536,757 @@ let pcd_loc = self#location pcd_loc in let pcd_attributes = self#attributes pcd_attributes in self#record - [("pcd_name", pcd_name); - ("pcd_args", pcd_args); - ("pcd_res", pcd_res); - ("pcd_loc", pcd_loc); - ("pcd_attributes", pcd_attributes)] - method constructor_arguments : constructor_arguments -> 'res= + [ + ("pcd_name", pcd_name); + ("pcd_args", pcd_args); + ("pcd_res", pcd_res); + ("pcd_loc", pcd_loc); + ("pcd_attributes", pcd_attributes); + ] + + method constructor_arguments : constructor_arguments -> 'res = fun x -> match x with | Pcstr_tuple a -> let a = self#list self#core_type a in - self#constr "Pcstr_tuple" [a] + self#constr "Pcstr_tuple" [ a ] | Pcstr_record a -> let a = self#list self#label_declaration a in - self#constr "Pcstr_record" [a] - method type_extension : type_extension -> 'res= - fun - { ptyext_path; ptyext_params; ptyext_constructors; ptyext_private; - ptyext_loc; ptyext_attributes } - -> + self#constr "Pcstr_record" [ a ] + + method type_extension : type_extension -> 'res = + fun { + ptyext_path; + ptyext_params; + ptyext_constructors; + ptyext_private; + ptyext_loc; + ptyext_attributes; + } -> let ptyext_path = self#longident_loc ptyext_path in let ptyext_params = self#list (fun (a, b) -> - let a = self#core_type a in - let b = self#variance b in self#tuple [a; b]) ptyext_params in + let a = self#core_type a in + let b = + (fun (a, b) -> + let a = self#variance a in + let b = self#injectivity b in + self#tuple [ a; b ]) + b + in + self#tuple [ a; b ]) + ptyext_params + in let ptyext_constructors = - self#list self#extension_constructor ptyext_constructors in + self#list self#extension_constructor ptyext_constructors + in let ptyext_private = self#private_flag ptyext_private in let ptyext_loc = self#location ptyext_loc in let ptyext_attributes = self#attributes ptyext_attributes in self#record - [("ptyext_path", ptyext_path); - ("ptyext_params", ptyext_params); - ("ptyext_constructors", ptyext_constructors); - ("ptyext_private", ptyext_private); - ("ptyext_loc", ptyext_loc); - ("ptyext_attributes", ptyext_attributes)] - method extension_constructor : extension_constructor -> 'res= + [ + ("ptyext_path", ptyext_path); + ("ptyext_params", ptyext_params); + ("ptyext_constructors", ptyext_constructors); + ("ptyext_private", ptyext_private); + ("ptyext_loc", ptyext_loc); + ("ptyext_attributes", ptyext_attributes); + ] + + method extension_constructor : extension_constructor -> 'res = fun { pext_name; pext_kind; pext_loc; pext_attributes } -> let pext_name = self#loc self#string pext_name in let pext_kind = self#extension_constructor_kind pext_kind in let pext_loc = self#location pext_loc in let pext_attributes = self#attributes pext_attributes in self#record - [("pext_name", pext_name); - ("pext_kind", pext_kind); - ("pext_loc", pext_loc); - ("pext_attributes", pext_attributes)] - method type_exception : type_exception -> 'res= + [ + ("pext_name", pext_name); + ("pext_kind", pext_kind); + ("pext_loc", pext_loc); + ("pext_attributes", pext_attributes); + ] + + method type_exception : type_exception -> 'res = fun { ptyexn_constructor; ptyexn_loc; ptyexn_attributes } -> let ptyexn_constructor = - self#extension_constructor ptyexn_constructor in + self#extension_constructor ptyexn_constructor + in let ptyexn_loc = self#location ptyexn_loc in let ptyexn_attributes = self#attributes ptyexn_attributes in self#record - [("ptyexn_constructor", ptyexn_constructor); - ("ptyexn_loc", ptyexn_loc); - ("ptyexn_attributes", ptyexn_attributes)] - method extension_constructor_kind : extension_constructor_kind -> 'res= + [ + ("ptyexn_constructor", ptyexn_constructor); + ("ptyexn_loc", ptyexn_loc); + ("ptyexn_attributes", ptyexn_attributes); + ] + + method extension_constructor_kind : extension_constructor_kind -> 'res = fun x -> match x with | Pext_decl (a, b) -> let a = self#constructor_arguments a in let b = self#option self#core_type b in - self#constr "Pext_decl" [a; b] + self#constr "Pext_decl" [ a; b ] | Pext_rebind a -> - let a = self#longident_loc a in self#constr "Pext_rebind" [a] - method class_type : class_type -> 'res= + let a = self#longident_loc a in + self#constr "Pext_rebind" [ a ] + + method class_type : class_type -> 'res = fun { pcty_desc; pcty_loc; pcty_attributes } -> let pcty_desc = self#class_type_desc pcty_desc in let pcty_loc = self#location pcty_loc in let pcty_attributes = self#attributes pcty_attributes in self#record - [("pcty_desc", pcty_desc); - ("pcty_loc", pcty_loc); - ("pcty_attributes", pcty_attributes)] - method class_type_desc : class_type_desc -> 'res= + [ + ("pcty_desc", pcty_desc); + ("pcty_loc", pcty_loc); + ("pcty_attributes", pcty_attributes); + ] + + method class_type_desc : class_type_desc -> 'res = fun x -> match x with | Pcty_constr (a, b) -> let a = self#longident_loc a in let b = self#list self#core_type b in - self#constr "Pcty_constr" [a; b] + self#constr "Pcty_constr" [ a; b ] | Pcty_signature a -> let a = self#class_signature a in - self#constr "Pcty_signature" [a] + self#constr "Pcty_signature" [ a ] | Pcty_arrow (a, b, c) -> let a = self#arg_label a in let b = self#core_type b in - let c = self#class_type c in self#constr "Pcty_arrow" [a; b; c] + let c = self#class_type c in + self#constr "Pcty_arrow" [ a; b; c ] | Pcty_extension a -> - let a = self#extension a in self#constr "Pcty_extension" [a] + let a = self#extension a in + self#constr "Pcty_extension" [ a ] | Pcty_open (a, b) -> let a = self#open_description a in - let b = self#class_type b in self#constr "Pcty_open" [a; b] - method class_signature : class_signature -> 'res= + let b = self#class_type b in + self#constr "Pcty_open" [ a; b ] + + method class_signature : class_signature -> 'res = fun { pcsig_self; pcsig_fields } -> let pcsig_self = self#core_type pcsig_self in let pcsig_fields = self#list self#class_type_field pcsig_fields in self#record - [("pcsig_self", pcsig_self); ("pcsig_fields", pcsig_fields)] - method class_type_field : class_type_field -> 'res= + [ ("pcsig_self", pcsig_self); ("pcsig_fields", pcsig_fields) ] + + method class_type_field : class_type_field -> 'res = fun { pctf_desc; pctf_loc; pctf_attributes } -> let pctf_desc = self#class_type_field_desc pctf_desc in let pctf_loc = self#location pctf_loc in let pctf_attributes = self#attributes pctf_attributes in self#record - [("pctf_desc", pctf_desc); - ("pctf_loc", pctf_loc); - ("pctf_attributes", pctf_attributes)] - method class_type_field_desc : class_type_field_desc -> 'res= + [ + ("pctf_desc", pctf_desc); + ("pctf_loc", pctf_loc); + ("pctf_attributes", pctf_attributes); + ] + + method class_type_field_desc : class_type_field_desc -> 'res = fun x -> match x with | Pctf_inherit a -> - let a = self#class_type a in self#constr "Pctf_inherit" [a] + let a = self#class_type a in + self#constr "Pctf_inherit" [ a ] | Pctf_val a -> let a = (fun (a, b, c, d) -> - let a = self#loc self#label a in - let b = self#mutable_flag b in - let c = self#virtual_flag c in - let d = self#core_type d in self#tuple [a; b; c; d]) a in - self#constr "Pctf_val" [a] + let a = self#loc self#label a in + let b = self#mutable_flag b in + let c = self#virtual_flag c in + let d = self#core_type d in + self#tuple [ a; b; c; d ]) + a + in + self#constr "Pctf_val" [ a ] | Pctf_method a -> let a = (fun (a, b, c, d) -> - let a = self#loc self#label a in - let b = self#private_flag b in - let c = self#virtual_flag c in - let d = self#core_type d in self#tuple [a; b; c; d]) a in - self#constr "Pctf_method" [a] + let a = self#loc self#label a in + let b = self#private_flag b in + let c = self#virtual_flag c in + let d = self#core_type d in + self#tuple [ a; b; c; d ]) + a + in + self#constr "Pctf_method" [ a ] | Pctf_constraint a -> let a = (fun (a, b) -> - let a = self#core_type a in - let b = self#core_type b in self#tuple [a; b]) a in - self#constr "Pctf_constraint" [a] + let a = self#core_type a in + let b = self#core_type b in + self#tuple [ a; b ]) + a + in + self#constr "Pctf_constraint" [ a ] | Pctf_attribute a -> - let a = self#attribute a in self#constr "Pctf_attribute" [a] + let a = self#attribute a in + self#constr "Pctf_attribute" [ a ] | Pctf_extension a -> - let a = self#extension a in self#constr "Pctf_extension" [a] - method class_infos : 'a . ('a -> 'res) -> 'a class_infos -> 'res= - fun _a -> - fun - { pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes - } - -> - let pci_virt = self#virtual_flag pci_virt in - let pci_params = - self#list - (fun (a, b) -> - let a = self#core_type a in - let b = self#variance b in self#tuple [a; b]) pci_params in - let pci_name = self#loc self#string pci_name in - let pci_expr = _a pci_expr in - let pci_loc = self#location pci_loc in - let pci_attributes = self#attributes pci_attributes in - self#record - [("pci_virt", pci_virt); + let a = self#extension a in + self#constr "Pctf_extension" [ a ] + + method class_infos : 'a. ('a -> 'res) -> 'a class_infos -> 'res = + fun _a + { pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes } -> + let pci_virt = self#virtual_flag pci_virt in + let pci_params = + self#list + (fun (a, b) -> + let a = self#core_type a in + let b = + (fun (a, b) -> + let a = self#variance a in + let b = self#injectivity b in + self#tuple [ a; b ]) + b + in + self#tuple [ a; b ]) + pci_params + in + let pci_name = self#loc self#string pci_name in + let pci_expr = _a pci_expr in + let pci_loc = self#location pci_loc in + let pci_attributes = self#attributes pci_attributes in + self#record + [ + ("pci_virt", pci_virt); ("pci_params", pci_params); ("pci_name", pci_name); ("pci_expr", pci_expr); ("pci_loc", pci_loc); - ("pci_attributes", pci_attributes)] - method class_description : class_description -> 'res= + ("pci_attributes", pci_attributes); + ] + + method class_description : class_description -> 'res = self#class_infos self#class_type - method class_type_declaration : class_type_declaration -> 'res= + + method class_type_declaration : class_type_declaration -> 'res = self#class_infos self#class_type - method class_expr : class_expr -> 'res= + + method class_expr : class_expr -> 'res = fun { pcl_desc; pcl_loc; pcl_attributes } -> let pcl_desc = self#class_expr_desc pcl_desc in let pcl_loc = self#location pcl_loc in let pcl_attributes = self#attributes pcl_attributes in self#record - [("pcl_desc", pcl_desc); - ("pcl_loc", pcl_loc); - ("pcl_attributes", pcl_attributes)] - method class_expr_desc : class_expr_desc -> 'res= + [ + ("pcl_desc", pcl_desc); + ("pcl_loc", pcl_loc); + ("pcl_attributes", pcl_attributes); + ] + + method class_expr_desc : class_expr_desc -> 'res = fun x -> match x with | Pcl_constr (a, b) -> let a = self#longident_loc a in let b = self#list self#core_type b in - self#constr "Pcl_constr" [a; b] + self#constr "Pcl_constr" [ a; b ] | Pcl_structure a -> - let a = self#class_structure a in self#constr "Pcl_structure" [a] + let a = self#class_structure a in + self#constr "Pcl_structure" [ a ] | Pcl_fun (a, b, c, d) -> let a = self#arg_label a in let b = self#option self#expression b in let c = self#pattern c in - let d = self#class_expr d in self#constr "Pcl_fun" [a; b; c; d] + let d = self#class_expr d in + self#constr "Pcl_fun" [ a; b; c; d ] | Pcl_apply (a, b) -> let a = self#class_expr a in let b = self#list (fun (a, b) -> - let a = self#arg_label a in - let b = self#expression b in self#tuple [a; b]) b in - self#constr "Pcl_apply" [a; b] + let a = self#arg_label a in + let b = self#expression b in + self#tuple [ a; b ]) + b + in + self#constr "Pcl_apply" [ a; b ] | Pcl_let (a, b, c) -> let a = self#rec_flag a in let b = self#list self#value_binding b in - let c = self#class_expr c in self#constr "Pcl_let" [a; b; c] + let c = self#class_expr c in + self#constr "Pcl_let" [ a; b; c ] | Pcl_constraint (a, b) -> let a = self#class_expr a in - let b = self#class_type b in self#constr "Pcl_constraint" [a; b] + let b = self#class_type b in + self#constr "Pcl_constraint" [ a; b ] | Pcl_extension a -> - let a = self#extension a in self#constr "Pcl_extension" [a] + let a = self#extension a in + self#constr "Pcl_extension" [ a ] | Pcl_open (a, b) -> let a = self#open_description a in - let b = self#class_expr b in self#constr "Pcl_open" [a; b] - method class_structure : class_structure -> 'res= + let b = self#class_expr b in + self#constr "Pcl_open" [ a; b ] + + method class_structure : class_structure -> 'res = fun { pcstr_self; pcstr_fields } -> let pcstr_self = self#pattern pcstr_self in let pcstr_fields = self#list self#class_field pcstr_fields in self#record - [("pcstr_self", pcstr_self); ("pcstr_fields", pcstr_fields)] - method class_field : class_field -> 'res= + [ ("pcstr_self", pcstr_self); ("pcstr_fields", pcstr_fields) ] + + method class_field : class_field -> 'res = fun { pcf_desc; pcf_loc; pcf_attributes } -> let pcf_desc = self#class_field_desc pcf_desc in let pcf_loc = self#location pcf_loc in let pcf_attributes = self#attributes pcf_attributes in self#record - [("pcf_desc", pcf_desc); - ("pcf_loc", pcf_loc); - ("pcf_attributes", pcf_attributes)] - method class_field_desc : class_field_desc -> 'res= + [ + ("pcf_desc", pcf_desc); + ("pcf_loc", pcf_loc); + ("pcf_attributes", pcf_attributes); + ] + + method class_field_desc : class_field_desc -> 'res = fun x -> match x with | Pcf_inherit (a, b, c) -> let a = self#override_flag a in let b = self#class_expr b in let c = self#option (self#loc self#string) c in - self#constr "Pcf_inherit" [a; b; c] + self#constr "Pcf_inherit" [ a; b; c ] | Pcf_val a -> let a = (fun (a, b, c) -> - let a = self#loc self#label a in - let b = self#mutable_flag b in - let c = self#class_field_kind c in self#tuple [a; b; c]) a in - self#constr "Pcf_val" [a] + let a = self#loc self#label a in + let b = self#mutable_flag b in + let c = self#class_field_kind c in + self#tuple [ a; b; c ]) + a + in + self#constr "Pcf_val" [ a ] | Pcf_method a -> let a = (fun (a, b, c) -> - let a = self#loc self#label a in - let b = self#private_flag b in - let c = self#class_field_kind c in self#tuple [a; b; c]) a in - self#constr "Pcf_method" [a] + let a = self#loc self#label a in + let b = self#private_flag b in + let c = self#class_field_kind c in + self#tuple [ a; b; c ]) + a + in + self#constr "Pcf_method" [ a ] | Pcf_constraint a -> let a = (fun (a, b) -> - let a = self#core_type a in - let b = self#core_type b in self#tuple [a; b]) a in - self#constr "Pcf_constraint" [a] + let a = self#core_type a in + let b = self#core_type b in + self#tuple [ a; b ]) + a + in + self#constr "Pcf_constraint" [ a ] | Pcf_initializer a -> - let a = self#expression a in self#constr "Pcf_initializer" [a] + let a = self#expression a in + self#constr "Pcf_initializer" [ a ] | Pcf_attribute a -> - let a = self#attribute a in self#constr "Pcf_attribute" [a] + let a = self#attribute a in + self#constr "Pcf_attribute" [ a ] | Pcf_extension a -> - let a = self#extension a in self#constr "Pcf_extension" [a] - method class_field_kind : class_field_kind -> 'res= + let a = self#extension a in + self#constr "Pcf_extension" [ a ] + + method class_field_kind : class_field_kind -> 'res = fun x -> match x with | Cfk_virtual a -> - let a = self#core_type a in self#constr "Cfk_virtual" [a] + let a = self#core_type a in + self#constr "Cfk_virtual" [ a ] | Cfk_concrete (a, b) -> let a = self#override_flag a in - let b = self#expression b in self#constr "Cfk_concrete" [a; b] - method class_declaration : class_declaration -> 'res= + let b = self#expression b in + self#constr "Cfk_concrete" [ a; b ] + + method class_declaration : class_declaration -> 'res = self#class_infos self#class_expr - method module_type : module_type -> 'res= + + method module_type : module_type -> 'res = fun { pmty_desc; pmty_loc; pmty_attributes } -> let pmty_desc = self#module_type_desc pmty_desc in let pmty_loc = self#location pmty_loc in let pmty_attributes = self#attributes pmty_attributes in self#record - [("pmty_desc", pmty_desc); - ("pmty_loc", pmty_loc); - ("pmty_attributes", pmty_attributes)] - method module_type_desc : module_type_desc -> 'res= + [ + ("pmty_desc", pmty_desc); + ("pmty_loc", pmty_loc); + ("pmty_attributes", pmty_attributes); + ] + + method module_type_desc : module_type_desc -> 'res = fun x -> match x with | Pmty_ident a -> - let a = self#longident_loc a in self#constr "Pmty_ident" [a] + let a = self#longident_loc a in + self#constr "Pmty_ident" [ a ] | Pmty_signature a -> - let a = self#signature a in self#constr "Pmty_signature" [a] + let a = self#signature a in + self#constr "Pmty_signature" [ a ] | Pmty_functor (a, b) -> let a = self#functor_parameter a in - let b = self#module_type b in self#constr "Pmty_functor" [a; b] + let b = self#module_type b in + self#constr "Pmty_functor" [ a; b ] | Pmty_with (a, b) -> let a = self#module_type a in let b = self#list self#with_constraint b in - self#constr "Pmty_with" [a; b] + self#constr "Pmty_with" [ a; b ] | Pmty_typeof a -> - let a = self#module_expr a in self#constr "Pmty_typeof" [a] + let a = self#module_expr a in + self#constr "Pmty_typeof" [ a ] | Pmty_extension a -> - let a = self#extension a in self#constr "Pmty_extension" [a] + let a = self#extension a in + self#constr "Pmty_extension" [ a ] | Pmty_alias a -> - let a = self#longident_loc a in self#constr "Pmty_alias" [a] - method functor_parameter : functor_parameter -> 'res= + let a = self#longident_loc a in + self#constr "Pmty_alias" [ a ] + + method functor_parameter : functor_parameter -> 'res = fun x -> match x with | Unit -> self#constr "Unit" [] | Named (a, b) -> let a = self#loc (self#option self#string) a in - let b = self#module_type b in self#constr "Named" [a; b] - method signature : signature -> 'res= self#list self#signature_item - method signature_item : signature_item -> 'res= + let b = self#module_type b in + self#constr "Named" [ a; b ] + + method signature : signature -> 'res = self#list self#signature_item + + method signature_item : signature_item -> 'res = fun { psig_desc; psig_loc } -> let psig_desc = self#signature_item_desc psig_desc in let psig_loc = self#location psig_loc in - self#record [("psig_desc", psig_desc); ("psig_loc", psig_loc)] - method signature_item_desc : signature_item_desc -> 'res= + self#record [ ("psig_desc", psig_desc); ("psig_loc", psig_loc) ] + + method signature_item_desc : signature_item_desc -> 'res = fun x -> match x with | Psig_value a -> - let a = self#value_description a in self#constr "Psig_value" [a] + let a = self#value_description a in + self#constr "Psig_value" [ a ] | Psig_type (a, b) -> let a = self#rec_flag a in let b = self#list self#type_declaration b in - self#constr "Psig_type" [a; b] + self#constr "Psig_type" [ a; b ] | Psig_typesubst a -> let a = self#list self#type_declaration a in - self#constr "Psig_typesubst" [a] + self#constr "Psig_typesubst" [ a ] | Psig_typext a -> - let a = self#type_extension a in self#constr "Psig_typext" [a] + let a = self#type_extension a in + self#constr "Psig_typext" [ a ] | Psig_exception a -> - let a = self#type_exception a in self#constr "Psig_exception" [a] + let a = self#type_exception a in + self#constr "Psig_exception" [ a ] | Psig_module a -> let a = self#module_declaration a in - self#constr "Psig_module" [a] + self#constr "Psig_module" [ a ] | Psig_modsubst a -> let a = self#module_substitution a in - self#constr "Psig_modsubst" [a] + self#constr "Psig_modsubst" [ a ] | Psig_recmodule a -> let a = self#list self#module_declaration a in - self#constr "Psig_recmodule" [a] + self#constr "Psig_recmodule" [ a ] | Psig_modtype a -> let a = self#module_type_declaration a in - self#constr "Psig_modtype" [a] + self#constr "Psig_modtype" [ a ] | Psig_open a -> - let a = self#open_description a in self#constr "Psig_open" [a] + let a = self#open_description a in + self#constr "Psig_open" [ a ] | Psig_include a -> let a = self#include_description a in - self#constr "Psig_include" [a] + self#constr "Psig_include" [ a ] | Psig_class a -> let a = self#list self#class_description a in - self#constr "Psig_class" [a] + self#constr "Psig_class" [ a ] | Psig_class_type a -> let a = self#list self#class_type_declaration a in - self#constr "Psig_class_type" [a] + self#constr "Psig_class_type" [ a ] | Psig_attribute a -> - let a = self#attribute a in self#constr "Psig_attribute" [a] + let a = self#attribute a in + self#constr "Psig_attribute" [ a ] | Psig_extension (a, b) -> let a = self#extension a in - let b = self#attributes b in self#constr "Psig_extension" [a; b] - method module_declaration : module_declaration -> 'res= + let b = self#attributes b in + self#constr "Psig_extension" [ a; b ] + + method module_declaration : module_declaration -> 'res = fun { pmd_name; pmd_type; pmd_attributes; pmd_loc } -> let pmd_name = self#loc (self#option self#string) pmd_name in let pmd_type = self#module_type pmd_type in let pmd_attributes = self#attributes pmd_attributes in let pmd_loc = self#location pmd_loc in self#record - [("pmd_name", pmd_name); - ("pmd_type", pmd_type); - ("pmd_attributes", pmd_attributes); - ("pmd_loc", pmd_loc)] - method module_substitution : module_substitution -> 'res= + [ + ("pmd_name", pmd_name); + ("pmd_type", pmd_type); + ("pmd_attributes", pmd_attributes); + ("pmd_loc", pmd_loc); + ] + + method module_substitution : module_substitution -> 'res = fun { pms_name; pms_manifest; pms_attributes; pms_loc } -> let pms_name = self#loc self#string pms_name in let pms_manifest = self#longident_loc pms_manifest in let pms_attributes = self#attributes pms_attributes in let pms_loc = self#location pms_loc in self#record - [("pms_name", pms_name); - ("pms_manifest", pms_manifest); - ("pms_attributes", pms_attributes); - ("pms_loc", pms_loc)] - method module_type_declaration : module_type_declaration -> 'res= + [ + ("pms_name", pms_name); + ("pms_manifest", pms_manifest); + ("pms_attributes", pms_attributes); + ("pms_loc", pms_loc); + ] + + method module_type_declaration : module_type_declaration -> 'res = fun { pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc } -> let pmtd_name = self#loc self#string pmtd_name in let pmtd_type = self#option self#module_type pmtd_type in let pmtd_attributes = self#attributes pmtd_attributes in let pmtd_loc = self#location pmtd_loc in self#record - [("pmtd_name", pmtd_name); - ("pmtd_type", pmtd_type); - ("pmtd_attributes", pmtd_attributes); - ("pmtd_loc", pmtd_loc)] - method open_infos : 'a . ('a -> 'res) -> 'a open_infos -> 'res= - fun _a -> - fun { popen_expr; popen_override; popen_loc; popen_attributes } -> - let popen_expr = _a popen_expr in - let popen_override = self#override_flag popen_override in - let popen_loc = self#location popen_loc in - let popen_attributes = self#attributes popen_attributes in - self#record - [("popen_expr", popen_expr); + [ + ("pmtd_name", pmtd_name); + ("pmtd_type", pmtd_type); + ("pmtd_attributes", pmtd_attributes); + ("pmtd_loc", pmtd_loc); + ] + + method open_infos : 'a. ('a -> 'res) -> 'a open_infos -> 'res = + fun _a { popen_expr; popen_override; popen_loc; popen_attributes } -> + let popen_expr = _a popen_expr in + let popen_override = self#override_flag popen_override in + let popen_loc = self#location popen_loc in + let popen_attributes = self#attributes popen_attributes in + self#record + [ + ("popen_expr", popen_expr); ("popen_override", popen_override); ("popen_loc", popen_loc); - ("popen_attributes", popen_attributes)] - method open_description : open_description -> 'res= + ("popen_attributes", popen_attributes); + ] + + method open_description : open_description -> 'res = self#open_infos self#longident_loc - method open_declaration : open_declaration -> 'res= + + method open_declaration : open_declaration -> 'res = self#open_infos self#module_expr - method include_infos : 'a . ('a -> 'res) -> 'a include_infos -> 'res= - fun _a -> - fun { pincl_mod; pincl_loc; pincl_attributes } -> - let pincl_mod = _a pincl_mod in - let pincl_loc = self#location pincl_loc in - let pincl_attributes = self#attributes pincl_attributes in - self#record - [("pincl_mod", pincl_mod); + + method include_infos : 'a. ('a -> 'res) -> 'a include_infos -> 'res = + fun _a { pincl_mod; pincl_loc; pincl_attributes } -> + let pincl_mod = _a pincl_mod in + let pincl_loc = self#location pincl_loc in + let pincl_attributes = self#attributes pincl_attributes in + self#record + [ + ("pincl_mod", pincl_mod); ("pincl_loc", pincl_loc); - ("pincl_attributes", pincl_attributes)] - method include_description : include_description -> 'res= + ("pincl_attributes", pincl_attributes); + ] + + method include_description : include_description -> 'res = self#include_infos self#module_type - method include_declaration : include_declaration -> 'res= + + method include_declaration : include_declaration -> 'res = self#include_infos self#module_expr - method with_constraint : with_constraint -> 'res= + + method with_constraint : with_constraint -> 'res = fun x -> match x with | Pwith_type (a, b) -> let a = self#longident_loc a in let b = self#type_declaration b in - self#constr "Pwith_type" [a; b] + self#constr "Pwith_type" [ a; b ] | Pwith_module (a, b) -> let a = self#longident_loc a in - let b = self#longident_loc b in self#constr "Pwith_module" [a; b] + let b = self#longident_loc b in + self#constr "Pwith_module" [ a; b ] | Pwith_typesubst (a, b) -> let a = self#longident_loc a in let b = self#type_declaration b in - self#constr "Pwith_typesubst" [a; b] + self#constr "Pwith_typesubst" [ a; b ] | Pwith_modsubst (a, b) -> let a = self#longident_loc a in let b = self#longident_loc b in - self#constr "Pwith_modsubst" [a; b] - method module_expr : module_expr -> 'res= + self#constr "Pwith_modsubst" [ a; b ] + + method module_expr : module_expr -> 'res = fun { pmod_desc; pmod_loc; pmod_attributes } -> let pmod_desc = self#module_expr_desc pmod_desc in let pmod_loc = self#location pmod_loc in let pmod_attributes = self#attributes pmod_attributes in self#record - [("pmod_desc", pmod_desc); - ("pmod_loc", pmod_loc); - ("pmod_attributes", pmod_attributes)] - method module_expr_desc : module_expr_desc -> 'res= + [ + ("pmod_desc", pmod_desc); + ("pmod_loc", pmod_loc); + ("pmod_attributes", pmod_attributes); + ] + + method module_expr_desc : module_expr_desc -> 'res = fun x -> match x with | Pmod_ident a -> - let a = self#longident_loc a in self#constr "Pmod_ident" [a] + let a = self#longident_loc a in + self#constr "Pmod_ident" [ a ] | Pmod_structure a -> - let a = self#structure a in self#constr "Pmod_structure" [a] + let a = self#structure a in + self#constr "Pmod_structure" [ a ] | Pmod_functor (a, b) -> let a = self#functor_parameter a in - let b = self#module_expr b in self#constr "Pmod_functor" [a; b] + let b = self#module_expr b in + self#constr "Pmod_functor" [ a; b ] | Pmod_apply (a, b) -> let a = self#module_expr a in - let b = self#module_expr b in self#constr "Pmod_apply" [a; b] + let b = self#module_expr b in + self#constr "Pmod_apply" [ a; b ] | Pmod_constraint (a, b) -> let a = self#module_expr a in let b = self#module_type b in - self#constr "Pmod_constraint" [a; b] + self#constr "Pmod_constraint" [ a; b ] | Pmod_unpack a -> - let a = self#expression a in self#constr "Pmod_unpack" [a] + let a = self#expression a in + self#constr "Pmod_unpack" [ a ] | Pmod_extension a -> - let a = self#extension a in self#constr "Pmod_extension" [a] - method structure : structure -> 'res= self#list self#structure_item - method structure_item : structure_item -> 'res= + let a = self#extension a in + self#constr "Pmod_extension" [ a ] + + method structure : structure -> 'res = self#list self#structure_item + + method structure_item : structure_item -> 'res = fun { pstr_desc; pstr_loc } -> let pstr_desc = self#structure_item_desc pstr_desc in let pstr_loc = self#location pstr_loc in - self#record [("pstr_desc", pstr_desc); ("pstr_loc", pstr_loc)] - method structure_item_desc : structure_item_desc -> 'res= + self#record [ ("pstr_desc", pstr_desc); ("pstr_loc", pstr_loc) ] + + method structure_item_desc : structure_item_desc -> 'res = fun x -> match x with | Pstr_eval (a, b) -> let a = self#expression a in - let b = self#attributes b in self#constr "Pstr_eval" [a; b] + let b = self#attributes b in + self#constr "Pstr_eval" [ a; b ] | Pstr_value (a, b) -> let a = self#rec_flag a in let b = self#list self#value_binding b in - self#constr "Pstr_value" [a; b] + self#constr "Pstr_value" [ a; b ] | Pstr_primitive a -> let a = self#value_description a in - self#constr "Pstr_primitive" [a] + self#constr "Pstr_primitive" [ a ] | Pstr_type (a, b) -> let a = self#rec_flag a in let b = self#list self#type_declaration b in - self#constr "Pstr_type" [a; b] + self#constr "Pstr_type" [ a; b ] | Pstr_typext a -> - let a = self#type_extension a in self#constr "Pstr_typext" [a] + let a = self#type_extension a in + self#constr "Pstr_typext" [ a ] | Pstr_exception a -> - let a = self#type_exception a in self#constr "Pstr_exception" [a] + let a = self#type_exception a in + self#constr "Pstr_exception" [ a ] | Pstr_module a -> - let a = self#module_binding a in self#constr "Pstr_module" [a] + let a = self#module_binding a in + self#constr "Pstr_module" [ a ] | Pstr_recmodule a -> let a = self#list self#module_binding a in - self#constr "Pstr_recmodule" [a] + self#constr "Pstr_recmodule" [ a ] | Pstr_modtype a -> let a = self#module_type_declaration a in - self#constr "Pstr_modtype" [a] + self#constr "Pstr_modtype" [ a ] | Pstr_open a -> - let a = self#open_declaration a in self#constr "Pstr_open" [a] + let a = self#open_declaration a in + self#constr "Pstr_open" [ a ] | Pstr_class a -> let a = self#list self#class_declaration a in - self#constr "Pstr_class" [a] + self#constr "Pstr_class" [ a ] | Pstr_class_type a -> let a = self#list self#class_type_declaration a in - self#constr "Pstr_class_type" [a] + self#constr "Pstr_class_type" [ a ] | Pstr_include a -> let a = self#include_declaration a in - self#constr "Pstr_include" [a] + self#constr "Pstr_include" [ a ] | Pstr_attribute a -> - let a = self#attribute a in self#constr "Pstr_attribute" [a] + let a = self#attribute a in + self#constr "Pstr_attribute" [ a ] | Pstr_extension (a, b) -> let a = self#extension a in - let b = self#attributes b in self#constr "Pstr_extension" [a; b] - method value_binding : value_binding -> 'res= + let b = self#attributes b in + self#constr "Pstr_extension" [ a; b ] + + method value_binding : value_binding -> 'res = fun { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } -> let pvb_pat = self#pattern pvb_pat in let pvb_expr = self#expression pvb_expr in let pvb_attributes = self#attributes pvb_attributes in let pvb_loc = self#location pvb_loc in self#record - [("pvb_pat", pvb_pat); - ("pvb_expr", pvb_expr); - ("pvb_attributes", pvb_attributes); - ("pvb_loc", pvb_loc)] - method module_binding : module_binding -> 'res= + [ + ("pvb_pat", pvb_pat); + ("pvb_expr", pvb_expr); + ("pvb_attributes", pvb_attributes); + ("pvb_loc", pvb_loc); + ] + + method module_binding : module_binding -> 'res = fun { pmb_name; pmb_expr; pmb_attributes; pmb_loc } -> let pmb_name = self#loc (self#option self#string) pmb_name in let pmb_expr = self#module_expr pmb_expr in let pmb_attributes = self#attributes pmb_attributes in let pmb_loc = self#location pmb_loc in self#record - [("pmb_name", pmb_name); - ("pmb_expr", pmb_expr); - ("pmb_attributes", pmb_attributes); - ("pmb_loc", pmb_loc)] - method toplevel_phrase : toplevel_phrase -> 'res= + [ + ("pmb_name", pmb_name); + ("pmb_expr", pmb_expr); + ("pmb_attributes", pmb_attributes); + ("pmb_loc", pmb_loc); + ] + + method toplevel_phrase : toplevel_phrase -> 'res = fun x -> match x with | Ptop_def a -> - let a = self#structure a in self#constr "Ptop_def" [a] + let a = self#structure a in + self#constr "Ptop_def" [ a ] | Ptop_dir a -> - let a = self#toplevel_directive a in self#constr "Ptop_dir" [a] - method toplevel_directive : toplevel_directive -> 'res= + let a = self#toplevel_directive a in + self#constr "Ptop_dir" [ a ] + + method toplevel_directive : toplevel_directive -> 'res = fun { pdir_name; pdir_arg; pdir_loc } -> let pdir_name = self#loc self#string pdir_name in let pdir_arg = self#option self#directive_argument pdir_arg in let pdir_loc = self#location pdir_loc in self#record - [("pdir_name", pdir_name); - ("pdir_arg", pdir_arg); - ("pdir_loc", pdir_loc)] - method directive_argument : directive_argument -> 'res= + [ + ("pdir_name", pdir_name); + ("pdir_arg", pdir_arg); + ("pdir_loc", pdir_loc); + ] + + method directive_argument : directive_argument -> 'res = fun { pdira_desc; pdira_loc } -> let pdira_desc = self#directive_argument_desc pdira_desc in let pdira_loc = self#location pdira_loc in - self#record [("pdira_desc", pdira_desc); ("pdira_loc", pdira_loc)] - method directive_argument_desc : directive_argument_desc -> 'res= + self#record [ ("pdira_desc", pdira_desc); ("pdira_loc", pdira_loc) ] + + method directive_argument_desc : directive_argument_desc -> 'res = fun x -> match x with | Pdir_string a -> - let a = self#string a in self#constr "Pdir_string" [a] + let a = self#string a in + self#constr "Pdir_string" [ a ] | Pdir_int (a, b) -> let a = self#string a in - let b = self#option self#char b in self#constr "Pdir_int" [a; b] + let b = self#option self#char b in + self#constr "Pdir_int" [ a; b ] | Pdir_ident a -> - let a = self#longident a in self#constr "Pdir_ident" [a] - | Pdir_bool a -> let a = self#bool a in self#constr "Pdir_bool" [a] + let a = self#longident a in + self#constr "Pdir_ident" [ a ] + | Pdir_bool a -> + let a = self#bool a in + self#constr "Pdir_bool" [ a ] + + method cases : cases -> 'res = self#list self#case end + [@@@end] diff -Nru ppxlib-0.15.0/ast/cinaps/ast_cinaps_helpers.ml ppxlib-0.24.0/ast/cinaps/ast_cinaps_helpers.ml --- ppxlib-0.15.0/ast/cinaps/ast_cinaps_helpers.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/ast/cinaps/ast_cinaps_helpers.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,52 @@ +(* -*- tuareg -*- *) + +include StdLabels +include Printf + +let nl () = printf "\n" + +let qualified_types = + [ + ( "Parsetree", + [ + "structure"; + "signature"; + "toplevel_phrase"; + "core_type"; + "expression"; + "pattern"; + "case"; + "type_declaration"; + "type_extension"; + "extension_constructor"; + ] ); + ] + +let all_types = List.concat (List.map ~f:snd qualified_types) + +let foreach_module f = + nl (); + List.iter qualified_types ~f:(fun (m, types) -> f m types) + +let foreach_type f = foreach_module (fun m -> List.iter ~f:(f m)) + +let foreach_version f = + nl (); + List.iter Supported_version.all ~f:(fun v -> + f (Supported_version.to_int v) (Supported_version.to_string v)) + +let foreach_version_pair f = + nl (); + let rec aux = function + | x :: (y :: _ as tail) -> + f (Supported_version.to_int x) (Supported_version.to_int y); + aux tail + | [ _ ] | [] -> () + in + aux Supported_version.all + +let with_then_and () = + let first = ref true in + fun oc -> + output_string oc (if !first then "with" else " and"); + first := false diff -Nru ppxlib-0.15.0/ast/cinaps/dune ppxlib-0.24.0/ast/cinaps/dune --- ppxlib-0.15.0/ast/cinaps/dune 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/ast/cinaps/dune 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,3 @@ +(library + (name ast_cinaps_helpers) + (libraries supported_version)) diff -Nru ppxlib-0.15.0/ast/dune ppxlib-0.24.0/ast/dune --- ppxlib-0.15.0/ast/dune 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/ast/dune 2021-12-08 21:53:37.000000000 +0000 @@ -1,26 +1,23 @@ +;; Note that to use the preprocessor for the (* IF_AT_LEAST ... *) +;; syntax you have to make sure the module is in the module list in +;; (per_module ) + (library - (name ppxlib_ast) + (name ppxlib_ast) (public_name ppxlib.ast) - (libraries - ocaml-compiler-libs.shadow - ocaml-compiler-libs.common - compiler-libs.common - ocaml-migrate-parsetree) - (flags (:standard -open Ocaml_shadow -safe-string) -w -9-27-32) - (modules - ast - import - lexer_helper - location_helper - misc_helper - pprintast - ppxlib_ast - warn) - (lint (pps ppxlib_traverse -deriving-keep-w32=impl))) + (libraries astlib stdlib-shims) + (flags + (:standard -safe-string) + -w + -9-27-32) + (preprocess + (per_module + ((action + (run %{exe:pp/pp.exe} %{ocaml_version} %{input-file})) + versions))) + (lint + (pps ppxlib_traverse -deriving-keep-w32=impl))) -;; This is to make the code compatible with different versions of -;; OCaml -(rule - (targets location_helper.ml clflags_helper.ml misc_helper.ml) - (deps gen-compiler_specifics) - (action (run %{ocaml} %{deps} %{ocaml_version} %{targets}))) +(cinaps + (files *.ml *.mli) + (libraries ast_cinaps_helpers)) diff -Nru ppxlib-0.15.0/ast/gen-compiler_specifics ppxlib-0.24.0/ast/gen-compiler_specifics --- ppxlib-0.15.0/ast/gen-compiler_specifics 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/ast/gen-compiler_specifics 1970-01-01 00:00:00.000000000 +0000 @@ -1,49 +0,0 @@ -(* -*- tuareg -*- *) - -open Printf - -let with_file path ~f = - let oc = open_out_bin path in - let pr fmt = fprintf oc (fmt ^^ "\n") in - f pr; - close_out oc - -let () = - let ver = Scanf.sscanf Sys.argv.(1) "%u.%u" (fun a b -> a, b) in - with_file Sys.argv.(2) ~f:(fun pr -> (* location_helper *) - if ver < (4, 06) then - pr {| -let deprecated loc s = - Ocaml_common.Location.prerr_warning loc (Ocaml_common.Warnings.Deprecated s) -|}; - if ver < (4, 08) then begin - pr {| -let print_error ppf loc = Ocaml_common.Location.print_error ppf loc -let error_of_printer ~loc x y = Ocaml_common.Location.error_of_printer loc x y -|}; - end else begin - pr {| -let print_error ppf loc = Format.fprintf ppf "%%aError:" Ocaml_common.Location.print_loc loc -let error_of_printer ~loc x y = Ocaml_common.Location.error_of_printer ~loc x y -|}; - end); - with_file Sys.argv.(3) ~f:(fun pr -> (* clflags_helper *) - if ver < (4, 08) then begin - pr {| -let is_unsafe () = !Ocaml_common.Clflags.fast[@ocaml.warning "-3"] -|}; - end else begin - pr {| -let is_unsafe () = !Ocaml_common.Clflags.unsafe[@ocaml.warning "-3"] -|}; - end); - with_file Sys.argv.(4) ~f:(fun pr -> (* misc_helper *) - if ver < (4, 10) then begin - pr {| -let may = Import.Misc.may -|}; - end else begin - pr {| -let may f = function Some v -> f v | None -> () -|}; - end) diff -Nru ppxlib-0.15.0/ast/import.ml ppxlib-0.24.0/ast/import.ml --- ppxlib-0.15.0/ast/import.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/ast/import.ml 2021-12-08 21:53:37.000000000 +0000 @@ -4,146 +4,115 @@ It must be opened in all modules, especially the ones coming from the compiler. *) -module Js = Migrate_parsetree.OCaml_410 -module Ocaml = Migrate_parsetree.Versions.OCaml_current - -module Select_ast(Ocaml : Migrate_parsetree.Versions.OCaml_version) = struct - open Migrate_parsetree +module Js = Versions.OCaml_412 +module Ocaml = Versions.OCaml_current +module Select_ast (Ocaml : Versions.OCaml_version) = struct include Js module Type = struct type ('js, 'ocaml) t = | Signature - : (Js .Ast.Parsetree.signature, - Ocaml.Ast.Parsetree.signature) t + : (Js.Ast.Parsetree.signature, Ocaml.Ast.Parsetree.signature) t | Structure - : (Js .Ast.Parsetree.structure, - Ocaml.Ast.Parsetree.structure) t + : (Js.Ast.Parsetree.structure, Ocaml.Ast.Parsetree.structure) t | Toplevel_phrase - : (Js .Ast.Parsetree.toplevel_phrase, - Ocaml.Ast.Parsetree.toplevel_phrase) t - | Out_phrase - : (Js .Ast.Outcometree.out_phrase, - Ocaml.Ast.Outcometree.out_phrase) t + : ( Js.Ast.Parsetree.toplevel_phrase, + Ocaml.Ast.Parsetree.toplevel_phrase ) + t | Expression - : (Js .Ast.Parsetree.expression, - Ocaml.Ast.Parsetree.expression) t + : (Js.Ast.Parsetree.expression, Ocaml.Ast.Parsetree.expression) t | Core_type - : (Js .Ast.Parsetree.core_type, - Ocaml.Ast.Parsetree.core_type) t + : (Js.Ast.Parsetree.core_type, Ocaml.Ast.Parsetree.core_type) t | Type_declaration - : (Js .Ast.Parsetree.type_declaration, - Ocaml.Ast.Parsetree.type_declaration) t + : ( Js.Ast.Parsetree.type_declaration, + Ocaml.Ast.Parsetree.type_declaration ) + t | Type_extension - : (Js .Ast.Parsetree.type_extension, - Ocaml.Ast.Parsetree.type_extension) t + : ( Js.Ast.Parsetree.type_extension, + Ocaml.Ast.Parsetree.type_extension ) + t | Extension_constructor - : (Js .Ast.Parsetree.extension_constructor, - Ocaml.Ast.Parsetree.extension_constructor) t - | List - : ('a, 'b) t -> ('a list, 'b list) t - | Pair - : ('a, 'b) t * ('c, 'd) t -> ('a * 'c, 'b * 'd) t + : ( Js.Ast.Parsetree.extension_constructor, + Ocaml.Ast.Parsetree.extension_constructor ) + t + | List : ('a, 'b) t -> ('a list, 'b list) t + | Pair : ('a, 'b) t * ('c, 'd) t -> ('a * 'c, 'b * 'd) t end - open Type - module Of_ocaml = Versions.Convert(Ocaml)(Js) - module To_ocaml = Versions.Convert(Js)(Ocaml) + open Type + module Of_ocaml = Versions.Convert (Ocaml) (Js) + module To_ocaml = Versions.Convert (Js) (Ocaml) let rec of_ocaml : type ocaml js. (js, ocaml) Type.t -> ocaml -> js = let open Of_ocaml in fun node -> match node with - | Signature -> copy_signature - | Structure -> copy_structure - | Toplevel_phrase -> copy_toplevel_phrase - | Out_phrase -> copy_out_phrase - | Expression -> copy_expression - | Core_type -> copy_core_type - | Type_declaration -> copy_type_declaration - | Type_extension -> copy_type_extension + | Signature -> copy_signature + | Structure -> copy_structure + | Toplevel_phrase -> copy_toplevel_phrase + | Expression -> copy_expression + | Core_type -> copy_core_type + | Type_declaration -> copy_type_declaration + | Type_extension -> copy_type_extension | Extension_constructor -> copy_extension_constructor - | List t -> List.map (of_ocaml t) - | Pair (a, b) -> - let f = of_ocaml a in - let g = of_ocaml b in - fun (x, y) -> (f x, g y) + | List t -> List.map (of_ocaml t) + | Pair (a, b) -> + let f = of_ocaml a in + let g = of_ocaml b in + fun (x, y) -> (f x, g y) let rec to_ocaml : type ocaml js. (js, ocaml) Type.t -> js -> ocaml = let open To_ocaml in fun node -> match node with - | Signature -> copy_signature - | Structure -> copy_structure - | Toplevel_phrase -> copy_toplevel_phrase - | Out_phrase -> copy_out_phrase - | Expression -> copy_expression - | Core_type -> copy_core_type - | Type_declaration -> copy_type_declaration - | Type_extension -> copy_type_extension + | Signature -> copy_signature + | Structure -> copy_structure + | Toplevel_phrase -> copy_toplevel_phrase + | Expression -> copy_expression + | Core_type -> copy_core_type + | Type_declaration -> copy_type_declaration + | Type_extension -> copy_type_extension | Extension_constructor -> copy_extension_constructor - | List t -> List.map (to_ocaml t) - | Pair (a, b) -> - let f = to_ocaml a in - let g = to_ocaml b in - fun (x, y) -> (f x, g y) + | List t -> List.map (to_ocaml t) + | Pair (a, b) -> + let f = to_ocaml a in + let g = to_ocaml b in + fun (x, y) -> (f x, g y) - let of_ocaml_mapper item f x = - to_ocaml item x |> f |> of_ocaml item + let of_ocaml_mapper item f ctxt x = to_ocaml item x |> f ctxt |> of_ocaml item - let to_ocaml_mapper item f x = - of_ocaml item x |> f |> to_ocaml item + let to_ocaml_mapper item f ctxt x = of_ocaml item x |> f ctxt |> to_ocaml item end -module Selected_ast = Select_ast(Ocaml) - -(* Modules from migrate_parsetree *) -module Parsetree = Selected_ast.Ast.Parsetree -module Asttypes = Selected_ast.Ast.Asttypes -module Ast_helper = Selected_ast.Ast.Ast_helper -module Docstrings = Selected_ast.Ast.Docstrings - +module Selected_ast = Select_ast (Ocaml) +module Ast_helper = Ast_helper_lite -module Location = struct - include Ocaml_common.Location - include Location_helper -end +(* Modules from Ast_ of Astlib, where is the compiler version the ppxlib driver is compiled with *) +module Parsetree = Selected_ast.Ast.Parsetree +module Asttypes = Selected_ast.Ast.Asttypes -module Lexer = struct - include Ocaml_common.Lexer - include Lexer_helper -end - -module Syntaxerr = struct - include Ocaml_common.Syntaxerr -end +(* Other Astlib modules *) +module Location = Astlib.Location +module Longident = Astlib.Longident module Parse = struct - include Ocaml_common.Parse - module Of_ocaml = Migrate_parsetree.Versions.Convert(Ocaml)(Js) + include Astlib.Parse + module Of_ocaml = Versions.Convert (Ocaml) (Js) + let implementation lexbuf = implementation lexbuf |> Of_ocaml.copy_structure + let interface lexbuf = interface lexbuf |> Of_ocaml.copy_signature - let toplevel_phrase lexbuf = toplevel_phrase lexbuf |> Of_ocaml.copy_toplevel_phrase - let use_file lexbuf = use_file lexbuf |> List.map Of_ocaml.copy_toplevel_phrase + + let toplevel_phrase lexbuf = + toplevel_phrase lexbuf |> Of_ocaml.copy_toplevel_phrase + + let use_file lexbuf = + use_file lexbuf |> List.map Of_ocaml.copy_toplevel_phrase + let core_type lexbuf = core_type lexbuf |> Of_ocaml.copy_core_type + let expression lexbuf = expression lexbuf |> Of_ocaml.copy_expression - let pattern lexbuf = pattern lexbuf |> Of_ocaml.copy_pattern -end -module Parser = struct - include Ocaml_common.Parser - module Of_ocaml = Migrate_parsetree.Versions.Convert(Ocaml)(Js) - let use_file lexer lexbuf = use_file lexer lexbuf |> List.map Of_ocaml.copy_toplevel_phrase - let toplevel_phrase lexer lexbuf = toplevel_phrase lexer lexbuf |> Of_ocaml.copy_toplevel_phrase - let parse_pattern lexer lexbuf = parse_pattern lexer lexbuf |> Of_ocaml.copy_pattern - let parse_expression lexer lexbuf = parse_expression lexer lexbuf |> Of_ocaml.copy_expression - let parse_core_type lexer lexbuf = parse_core_type lexer lexbuf |> Of_ocaml.copy_core_type - let interface lexer lexbuf = interface lexer lexbuf |> Of_ocaml.copy_signature - let implementation lexer lexbuf = implementation lexer lexbuf |> Of_ocaml.copy_structure + let pattern lexbuf = pattern lexbuf |> Of_ocaml.copy_pattern end - -(* Modules imported directly from the compiler *) -module Longident = Ocaml_common.Longident -module Misc = Ocaml_common.Misc -module Warnings = Ocaml_common.Warnings diff -Nru ppxlib-0.15.0/ast/lexer_helper.ml ppxlib-0.24.0/ast/lexer_helper.ml --- ppxlib-0.15.0/ast/lexer_helper.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/ast/lexer_helper.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,63 +0,0 @@ -open Ocaml_common.Parser - -let keyword_table = - Ocaml_common.Misc.create_hashtable 149 [ - "and", AND; - "as", AS; - "assert", ASSERT; - "begin", BEGIN; - "class", CLASS; - "constraint", CONSTRAINT; - "do", DO; - "done", DONE; - "downto", DOWNTO; - "else", ELSE; - "end", END; - "exception", EXCEPTION; - "external", EXTERNAL; - "false", FALSE; - "for", FOR; - "fun", FUN; - "function", FUNCTION; - "functor", FUNCTOR; - "if", IF; - "in", IN; - "include", INCLUDE; - "inherit", INHERIT; - "initializer", INITIALIZER; - "lazy", LAZY; - "let", LET; - "match", MATCH; - "method", METHOD; - "module", MODULE; - "mutable", MUTABLE; - "new", NEW; - "nonrec", NONREC; - "object", OBJECT; - "of", OF; - "open", OPEN; - "or", OR; -(* "parser", PARSER; *) - "private", PRIVATE; - "rec", REC; - "sig", SIG; - "struct", STRUCT; - "then", THEN; - "to", TO; - "true", TRUE; - "try", TRY; - "type", TYPE; - "val", VAL; - "virtual", VIRTUAL; - "when", WHEN; - "while", WHILE; - "with", WITH; - - "lor", INFIXOP3("lor"); (* Should be INFIXOP2 *) - "lxor", INFIXOP3("lxor"); (* Should be INFIXOP2 *) - "mod", INFIXOP3("mod"); - "land", INFIXOP3("land"); - "lsl", INFIXOP4("lsl"); - "lsr", INFIXOP4("lsr"); - "asr", INFIXOP4("asr") -] diff -Nru ppxlib-0.15.0/ast/location_error.ml ppxlib-0.24.0/ast/location_error.ml --- ppxlib-0.15.0/ast/location_error.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/ast/location_error.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,43 @@ +open Import + +type t = Astlib.Location.Error.t + +let to_extension (error : Astlib.Location.Error.t) = + let open Astlib.Location.Error in + let open Ast_helper in + if not (is_well_formed error) then + raise (Invalid_argument "to_extension: expected kind Report_error"); + let sub_msgs = sub_msgs error in + let main_msg = main_msg error in + let err_extension_name loc = { Location.loc; txt = "ocaml.error" } in + let mk_string_constant x = Str.eval (Exp.constant (Const.string x)) in + let extension_of_sub_msg (sub_msg : string Location.loc) = + Str.extension + (err_extension_name sub_msg.loc, PStr [ mk_string_constant sub_msg.txt ]) + in + ( err_extension_name main_msg.loc, + Parsetree.PStr + (mk_string_constant main_msg.txt :: List.map extension_of_sub_msg sub_msgs) + ) + +let register_error_of_exn = Astlib.Location.register_error_of_exn + +let message error = + let { Astlib.Location.txt; _ } = Astlib.Location.Error.main_msg error in + txt + +let set_message = Astlib.Location.Error.set_main_msg + +let make ~loc txt ~sub = + let sub = List.map (fun (loc, txt) -> { Astlib.Location.loc; txt }) sub in + Astlib.Location.Error.make ~sub { loc; txt } + +let update_loc = Astlib.Location.Error.set_main_loc + +let get_location error = + let { Astlib.Location.loc; _ } = Astlib.Location.Error.main_msg error in + loc + +let of_exn = Astlib.Location.Error.of_exn + +let raise error = raise (Astlib.Location.Error error) diff -Nru ppxlib-0.15.0/ast/location_error.mli ppxlib-0.24.0/ast/location_error.mli --- ppxlib-0.15.0/ast/location_error.mli 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/ast/location_error.mli 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,21 @@ +open Import + +type t = Astlib.Location.Error.t + +val of_exn : exn -> t option + +val register_error_of_exn : (exn -> t option) -> unit + +val message : t -> string + +val set_message : t -> string -> t + +val make : loc:Location.t -> string -> sub:(Location.t * string) list -> t + +val to_extension : t -> Import.Parsetree.extension + +val raise : t -> 'a + +val update_loc : t -> Location.t -> t + +val get_location : t -> Location.t diff -Nru ppxlib-0.15.0/ast/pp/dune ppxlib-0.24.0/ast/pp/dune --- ppxlib-0.15.0/ast/pp/dune 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/ast/pp/dune 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,6 @@ +(executables + (names pp) + (libraries supported_version) + (flags :standard -w -3)) + +(ocamllex pp_rewrite) diff -Nru ppxlib-0.15.0/ast/pp/pp.ml ppxlib-0.24.0/ast/pp/pp.ml --- ppxlib-0.15.0/ast/pp/pp.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/ast/pp/pp.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,16 @@ +let () = + match Sys.argv with + | [| _; ocaml_version_str; fname |] -> + let ocaml_version = + match Supported_version.of_string ocaml_version_str with + | Some v -> string_of_int (Supported_version.to_int v) + | None -> + Printf.eprintf "Unknown OCaml version %s\n" ocaml_version_str; + exit 1 + in + let ic = open_in_bin fname in + Printf.printf "# 1 %S\n" fname; + Pp_rewrite.rewrite ocaml_version (Lexing.from_channel ic) + | _ -> + Printf.eprintf "%s: \n" Sys.executable_name; + exit 2 diff -Nru ppxlib-0.15.0/ast/pp/pp.mli ppxlib-0.24.0/ast/pp/pp.mli --- ppxlib-0.15.0/ast/pp/pp.mli 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/ast/pp/pp.mli 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1 @@ +(* empty *) diff -Nru ppxlib-0.15.0/ast/pp/pp_rewrite.mli ppxlib-0.24.0/ast/pp/pp_rewrite.mli --- ppxlib-0.15.0/ast/pp/pp_rewrite.mli 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/ast/pp/pp_rewrite.mli 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1 @@ +val rewrite : string -> Lexing.lexbuf -> unit diff -Nru ppxlib-0.15.0/ast/pp/pp_rewrite.mll ppxlib-0.24.0/ast/pp/pp_rewrite.mll --- ppxlib-0.15.0/ast/pp/pp_rewrite.mll 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/ast/pp/pp_rewrite.mll 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,27 @@ +{ +open Printf + +let print_ocaml_version version = + let patt_len = String.length "OCAML_VERSION" in + (* Note: the spaces in the replacements are to preserve locations *) + printf "%-*s" patt_len version +} + +rule rewrite ocaml_version = parse + | "OCAML_VERSION" + { print_ocaml_version ocaml_version; + rewrite ocaml_version lexbuf + } + | "(*IF_AT_LEAST " ([^'*' ' ']* as v) " " ([^'*']* as s) "*)" + { let chunk = if (v <= ocaml_version) + then " " ^ String.make (String.length v + 1) ' ' ^ s ^ " " + else Lexing.lexeme lexbuf + in + print_string chunk; + rewrite ocaml_version lexbuf + } + | _ as c + { print_char c; + rewrite ocaml_version lexbuf + } + | eof { () } diff -Nru ppxlib-0.15.0/ast/pprintast.ml ppxlib-0.24.0/ast/pprintast.ml --- ppxlib-0.15.0/ast/pprintast.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/ast/pprintast.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,1650 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Thomas Gazagnaire, OCamlPro *) -(* Fabrice Le Fessant, INRIA Saclay *) -(* Hongbo Zhang, University of Pennsylvania *) -(* *) -(* Copyright 2007 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Original Code from Ber-metaocaml, modified for 3.12.0 and fixed *) -(* Printing code expressions *) -(* Authors: Ed Pizzi, Fabrice Le Fessant *) -(* Extensive Rewrite: Hongbo Zhang: University of Pennsylvania *) -(* TODO more fine-grained precedence pretty-printing *) - -open Import -open Asttypes -open Format -open Location -open Longident -open Parsetree -open Ast_helper - -let prefix_symbols = [ '!'; '?'; '~' ] ;; -let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/'; - '$'; '%'; '#' ] - -(* type fixity = Infix| Prefix *) -let special_infix_strings = - ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "::" ] - -let letop s = - String.length s > 3 - && s.[0] = 'l' - && s.[1] = 'e' - && s.[2] = 't' - && List.mem s.[3] infix_symbols - -let andop s = - String.length s > 3 - && s.[0] = 'a' - && s.[1] = 'n' - && s.[2] = 'd' - && List.mem s.[3] infix_symbols - -(* determines if the string is an infix string. - checks backwards, first allowing a renaming postfix ("_102") which - may have resulted from Pexp -> Texp -> Pexp translation, then checking - if all the characters in the beginning of the string are valid infix - characters. *) -let fixity_of_string = function - | "" -> `Normal - | s when List.mem s special_infix_strings -> `Infix s - | s when List.mem s.[0] infix_symbols -> `Infix s - | s when List.mem s.[0] prefix_symbols -> `Prefix s - | s when s.[0] = '.' -> `Mixfix s - | s when letop s -> `Letop s - | s when andop s -> `Andop s - | _ -> `Normal - -let view_fixity_of_exp = function - | {pexp_desc = Pexp_ident {txt=Lident l;_}; pexp_attributes = []} -> - fixity_of_string l - | _ -> `Normal - -let is_infix = function `Infix _ -> true | _ -> false -let is_mixfix = function `Mixfix _ -> true | _ -> false -let is_kwdop = function `Letop _ | `Andop _ -> true | _ -> false - -let first_is c str = - str <> "" && str.[0] = c -let last_is c str = - str <> "" && str.[String.length str - 1] = c - -let first_is_in cs str = - str <> "" && List.mem str.[0] cs - -(* which identifiers are in fact operators needing parentheses *) -let needs_parens txt = - let fix = fixity_of_string txt in - is_infix fix - || is_mixfix fix - || is_kwdop fix - || first_is_in prefix_symbols txt - -(* some infixes need spaces around parens to avoid clashes with comment - syntax *) -let needs_spaces txt = - first_is '*' txt || last_is '*' txt - -(* add parentheses to binders when they are in fact infix or prefix operators *) -let protect_ident ppf txt = - let format : (_, _, _) format = - if not (needs_parens txt) then "%s" - else if needs_spaces txt then "(@;%s@;)" - else "(%s)" - in fprintf ppf format txt - -let protect_longident ppf print_longident longprefix txt = - let format : (_, _, _) format = - if not (needs_parens txt) then "%a.%s" - else if needs_spaces txt then "%a.(@;%s@;)" - else "%a.(%s)" in - fprintf ppf format print_longident longprefix txt - -type space_formatter = (unit, Format.formatter, unit) format - -let override = function - | Override -> "!" - | Fresh -> "" - -(* variance encoding: need to sync up with the [parser.mly] *) -let type_variance = function - | Invariant -> "" - | Covariant -> "+" - | Contravariant -> "-" - -type construct = - [ `cons of expression list - | `list of expression list - | `nil - | `normal - | `simple of Longident.t - | `tuple ] - -let view_expr x = - match x.pexp_desc with - | Pexp_construct ( {txt= Lident "()"; _},_) -> `tuple - | Pexp_construct ( {txt= Lident "[]";_},_) -> `nil - | Pexp_construct ( {txt= Lident"::";_},Some _) -> - let rec loop exp acc = match exp with - | {pexp_desc=Pexp_construct ({txt=Lident "[]";_},_); - pexp_attributes = []} -> - (List.rev acc,true) - | {pexp_desc= - Pexp_construct ({txt=Lident "::";_}, - Some ({pexp_desc= Pexp_tuple([e1;e2]); - pexp_attributes = []})); - pexp_attributes = []} - -> - loop e2 (e1::acc) - | e -> (List.rev (e::acc),false) in - let (ls,b) = loop x [] in - if b then - `list ls - else `cons ls - | Pexp_construct (x,None) -> `simple (x.txt) - | _ -> `normal - -let is_simple_construct :construct -> bool = function - | `nil | `tuple | `list _ | `simple _ -> true - | `cons _ | `normal -> false - -let pp = fprintf - -type ctxt = { - pipe : bool; - semi : bool; - ifthenelse : bool; -} - -let reset_ctxt = { pipe=false; semi=false; ifthenelse=false } -let under_pipe ctxt = { ctxt with pipe=true } -let under_semi ctxt = { ctxt with semi=true } -let under_ifthenelse ctxt = { ctxt with ifthenelse=true } -(* -let reset_semi ctxt = { ctxt with semi=false } -let reset_ifthenelse ctxt = { ctxt with ifthenelse=false } -let reset_pipe ctxt = { ctxt with pipe=false } -*) - -let list : 'a . ?sep:space_formatter -> ?first:space_formatter -> - ?last:space_formatter -> (Format.formatter -> 'a -> unit) -> - Format.formatter -> 'a list -> unit - = fun ?sep ?first ?last fu f xs -> - let first = match first with Some x -> x |None -> ("": _ format6) - and last = match last with Some x -> x |None -> ("": _ format6) - and sep = match sep with Some x -> x |None -> ("@ ": _ format6) in - let aux f = function - | [] -> () - | [x] -> fu f x - | xs -> - let rec loop f = function - | [x] -> fu f x - | x::xs -> fu f x; pp f sep; loop f xs; - | _ -> assert false in begin - pp f first; loop f xs; pp f last; - end in - aux f xs - -let option : 'a. ?first:space_formatter -> ?last:space_formatter -> - (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit - = fun ?first ?last fu f a -> - let first = match first with Some x -> x | None -> ("": _ format6) - and last = match last with Some x -> x | None -> ("": _ format6) in - match a with - | None -> () - | Some x -> pp f first; fu f x; pp f last - -let paren: 'a . ?first:space_formatter -> ?last:space_formatter -> - bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit - = fun ?(first=("": _ format6)) ?(last=("": _ format6)) b fu f x -> - if b then (pp f "("; pp f first; fu f x; pp f last; pp f ")") - else fu f x - -let rec longident f = function - | Lident s -> protect_ident f s - | Ldot(y,s) -> protect_longident f longident y s - | Lapply (y,s) -> - pp f "%a(%a)" longident y longident s - -let longident_loc f x = pp f "%a" longident x.txt - -let constant f = function - | Pconst_char i -> - pp f "%C" i - | Pconst_string (i, None) -> - pp f "%S" i - | Pconst_string (i, Some delim) -> - pp f "{%s|%s|%s}" delim i delim - | Pconst_integer (i, None) -> - paren (first_is '-' i) (fun f -> pp f "%s") f i - | Pconst_integer (i, Some m) -> - paren (first_is '-' i) (fun f (i, m) -> pp f "%s%c" i m) f (i,m) - | Pconst_float (i, None) -> - paren (first_is '-' i) (fun f -> pp f "%s") f i - | Pconst_float (i, Some m) -> - paren (first_is '-' i) (fun f (i,m) -> pp f "%s%c" i m) f (i,m) - -(* trailing space*) -let mutable_flag f = function - | Immutable -> () - | Mutable -> pp f "mutable@;" -let virtual_flag f = function - | Concrete -> () - | Virtual -> pp f "virtual@;" - -(* trailing space added *) -let rec_flag f rf = - match rf with - | Nonrecursive -> () - | Recursive -> pp f "rec " -let nonrec_flag f rf = - match rf with - | Nonrecursive -> pp f "nonrec " - | Recursive -> () -let direction_flag f = function - | Upto -> pp f "to@ " - | Downto -> pp f "downto@ " -let private_flag f = function - | Public -> () - | Private -> pp f "private@ " - -let iter_loc f ctxt {txt; loc = _} = f ctxt txt - -let constant_string f s = pp f "%S" s - -let tyvar ppf s = - if String.length s >= 2 && s.[1] = '\'' then - (* without the space, this would be parsed as - a character literal *) - Format.fprintf ppf "' %s" s - else - Format.fprintf ppf "'%s" s - -let tyvar_loc f str = tyvar f str.txt -let string_quot f x = pp f "`%s" x - -(* c ['a,'b] *) -let rec class_params_def ctxt f = function - | [] -> () - | l -> - pp f "[%a] " (* space *) - (list (type_param ctxt) ~sep:",") l - -and type_with_label ctxt f (label, c) = - match label with - | Nolabel -> core_type1 ctxt f c (* otherwise parenthesize *) - | Labelled s -> pp f "%s:%a" s (core_type1 ctxt) c - | Optional s -> pp f "?%s:%a" s (core_type1 ctxt) c - -and core_type ctxt f x = - if x.ptyp_attributes <> [] then begin - pp f "((%a)%a)" (core_type ctxt) {x with ptyp_attributes=[]} - (attributes ctxt) x.ptyp_attributes - end - else match x.ptyp_desc with - | Ptyp_arrow (l, ct1, ct2) -> - pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) - (type_with_label ctxt) (l,ct1) (core_type ctxt) ct2 - | Ptyp_alias (ct, s) -> - pp f "@[<2>%a@;as@;%a@]" (core_type1 ctxt) ct tyvar s - | Ptyp_poly ([], ct) -> - core_type ctxt f ct - | Ptyp_poly (sl, ct) -> - pp f "@[<2>%a%a@]" - (fun f l -> - pp f "%a" - (fun f l -> match l with - | [] -> () - | _ -> - pp f "%a@;.@;" - (list tyvar_loc ~sep:"@;") l) - l) - sl (core_type ctxt) ct - | _ -> pp f "@[<2>%a@]" (core_type1 ctxt) x - -and core_type1 ctxt f x = - if x.ptyp_attributes <> [] then core_type ctxt f x - else match x.ptyp_desc with - | Ptyp_any -> pp f "_"; - | Ptyp_var s -> tyvar f s; - | Ptyp_tuple l -> pp f "(%a)" (list (core_type1 ctxt) ~sep:"@;*@;") l - | Ptyp_constr (li, l) -> - pp f (* "%a%a@;" *) "%a%a" - (fun f l -> match l with - |[] -> () - |[x]-> pp f "%a@;" (core_type1 ctxt) x - | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:",@;" f l) - l longident_loc li - | Ptyp_variant (l, closed, low) -> - let type_variant_helper f x = - match x.prf_desc with - | Rtag (l, _, ctl) -> - pp f "@[<2>%a%a@;%a@]" (iter_loc string_quot) l - (fun f l -> match l with - |[] -> () - | _ -> pp f "@;of@;%a" - (list (core_type ctxt) ~sep:"&") ctl) ctl - (attributes ctxt) x.prf_attributes - | Rinherit ct -> core_type ctxt f ct in - pp f "@[<2>[%a%a]@]" - (fun f l -> - match l, closed with - | [], Closed -> () - | [], Open -> pp f ">" (* Cf #7200: print [>] correctly *) - | _ -> - pp f "%s@;%a" - (match (closed,low) with - | (Closed,None) -> "" - | (Closed,Some _) -> "<" (* FIXME desugar the syntax sugar*) - | (Open,_) -> ">") - (list type_variant_helper ~sep:"@;<1 -2>| ") l) l - (fun f low -> match low with - |Some [] |None -> () - |Some xs -> - pp f ">@ %a" - (list string_quot) xs) low - | Ptyp_object (l, o) -> - let core_field_type f x = match x.pof_desc with - | Otag (l, ct) -> - (* Cf #7200 *) - pp f "@[%s: %a@ %a@ @]" l.txt - (core_type ctxt) ct (attributes ctxt) x.pof_attributes - | Oinherit ct -> - pp f "@[%a@ @]" (core_type ctxt) ct - in - let field_var f = function - | Asttypes.Closed -> () - | Asttypes.Open -> - match l with - | [] -> pp f ".." - | _ -> pp f " ;.." - in - pp f "@[<@ %a%a@ > @]" - (list core_field_type ~sep:";") l - field_var o (* Cf #7200 *) - | Ptyp_class (li, l) -> (*FIXME*) - pp f "@[%a#%a@]" - (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") l - longident_loc li - | Ptyp_package (lid, cstrs) -> - let aux f (s, ct) = - pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct in - (match cstrs with - |[] -> pp f "@[(module@ %a)@]" longident_loc lid - |_ -> - pp f "@[(module@ %a@ with@ %a)@]" longident_loc lid - (list aux ~sep:"@ and@ ") cstrs) - | Ptyp_extension e -> extension ctxt f e - | _ -> paren true (core_type ctxt) f x - -(********************pattern********************) -(* be cautious when use [pattern], [pattern1] is preferred *) -and pattern ctxt f x = - let rec list_of_pattern acc = function (* only consider ((A|B)|C)*) - | {ppat_desc= Ppat_or (p1,p2); ppat_attributes = []} -> - list_of_pattern (p2::acc) p1 - | x -> x::acc - in - if x.ppat_attributes <> [] then begin - pp f "((%a)%a)" (pattern ctxt) {x with ppat_attributes=[]} - (attributes ctxt) x.ppat_attributes - end - else match x.ppat_desc with - | Ppat_alias (p, s) -> - pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p protect_ident s.txt (* RA*) - | Ppat_or _ -> (* *) - pp f "@[%a@]" (list ~sep:"@,|" (pattern ctxt)) - (list_of_pattern [] x) - | _ -> pattern1 ctxt f x - -and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit = - let rec pattern_list_helper f = function - | {ppat_desc = - Ppat_construct - ({ txt = Lident("::") ;_}, - Some ({ppat_desc = Ppat_tuple([pat1; pat2]);_})); - ppat_attributes = []} - - -> - pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*) - | p -> pattern1 ctxt f p - in - if x.ppat_attributes <> [] then pattern ctxt f x - else match x.ppat_desc with - | Ppat_variant (l, Some p) -> - pp f "@[<2>`%s@;%a@]" l (simple_pattern ctxt) p - | Ppat_construct (({txt=Lident("()"|"[]");_}), _) -> simple_pattern ctxt f x - | Ppat_construct (({txt;_} as li), po) -> - (* FIXME The third field always false *) - if txt = Lident "::" then - pp f "%a" pattern_list_helper x - else - (match po with - | Some x -> pp f "%a@;%a" longident_loc li (simple_pattern ctxt) x - | None -> pp f "%a" longident_loc li) - | _ -> simple_pattern ctxt f x - -and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = - if x.ppat_attributes <> [] then pattern ctxt f x - else match x.ppat_desc with - | Ppat_construct (({txt=Lident ("()"|"[]" as x);_}), _) -> pp f "%s" x - | Ppat_any -> pp f "_"; - | Ppat_var ({txt = txt;_}) -> protect_ident f txt - | Ppat_array l -> - pp f "@[<2>[|%a|]@]" (list (pattern1 ctxt) ~sep:";") l - | Ppat_unpack { txt = None } -> - pp f "(module@ _)@ " - | Ppat_unpack { txt= Some s } -> - pp f "(module@ %s)@ " s - | Ppat_type li -> - pp f "#%a" longident_loc li - | Ppat_record (l, closed) -> - let longident_x_pattern f (li, p) = - match (li,p) with - | ({txt=Lident s;_ }, - {ppat_desc=Ppat_var {txt;_}; - ppat_attributes=[]; _}) - when s = txt -> - pp f "@[<2>%a@]" longident_loc li - | _ -> - pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p - in - begin match closed with - | Closed -> - pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l - | _ -> - pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l - end - | Ppat_tuple l -> - pp f "@[<1>(%a)@]" (list ~sep:",@;" (pattern1 ctxt)) l (* level1*) - | Ppat_constant (c) -> pp f "%a" constant c - | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2 - | Ppat_variant (l,None) -> pp f "`%s" l - | Ppat_constraint (p, ct) -> - pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct - | Ppat_lazy p -> - pp f "@[<2>(lazy@;%a)@]" (pattern1 ctxt) p - | Ppat_exception p -> - pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p - | Ppat_extension e -> extension ctxt f e - | Ppat_open (lid, p) -> - let with_paren = - match p.ppat_desc with - | Ppat_array _ | Ppat_record _ - | Ppat_construct (({txt=Lident ("()"|"[]");_}), _) -> false - | _ -> true in - pp f "@[<2>%a.%a @]" longident_loc lid - (paren with_paren @@ pattern1 ctxt) p - | _ -> paren true (pattern ctxt) f x - -and label_exp ctxt f (l,opt,p) = - match l with - | Nolabel -> - (* single case pattern parens needed here *) - pp f "%a@ " (simple_pattern ctxt) p - | Optional rest -> - begin match p with - | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} - when txt = rest -> - (match opt with - | Some o -> pp f "?(%s=@;%a)@;" rest (expression ctxt) o - | None -> pp f "?%s@ " rest) - | _ -> - (match opt with - | Some o -> - pp f "?%s:(%a=@;%a)@;" - rest (pattern1 ctxt) p (expression ctxt) o - | None -> pp f "?%s:%a@;" rest (simple_pattern ctxt) p) - end - | Labelled l -> match p with - | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} - when txt = l -> - pp f "~%s@;" l - | _ -> pp f "~%s:%a@;" l (simple_pattern ctxt) p - -and sugar_expr ctxt f e = - if e.pexp_attributes <> [] then false - else match e.pexp_desc with - | Pexp_apply ({ pexp_desc = Pexp_ident {txt = id; _}; - pexp_attributes=[]; _}, args) - when List.for_all (fun (lab, _) -> lab = Nolabel) args -> begin - let print_indexop a path_prefix assign left right print_index indices - rem_args = - let print_path ppf = function - | None -> () - | Some m -> pp ppf ".%a" longident m in - match assign, rem_args with - | false, [] -> - pp f "@[%a%a%s%a%s@]" - (simple_expr ctxt) a print_path path_prefix - left (list ~sep:"," print_index) indices right; true - | true, [v] -> - pp f "@[%a%a%s%a%s@ <-@;<1 2>%a@]" - (simple_expr ctxt) a print_path path_prefix - left (list ~sep:"," print_index) indices right - (simple_expr ctxt) v; true - | _ -> false in - match id, List.map snd args with - | Lident "!", [e] -> - pp f "@[!%a@]" (simple_expr ctxt) e; true - | Ldot (path, ("get"|"set" as func)), a :: other_args -> begin - let assign = func = "set" in - let print = print_indexop a None assign in - match path, other_args with - | Lident "Array", i :: rest -> - print ".(" ")" (expression ctxt) [i] rest - | Lident "String", i :: rest -> - print ".[" "]" (expression ctxt) [i] rest - | Ldot (Lident "Bigarray", "Array1"), i1 :: rest -> - print ".{" "}" (simple_expr ctxt) [i1] rest - | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest -> - print ".{" "}" (simple_expr ctxt) [i1; i2] rest - | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest -> - print ".{" "}" (simple_expr ctxt) [i1; i2; i3] rest - | Ldot (Lident "Bigarray", "Genarray"), - {pexp_desc = Pexp_array indexes; pexp_attributes = []} :: rest -> - print ".{" "}" (simple_expr ctxt) indexes rest - | _ -> false - end - | (Lident s | Ldot(_,s)) , a :: i :: rest - when first_is '.' s -> - (* extract operator: - assignment operators end with [right_bracket ^ "<-"], - access operators end with [right_bracket] directly - *) - let assign = last_is '-' s in - let kind = - (* extract the right end bracket *) - let n = String.length s in - if assign then s.[n - 3] else s.[n - 1] in - let left, right = match kind with - | ')' -> '(', ")" - | ']' -> '[', "]" - | '}' -> '{', "}" - | _ -> assert false in - let path_prefix = match id with - | Ldot(m,_) -> Some m - | _ -> None in - let left = String.sub s 0 (1+String.index s left) in - print_indexop a path_prefix assign left right - (expression ctxt) [i] rest - | _ -> false - end - | _ -> false - -and expression ctxt f x = - if x.pexp_attributes <> [] then - pp f "((%a)@,%a)" (expression ctxt) {x with pexp_attributes=[]} - (attributes ctxt) x.pexp_attributes - else match x.pexp_desc with - | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _ - when ctxt.pipe || ctxt.semi -> - paren true (expression reset_ctxt) f x - | Pexp_ifthenelse _ | Pexp_sequence _ when ctxt.ifthenelse -> - paren true (expression reset_ctxt) f x - | Pexp_let _ | Pexp_letmodule _ | Pexp_open _ - | Pexp_letexception _ | Pexp_letop _ - when ctxt.semi -> - paren true (expression reset_ctxt) f x - | Pexp_fun (l, e0, p, e) -> - pp f "@[<2>fun@;%a->@;%a@]" - (label_exp ctxt) (l, e0, p) - (expression ctxt) e - | Pexp_function l -> - pp f "@[function%a@]" (case_list ctxt) l - | Pexp_match (e, l) -> - pp f "@[@[@[<2>match %a@]@ with@]%a@]" - (expression reset_ctxt) e (case_list ctxt) l - - | Pexp_try (e, l) -> - pp f "@[<0>@[try@ %a@]@ @[<0>with%a@]@]" - (* "try@;@[<2>%a@]@\nwith@\n%a"*) - (expression reset_ctxt) e (case_list ctxt) l - | Pexp_let (rf, l, e) -> - (* pp f "@[<2>let %a%a in@;<1 -2>%a@]" - (*no indentation here, a new line*) *) - (* rec_flag rf *) - pp f "@[<2>%a in@;<1 -2>%a@]" - (bindings reset_ctxt) (rf,l) - (expression ctxt) e - | Pexp_apply (e, l) -> - begin if not (sugar_expr ctxt f x) then - match view_fixity_of_exp e with - | `Infix s -> - begin match l with - | [ (Nolabel, _) as arg1; (Nolabel, _) as arg2 ] -> - (* FIXME associativity label_x_expression_param *) - pp f "@[<2>%a@;%s@;%a@]" - (label_x_expression_param reset_ctxt) arg1 s - (label_x_expression_param ctxt) arg2 - | _ -> - pp f "@[<2>%a %a@]" - (simple_expr ctxt) e - (list (label_x_expression_param ctxt)) l - end - | `Prefix s -> - let s = - if List.mem s ["~+";"~-";"~+.";"~-."] && - (match l with - (* See #7200: avoid turning (~- 1) into (- 1) which is - parsed as an int literal *) - |[(_,{pexp_desc=Pexp_constant _})] -> false - | _ -> true) - then String.sub s 1 (String.length s -1) - else s in - begin match l with - | [(Nolabel, x)] -> - pp f "@[<2>%s@;%a@]" s (simple_expr ctxt) x - | _ -> - pp f "@[<2>%a %a@]" (simple_expr ctxt) e - (list (label_x_expression_param ctxt)) l - end - | _ -> - pp f "@[%a@]" begin fun f (e,l) -> - pp f "%a@ %a" (expression2 ctxt) e - (list (label_x_expression_param reset_ctxt)) l - (* reset here only because [function,match,try,sequence] - are lower priority *) - end (e,l) - end - - | Pexp_construct (li, Some eo) - when not (is_simple_construct (view_expr x))-> (* Not efficient FIXME*) - (match view_expr x with - | `cons ls -> list (simple_expr ctxt) f ls ~sep:"@;::@;" - | `normal -> - pp f "@[<2>%a@;%a@]" longident_loc li - (simple_expr ctxt) eo - | _ -> assert false) - | Pexp_setfield (e1, li, e2) -> - pp f "@[<2>%a.%a@ <-@ %a@]" - (simple_expr ctxt) e1 longident_loc li (simple_expr ctxt) e2 - | Pexp_ifthenelse (e1, e2, eo) -> - (* @;@[<2>else@ %a@]@] *) - let fmt:(_,_,_)format ="@[@[<2>if@ %a@]@;@[<2>then@ %a@]%a@]" in - let expression_under_ifthenelse = expression (under_ifthenelse ctxt) in - pp f fmt expression_under_ifthenelse e1 expression_under_ifthenelse e2 - (fun f eo -> match eo with - | Some x -> - pp f "@;@[<2>else@;%a@]" (expression (under_semi ctxt)) x - | None -> () (* pp f "()" *)) eo - | Pexp_sequence _ -> - let rec sequence_helper acc = function - | {pexp_desc=Pexp_sequence(e1,e2); pexp_attributes = []} -> - sequence_helper (e1::acc) e2 - | v -> List.rev (v::acc) in - let lst = sequence_helper [] x in - pp f "@[%a@]" - (list (expression (under_semi ctxt)) ~sep:";@;") lst - | Pexp_new (li) -> - pp f "@[new@ %a@]" longident_loc li; - | Pexp_setinstvar (s, e) -> - pp f "@[%s@ <-@ %a@]" s.txt (expression ctxt) e - | Pexp_override l -> (* FIXME *) - let string_x_expression f (s, e) = - pp f "@[%s@ =@ %a@]" s.txt (expression ctxt) e in - pp f "@[{<%a>}@]" - (list string_x_expression ~sep:";" ) l; - | Pexp_letmodule (s, me, e) -> - pp f "@[let@ module@ %s@ =@ %a@ in@ %a@]" - (match s.txt with None -> "_" | Some s -> s) - (module_expr reset_ctxt) me (expression ctxt) e - | Pexp_letexception (cd, e) -> - pp f "@[let@ exception@ %a@ in@ %a@]" - (extension_constructor ctxt) cd - (expression ctxt) e - | Pexp_assert e -> - pp f "@[assert@ %a@]" (simple_expr ctxt) e - | Pexp_lazy (e) -> - pp f "@[lazy@ %a@]" (simple_expr ctxt) e - (* Pexp_poly: impossible but we should print it anyway, rather than - assert false *) - | Pexp_poly (e, None) -> - pp f "@[!poly!@ %a@]" (simple_expr ctxt) e - | Pexp_poly (e, Some ct) -> - pp f "@[(!poly!@ %a@ : %a)@]" - (simple_expr ctxt) e (core_type ctxt) ct - | Pexp_open (o, e) -> - pp f "@[<2>let open%s %a in@;%a@]" - (override o.popen_override) (module_expr ctxt) o.popen_expr - (expression ctxt) e - | Pexp_variant (l,Some eo) -> - pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) eo - | Pexp_letop {let_; ands; body} -> - pp f "@[<2>@[%a@,%a@] in@;<1 -2>%a@]" - (binding_op ctxt) let_ - (list ~sep:"@," (binding_op ctxt)) ands - (expression ctxt) body - | Pexp_extension e -> extension ctxt f e - | Pexp_unreachable -> pp f "." - | _ -> expression1 ctxt f x - -and expression1 ctxt f x = - if x.pexp_attributes <> [] then expression ctxt f x - else match x.pexp_desc with - | Pexp_object cs -> pp f "%a" (class_structure ctxt) cs - | _ -> expression2 ctxt f x -(* used in [Pexp_apply] *) - -and expression2 ctxt f x = - if x.pexp_attributes <> [] then expression ctxt f x - else match x.pexp_desc with - | Pexp_field (e, li) -> - pp f "@[%a.%a@]" (simple_expr ctxt) e longident_loc li - | Pexp_send (e, s) -> pp f "@[%a#%s@]" (simple_expr ctxt) e s.txt - - | _ -> simple_expr ctxt f x - -and simple_expr ctxt f x = - if x.pexp_attributes <> [] then expression ctxt f x - else match x.pexp_desc with - | Pexp_construct _ when is_simple_construct (view_expr x) -> - (match view_expr x with - | `nil -> pp f "[]" - | `tuple -> pp f "()" - | `list xs -> - pp f "@[[%a]@]" - (list (expression (under_semi ctxt)) ~sep:";@;") xs - | `simple x -> longident f x - | _ -> assert false) - | Pexp_ident li -> - longident_loc f li - (* (match view_fixity_of_exp x with *) - (* |`Normal -> longident_loc f li *) - (* | `Prefix _ | `Infix _ -> pp f "( %a )" longident_loc li) *) - | Pexp_constant c -> constant f c; - | Pexp_pack me -> - pp f "(module@;%a)" (module_expr ctxt) me - | Pexp_newtype (lid, e) -> - pp f "fun@;(type@;%s)@;->@;%a" lid.txt (expression ctxt) e - | Pexp_tuple l -> - pp f "@[(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l - | Pexp_constraint (e, ct) -> - pp f "(%a : %a)" (expression ctxt) e (core_type ctxt) ct - | Pexp_coerce (e, cto1, ct) -> - pp f "(%a%a :> %a)" (expression ctxt) e - (option (core_type ctxt) ~first:" : " ~last:" ") cto1 (* no sep hint*) - (core_type ctxt) ct - | Pexp_variant (l, None) -> pp f "`%s" l - | Pexp_record (l, eo) -> - let longident_x_expression f ( li, e) = - match e with - | {pexp_desc=Pexp_ident {txt;_}; - pexp_attributes=[]; _} when li.txt = txt -> - pp f "@[%a@]" longident_loc li - | _ -> - pp f "@[%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e - in - pp f "@[@[{@;%a%a@]@;}@]"(* "@[{%a%a}@]" *) - (option ~last:" with@;" (simple_expr ctxt)) eo - (list longident_x_expression ~sep:";@;") l - | Pexp_array (l) -> - pp f "@[<0>@[<2>[|%a|]@]@]" - (list (simple_expr (under_semi ctxt)) ~sep:";") l - | Pexp_while (e1, e2) -> - let fmt : (_,_,_) format = "@[<2>while@;%a@;do@;%a@;done@]" in - pp f fmt (expression ctxt) e1 (expression ctxt) e2 - | Pexp_for (s, e1, e2, df, e3) -> - let fmt:(_,_,_)format = - "@[@[@[<2>for %a =@;%a@;%a%a@;do@]@;%a@]@;done@]" in - let expression = expression ctxt in - pp f fmt (pattern ctxt) s expression e1 direction_flag - df expression e2 expression e3 - | _ -> paren true (expression ctxt) f x - -and attributes ctxt f l = - List.iter (attribute ctxt f) l - -and item_attributes ctxt f l = - List.iter (item_attribute ctxt f) l - -and attribute ctxt f a = - pp f "@[<2>[@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload - -and item_attribute ctxt f a = - pp f "@[<2>[@@@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload - -and floating_attribute ctxt f a = - pp f "@[<2>[@@@@@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload - -and value_description ctxt f x = - (* note: value_description has an attribute field, - but they're already printed by the callers this method *) - pp f "@[%a%a@]" (core_type ctxt) x.pval_type - (fun f x -> - if x.pval_prim <> [] - then pp f "@ =@ %a" (list constant_string) x.pval_prim - ) x - -and extension ctxt f (s, e) = - pp f "@[<2>[%%%s@ %a]@]" s.txt (payload ctxt) e - -and item_extension ctxt f (s, e) = - pp f "@[<2>[%%%%%s@ %a]@]" s.txt (payload ctxt) e - -and exception_declaration ctxt f x = - pp f "@[exception@ %a@]%a" - (extension_constructor ctxt) x.ptyexn_constructor - (item_attributes ctxt) x.ptyexn_attributes - -and class_type_field ctxt f x = - match x.pctf_desc with - | Pctf_inherit (ct) -> - pp f "@[<2>inherit@ %a@]%a" (class_type ctxt) ct - (item_attributes ctxt) x.pctf_attributes - | Pctf_val (s, mf, vf, ct) -> - pp f "@[<2>val @ %a%a%s@ :@ %a@]%a" - mutable_flag mf virtual_flag vf s.txt (core_type ctxt) ct - (item_attributes ctxt) x.pctf_attributes - | Pctf_method (s, pf, vf, ct) -> - pp f "@[<2>method %a %a%s :@;%a@]%a" - private_flag pf virtual_flag vf s.txt (core_type ctxt) ct - (item_attributes ctxt) x.pctf_attributes - | Pctf_constraint (ct1, ct2) -> - pp f "@[<2>constraint@ %a@ =@ %a@]%a" - (core_type ctxt) ct1 (core_type ctxt) ct2 - (item_attributes ctxt) x.pctf_attributes - | Pctf_attribute a -> floating_attribute ctxt f a - | Pctf_extension e -> - item_extension ctxt f e; - item_attributes ctxt f x.pctf_attributes - -and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l ;_} = - pp f "@[@[object@[<1>%a@]@ %a@]@ end@]" - (fun f -> function - {ptyp_desc=Ptyp_any; ptyp_attributes=[]; _} -> () - | ct -> pp f " (%a)" (core_type ctxt) ct) ct - (list (class_type_field ctxt) ~sep:"@;") l - -(* call [class_signature] called by [class_signature] *) -and class_type ctxt f x = - match x.pcty_desc with - | Pcty_signature cs -> - class_signature ctxt f cs; - attributes ctxt f x.pcty_attributes - | Pcty_constr (li, l) -> - pp f "%a%a%a" - (fun f l -> match l with - | [] -> () - | _ -> pp f "[%a]@ " (list (core_type ctxt) ~sep:"," ) l) l - longident_loc li - (attributes ctxt) x.pcty_attributes - | Pcty_arrow (l, co, cl) -> - pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) - (type_with_label ctxt) (l,co) - (class_type ctxt) cl - | Pcty_extension e -> - extension ctxt f e; - attributes ctxt f x.pcty_attributes - | Pcty_open (o, e) -> - pp f "@[<2>let open%s %a in@;%a@]" - (override o.popen_override) longident_loc o.popen_expr - (class_type ctxt) e - -(* [class type a = object end] *) -and class_type_declaration_list ctxt f l = - let class_type_declaration kwd f x = - let { pci_params=ls; pci_name={ txt; _ }; _ } = x in - pp f "@[<2>%s %a%a%s@ =@ %a@]%a" kwd - virtual_flag x.pci_virt - (class_params_def ctxt) ls txt - (class_type ctxt) x.pci_expr - (item_attributes ctxt) x.pci_attributes - in - match l with - | [] -> () - | [x] -> class_type_declaration "class type" f x - | x :: xs -> - pp f "@[%a@,%a@]" - (class_type_declaration "class type") x - (list ~sep:"@," (class_type_declaration "and")) xs - -and class_field ctxt f x = - match x.pcf_desc with - | Pcf_inherit (ovf, ce, so) -> - pp f "@[<2>inherit@ %s@ %a%a@]%a" (override ovf) - (class_expr ctxt) ce - (fun f so -> match so with - | None -> (); - | Some (s) -> pp f "@ as %s" s.txt ) so - (item_attributes ctxt) x.pcf_attributes - | Pcf_val (s, mf, Cfk_concrete (ovf, e)) -> - pp f "@[<2>val%s %a%s =@;%a@]%a" (override ovf) - mutable_flag mf s.txt - (expression ctxt) e - (item_attributes ctxt) x.pcf_attributes - | Pcf_method (s, pf, Cfk_virtual ct) -> - pp f "@[<2>method virtual %a %s :@;%a@]%a" - private_flag pf s.txt - (core_type ctxt) ct - (item_attributes ctxt) x.pcf_attributes - | Pcf_val (s, mf, Cfk_virtual ct) -> - pp f "@[<2>val virtual %a%s :@ %a@]%a" - mutable_flag mf s.txt - (core_type ctxt) ct - (item_attributes ctxt) x.pcf_attributes - | Pcf_method (s, pf, Cfk_concrete (ovf, e)) -> - let bind e = - binding ctxt f - {pvb_pat= - {ppat_desc=Ppat_var s; - ppat_loc=Location.none; - ppat_loc_stack=[]; - ppat_attributes=[]}; - pvb_expr=e; - pvb_attributes=[]; - pvb_loc=Location.none; - } - in - pp f "@[<2>method%s %a%a@]%a" - (override ovf) - private_flag pf - (fun f -> function - | {pexp_desc=Pexp_poly (e, Some ct); pexp_attributes=[]; _} -> - pp f "%s :@;%a=@;%a" - s.txt (core_type ctxt) ct (expression ctxt) e - | {pexp_desc=Pexp_poly (e, None); pexp_attributes=[]; _} -> - bind e - | _ -> bind e) e - (item_attributes ctxt) x.pcf_attributes - | Pcf_constraint (ct1, ct2) -> - pp f "@[<2>constraint %a =@;%a@]%a" - (core_type ctxt) ct1 - (core_type ctxt) ct2 - (item_attributes ctxt) x.pcf_attributes - | Pcf_initializer (e) -> - pp f "@[<2>initializer@ %a@]%a" - (expression ctxt) e - (item_attributes ctxt) x.pcf_attributes - | Pcf_attribute a -> floating_attribute ctxt f a - | Pcf_extension e -> - item_extension ctxt f e; - item_attributes ctxt f x.pcf_attributes - -and class_structure ctxt f { pcstr_self = p; pcstr_fields = l } = - pp f "@[@[object%a@;%a@]@;end@]" - (fun f p -> match p.ppat_desc with - | Ppat_any -> () - | Ppat_constraint _ -> pp f " %a" (pattern ctxt) p - | _ -> pp f " (%a)" (pattern ctxt) p) p - (list (class_field ctxt)) l - -and class_expr ctxt f x = - if x.pcl_attributes <> [] then begin - pp f "((%a)%a)" (class_expr ctxt) {x with pcl_attributes=[]} - (attributes ctxt) x.pcl_attributes - end else - match x.pcl_desc with - | Pcl_structure (cs) -> class_structure ctxt f cs - | Pcl_fun (l, eo, p, e) -> - pp f "fun@ %a@ ->@ %a" - (label_exp ctxt) (l,eo,p) - (class_expr ctxt) e - | Pcl_let (rf, l, ce) -> - pp f "%a@ in@ %a" - (bindings ctxt) (rf,l) - (class_expr ctxt) ce - | Pcl_apply (ce, l) -> - pp f "((%a)@ %a)" (* Cf: #7200 *) - (class_expr ctxt) ce - (list (label_x_expression_param ctxt)) l - | Pcl_constr (li, l) -> - pp f "%a%a" - (fun f l-> if l <>[] then - pp f "[%a]@ " - (list (core_type ctxt) ~sep:",") l) l - longident_loc li - | Pcl_constraint (ce, ct) -> - pp f "(%a@ :@ %a)" - (class_expr ctxt) ce - (class_type ctxt) ct - | Pcl_extension e -> extension ctxt f e - | Pcl_open (o, e) -> - pp f "@[<2>let open%s %a in@;%a@]" - (override o.popen_override) longident_loc o.popen_expr - (class_expr ctxt) e - -and module_type ctxt f x = - if x.pmty_attributes <> [] then begin - pp f "((%a)%a)" (module_type ctxt) {x with pmty_attributes=[]} - (attributes ctxt) x.pmty_attributes - end else - match x.pmty_desc with - | Pmty_functor (Unit, mt2) -> - pp f "@[functor () ->@ %a@]" (module_type ctxt) mt2 - | Pmty_functor (Named (s, mt1), mt2) -> - begin match s.txt with - | None -> - pp f "@[%a@ ->@ %a@]" - (module_type1 ctxt) mt1 (module_type ctxt) mt2 - | Some name -> - pp f "@[functor@ (%s@ :@ %a)@ ->@ %a@]" name - (module_type ctxt) mt1 (module_type ctxt) mt2 - end - | Pmty_with (mt, []) -> module_type ctxt f mt - | Pmty_with (mt, l) -> - let with_constraint f = function - | Pwith_type (li, ({ptype_params= ls ;_} as td)) -> - let ls = List.map fst ls in - pp f "type@ %a %a =@ %a" - (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") - ls longident_loc li (type_declaration ctxt) td - | Pwith_module (li, li2) -> - pp f "module %a =@ %a" longident_loc li longident_loc li2; - | Pwith_typesubst (li, ({ptype_params=ls;_} as td)) -> - let ls = List.map fst ls in - pp f "type@ %a %a :=@ %a" - (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") - ls longident_loc li - (type_declaration ctxt) td - | Pwith_modsubst (li, li2) -> - pp f "module %a :=@ %a" longident_loc li longident_loc li2 in - pp f "@[%a@ with@ %a@]" - (module_type1 ctxt) mt (list with_constraint ~sep:"@ and@ ") l - | _ -> module_type1 ctxt f x - -and module_type1 ctxt f x = - if x.pmty_attributes <> [] then module_type ctxt f x - else match x.pmty_desc with - | Pmty_ident li -> - pp f "%a" longident_loc li; - | Pmty_alias li -> - pp f "(module %a)" longident_loc li; - | Pmty_signature (s) -> - pp f "@[@[sig@ %a@]@ end@]" (* "@[sig@ %a@ end@]" *) - (list (signature_item ctxt)) s (* FIXME wrong indentation*) - | Pmty_typeof me -> - pp f "@[module@ type@ of@ %a@]" (module_expr ctxt) me - | Pmty_extension e -> extension ctxt f e - | _ -> paren true (module_type ctxt) f x - -and signature ctxt f x = list ~sep:"@\n" (signature_item ctxt) f x - -and signature_item ctxt f x : unit = - match x.psig_desc with - | Psig_type (rf, l) -> - type_def_list ctxt f (rf, true, l) - | Psig_typesubst l -> - type_def_list ctxt f (Nonrecursive, false, l) - | Psig_value vd -> - let intro = if vd.pval_prim = [] then "val" else "external" in - pp f "@[<2>%s@ %a@ :@ %a@]%a" intro - protect_ident vd.pval_name.txt - (value_description ctxt) vd - (item_attributes ctxt) vd.pval_attributes - | Psig_typext te -> - type_extension ctxt f te - | Psig_exception ed -> - exception_declaration ctxt f ed - | Psig_class l -> - let class_description kwd f ({pci_params=ls;pci_name={txt;_};_} as x) = - pp f "@[<2>%s %a%a%s@;:@;%a@]%a" kwd - virtual_flag x.pci_virt - (class_params_def ctxt) ls txt - (class_type ctxt) x.pci_expr - (item_attributes ctxt) x.pci_attributes - in begin - match l with - | [] -> () - | [x] -> class_description "class" f x - | x :: xs -> - pp f "@[%a@,%a@]" - (class_description "class") x - (list ~sep:"@," (class_description "and")) xs - end - | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias; - pmty_attributes=[]; _};_} as pmd) -> - pp f "@[module@ %s@ =@ %a@]%a" - (match pmd.pmd_name.txt with None -> "_" | Some s -> s) - longident_loc alias - (item_attributes ctxt) pmd.pmd_attributes - | Psig_module pmd -> - pp f "@[module@ %s@ :@ %a@]%a" - (match pmd.pmd_name.txt with None -> "_" | Some s -> s) - (module_type ctxt) pmd.pmd_type - (item_attributes ctxt) pmd.pmd_attributes - | Psig_modsubst pms -> - pp f "@[module@ %s@ :=@ %a@]%a" pms.pms_name.txt - longident_loc pms.pms_manifest - (item_attributes ctxt) pms.pms_attributes - | Psig_open od -> - pp f "@[open%s@ %a@]%a" - (override od.popen_override) - longident_loc od.popen_expr - (item_attributes ctxt) od.popen_attributes - | Psig_include incl -> - pp f "@[include@ %a@]%a" - (module_type ctxt) incl.pincl_mod - (item_attributes ctxt) incl.pincl_attributes - | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> - pp f "@[module@ type@ %s%a@]%a" - s.txt - (fun f md -> match md with - | None -> () - | Some mt -> - pp_print_space f () ; - pp f "@ =@ %a" (module_type ctxt) mt - ) md - (item_attributes ctxt) attrs - | Psig_class_type (l) -> class_type_declaration_list ctxt f l - | Psig_recmodule decls -> - let rec string_x_module_type_list f ?(first=true) l = - match l with - | [] -> () ; - | pmd :: tl -> - if not first then - pp f "@ @[and@ %s:@ %a@]%a" - (match pmd.pmd_name.txt with None -> "_" | Some s -> s) - (module_type1 ctxt) pmd.pmd_type - (item_attributes ctxt) pmd.pmd_attributes - else - pp f "@[module@ rec@ %s:@ %a@]%a" - (match pmd.pmd_name.txt with None -> "_" | Some s -> s) - (module_type1 ctxt) pmd.pmd_type - (item_attributes ctxt) pmd.pmd_attributes; - string_x_module_type_list f ~first:false tl - in - string_x_module_type_list f decls - | Psig_attribute a -> floating_attribute ctxt f a - | Psig_extension(e, a) -> - item_extension ctxt f e; - item_attributes ctxt f a - -and module_expr ctxt f x = - if x.pmod_attributes <> [] then - pp f "((%a)%a)" (module_expr ctxt) {x with pmod_attributes=[]} - (attributes ctxt) x.pmod_attributes - else match x.pmod_desc with - | Pmod_structure (s) -> - pp f "@[struct@;@[<0>%a@]@;<1 -2>end@]" - (list (structure_item ctxt) ~sep:"@\n") s; - | Pmod_constraint (me, mt) -> - pp f "@[(%a@ :@ %a)@]" - (module_expr ctxt) me - (module_type ctxt) mt - | Pmod_ident (li) -> - pp f "%a" longident_loc li; - | Pmod_functor (Unit, me) -> - pp f "functor ()@;->@;%a" (module_expr ctxt) me - | Pmod_functor (Named (s, mt), me) -> - pp f "functor@ (%s@ :@ %a)@;->@;%a" - (match s.txt with None -> "_" | Some s -> s) - (module_type ctxt) mt (module_expr ctxt) me - | Pmod_apply (me1, me2) -> - pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2 - (* Cf: #7200 *) - | Pmod_unpack e -> - pp f "(val@ %a)" (expression ctxt) e - | Pmod_extension e -> extension ctxt f e - -and structure ctxt f x = list ~sep:"@\n" (structure_item ctxt) f x - -and payload ctxt f = function - | PStr [{pstr_desc = Pstr_eval (e, attrs)}] -> - pp f "@[<2>%a@]%a" - (expression ctxt) e - (item_attributes ctxt) attrs - | PStr x -> structure ctxt f x - | PTyp x -> pp f ":"; core_type ctxt f x - | PSig x -> pp f ":"; signature ctxt f x - | PPat (x, None) -> pp f "?"; pattern ctxt f x - | PPat (x, Some e) -> - pp f "?"; pattern ctxt f x; - pp f " when "; expression ctxt f e - -(* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *) -and binding ctxt f {pvb_pat=p; pvb_expr=x; _} = - (* .pvb_attributes have already been printed by the caller, #bindings *) - let rec pp_print_pexp_function f x = - if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x - else match x.pexp_desc with - | Pexp_fun (label, eo, p, e) -> - if label=Nolabel then - pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function e - else - pp f "%a@ %a" - (label_exp ctxt) (label,eo,p) pp_print_pexp_function e - | Pexp_newtype (str,e) -> - pp f "(type@ %s)@ %a" str.txt pp_print_pexp_function e - | _ -> pp f "=@;%a" (expression ctxt) x - in - let tyvars_str tyvars = List.map (fun v -> v.txt) tyvars in - let is_desugared_gadt p e = - let gadt_pattern = - match p with - | {ppat_desc=Ppat_constraint({ppat_desc=Ppat_var _} as pat, - {ptyp_desc=Ptyp_poly (args_tyvars, rt)}); - ppat_attributes=[]}-> - Some (pat, args_tyvars, rt) - | _ -> None in - let rec gadt_exp tyvars e = - match e with - | {pexp_desc=Pexp_newtype (tyvar, e); pexp_attributes=[]} -> - gadt_exp (tyvar :: tyvars) e - | {pexp_desc=Pexp_constraint (e, ct); pexp_attributes=[]} -> - Some (List.rev tyvars, e, ct) - | _ -> None in - let gadt_exp = gadt_exp [] e in - match gadt_pattern, gadt_exp with - | Some (p, pt_tyvars, pt_ct), Some (e_tyvars, e, e_ct) - when tyvars_str pt_tyvars = tyvars_str e_tyvars -> - let ety = Typ.varify_constructors e_tyvars e_ct in - if ety = pt_ct then - Some (p, pt_tyvars, e_ct, e) else None - | _ -> None in - if x.pexp_attributes <> [] - then pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x else - match is_desugared_gadt p x with - | Some (p, [], ct, e) -> - pp f "%a@;: %a@;=@;%a" - (simple_pattern ctxt) p (core_type ctxt) ct (expression ctxt) e - | Some (p, tyvars, ct, e) -> begin - pp f "%a@;: type@;%a.@;%a@;=@;%a" - (simple_pattern ctxt) p (list pp_print_string ~sep:"@;") - (tyvars_str tyvars) (core_type ctxt) ct (expression ctxt) e - end - | None -> begin - match p with - | {ppat_desc=Ppat_constraint(p ,ty); - ppat_attributes=[]} -> (* special case for the first*) - begin match ty with - | {ptyp_desc=Ptyp_poly _; ptyp_attributes=[]} -> - pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p - (core_type ctxt) ty (expression ctxt) x - | _ -> - pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p - (core_type ctxt) ty (expression ctxt) x - end - | {ppat_desc=Ppat_var _; ppat_attributes=[]} -> - pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x - | _ -> - pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x - end - -(* [in] is not printed *) -and bindings ctxt f (rf,l) = - let binding kwd rf f x = - pp f "@[<2>%s %a%a@]%a" kwd rec_flag rf - (binding ctxt) x (item_attributes ctxt) x.pvb_attributes - in - match l with - | [] -> () - | [x] -> binding "let" rf f x - | x::xs -> - pp f "@[%a@,%a@]" - (binding "let" rf) x - (list ~sep:"@," (binding "and" Nonrecursive)) xs - -and binding_op ctxt f x = - pp f "@[<2>%s %a@;=@;%a@]" - x.pbop_op.txt (pattern ctxt) x.pbop_pat (expression ctxt) x.pbop_exp - -and structure_item ctxt f x = - match x.pstr_desc with - | Pstr_eval (e, attrs) -> - pp f "@[;;%a@]%a" - (expression ctxt) e - (item_attributes ctxt) attrs - | Pstr_type (_, []) -> assert false - | Pstr_type (rf, l) -> type_def_list ctxt f (rf, true, l) - | Pstr_value (rf, l) -> - (* pp f "@[let %a%a@]" rec_flag rf bindings l *) - pp f "@[<2>%a@]" (bindings ctxt) (rf,l) - | Pstr_typext te -> type_extension ctxt f te - | Pstr_exception ed -> exception_declaration ctxt f ed - | Pstr_module x -> - let rec module_helper = function - | {pmod_desc=Pmod_functor(arg_opt,me'); pmod_attributes = []} -> - begin match arg_opt with - | Unit -> pp f "()" - | Named (s, mt) -> - pp f "(%s:%a)" - (match s.txt with None -> "_" | Some s -> s) - (module_type ctxt) mt - end; - module_helper me' - | me -> me - in - pp f "@[module %s%a@]%a" - (match x.pmb_name.txt with None -> "_" | Some s -> s) - (fun f me -> - let me = module_helper me in - match me with - | {pmod_desc= - Pmod_constraint - (me', - ({pmty_desc=(Pmty_ident (_) - | Pmty_signature (_));_} as mt)); - pmod_attributes = []} -> - pp f " :@;%a@;=@;%a@;" - (module_type ctxt) mt (module_expr ctxt) me' - | _ -> pp f " =@ %a" (module_expr ctxt) me - ) x.pmb_expr - (item_attributes ctxt) x.pmb_attributes - | Pstr_open od -> - pp f "@[<2>open%s@;%a@]%a" - (override od.popen_override) - (module_expr ctxt) od.popen_expr - (item_attributes ctxt) od.popen_attributes - | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> - pp f "@[module@ type@ %s%a@]%a" - s.txt - (fun f md -> match md with - | None -> () - | Some mt -> - pp_print_space f () ; - pp f "@ =@ %a" (module_type ctxt) mt - ) md - (item_attributes ctxt) attrs - | Pstr_class l -> - let extract_class_args cl = - let rec loop acc = function - | {pcl_desc=Pcl_fun (l, eo, p, cl'); pcl_attributes = []} -> - loop ((l,eo,p) :: acc) cl' - | cl -> List.rev acc, cl - in - let args, cl = loop [] cl in - let constr, cl = - match cl with - | {pcl_desc=Pcl_constraint (cl', ct); pcl_attributes = []} -> - Some ct, cl' - | _ -> None, cl - in - args, constr, cl - in - let class_constraint f ct = pp f ": @[%a@] " (class_type ctxt) ct in - let class_declaration kwd f - ({pci_params=ls; pci_name={txt;_}; _} as x) = - let args, constr, cl = extract_class_args x.pci_expr in - pp f "@[<2>%s %a%a%s %a%a=@;%a@]%a" kwd - virtual_flag x.pci_virt - (class_params_def ctxt) ls txt - (list (label_exp ctxt)) args - (option class_constraint) constr - (class_expr ctxt) cl - (item_attributes ctxt) x.pci_attributes - in begin - match l with - | [] -> () - | [x] -> class_declaration "class" f x - | x :: xs -> - pp f "@[%a@,%a@]" - (class_declaration "class") x - (list ~sep:"@," (class_declaration "and")) xs - end - | Pstr_class_type l -> class_type_declaration_list ctxt f l - | Pstr_primitive vd -> - pp f "@[external@ %a@ :@ %a@]%a" - protect_ident vd.pval_name.txt - (value_description ctxt) vd - (item_attributes ctxt) vd.pval_attributes - | Pstr_include incl -> - pp f "@[include@ %a@]%a" - (module_expr ctxt) incl.pincl_mod - (item_attributes ctxt) incl.pincl_attributes - | Pstr_recmodule decls -> (* 3.07 *) - let aux f = function - | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) -> - pp f "@[@ and@ %s:%a@ =@ %a@]%a" - (match pmb.pmb_name.txt with None -> "_" | Some s -> s) - (module_type ctxt) typ - (module_expr ctxt) expr - (item_attributes ctxt) pmb.pmb_attributes - | pmb -> - pp f "@[@ and@ %s@ =@ %a@]%a" - (match pmb.pmb_name.txt with None -> "_" | Some s -> s) - (module_expr ctxt) pmb.pmb_expr - (item_attributes ctxt) pmb.pmb_attributes - in - begin match decls with - | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 -> - pp f "@[@[module@ rec@ %s:%a@ =@ %a@]%a@ %a@]" - (match pmb.pmb_name.txt with None -> "_" | Some s -> s) - (module_type ctxt) typ - (module_expr ctxt) expr - (item_attributes ctxt) pmb.pmb_attributes - (fun f l2 -> List.iter (aux f) l2) l2 - | pmb :: l2 -> - pp f "@[@[module@ rec@ %s@ =@ %a@]%a@ %a@]" - (match pmb.pmb_name.txt with None -> "_" | Some s -> s) - (module_expr ctxt) pmb.pmb_expr - (item_attributes ctxt) pmb.pmb_attributes - (fun f l2 -> List.iter (aux f) l2) l2 - | _ -> assert false - end - | Pstr_attribute a -> floating_attribute ctxt f a - | Pstr_extension(e, a) -> - item_extension ctxt f e; - item_attributes ctxt f a - -and type_param ctxt f (ct, a) = - pp f "%s%a" (type_variance a) (core_type ctxt) ct - -and type_params ctxt f = function - | [] -> () - | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",@;") l - -and type_def_list ctxt f (rf, exported, l) = - let type_decl kwd rf f x = - let eq = - if (x.ptype_kind = Ptype_abstract) - && (x.ptype_manifest = None) then "" - else if exported then " =" - else " :=" - in - pp f "@[<2>%s %a%a%s%s%a@]%a" kwd - nonrec_flag rf - (type_params ctxt) x.ptype_params - x.ptype_name.txt eq - (type_declaration ctxt) x - (item_attributes ctxt) x.ptype_attributes - in - match l with - | [] -> assert false - | [x] -> type_decl "type" rf f x - | x :: xs -> pp f "@[%a@,%a@]" - (type_decl "type" rf) x - (list ~sep:"@," (type_decl "and" Recursive)) xs - -and record_declaration ctxt f lbls = - let type_record_field f pld = - pp f "@[<2>%a%s:@;%a@;%a@]" - mutable_flag pld.pld_mutable - pld.pld_name.txt - (core_type ctxt) pld.pld_type - (attributes ctxt) pld.pld_attributes - in - pp f "{@\n%a}" - (list type_record_field ~sep:";@\n" ) lbls - -and type_declaration ctxt f x = - (* type_declaration has an attribute field, - but it's been printed by the caller of this method *) - let priv f = - match x.ptype_private with - | Public -> () - | Private -> pp f "@;private" - in - let manifest f = - match x.ptype_manifest with - | None -> () - | Some y -> - if x.ptype_kind = Ptype_abstract then - pp f "%t@;%a" priv (core_type ctxt) y - else - pp f "@;%a" (core_type ctxt) y - in - let constructor_declaration f pcd = - pp f "|@;"; - constructor_declaration ctxt f - (pcd.pcd_name.txt, pcd.pcd_args, pcd.pcd_res, pcd.pcd_attributes) - in - let repr f = - let intro f = - if x.ptype_manifest = None then () - else pp f "@;=" - in - match x.ptype_kind with - | Ptype_variant xs -> - let variants fmt xs = - if xs = [] then pp fmt " |" else - pp fmt "@\n%a" (list ~sep:"@\n" constructor_declaration) xs - in pp f "%t%t%a" intro priv variants xs - | Ptype_abstract -> () - | Ptype_record l -> - pp f "%t%t@;%a" intro priv (record_declaration ctxt) l - | Ptype_open -> pp f "%t%t@;.." intro priv - in - let constraints f = - List.iter - (fun (ct1,ct2,_) -> - pp f "@[@ constraint@ %a@ =@ %a@]" - (core_type ctxt) ct1 (core_type ctxt) ct2) - x.ptype_cstrs - in - pp f "%t%t%t" manifest repr constraints - -and type_extension ctxt f x = - let extension_constructor f x = - pp f "@\n|@;%a" (extension_constructor ctxt) x - in - pp f "@[<2>type %a%a += %a@ %a@]%a" - (fun f -> function - | [] -> () - | l -> - pp f "%a@;" (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l) - x.ptyext_params - longident_loc x.ptyext_path - private_flag x.ptyext_private (* Cf: #7200 *) - (list ~sep:"" extension_constructor) - x.ptyext_constructors - (item_attributes ctxt) x.ptyext_attributes - -and constructor_declaration ctxt f (name, args, res, attrs) = - let name = - match name with - | "::" -> "(::)" - | s -> s in - match res with - | None -> - pp f "%s%a@;%a" name - (fun f -> function - | Pcstr_tuple [] -> () - | Pcstr_tuple l -> - pp f "@;of@;%a" (list (core_type1 ctxt) ~sep:"@;*@;") l - | Pcstr_record l -> pp f "@;of@;%a" (record_declaration ctxt) l - ) args - (attributes ctxt) attrs - | Some r -> - pp f "%s:@;%a@;%a" name - (fun f -> function - | Pcstr_tuple [] -> core_type1 ctxt f r - | Pcstr_tuple l -> pp f "%a@;->@;%a" - (list (core_type1 ctxt) ~sep:"@;*@;") l - (core_type1 ctxt) r - | Pcstr_record l -> - pp f "%a@;->@;%a" (record_declaration ctxt) l (core_type1 ctxt) r - ) - args - (attributes ctxt) attrs - -and extension_constructor ctxt f x = - (* Cf: #7200 *) - match x.pext_kind with - | Pext_decl(l, r) -> - constructor_declaration ctxt f (x.pext_name.txt, l, r, x.pext_attributes) - | Pext_rebind li -> - pp f "%s%a@;=@;%a" x.pext_name.txt - (attributes ctxt) x.pext_attributes - longident_loc li - -and case_list ctxt f l : unit = - let aux f {pc_lhs; pc_guard; pc_rhs} = - pp f "@;| @[<2>%a%a@;->@;%a@]" - (pattern ctxt) pc_lhs (option (expression ctxt) ~first:"@;when@;") - pc_guard (expression (under_pipe ctxt)) pc_rhs - in - list aux f l ~sep:"" - -and label_x_expression_param ctxt f (l,e) = - let simple_name = match e with - | {pexp_desc=Pexp_ident {txt=Lident l;_}; - pexp_attributes=[]} -> Some l - | _ -> None - in match l with - | Nolabel -> expression2 ctxt f e (* level 2*) - | Optional str -> - if Some str = simple_name then - pp f "?%s" str - else - pp f "?%s:%a" str (simple_expr ctxt) e - | Labelled lbl -> - if Some lbl = simple_name then - pp f "~%s" lbl - else - pp f "~%s:%a" lbl (simple_expr ctxt) e - -and directive_argument f x = - match x.pdira_desc with - | Pdir_string (s) -> pp f "@ %S" s - | Pdir_int (n, None) -> pp f "@ %s" n - | Pdir_int (n, Some m) -> pp f "@ %s%c" n m - | Pdir_ident (li) -> pp f "@ %a" longident li - | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b) - -let toplevel_phrase f x = - match x with - | Ptop_def (s) ->pp f "@[%a@]" (list (structure_item reset_ctxt)) s - (* pp_open_hvbox f 0; *) - (* pp_print_list structure_item f s ; *) - (* pp_close_box f (); *) - | Ptop_dir {pdir_name; pdir_arg = None; _} -> - pp f "@[#%s@]" pdir_name.txt - | Ptop_dir {pdir_name; pdir_arg = Some pdir_arg; _} -> - pp f "@[#%s@ %a@]" pdir_name.txt directive_argument pdir_arg - -let expression f x = - pp f "@[%a@]" (expression reset_ctxt) x - -let string_of_expression x = - ignore (flush_str_formatter ()) ; - let f = str_formatter in - expression f x; - flush_str_formatter () - -let string_of_structure x = - ignore (flush_str_formatter ()); - let f = str_formatter in - structure reset_ctxt f x; - flush_str_formatter () - -let top_phrase f x = - pp_print_newline f (); - toplevel_phrase f x; - pp f ";;"; - pp_print_newline f () - -let core_type = core_type reset_ctxt -let pattern = pattern reset_ctxt -let signature = signature reset_ctxt -let structure = structure reset_ctxt -let class_expr = class_expr reset_ctxt -let class_field = class_field reset_ctxt -let class_type = class_type reset_ctxt -let class_signature = class_signature reset_ctxt -let class_type_field = class_type_field reset_ctxt -let module_expr = module_expr reset_ctxt -let module_type = module_type reset_ctxt -let signature_item = signature_item reset_ctxt -let structure_item = structure_item reset_ctxt diff -Nru ppxlib-0.15.0/ast/pprintast.mli ppxlib-0.24.0/ast/pprintast.mli --- ppxlib-0.15.0/ast/pprintast.mli 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/ast/pprintast.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,39 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Hongbo Zhang (University of Pennsylvania) *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Import - -type space_formatter = (unit, Format.formatter, unit) format - -val toplevel_phrase : Format.formatter -> Parsetree.toplevel_phrase -> unit -val expression : Format.formatter -> Parsetree.expression -> unit -val string_of_expression : Parsetree.expression -> string -val top_phrase: Format.formatter -> Parsetree.toplevel_phrase -> unit -val core_type: Format.formatter -> Parsetree.core_type -> unit -val pattern: Format.formatter -> Parsetree.pattern -> unit -val signature: Format.formatter -> Parsetree.signature -> unit -val structure: Format.formatter -> Parsetree.structure -> unit -val string_of_structure: Parsetree.structure -> string - -(* Added in the ppxlib copy *) -val class_expr : Format.formatter -> Parsetree.class_expr -> unit -val class_field : Format.formatter -> Parsetree.class_field -> unit -val class_type : Format.formatter -> Parsetree.class_type -> unit -val class_signature : Format.formatter -> Parsetree.class_signature -> unit -val class_type_field : Format.formatter -> Parsetree.class_type_field -> unit -val module_expr : Format.formatter -> Parsetree.module_expr -> unit -val module_type : Format.formatter -> Parsetree.module_type -> unit -val signature_item : Format.formatter -> Parsetree.signature_item -> unit -val structure_item : Format.formatter -> Parsetree.structure_item -> unit diff -Nru ppxlib-0.15.0/ast/ppxlib_ast.ml ppxlib-0.24.0/ast/ppxlib_ast.ml --- ppxlib-0.15.0/ast/ppxlib_ast.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/ast/ppxlib_ast.ml 2021-12-08 21:53:37.000000000 +0000 @@ -1,18 +1,19 @@ open Import -module Ast = Ast -module Ast_helper = Ast_helper -module Ast_magic = Selected_ast.Ast.Config -module Asttypes = Asttypes -module Docstrings = Docstrings -module Extra_warnings = Warn -module Lexer = Lexer -module Parse = Parse -module Parser = Parser -module Parsetree = Parsetree -module Pprintast = Pprintast -module Select_ast = Select_ast -module Selected_ast = Selected_ast -module Syntaxerr = Syntaxerr +module type OCaml_version = Versions.OCaml_version -module Import_for_core = Import +module Ast = Ast +module Ast_helper = Ast_helper +module Ast_magic = Selected_ast.Ast.Config +module Asttypes = Asttypes +module Compiler_version = Versions.OCaml_current +module Js = Js +module Find_version = Versions.Find_version +module Convert = Versions.Convert +module Extra_warnings = Warn +module Location_error = Location_error +module Parse = Parse +module Parsetree = Parsetree +module Pprintast = Astlib.Pprintast +module Select_ast = Select_ast +module Selected_ast = Selected_ast diff -Nru ppxlib-0.15.0/ast/stdlib0.ml ppxlib-0.24.0/ast/stdlib0.ml --- ppxlib-0.15.0/ast/stdlib0.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/ast/stdlib0.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,7 @@ +module Int = struct + let to_string = string_of_int +end + +module Option = struct + let map f o = match o with None -> None | Some v -> Some (f v) +end diff -Nru ppxlib-0.15.0/ast/supported_version/dune ppxlib-0.24.0/ast/supported_version/dune --- ppxlib-0.15.0/ast/supported_version/dune 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/ast/supported_version/dune 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,2 @@ +(library + (name supported_version)) diff -Nru ppxlib-0.15.0/ast/supported_version/supported_version.ml ppxlib-0.24.0/ast/supported_version/supported_version.ml --- ppxlib-0.15.0/ast/supported_version/supported_version.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/ast/supported_version/supported_version.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,26 @@ +type t = int * int + +let all = + [ + (4, 02); + (4, 03); + (4, 04); + (4, 05); + (4, 06); + (4, 07); + (4, 08); + (4, 09); + (4, 10); + (4, 11); + (4, 12); + (4, 13); + (4, 14); + ] + +let to_string (a, b) = Printf.sprintf "%d.%02d" a b + +let to_int (a, b) = (a * 100) + b + +let of_string s = + let t = Scanf.sscanf s "%u.%u" (fun a b -> (a, b)) in + if List.mem t all then Some t else None diff -Nru ppxlib-0.15.0/ast/supported_version/supported_version.mli ppxlib-0.24.0/ast/supported_version/supported_version.mli --- ppxlib-0.15.0/ast/supported_version/supported_version.mli 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/ast/supported_version/supported_version.mli 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,14 @@ +(** Supported versions of the OCaml AST *) + +type t + +val all : t list + +val to_string : t -> string +(** Return a string such as "4.02" *) + +val to_int : t -> int +(** Return an integer such as [402] *) + +val of_string : string -> t option +(** Parse a string as reported by [ocamlc -version] *) diff -Nru ppxlib-0.15.0/ast/versions.ml ppxlib-0.24.0/ast/versions.ml --- ppxlib-0.15.0/ast/versions.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/ast/versions.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,571 @@ +(**************************************************************************) +(* *) +(* OCaml Migrate Parsetree *) +(* *) +(* Frédéric Bour *) +(* Jérémie Dimino, Jane Street Europe *) +(* *) +(* Copyright 2017 Institut National de Recherche en Informatique et *) +(* en Automatique (INRIA). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* BEGIN of BLACK MAGIC *) +(*$ open Ast_cinaps_helpers $*) + +type _ witnesses = .. + +type _ migration = .. +type _ migration += Undefined : _ migration + +type 'a migration_info = { + mutable next_version : 'a migration; + mutable previous_version : 'a migration; +} + +(** Abstract view of a version of an OCaml Ast *) +module type Ast = sig + (*$ foreach_module (fun m types -> + printf " module %s : sig\n" m; + List.iter types ~f:(printf " type %s\n"); + printf " end\n" + ) + *) + module Parsetree : sig + type structure + type signature + type toplevel_phrase + type core_type + type expression + type pattern + type case + type type_declaration + type type_extension + type extension_constructor + end +(*$*) + module Config : sig + val ast_impl_magic_number : string + val ast_intf_magic_number : string + end +end + +(* Shortcuts for talking about ast types outside of the module language *) + +type 'a _types = 'a constraint 'a + = < + (*$ foreach_type (fun _ s -> printf " %-21s : _;\n" s) *) + structure : _; + signature : _; + toplevel_phrase : _; + core_type : _; + expression : _; + pattern : _; + case : _; + type_declaration : _; + type_extension : _; + extension_constructor : _; +(*$*) + > +;; + +(*$ foreach_type (fun _ s -> + printf "type 'a get_%s =\n" s; + printf " 'x constraint 'a _types = < %s : 'x; .. >\n" s + ) *) +type 'a get_structure = + 'x constraint 'a _types = < structure : 'x; .. > +type 'a get_signature = + 'x constraint 'a _types = < signature : 'x; .. > +type 'a get_toplevel_phrase = + 'x constraint 'a _types = < toplevel_phrase : 'x; .. > +type 'a get_core_type = + 'x constraint 'a _types = < core_type : 'x; .. > +type 'a get_expression = + 'x constraint 'a _types = < expression : 'x; .. > +type 'a get_pattern = + 'x constraint 'a _types = < pattern : 'x; .. > +type 'a get_case = + 'x constraint 'a _types = < case : 'x; .. > +type 'a get_type_declaration = + 'x constraint 'a _types = < type_declaration : 'x; .. > +type 'a get_type_extension = + 'x constraint 'a _types = < type_extension : 'x; .. > +type 'a get_extension_constructor = + 'x constraint 'a _types = < extension_constructor : 'x; .. > +(*$*) + +module type OCaml_version = sig + module Ast : Ast + val version : int + val string_version : string + type types = < + (*$ foreach_type (fun m s -> printf " %-21s : Ast.%s.%s;\n" s m s)*) + structure : Ast.Parsetree.structure; + signature : Ast.Parsetree.signature; + toplevel_phrase : Ast.Parsetree.toplevel_phrase; + core_type : Ast.Parsetree.core_type; + expression : Ast.Parsetree.expression; + pattern : Ast.Parsetree.pattern; + case : Ast.Parsetree.case; + type_declaration : Ast.Parsetree.type_declaration; + type_extension : Ast.Parsetree.type_extension; + extension_constructor : Ast.Parsetree.extension_constructor; +(*$*) + > _types + type _ witnesses += Version : types witnesses + val migration_info : types migration_info +end + +module Make_witness(Ast : Ast) = +struct + type types = < + (*$ foreach_type (fun m s -> printf " %-21s : Ast.%s.%s;\n" s m s)*) + structure : Ast.Parsetree.structure; + signature : Ast.Parsetree.signature; + toplevel_phrase : Ast.Parsetree.toplevel_phrase; + core_type : Ast.Parsetree.core_type; + expression : Ast.Parsetree.expression; + pattern : Ast.Parsetree.pattern; + case : Ast.Parsetree.case; + type_declaration : Ast.Parsetree.type_declaration; + type_extension : Ast.Parsetree.type_extension; + extension_constructor : Ast.Parsetree.extension_constructor; +(*$*) + > _types + type _ witnesses += Version : types witnesses + let migration_info : types migration_info = + { next_version = Undefined; previous_version = Undefined } +end + +type 'types ocaml_version = + (module OCaml_version + (*$ let sep = with_then_and () in + foreach_type (fun m s -> + printf " %t type Ast.%s.%s = 'types get_%s\n" sep m s s) *) + with type Ast.Parsetree.structure = 'types get_structure + and type Ast.Parsetree.signature = 'types get_signature + and type Ast.Parsetree.toplevel_phrase = 'types get_toplevel_phrase + and type Ast.Parsetree.core_type = 'types get_core_type + and type Ast.Parsetree.expression = 'types get_expression + and type Ast.Parsetree.pattern = 'types get_pattern + and type Ast.Parsetree.case = 'types get_case + and type Ast.Parsetree.type_declaration = 'types get_type_declaration + and type Ast.Parsetree.type_extension = 'types get_type_extension + and type Ast.Parsetree.extension_constructor = 'types get_extension_constructor +(*$*) + ) + +type ('from, 'to_) migration_functions = { + (*$ foreach_type (fun _ s -> + printf " copy_%s: 'from get_%s -> 'to_ get_%s;\n" s s s) *) + copy_structure: 'from get_structure -> 'to_ get_structure; + copy_signature: 'from get_signature -> 'to_ get_signature; + copy_toplevel_phrase: 'from get_toplevel_phrase -> 'to_ get_toplevel_phrase; + copy_core_type: 'from get_core_type -> 'to_ get_core_type; + copy_expression: 'from get_expression -> 'to_ get_expression; + copy_pattern: 'from get_pattern -> 'to_ get_pattern; + copy_case: 'from get_case -> 'to_ get_case; + copy_type_declaration: 'from get_type_declaration -> 'to_ get_type_declaration; + copy_type_extension: 'from get_type_extension -> 'to_ get_type_extension; + copy_extension_constructor: 'from get_extension_constructor -> 'to_ get_extension_constructor; +(*$*) +} + +let id x = x +let migration_identity : ('a, 'a) migration_functions = { + (*$ foreach_type (fun _ s -> printf " copy_%s = id;\n" s) *) + copy_structure = id; + copy_signature = id; + copy_toplevel_phrase = id; + copy_core_type = id; + copy_expression = id; + copy_pattern = id; + copy_case = id; + copy_type_declaration = id; + copy_type_extension = id; + copy_extension_constructor = id; +(*$*) +} + +let compose f g x = f (g x) +let migration_compose (ab : ('a, 'b) migration_functions) (bc : ('b, 'c) migration_functions) : ('a, 'c) migration_functions = { + (*$ foreach_type (fun _ s -> + printf " copy_%-21s = compose bc.copy_%-21s ab.copy_%s;\n" s s s) *) + copy_structure = compose bc.copy_structure ab.copy_structure; + copy_signature = compose bc.copy_signature ab.copy_signature; + copy_toplevel_phrase = compose bc.copy_toplevel_phrase ab.copy_toplevel_phrase; + copy_core_type = compose bc.copy_core_type ab.copy_core_type; + copy_expression = compose bc.copy_expression ab.copy_expression; + copy_pattern = compose bc.copy_pattern ab.copy_pattern; + copy_case = compose bc.copy_case ab.copy_case; + copy_type_declaration = compose bc.copy_type_declaration ab.copy_type_declaration; + copy_type_extension = compose bc.copy_type_extension ab.copy_type_extension; + copy_extension_constructor = compose bc.copy_extension_constructor ab.copy_extension_constructor; +(*$*) +} + +type _ migration += Migration : 'from ocaml_version * ('from, 'to_) migration_functions * 'to_ ocaml_version -> 'from migration + +module type Migrate_module = sig + module From : Ast + module To : Ast + (*$ foreach_type (fun m s -> + printf " val copy_%-21s: From.%s.%s -> To.%s.%s\n" s m s m s) *) + val copy_structure : From.Parsetree.structure -> To.Parsetree.structure + val copy_signature : From.Parsetree.signature -> To.Parsetree.signature + val copy_toplevel_phrase : From.Parsetree.toplevel_phrase -> To.Parsetree.toplevel_phrase + val copy_core_type : From.Parsetree.core_type -> To.Parsetree.core_type + val copy_expression : From.Parsetree.expression -> To.Parsetree.expression + val copy_pattern : From.Parsetree.pattern -> To.Parsetree.pattern + val copy_case : From.Parsetree.case -> To.Parsetree.case + val copy_type_declaration : From.Parsetree.type_declaration -> To.Parsetree.type_declaration + val copy_type_extension : From.Parsetree.type_extension -> To.Parsetree.type_extension + val copy_extension_constructor: From.Parsetree.extension_constructor -> To.Parsetree.extension_constructor +(*$*) +end + +module Migration_functions + (A : OCaml_version) (B : OCaml_version) + (A_to_B : Migrate_module with module From = A.Ast and module To = B.Ast) += +struct + let migration_functions : (A.types, B.types) migration_functions = + let open A_to_B in + { + (*$ foreach_type (fun _ s -> printf " copy_%s;\n" s) *) + copy_structure; + copy_signature; + copy_toplevel_phrase; + copy_core_type; + copy_expression; + copy_pattern; + copy_case; + copy_type_declaration; + copy_type_extension; + copy_extension_constructor; +(*$*) + } +end + +module Register_migration (A : OCaml_version) (B : OCaml_version) + (A_to_B : Migrate_module with module From = A.Ast and module To = B.Ast) + (B_to_A : Migrate_module with module From = B.Ast and module To = A.Ast) += +struct + let () = ( + let is_undefined : type a. a migration -> bool = function + | Undefined -> true + | _ -> false + in + assert (A.version < B.version); + assert (is_undefined A.migration_info.next_version); + assert (is_undefined B.migration_info.previous_version); + let module A_to_B_fun = Migration_functions(A)(B)(A_to_B) in + let module B_to_A_fun = Migration_functions(B)(A)(B_to_A) in + A.migration_info.next_version <- + Migration ((module A), A_to_B_fun.migration_functions, (module B)); + B.migration_info.previous_version <- + Migration ((module B), B_to_A_fun.migration_functions, (module A)); + ) +end + +type 'from immediate_migration = + | No_migration : 'from immediate_migration + | Immediate_migration + : ('from, 'to_) migration_functions * 'to_ ocaml_version + -> 'from immediate_migration + +let immediate_migration + (*$ foreach_type (fun _ s -> printf " (type %s)\n" s) *) + (type structure) + (type signature) + (type toplevel_phrase) + (type core_type) + (type expression) + (type pattern) + (type case) + (type type_declaration) + (type type_extension) + (type extension_constructor) +(*$*) + ((module A) : < + (*$ foreach_type (fun _ s -> printf " %-21s : %s;\n" s s) *) + structure : structure; + signature : signature; + toplevel_phrase : toplevel_phrase; + core_type : core_type; + expression : expression; + pattern : pattern; + case : case; + type_declaration : type_declaration; + type_extension : type_extension; + extension_constructor : extension_constructor; +(*$*) + > ocaml_version) + direction + = + let version = match direction with + | `Next -> A.migration_info.next_version + | `Previous -> A.migration_info.previous_version + in + match version with + | Undefined -> No_migration + | Migration (_, funs, to_) -> Immediate_migration (funs, to_) + | _ -> assert false + +let migrate + (*$ foreach_type (fun _ s -> printf " (type %s1) (type %s2)\n" s s) *) + (type structure1) (type structure2) + (type signature1) (type signature2) + (type toplevel_phrase1) (type toplevel_phrase2) + (type core_type1) (type core_type2) + (type expression1) (type expression2) + (type pattern1) (type pattern2) + (type case1) (type case2) + (type type_declaration1) (type type_declaration2) + (type type_extension1) (type type_extension2) + (type extension_constructor1) (type extension_constructor2) +(*$*) + ((module A) : < + (*$ foreach_type (fun _ s -> printf " %-21s : %s1;\n" s s) *) + structure : structure1; + signature : signature1; + toplevel_phrase : toplevel_phrase1; + core_type : core_type1; + expression : expression1; + pattern : pattern1; + case : case1; + type_declaration : type_declaration1; + type_extension : type_extension1; + extension_constructor : extension_constructor1; +(*$*) + > ocaml_version) + ((module B) : < + (*$ foreach_type (fun _ s -> printf " %-21s : %s2;\n" s s) *) + structure : structure2; + signature : signature2; + toplevel_phrase : toplevel_phrase2; + core_type : core_type2; + expression : expression2; + pattern : pattern2; + case : case2; + type_declaration : type_declaration2; + type_extension : type_extension2; + extension_constructor : extension_constructor2; +(*$*) + > ocaml_version) + : (A.types, B.types) migration_functions + = + match A.Version with + | B.Version -> migration_identity + | _ -> + let direction = if A.version < B.version then `Next else `Previous in + let rec migrate (m : A.types immediate_migration) : (A.types, B.types) migration_functions = + match m with + | No_migration -> assert false + | Immediate_migration (f, (module To)) -> + match To.Version with + | B.Version -> f + | _ -> + match immediate_migration (module To) direction with + | No_migration -> assert false + | Immediate_migration (g, to2) -> + migrate (Immediate_migration (migration_compose f g, to2)) + in + migrate (immediate_migration (module A) direction) + +module Convert (A : OCaml_version) (B : OCaml_version) = struct + let { + (*$ foreach_type (fun _ s -> printf " copy_%s;\n" s) *) + copy_structure; + copy_signature; + copy_toplevel_phrase; + copy_core_type; + copy_expression; + copy_pattern; + copy_case; + copy_type_declaration; + copy_type_extension; + copy_extension_constructor; +(*$*) + } : (A.types, B.types) migration_functions = + migrate (module A) (module B) +end + +(*$ foreach_version (fun n version -> + printf "module OCaml_%d = struct\n" n; + printf " module Ast = Astlib.Ast_%d\n" n; + printf " include Make_witness(Astlib.Ast_%d)\n" n; + printf " let version = %d\n" n; + printf " let string_version = %S\n" version; + printf "end\n"; + printf "let ocaml_%d : OCaml_%d.types ocaml_version = (module OCaml_%d)\n" + n n n; + ) +*) +module OCaml_402 = struct + module Ast = Astlib.Ast_402 + include Make_witness(Astlib.Ast_402) + let version = 402 + let string_version = "4.02" +end +let ocaml_402 : OCaml_402.types ocaml_version = (module OCaml_402) +module OCaml_403 = struct + module Ast = Astlib.Ast_403 + include Make_witness(Astlib.Ast_403) + let version = 403 + let string_version = "4.03" +end +let ocaml_403 : OCaml_403.types ocaml_version = (module OCaml_403) +module OCaml_404 = struct + module Ast = Astlib.Ast_404 + include Make_witness(Astlib.Ast_404) + let version = 404 + let string_version = "4.04" +end +let ocaml_404 : OCaml_404.types ocaml_version = (module OCaml_404) +module OCaml_405 = struct + module Ast = Astlib.Ast_405 + include Make_witness(Astlib.Ast_405) + let version = 405 + let string_version = "4.05" +end +let ocaml_405 : OCaml_405.types ocaml_version = (module OCaml_405) +module OCaml_406 = struct + module Ast = Astlib.Ast_406 + include Make_witness(Astlib.Ast_406) + let version = 406 + let string_version = "4.06" +end +let ocaml_406 : OCaml_406.types ocaml_version = (module OCaml_406) +module OCaml_407 = struct + module Ast = Astlib.Ast_407 + include Make_witness(Astlib.Ast_407) + let version = 407 + let string_version = "4.07" +end +let ocaml_407 : OCaml_407.types ocaml_version = (module OCaml_407) +module OCaml_408 = struct + module Ast = Astlib.Ast_408 + include Make_witness(Astlib.Ast_408) + let version = 408 + let string_version = "4.08" +end +let ocaml_408 : OCaml_408.types ocaml_version = (module OCaml_408) +module OCaml_409 = struct + module Ast = Astlib.Ast_409 + include Make_witness(Astlib.Ast_409) + let version = 409 + let string_version = "4.09" +end +let ocaml_409 : OCaml_409.types ocaml_version = (module OCaml_409) +module OCaml_410 = struct + module Ast = Astlib.Ast_410 + include Make_witness(Astlib.Ast_410) + let version = 410 + let string_version = "4.10" +end +let ocaml_410 : OCaml_410.types ocaml_version = (module OCaml_410) +module OCaml_411 = struct + module Ast = Astlib.Ast_411 + include Make_witness(Astlib.Ast_411) + let version = 411 + let string_version = "4.11" +end +let ocaml_411 : OCaml_411.types ocaml_version = (module OCaml_411) +module OCaml_412 = struct + module Ast = Astlib.Ast_412 + include Make_witness(Astlib.Ast_412) + let version = 412 + let string_version = "4.12" +end +let ocaml_412 : OCaml_412.types ocaml_version = (module OCaml_412) +module OCaml_413 = struct + module Ast = Astlib.Ast_413 + include Make_witness(Astlib.Ast_413) + let version = 413 + let string_version = "4.13" +end +let ocaml_413 : OCaml_413.types ocaml_version = (module OCaml_413) +module OCaml_414 = struct + module Ast = Astlib.Ast_414 + include Make_witness(Astlib.Ast_414) + let version = 414 + let string_version = "4.14" +end +let ocaml_414 : OCaml_414.types ocaml_version = (module OCaml_414) +(*$*) + +let all_versions : (module OCaml_version) list = [ + (*$foreach_version (fun n _ -> + printf "(module OCaml_%d : OCaml_version);\n" n)*) +(module OCaml_402 : OCaml_version); +(module OCaml_403 : OCaml_version); +(module OCaml_404 : OCaml_version); +(module OCaml_405 : OCaml_version); +(module OCaml_406 : OCaml_version); +(module OCaml_407 : OCaml_version); +(module OCaml_408 : OCaml_version); +(module OCaml_409 : OCaml_version); +(module OCaml_410 : OCaml_version); +(module OCaml_411 : OCaml_version); +(module OCaml_412 : OCaml_version); +(module OCaml_413 : OCaml_version); +(module OCaml_414 : OCaml_version); +(*$*) +] + +(*$foreach_version_pair (fun a b -> + printf "include Register_migration(OCaml_%d)(OCaml_%d)\n" a b; + printf " (Astlib.Migrate_%d_%d)(Astlib.Migrate_%d_%d)\n" a b b a + ) +*) +include Register_migration(OCaml_402)(OCaml_403) + (Astlib.Migrate_402_403)(Astlib.Migrate_403_402) +include Register_migration(OCaml_403)(OCaml_404) + (Astlib.Migrate_403_404)(Astlib.Migrate_404_403) +include Register_migration(OCaml_404)(OCaml_405) + (Astlib.Migrate_404_405)(Astlib.Migrate_405_404) +include Register_migration(OCaml_405)(OCaml_406) + (Astlib.Migrate_405_406)(Astlib.Migrate_406_405) +include Register_migration(OCaml_406)(OCaml_407) + (Astlib.Migrate_406_407)(Astlib.Migrate_407_406) +include Register_migration(OCaml_407)(OCaml_408) + (Astlib.Migrate_407_408)(Astlib.Migrate_408_407) +include Register_migration(OCaml_408)(OCaml_409) + (Astlib.Migrate_408_409)(Astlib.Migrate_409_408) +include Register_migration(OCaml_409)(OCaml_410) + (Astlib.Migrate_409_410)(Astlib.Migrate_410_409) +include Register_migration(OCaml_410)(OCaml_411) + (Astlib.Migrate_410_411)(Astlib.Migrate_411_410) +include Register_migration(OCaml_411)(OCaml_412) + (Astlib.Migrate_411_412)(Astlib.Migrate_412_411) +include Register_migration(OCaml_412)(OCaml_413) + (Astlib.Migrate_412_413)(Astlib.Migrate_413_412) +include Register_migration(OCaml_413)(OCaml_414) + (Astlib.Migrate_413_414)(Astlib.Migrate_414_413) +(*$*) + +module OCaml_current = OCaml_OCAML_VERSION + +module Find_version = struct + type t = Impl of (module OCaml_version) | Intf of (module OCaml_version) | Unknown + + let from_magic magic = + let rec loop = function + | [] -> Unknown + | (module Version : OCaml_version) :: tail -> + if Version.Ast.Config.ast_impl_magic_number = magic then + Impl (module Version) + else if Version.Ast.Config.ast_intf_magic_number = magic then + Intf (module Version) + else + loop tail + in + loop all_versions +end diff -Nru ppxlib-0.15.0/ast/versions.mli ppxlib-0.24.0/ast/versions.mli --- ppxlib-0.15.0/ast/versions.mli 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/ast/versions.mli 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,164 @@ +(**************************************************************************) +(* *) +(* OCaml Migrate Parsetree *) +(* *) +(* Frédéric Bour *) +(* Jérémie Dimino, Jane Street Europe *) +(* *) +(* Copyright 2017 Institut National de Recherche en Informatique et *) +(* en Automatique (INRIA). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(*$ open Ast_cinaps_helpers $*) + +(** {1 Abstracting an OCaml frontend} *) + +(** Abstract view of a version of an OCaml Ast *) +module type Ast = sig + (*$ foreach_module (fun m types -> + printf " module %s : sig\n" m; + List.iter types ~f:(printf " type %s\n"); + printf " end\n" + ) + *) + module Parsetree : sig + type structure + type signature + type toplevel_phrase + type core_type + type expression + type pattern + type case + type type_declaration + type type_extension + type extension_constructor + end +(*$*) + module Config : sig + val ast_impl_magic_number : string + val ast_intf_magic_number : string + end +end + +(* Shortcuts for talking about ast types outside of the module language *) + +type 'a _types = 'a constraint 'a + = < + (*$ foreach_type (fun _ s -> printf " %-21s : _;\n" s) *) + structure : _; + signature : _; + toplevel_phrase : _; + core_type : _; + expression : _; + pattern : _; + case : _; + type_declaration : _; + type_extension : _; + extension_constructor : _; +(*$*) + > +;; + +(** A version of the OCaml frontend packs the ast with type witnesses + so that equalities can be recovered dynamically. *) +type _ witnesses (*IF_AT_LEAST 406 = private ..*) + +(** [migration_info] is an opaque type that is used to generate migration + functions. *) +type _ migration_info + +(** An OCaml frontend versions an Ast, version number and some witnesses for + conversion. *) +module type OCaml_version = sig + + (** Ast definition for this version *) + module Ast : Ast + + (* Version number as an integer, 402, 403, 404, ... *) + val version : int + + (* Version number as a user-friendly string *) + val string_version : string (* 4.02, 4.03, 4.04, ... *) + + (** Shortcut for talking about Ast types *) + type types = < + (*$ foreach_type (fun m s -> printf " %-21s : Ast.%s.%s;\n" s m s) *) + structure : Ast.Parsetree.structure; + signature : Ast.Parsetree.signature; + toplevel_phrase : Ast.Parsetree.toplevel_phrase; + core_type : Ast.Parsetree.core_type; + expression : Ast.Parsetree.expression; + pattern : Ast.Parsetree.pattern; + case : Ast.Parsetree.case; + type_declaration : Ast.Parsetree.type_declaration; + type_extension : Ast.Parsetree.type_extension; + extension_constructor : Ast.Parsetree.extension_constructor; +(*$*) + > _types + + (** A construtor for recovering type equalities between two arbitrary + versions. *) + type _ witnesses += Version : types witnesses + + (** Information used to derive migration functions, see below *) + val migration_info : types migration_info +end + +(** {1 Concrete frontend instances} *) + +(*$foreach_version (fun n _ -> + printf "module OCaml_%d : OCaml_version with module Ast = Astlib.Ast_%d\n" + n n + )*) +module OCaml_402 : OCaml_version with module Ast = Astlib.Ast_402 +module OCaml_403 : OCaml_version with module Ast = Astlib.Ast_403 +module OCaml_404 : OCaml_version with module Ast = Astlib.Ast_404 +module OCaml_405 : OCaml_version with module Ast = Astlib.Ast_405 +module OCaml_406 : OCaml_version with module Ast = Astlib.Ast_406 +module OCaml_407 : OCaml_version with module Ast = Astlib.Ast_407 +module OCaml_408 : OCaml_version with module Ast = Astlib.Ast_408 +module OCaml_409 : OCaml_version with module Ast = Astlib.Ast_409 +module OCaml_410 : OCaml_version with module Ast = Astlib.Ast_410 +module OCaml_411 : OCaml_version with module Ast = Astlib.Ast_411 +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 +(*$*) + +(* An alias to the current compiler version *) +module OCaml_current = OCaml_OCAML_VERSION + +(* The list of all supported versions *) +val all_versions : (module OCaml_version) list + +(** {1 Convenience definitions} *) + +(** Module level migration *) +module Convert (A : OCaml_version) (B : OCaml_version) : sig + (*$ foreach_type (fun m s -> + let fq = sprintf "%s.%s" m s in + printf " val copy_%-21s : A.Ast.%-31s -> B.Ast.%s\n" s fq fq) *) + val copy_structure : A.Ast.Parsetree.structure -> B.Ast.Parsetree.structure + val copy_signature : A.Ast.Parsetree.signature -> B.Ast.Parsetree.signature + val copy_toplevel_phrase : A.Ast.Parsetree.toplevel_phrase -> B.Ast.Parsetree.toplevel_phrase + val copy_core_type : A.Ast.Parsetree.core_type -> B.Ast.Parsetree.core_type + val copy_expression : A.Ast.Parsetree.expression -> B.Ast.Parsetree.expression + val copy_pattern : A.Ast.Parsetree.pattern -> B.Ast.Parsetree.pattern + val copy_case : A.Ast.Parsetree.case -> B.Ast.Parsetree.case + val copy_type_declaration : A.Ast.Parsetree.type_declaration -> B.Ast.Parsetree.type_declaration + val copy_type_extension : A.Ast.Parsetree.type_extension -> B.Ast.Parsetree.type_extension + val copy_extension_constructor : A.Ast.Parsetree.extension_constructor -> B.Ast.Parsetree.extension_constructor +(*$*) +end + +(** Helper to find the frontend corresponding to a given magic number *) +module Find_version : sig + type t = Impl of (module OCaml_version) | Intf of (module OCaml_version) | Unknown + + val from_magic : string -> t +end diff -Nru ppxlib-0.15.0/ast/warn.ml ppxlib-0.24.0/ast/warn.ml --- ppxlib-0.15.0/ast/warn.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/ast/warn.ml 2021-12-08 21:53:37.000000000 +0000 @@ -5,4 +5,5 @@ let about_ite_branch_ref = ref default_print_warning let care_about_ite_branch = ref false + let about_ite_branch loc = !about_ite_branch_ref loc diff -Nru ppxlib-0.15.0/astlib/ast_402.ml ppxlib-0.24.0/astlib/ast_402.ml --- ppxlib-0.15.0/astlib/ast_402.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/ast_402.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,883 @@ +(**************************************************************************) +(* *) +(* OCaml Migrate Parsetree *) +(* *) +(* Frédéric Bour *) +(* Jérémie Dimino and Leo White, Jane Street Europe *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Alain Frisch, LexiFi *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2017 Institut National de Recherche en Informatique et *) +(* en Automatique (INRIA). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module Asttypes = struct + (* Auxiliary a.s.t. types used by parsetree and typedtree. *) + + type constant (*IF_CURRENT = Asttypes.constant *) = + Const_int of int + | Const_char of char + | Const_string of string * 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 + + 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 'a loc = 'a Location.loc = { + txt : 'a; + loc : Location.t; + } + + + type variance (*IF_CURRENT = Asttypes.variance *) = + | Covariant + | Contravariant + | Invariant +end + +module Parsetree = struct + (** Abstract syntax tree produced by parsing *) + + open Asttypes + + (** {2 Extension points} *) + + type attribute = string loc * payload + (* [@id ARG] + [@@id ARG] + + Metadata containers passed around within the AST. + The compiler ignores unknown attributes. + *) + + and extension = string loc * payload + (* [%id ARG] + [%%id ARG] + + Sub-language placeholder -- rejected by the typechecker. + *) + + and attributes = attribute list + + and payload (*IF_CURRENT = Parsetree.payload *) = + | PStr of structure + | PTyp of core_type (* : T *) + | PPat of pattern * expression option (* ? P or ? P when E *) + + (** {2 Core language} *) + + (* Type expressions *) + + and core_type (*IF_CURRENT = Parsetree.core_type *) = + { + ptyp_desc: core_type_desc; + ptyp_loc: Location.t; + ptyp_attributes: attributes; (* ... [@id1] [@id2] *) + } + + and core_type_desc (*IF_CURRENT = Parsetree.core_type_desc *) = + | Ptyp_any + (* _ *) + | Ptyp_var of string + (* 'a *) + | Ptyp_arrow of label * core_type * core_type + (* T1 -> T2 (label = "") + ~l:T1 -> T2 (label = "l") + ?l:T1 -> T2 (label = "?l") + *) + | Ptyp_tuple of core_type list + (* T1 * ... * Tn + + Invariant: n >= 2 + *) + | Ptyp_constr of Longident.t loc * core_type list + (* tconstr + T tconstr + (T1, ..., Tn) tconstr + *) + | Ptyp_object of (string * attributes * core_type) list * closed_flag + (* < l1:T1; ...; ln:Tn > (flag = Closed) + < l1:T1; ...; ln:Tn; .. > (flag = Open) + *) + | Ptyp_class of Longident.t loc * core_type list + (* #tconstr + T #tconstr + (T1, ..., Tn) #tconstr + *) + | Ptyp_alias of core_type * string + (* T as 'a *) + | Ptyp_variant of row_field list * closed_flag * label list option + (* [ `A|`B ] (flag = Closed; labels = None) + [> `A|`B ] (flag = Open; labels = None) + [< `A|`B ] (flag = Closed; labels = Some []) + [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) + *) + | Ptyp_poly of string list * core_type + (* 'a1 ... 'an. T + + Can only appear in the following context: + + - As the core_type of a Ppat_constraint node corresponding + to a constraint on a let-binding: let x : 'a1 ... 'an. T + = e ... + + - Under Cfk_virtual for methods (not values). + + - As the core_type of a Pctf_method node. + + - As the core_type of a Pexp_poly node. + + - As the pld_type field of a label_declaration. + + - As a core_type of a Ptyp_object node. + *) + + | Ptyp_package of package_type + (* (module S) *) + | Ptyp_extension of extension + (* [%id] *) + + and package_type = Longident.t loc * (Longident.t loc * core_type) list + (* + (module S) + (module S with type t1 = T1 and ... and tn = Tn) + *) + + and row_field (*IF_CURRENT = Parsetree.row_field *) = + | Rtag of label * attributes * bool * core_type list + (* [`A] ( true, [] ) + [`A of T] ( false, [T] ) + [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) + [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) + + - The 2nd 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) + + - TODO: switch to a record representation, and keep location + *) + | Rinherit of core_type + (* [ T ] *) + + (* Patterns *) + + and pattern (*IF_CURRENT = Parsetree.pattern *) = + { + ppat_desc: pattern_desc; + ppat_loc: Location.t; + ppat_attributes: attributes; (* ... [@id1] [@id2] *) + } + + and pattern_desc (*IF_CURRENT = Parsetree.pattern_desc *) = + | Ppat_any + (* _ *) + | Ppat_var of string loc + (* x *) + | Ppat_alias of pattern * string loc + (* P as 'a *) + | Ppat_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Ppat_interval of constant * constant + (* 'a'..'z' + + Other forms of interval are recognized by the parser + but rejected by the type-checker. *) + | Ppat_tuple of pattern list + (* (P1, ..., Pn) + + Invariant: n >= 2 + *) + | Ppat_construct of Longident.t loc * pattern option + (* C None + C P Some P + C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) + *) + | Ppat_variant of label * pattern option + (* `A (None) + `A P (Some P) + *) + | Ppat_record of (Longident.t loc * pattern) list * closed_flag + (* { l1=P1; ...; ln=Pn } (flag = Closed) + { l1=P1; ...; ln=Pn; _} (flag = Open) + + Invariant: n > 0 + *) + | Ppat_array of pattern list + (* [| P1; ...; Pn |] *) + | Ppat_or of pattern * pattern + (* P1 | P2 *) + | Ppat_constraint of pattern * core_type + (* (P : T) *) + | Ppat_type of Longident.t loc + (* #tconst *) + | Ppat_lazy of pattern + (* lazy P *) + | Ppat_unpack of string loc + (* (module P) + Note: (module P : S) is represented as + Ppat_constraint(Ppat_unpack, Ptyp_package) + *) + | Ppat_exception of pattern + (* exception P *) + | Ppat_extension of extension + (* [%id] *) + + (* Value expressions *) + + and expression (*IF_CURRENT = Parsetree.expression *) = + { + pexp_desc: expression_desc; + pexp_loc: Location.t; + pexp_attributes: attributes; (* ... [@id1] [@id2] *) + } + + and expression_desc (*IF_CURRENT = Parsetree.expression_desc *) = + | Pexp_ident of Longident.t loc + (* x + M.x + *) + | Pexp_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Pexp_let of rec_flag * value_binding list * expression + (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) + *) + | Pexp_function of case list + (* function P1 -> E1 | ... | Pn -> En *) + | Pexp_fun of label * expression option * pattern * expression + (* fun P -> E1 (lab = "", None) + fun ~l:P -> E1 (lab = "l", None) + fun ?l:P -> E1 (lab = "?l", None) + fun ?l:(P = E0) -> E1 (lab = "?l", Some E0) + + Notes: + - If E0 is provided, lab must start with '?'. + - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. + - "let f P = E" is represented using Pexp_fun. + *) + | Pexp_apply of expression * (label * expression) list + (* E0 ~l1:E1 ... ~ln:En + li can be empty (non labeled argument) or start with '?' + (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 + (* (E1, ..., En) + + Invariant: n >= 2 + *) + | Pexp_construct of Longident.t loc * expression option + (* C None + C E Some E + C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) + *) + | Pexp_variant of label * expression option + (* `A (None) + `A E (Some E) + *) + | Pexp_record of (Longident.t loc * expression) list * expression option + (* { l1=P1; ...; ln=Pn } (None) + { E0 with l1=P1; ...; ln=Pn } (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 + (* for i = E1 to E2 do E3 done (flag = Upto) + for i = E1 downto E2 do E3 done (flag = Downto) + *) + | Pexp_constraint of expression * core_type + (* (E : T) *) + | Pexp_coerce of expression * core_type option * core_type + (* (E :> T) (None, T) + (E : T0 :> T) (Some T0, T) + *) + | Pexp_send of expression * string + (* E # m *) + | Pexp_new of Longident.t loc + (* new M.c *) + | Pexp_setinstvar of string loc * expression + (* x <- 2 *) + | Pexp_override of (string loc * expression) list + (* {< x1 = E1; ...; Xn = En >} *) + | Pexp_letmodule of string loc * module_expr * expression + (* let module M = ME 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 Cfk_concrete + for methods (not values). *) + | Pexp_object of class_structure + (* object ... end *) + | Pexp_newtype of string * expression + (* fun (type t) -> E *) + | Pexp_pack of module_expr + (* (module ME) + + (module ME : S) is represented as + Pexp_constraint(Pexp_pack, Ptyp_package S) *) + | Pexp_open of override_flag * Longident.t loc * expression + (* let open M in E + let! open M in E + *) + | Pexp_extension of extension + (* [%id] *) + + and case (*IF_CURRENT = Parsetree.case *) = (* (P -> E) or (P when E0 -> E) *) + { + pc_lhs: pattern; + pc_guard: expression option; + pc_rhs: expression; + } + + (* 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; + } + + (* + val x: T (prim = []) + external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) + + Note: when used under Pstr_primitive, prim cannot be empty + *) + + (* Type declarations *) + + and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = + { + ptype_name: string loc; + ptype_params: (core_type * variance) list; + (* ('a1,...'an) t; None represents _*) + ptype_cstrs: (core_type * core_type * Location.t) list; + (* ... constraint T1=T1' ... constraint Tn=Tn' *) + ptype_kind: type_kind; + ptype_private: private_flag; (* = private ... *) + ptype_manifest: core_type option; (* = T *) + ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) + ptype_loc: Location.t; + } + + (* + type t (abstract, no manifest) + type t = T0 (abstract, manifest=T0) + type t = C of T | ... (variant, no manifest) + type t = T0 = C of T | ... (variant, manifest=T0) + type t = {l: T; ...} (record, no manifest) + type t = T0 = {l : T; ...} (record, manifest=T0) + type t = .. (open, no manifest) + *) + + and type_kind (*IF_CURRENT = Parsetree.type_kind *) = + | Ptype_abstract + | Ptype_variant of constructor_declaration list + (* Invariant: non-empty 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 [@id1] [@id2] : T *) + } + + (* { ...; l: T; ... } (mutable=Immutable) + { ...; mutable l: T; ... } (mutable=Mutable) + + Note: T can be a Ptyp_poly. + *) + + and constructor_declaration (*IF_CURRENT = Parsetree.constructor_declaration *) = + { + pcd_name: string loc; + pcd_args: core_type list; + pcd_res: core_type option; + pcd_loc: Location.t; + pcd_attributes: attributes; (* C [@id1] [@id2] of ... *) + } + (* + | C of T1 * ... * Tn (res = None) + | C: T0 (args = [], res = Some T0) + | C: T1 * ... * Tn -> T0 (res = Some T0) + *) + + and type_extension (*IF_CURRENT = Parsetree.type_extension *) = + { + ptyext_path: Longident.t loc; + ptyext_params: (core_type * variance) list; + ptyext_constructors: extension_constructor list; + ptyext_private: private_flag; + ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + (* + 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 [@id1] [@id2] of ... *) + } + + and extension_constructor_kind (*IF_CURRENT = Parsetree.extension_constructor_kind *) = + Pext_decl of core_type list * core_type option + (* + | C of T1 * ... * Tn ([T1; ...; Tn], None) + | C: T0 ([], Some T0) + | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) + *) + | Pext_rebind of Longident.t loc + (* + | C = D + *) + + (** {2 Class language} *) + + (* 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 label * core_type * class_type + (* T -> CT (label = "") + ~l:T -> CT (label = "l") + ?l:T -> CT (label = "?l") + *) + | Pcty_extension of extension + (* [%id] *) + + and class_signature (*IF_CURRENT = Parsetree.class_signature *) = + { + pcsig_self: core_type; + pcsig_fields: class_type_field list; + } + (* object('selfpat) ... end + object ... end (self = 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 (string * mutable_flag * virtual_flag * core_type) + (* val x: T *) + | Pctf_method of (string * private_flag * virtual_flag * core_type) + (* method x: T + + Note: T can be a 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) list; + pci_name: string loc; + pci_expr: 'a; + pci_loc: Location.t; + pci_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + (* class c = ... + class ['a1,...,'an] c = ... + class virtual c = ... + + Also used for "class type" declaration. + *) + + and class_description = class_type class_infos + + and class_type_declaration = class_type class_infos + + (* 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 + ['a1, ..., 'an] c *) + | Pcl_structure of class_structure + (* object ... end *) + | Pcl_fun of label * expression option * pattern * class_expr + (* fun P -> CE (lab = "", None) + fun ~l:P -> CE (lab = "l", None) + fun ?l:P -> CE (lab = "?l", None) + fun ?l:(P = E0) -> CE (lab = "?l", Some E0) + *) + | Pcl_apply of class_expr * (label * expression) list + (* 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 + (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive) + *) + | Pcl_constraint of class_expr * class_type + (* (CE : CT) *) + | Pcl_extension of extension + (* [%id] *) + + and class_structure (*IF_CURRENT = Parsetree.class_structure *) = + { + pcstr_self: pattern; + pcstr_fields: class_field list; + } + (* object(selfpat) ... end + object ... end (self = 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 option + (* inherit CE + inherit CE as x + inherit! CE + inherit! CE as x + *) + | Pcf_val of (string loc * mutable_flag * class_field_kind) + (* val x = E + val virtual x: T + *) + | Pcf_method of (string loc * private_flag * class_field_kind) + (* method x = E (E can be a Pexp_poly) + method virtual x: T (T can be a 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 + + (** {2 Module language} *) + + (* 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 + (* S *) + | Pmty_signature of signature + (* sig ... end *) + | Pmty_functor of string loc * module_type option * 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 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 type_declaration list + (* type t1 = ... and ... and tn = ... *) + | Psig_typext of type_extension + (* type t1 += ... *) + | Psig_exception of extension_constructor + (* exception C of T *) + | Psig_module of module_declaration + (* module X : MT *) + | Psig_recmodule of module_declaration list + (* module rec X1 : MT1 and ... and Xn : MTn *) + | Psig_modtype of module_type_declaration + (* module type S = MT + 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 loc; + pmd_type: module_type; + pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) + pmd_loc: Location.t; + } + (* S : MT *) + + 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; + } + (* S = MT + S (abstract module type declaration, pmtd_type = None) + *) + + and open_description (*IF_CURRENT = Parsetree.open_description *) = + { + popen_lid: Longident.t loc; + popen_override: override_flag; + popen_loc: Location.t; + popen_attributes: attributes; + } + (* open! X - popen_override = Override (silences the 'used identifier + shadowing' warning) + open X - popen_override = Fresh + *) + + 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 + (* include MT *) + + and include_declaration = module_expr include_infos + (* 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_typesubst of type_declaration + (* with type t := ... *) + | Pwith_modsubst of string loc * Longident.t loc + (* with module X := Z *) + + (* 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 string loc * module_type option * module_expr + (* functor(X : MT1) -> ME *) + | Pmod_apply of module_expr * module_expr + (* ME1(ME2) *) + | 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 + (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN (flag = Recursive) + *) + | Pstr_primitive of value_description + (* external x: T = "s1" ... "sn" *) + | Pstr_type of type_declaration list + (* type t1 = ... and ... and tn = ... *) + | Pstr_typext of type_extension + (* type t1 += ... *) + | Pstr_exception of extension_constructor + (* 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_description + (* 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_binding (*IF_CURRENT = Parsetree.value_binding *) = + { + pvb_pat: pattern; + pvb_expr: expression; + pvb_attributes: attributes; + pvb_loc: Location.t; + } + + and module_binding (*IF_CURRENT = Parsetree.module_binding *) = + { + pmb_name: string loc; + pmb_expr: module_expr; + pmb_attributes: attributes; + pmb_loc: Location.t; + } + (* X = ME *) + + (** {2 Toplevel} *) + + (* Toplevel phrases *) + + type toplevel_phrase (*IF_CURRENT = Parsetree.toplevel_phrase *) = + | Ptop_def of structure + | Ptop_dir of string * directive_argument + (* #use, #load ... *) + + and directive_argument (*IF_CURRENT = Parsetree.directive_argument *) = + | Pdir_none + | Pdir_string of string + | Pdir_int of int + | Pdir_ident of Longident.t + | Pdir_bool of bool +end + +module Config = struct + let ast_impl_magic_number = "Caml1999M016" + let ast_intf_magic_number = "Caml1999N015" +end diff -Nru ppxlib-0.15.0/astlib/ast_403.ml ppxlib-0.24.0/astlib/ast_403.ml --- ppxlib-0.15.0/astlib/ast_403.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/ast_403.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,919 @@ +(**************************************************************************) +(* *) +(* OCaml Migrate Parsetree *) +(* *) +(* Frédéric Bour *) +(* Jérémie Dimino and Leo White, Jane Street Europe *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Alain Frisch, LexiFi *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2017 Institut National de Recherche en Informatique et *) +(* en Automatique (INRIA). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module Asttypes = struct + (* Auxiliary a.s.t. types used by parsetree and typedtree. *) + + type constant (*IF_CURRENT = Asttypes.constant *) = + Const_int of int + | Const_char of char + | Const_string of string * 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 + | Invariant +end + +module Parsetree = struct + (** Abstract syntax tree produced by parsing *) + + open Asttypes + + type constant (*IF_CURRENT = Parsetree.constant *) = + Pconst_integer of string * char option + (* 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 + (* 'c' *) + | Pconst_string of string * string option + (* "constant" + {delim|other constant|delim} + *) + | Pconst_float of string * char option + (* 3.4 2e5 1.4e-4 + + Suffixes [g-z][G-Z] are accepted by the parser. + Suffixes are rejected by the typechecker. + *) + + (** {2 Extension points} *) + + type attribute = string loc * payload + (* [@id ARG] + [@@id ARG] + + Metadata containers passed around within the AST. + The compiler ignores unknown attributes. + *) + + and extension = string loc * payload + (* [%id ARG] + [%%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 *) + | PTyp of core_type (* : T *) + | PPat of pattern * expression option (* ? P or ? P when E *) + + (** {2 Core language} *) + + (* Type expressions *) + + and core_type (*IF_CURRENT = Parsetree.core_type *) = + { + ptyp_desc: core_type_desc; + ptyp_loc: Location.t; + ptyp_attributes: attributes; (* ... [@id1] [@id2] *) + } + + and core_type_desc (*IF_CURRENT = Parsetree.core_type_desc *) = + | Ptyp_any + (* _ *) + | Ptyp_var of string + (* 'a *) + | Ptyp_arrow of arg_label * core_type * core_type + (* T1 -> T2 Simple + ~l:T1 -> T2 Labelled + ?l:T1 -> T2 Otional + *) + | Ptyp_tuple of core_type list + (* T1 * ... * Tn + + Invariant: n >= 2 + *) + | Ptyp_constr of Longident.t loc * core_type list + (* tconstr + T tconstr + (T1, ..., Tn) tconstr + *) + | Ptyp_object of (string * attributes * core_type) list * closed_flag + (* < l1:T1; ...; ln:Tn > (flag = Closed) + < l1:T1; ...; ln:Tn; .. > (flag = Open) + *) + | Ptyp_class of Longident.t loc * core_type list + (* #tconstr + T #tconstr + (T1, ..., Tn) #tconstr + *) + | Ptyp_alias of core_type * string + (* T as 'a *) + | Ptyp_variant of row_field list * closed_flag * label list option + (* [ `A|`B ] (flag = Closed; labels = None) + [> `A|`B ] (flag = Open; labels = None) + [< `A|`B ] (flag = Closed; labels = Some []) + [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) + *) + | Ptyp_poly of string list * core_type + (* 'a1 ... 'an. T + + Can only appear in the following context: + + - As the core_type of a Ppat_constraint node corresponding + to a constraint on a let-binding: let x : 'a1 ... 'an. T + = e ... + + - Under Cfk_virtual for methods (not values). + + - As the core_type of a Pctf_method node. + + - As the core_type of a Pexp_poly node. + + - As the pld_type field of a label_declaration. + + - As a core_type of a Ptyp_object node. + *) + + | Ptyp_package of package_type + (* (module S) *) + | Ptyp_extension of extension + (* [%id] *) + + and package_type = Longident.t loc * (Longident.t loc * core_type) list + (* + (module S) + (module S with type t1 = T1 and ... and tn = Tn) + *) + + and row_field (*IF_CURRENT = Parsetree.row_field *) = + | Rtag of label * attributes * bool * core_type list + (* [`A] ( true, [] ) + [`A of T] ( false, [T] ) + [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) + [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) + + - The 2nd 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) + + - TODO: switch to a record representation, and keep location + *) + | Rinherit of core_type + (* [ T ] *) + + (* Patterns *) + + and pattern (*IF_CURRENT = Parsetree.pattern *) = + { + ppat_desc: pattern_desc; + ppat_loc: Location.t; + ppat_attributes: attributes; (* ... [@id1] [@id2] *) + } + + and pattern_desc (*IF_CURRENT = Parsetree.pattern_desc *) = + | Ppat_any + (* _ *) + | Ppat_var of string loc + (* x *) + | Ppat_alias of pattern * string loc + (* P as 'a *) + | Ppat_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Ppat_interval of constant * constant + (* 'a'..'z' + + Other forms of interval are recognized by the parser + but rejected by the type-checker. *) + | Ppat_tuple of pattern list + (* (P1, ..., Pn) + + Invariant: n >= 2 + *) + | Ppat_construct of Longident.t loc * pattern option + (* C None + C P Some P + C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) + *) + | Ppat_variant of label * pattern option + (* `A (None) + `A P (Some P) + *) + | Ppat_record of (Longident.t loc * pattern) list * closed_flag + (* { l1=P1; ...; ln=Pn } (flag = Closed) + { l1=P1; ...; ln=Pn; _} (flag = Open) + + Invariant: n > 0 + *) + | Ppat_array of pattern list + (* [| P1; ...; Pn |] *) + | Ppat_or of pattern * pattern + (* P1 | P2 *) + | Ppat_constraint of pattern * core_type + (* (P : T) *) + | Ppat_type of Longident.t loc + (* #tconst *) + | Ppat_lazy of pattern + (* lazy P *) + | Ppat_unpack of string loc + (* (module P) + Note: (module P : S) is represented as + Ppat_constraint(Ppat_unpack, Ptyp_package) + *) + | Ppat_exception of pattern + (* exception P *) + | Ppat_extension of extension + (* [%id] *) + + (* Value expressions *) + + and expression (*IF_CURRENT = Parsetree.expression *) = + { + pexp_desc: expression_desc; + pexp_loc: Location.t; + pexp_attributes: attributes; (* ... [@id1] [@id2] *) + } + + and expression_desc (*IF_CURRENT = Parsetree.expression_desc *) = + | Pexp_ident of Longident.t loc + (* x + M.x + *) + | Pexp_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Pexp_let of rec_flag * value_binding list * expression + (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) + *) + | Pexp_function of case list + (* function P1 -> E1 | ... | Pn -> En *) + | Pexp_fun of arg_label * expression option * pattern * expression + (* fun P -> E1 (Simple, None) + fun ~l:P -> E1 (Labelled l, None) + fun ?l:P -> E1 (Optional l, None) + fun ?l:(P = E0) -> E1 (Optional l, Some E0) + + Notes: + - If E0 is provided, only Optional is allowed. + - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. + - "let f P = E" is represented using Pexp_fun. + *) + | Pexp_apply of expression * (arg_label * expression) list + (* E0 ~l1:E1 ... ~ln:En + li can be empty (non labeled argument) or start with '?' + (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 + (* (E1, ..., En) + + Invariant: n >= 2 + *) + | Pexp_construct of Longident.t loc * expression option + (* C None + C E Some E + C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) + *) + | Pexp_variant of label * expression option + (* `A (None) + `A E (Some E) + *) + | Pexp_record of (Longident.t loc * expression) list * expression option + (* { l1=P1; ...; ln=Pn } (None) + { E0 with l1=P1; ...; ln=Pn } (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 + (* for i = E1 to E2 do E3 done (flag = Upto) + for i = E1 downto E2 do E3 done (flag = Downto) + *) + | Pexp_constraint of expression * core_type + (* (E : T) *) + | Pexp_coerce of expression * core_type option * core_type + (* (E :> T) (None, T) + (E : T0 :> T) (Some T0, T) + *) + | Pexp_send of expression * string + (* E # m *) + | Pexp_new of Longident.t loc + (* new M.c *) + | Pexp_setinstvar of string loc * expression + (* x <- 2 *) + | Pexp_override of (string loc * expression) list + (* {< x1 = E1; ...; Xn = En >} *) + | Pexp_letmodule of string loc * module_expr * expression + (* let module M = ME 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 Cfk_concrete + for methods (not values). *) + | Pexp_object of class_structure + (* object ... end *) + | Pexp_newtype of string * expression + (* fun (type t) -> E *) + | Pexp_pack of module_expr + (* (module ME) + + (module ME : S) is represented as + Pexp_constraint(Pexp_pack, Ptyp_package S) *) + | Pexp_open of override_flag * Longident.t loc * expression + (* let open M in E + let! open M in E + *) + | Pexp_extension of extension + (* [%id] *) + | Pexp_unreachable + (* . *) + + and case (*IF_CURRENT = Parsetree.case *) = (* (P -> E) or (P when E0 -> E) *) + { + pc_lhs: pattern; + pc_guard: expression option; + pc_rhs: expression; + } + + (* 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; + } + + (* + val x: T (prim = []) + external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) + *) + + (* Type declarations *) + + and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = + { + ptype_name: string loc; + ptype_params: (core_type * variance) list; + (* ('a1,...'an) t; None represents _*) + ptype_cstrs: (core_type * core_type * Location.t) list; + (* ... constraint T1=T1' ... constraint Tn=Tn' *) + ptype_kind: type_kind; + ptype_private: private_flag; (* = private ... *) + ptype_manifest: core_type option; (* = T *) + ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) + ptype_loc: Location.t; + } + + (* + type t (abstract, no manifest) + type t = T0 (abstract, manifest=T0) + type t = C of T | ... (variant, no manifest) + type t = T0 = C of T | ... (variant, manifest=T0) + type t = {l: T; ...} (record, no manifest) + type t = T0 = {l : T; ...} (record, manifest=T0) + type t = .. (open, no manifest) + *) + + and type_kind (*IF_CURRENT = Parsetree.type_kind *) = + | Ptype_abstract + | Ptype_variant of constructor_declaration list + (* Invariant: non-empty 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 [@id1] [@id2] : T *) + } + + (* { ...; l: T; ... } (mutable=Immutable) + { ...; mutable l: T; ... } (mutable=Mutable) + + Note: T can be a Ptyp_poly. + *) + + and constructor_declaration (*IF_CURRENT = Parsetree.constructor_declaration *) = + { + pcd_name: string loc; + pcd_args: constructor_arguments; + pcd_res: core_type option; + pcd_loc: Location.t; + pcd_attributes: attributes; (* C [@id1] [@id2] of ... *) + } + + and constructor_arguments (*IF_CURRENT = Parsetree.constructor_arguments *) = + | Pcstr_tuple of core_type list + | Pcstr_record of label_declaration list + + (* + | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) + | C: T0 (res = Some T0, args = []) + | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) + | C of {...} (res = None, args = Pcstr_record) + | C: {...} -> T0 (res = Some T0, args = Pcstr_record) + | C of {...} as t (res = None, args = Pcstr_record) + *) + + and type_extension (*IF_CURRENT = Parsetree.type_extension *) = + { + ptyext_path: Longident.t loc; + ptyext_params: (core_type * variance) list; + ptyext_constructors: extension_constructor list; + ptyext_private: private_flag; + ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + (* + 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 [@id1] [@id2] of ... *) + } + + and extension_constructor_kind (*IF_CURRENT = Parsetree.extension_constructor_kind *) = + Pext_decl of constructor_arguments * core_type option + (* + | C of T1 * ... * Tn ([T1; ...; Tn], None) + | C: T0 ([], Some T0) + | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) + *) + | Pext_rebind of Longident.t loc + (* + | C = D + *) + + (** {2 Class language} *) + + (* 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 + (* T -> CT Simple + ~l:T -> CT Labelled l + ?l:T -> CT Optional l + *) + | Pcty_extension of extension + (* [%id] *) + + and class_signature (*IF_CURRENT = Parsetree.class_signature *) = + { + pcsig_self: core_type; + pcsig_fields: class_type_field list; + } + (* object('selfpat) ... end + object ... end (self = 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 (string * mutable_flag * virtual_flag * core_type) + (* val x: T *) + | Pctf_method of (string * private_flag * virtual_flag * core_type) + (* method x: T + + Note: T can be a 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) list; + pci_name: string loc; + pci_expr: 'a; + pci_loc: Location.t; + pci_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + (* class c = ... + class ['a1,...,'an] c = ... + class virtual c = ... + + Also used for "class type" declaration. + *) + + and class_description = class_type class_infos + + and class_type_declaration = class_type class_infos + + (* 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 + ['a1, ..., 'an] c *) + | Pcl_structure of class_structure + (* object ... end *) + | Pcl_fun of arg_label * expression option * pattern * class_expr + (* fun P -> CE (Simple, None) + fun ~l:P -> CE (Labelled l, None) + fun ?l:P -> CE (Optional l, None) + fun ?l:(P = E0) -> CE (Optional l, Some E0) + *) + | Pcl_apply of class_expr * (arg_label * expression) list + (* 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 + (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive) + *) + | Pcl_constraint of class_expr * class_type + (* (CE : CT) *) + | Pcl_extension of extension + (* [%id] *) + + and class_structure (*IF_CURRENT = Parsetree.class_structure *) = + { + pcstr_self: pattern; + pcstr_fields: class_field list; + } + (* object(selfpat) ... end + object ... end (self = 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 option + (* inherit CE + inherit CE as x + inherit! CE + inherit! CE as x + *) + | Pcf_val of (string loc * mutable_flag * class_field_kind) + (* val x = E + val virtual x: T + *) + | Pcf_method of (string loc * private_flag * class_field_kind) + (* method x = E (E can be a Pexp_poly) + method virtual x: T (T can be a 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 + + (** {2 Module language} *) + + (* 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 + (* S *) + | Pmty_signature of signature + (* sig ... end *) + | Pmty_functor of string loc * module_type option * 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 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_typext of type_extension + (* type t1 += ... *) + | Psig_exception of extension_constructor + (* exception C of T *) + | Psig_module of module_declaration + (* module X : MT *) + | Psig_recmodule of module_declaration list + (* module rec X1 : MT1 and ... and Xn : MTn *) + | Psig_modtype of module_type_declaration + (* module type S = MT + 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 loc; + pmd_type: module_type; + pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) + pmd_loc: Location.t; + } + (* S : MT *) + + 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; + } + (* S = MT + S (abstract module type declaration, pmtd_type = None) + *) + + and open_description (*IF_CURRENT = Parsetree.open_description *) = + { + popen_lid: Longident.t loc; + popen_override: override_flag; + popen_loc: Location.t; + popen_attributes: attributes; + } + (* open! X - popen_override = Override (silences the 'used identifier + shadowing' warning) + open X - popen_override = Fresh + *) + + 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 + (* include MT *) + + and include_declaration = module_expr include_infos + (* 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_typesubst of type_declaration + (* with type t := ... *) + | Pwith_modsubst of string loc * Longident.t loc + (* with module X := Z *) + + (* 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 string loc * module_type option * module_expr + (* functor(X : MT1) -> ME *) + | Pmod_apply of module_expr * module_expr + (* ME1(ME2) *) + | 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 + (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN (flag = 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 extension_constructor + (* 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_description + (* 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_binding (*IF_CURRENT = Parsetree.value_binding *) = + { + pvb_pat: pattern; + pvb_expr: expression; + pvb_attributes: attributes; + pvb_loc: Location.t; + } + + and module_binding (*IF_CURRENT = Parsetree.module_binding *) = + { + pmb_name: string loc; + pmb_expr: module_expr; + pmb_attributes: attributes; + pmb_loc: Location.t; + } + (* X = ME *) + + (** {2 Toplevel} *) + + (* Toplevel phrases *) + + type toplevel_phrase (*IF_CURRENT = Parsetree.toplevel_phrase *) = + | Ptop_def of structure + | Ptop_dir of string * directive_argument + (* #use, #load ... *) + + and directive_argument (*IF_CURRENT = Parsetree.directive_argument *) = + | Pdir_none + | 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 = "Caml1999M019" + let ast_intf_magic_number = "Caml1999N018" +end diff -Nru ppxlib-0.15.0/astlib/ast_404.ml ppxlib-0.24.0/astlib/ast_404.ml --- ppxlib-0.15.0/astlib/ast_404.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/ast_404.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,922 @@ +(**************************************************************************) +(* *) +(* OCaml Migrate Parsetree *) +(* *) +(* Frédéric Bour *) +(* Jérémie Dimino and Leo White, Jane Street Europe *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Alain Frisch, LexiFi *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2017 Institut National de Recherche en Informatique et *) +(* en Automatique (INRIA). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module Asttypes = struct + (** Auxiliary AST types used by parsetree and typedtree. *) + + type constant (*IF_CURRENT = Asttypes.constant *) = + Const_int of int + | Const_char of char + | Const_string of string * 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 + | Invariant +end + +module Parsetree = struct + (** Abstract syntax tree produced by parsing *) + + open Asttypes + + type constant (*IF_CURRENT = Parsetree.constant *) = + Pconst_integer of string * char option + (* 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 + (* 'c' *) + | Pconst_string of string * string option + (* "constant" + {delim|other constant|delim} + *) + | Pconst_float of string * char option + (* 3.4 2e5 1.4e-4 + + Suffixes [g-z][G-Z] are accepted by the parser. + Suffixes are rejected by the typechecker. + *) + + (** {2 Extension points} *) + + type attribute = string loc * payload + (* [@id ARG] + [@@id ARG] + + Metadata containers passed around within the AST. + The compiler ignores unknown attributes. + *) + + and extension = string loc * payload + (* [%id ARG] + [%%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 *) + | PTyp of core_type (* : T *) + | PPat of pattern * expression option (* ? P or ? P when E *) + + (** {2 Core language} *) + + (* Type expressions *) + + and core_type (*IF_CURRENT = Parsetree.core_type *) = + { + ptyp_desc: core_type_desc; + ptyp_loc: Location.t; + ptyp_attributes: attributes; (* ... [@id1] [@id2] *) + } + + and core_type_desc (*IF_CURRENT = Parsetree.core_type_desc *) = + | Ptyp_any + (* _ *) + | Ptyp_var of string + (* 'a *) + | Ptyp_arrow of arg_label * core_type * core_type + (* T1 -> T2 Simple + ~l:T1 -> T2 Labelled + ?l:T1 -> T2 Otional + *) + | Ptyp_tuple of core_type list + (* T1 * ... * Tn + + Invariant: n >= 2 + *) + | Ptyp_constr of Longident.t loc * core_type list + (* tconstr + T tconstr + (T1, ..., Tn) tconstr + *) + | Ptyp_object of (string * attributes * core_type) list * closed_flag + (* < l1:T1; ...; ln:Tn > (flag = Closed) + < l1:T1; ...; ln:Tn; .. > (flag = Open) + *) + | Ptyp_class of Longident.t loc * core_type list + (* #tconstr + T #tconstr + (T1, ..., Tn) #tconstr + *) + | Ptyp_alias of core_type * string + (* T as 'a *) + | Ptyp_variant of row_field list * closed_flag * label list option + (* [ `A|`B ] (flag = Closed; labels = None) + [> `A|`B ] (flag = Open; labels = None) + [< `A|`B ] (flag = Closed; labels = Some []) + [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) + *) + | Ptyp_poly of string list * core_type + (* 'a1 ... 'an. T + + Can only appear in the following context: + + - As the core_type of a Ppat_constraint node corresponding + to a constraint on a let-binding: let x : 'a1 ... 'an. T + = e ... + + - Under Cfk_virtual for methods (not values). + + - As the core_type of a Pctf_method node. + + - As the core_type of a Pexp_poly node. + + - As the pld_type field of a label_declaration. + + - As a core_type of a Ptyp_object node. + *) + + | Ptyp_package of package_type + (* (module S) *) + | Ptyp_extension of extension + (* [%id] *) + + and package_type = Longident.t loc * (Longident.t loc * core_type) list + (* + (module S) + (module S with type t1 = T1 and ... and tn = Tn) + *) + + and row_field (*IF_CURRENT = Parsetree.row_field *) = + | Rtag of label * attributes * bool * core_type list + (* [`A] ( true, [] ) + [`A of T] ( false, [T] ) + [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) + [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) + + - The 2nd 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) + + - TODO: switch to a record representation, and keep location + *) + | Rinherit of core_type + (* [ T ] *) + + (* Patterns *) + + and pattern (*IF_CURRENT = Parsetree.pattern *) = + { + ppat_desc: pattern_desc; + ppat_loc: Location.t; + ppat_attributes: attributes; (* ... [@id1] [@id2] *) + } + + and pattern_desc (*IF_CURRENT = Parsetree.pattern_desc *) = + | Ppat_any + (* _ *) + | Ppat_var of string loc + (* x *) + | Ppat_alias of pattern * string loc + (* P as 'a *) + | Ppat_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Ppat_interval of constant * constant + (* 'a'..'z' + + Other forms of interval are recognized by the parser + but rejected by the type-checker. *) + | Ppat_tuple of pattern list + (* (P1, ..., Pn) + + Invariant: n >= 2 + *) + | Ppat_construct of Longident.t loc * pattern option + (* C None + C P Some P + C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) + *) + | Ppat_variant of label * pattern option + (* `A (None) + `A P (Some P) + *) + | Ppat_record of (Longident.t loc * pattern) list * closed_flag + (* { l1=P1; ...; ln=Pn } (flag = Closed) + { l1=P1; ...; ln=Pn; _} (flag = Open) + + Invariant: n > 0 + *) + | Ppat_array of pattern list + (* [| P1; ...; Pn |] *) + | Ppat_or of pattern * pattern + (* P1 | P2 *) + | Ppat_constraint of pattern * core_type + (* (P : T) *) + | Ppat_type of Longident.t loc + (* #tconst *) + | Ppat_lazy of pattern + (* lazy P *) + | Ppat_unpack of string loc + (* (module P) + Note: (module P : S) is represented as + Ppat_constraint(Ppat_unpack, Ptyp_package) + *) + | Ppat_exception of pattern + (* exception P *) + | Ppat_extension of extension + (* [%id] *) + | Ppat_open of Longident.t loc * pattern + + (* Value expressions *) + + and expression (*IF_CURRENT = Parsetree.expression *) = + { + pexp_desc: expression_desc; + pexp_loc: Location.t; + pexp_attributes: attributes; (* ... [@id1] [@id2] *) + } + + and expression_desc (*IF_CURRENT = Parsetree.expression_desc *) = + | Pexp_ident of Longident.t loc + (* x + M.x + *) + | Pexp_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Pexp_let of rec_flag * value_binding list * expression + (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) + *) + | Pexp_function of case list + (* function P1 -> E1 | ... | Pn -> En *) + | Pexp_fun of arg_label * expression option * pattern * expression + (* fun P -> E1 (Simple, None) + fun ~l:P -> E1 (Labelled l, None) + fun ?l:P -> E1 (Optional l, None) + fun ?l:(P = E0) -> E1 (Optional l, Some E0) + + Notes: + - If E0 is provided, only Optional is allowed. + - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. + - "let f P = E" is represented using Pexp_fun. + *) + | Pexp_apply of expression * (arg_label * expression) list + (* E0 ~l1:E1 ... ~ln:En + li can be empty (non labeled argument) or start with '?' + (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 + (* (E1, ..., En) + + Invariant: n >= 2 + *) + | Pexp_construct of Longident.t loc * expression option + (* C None + C E Some E + C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) + *) + | Pexp_variant of label * expression option + (* `A (None) + `A E (Some E) + *) + | Pexp_record of (Longident.t loc * expression) list * expression option + (* { l1=P1; ...; ln=Pn } (None) + { E0 with l1=P1; ...; ln=Pn } (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 + (* for i = E1 to E2 do E3 done (flag = Upto) + for i = E1 downto E2 do E3 done (flag = Downto) + *) + | Pexp_constraint of expression * core_type + (* (E : T) *) + | Pexp_coerce of expression * core_type option * core_type + (* (E :> T) (None, T) + (E : T0 :> T) (Some T0, T) + *) + | Pexp_send of expression * string + (* E # m *) + | Pexp_new of Longident.t loc + (* new M.c *) + | Pexp_setinstvar of string loc * expression + (* x <- 2 *) + | Pexp_override of (string loc * expression) list + (* {< x1 = E1; ...; Xn = En >} *) + | Pexp_letmodule of string 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 Cfk_concrete + for methods (not values). *) + | Pexp_object of class_structure + (* object ... end *) + | Pexp_newtype of string * expression + (* fun (type t) -> E *) + | Pexp_pack of module_expr + (* (module ME) + + (module ME : S) is represented as + Pexp_constraint(Pexp_pack, Ptyp_package S) *) + | Pexp_open of override_flag * Longident.t loc * expression + (* let open M in E + let! open M in E + *) + | Pexp_extension of extension + (* [%id] *) + | Pexp_unreachable + (* . *) + + and case (*IF_CURRENT = Parsetree.case *) = (* (P -> E) or (P when E0 -> E) *) + { + pc_lhs: pattern; + pc_guard: expression option; + pc_rhs: expression; + } + + (* 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; + } + + (* + val x: T (prim = []) + external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) + *) + + (* Type declarations *) + + and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = + { + ptype_name: string loc; + ptype_params: (core_type * variance) list; + (* ('a1,...'an) t; None represents _*) + ptype_cstrs: (core_type * core_type * Location.t) list; + (* ... constraint T1=T1' ... constraint Tn=Tn' *) + ptype_kind: type_kind; + ptype_private: private_flag; (* = private ... *) + ptype_manifest: core_type option; (* = T *) + ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) + ptype_loc: Location.t; + } + + (* + type t (abstract, no manifest) + type t = T0 (abstract, manifest=T0) + type t = C of T | ... (variant, no manifest) + type t = T0 = C of T | ... (variant, manifest=T0) + type t = {l: T; ...} (record, no manifest) + type t = T0 = {l : T; ...} (record, manifest=T0) + type t = .. (open, no manifest) + *) + + and type_kind (*IF_CURRENT = Parsetree.type_kind *) = + | Ptype_abstract + | Ptype_variant of constructor_declaration list + (* Invariant: non-empty 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 [@id1] [@id2] : T *) + } + + (* { ...; l: T; ... } (mutable=Immutable) + { ...; mutable l: T; ... } (mutable=Mutable) + + Note: T can be a Ptyp_poly. + *) + + and constructor_declaration (*IF_CURRENT = Parsetree.constructor_declaration *) = + { + pcd_name: string loc; + pcd_args: constructor_arguments; + pcd_res: core_type option; + pcd_loc: Location.t; + pcd_attributes: attributes; (* C [@id1] [@id2] of ... *) + } + + and constructor_arguments (*IF_CURRENT = Parsetree.constructor_arguments *) = + | Pcstr_tuple of core_type list + | Pcstr_record of label_declaration list + + (* + | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) + | C: T0 (res = Some T0, args = []) + | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) + | C of {...} (res = None, args = Pcstr_record) + | C: {...} -> T0 (res = Some T0, args = Pcstr_record) + | C of {...} as t (res = None, args = Pcstr_record) + *) + + and type_extension (*IF_CURRENT = Parsetree.type_extension *) = + { + ptyext_path: Longident.t loc; + ptyext_params: (core_type * variance) list; + ptyext_constructors: extension_constructor list; + ptyext_private: private_flag; + ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + (* + 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 [@id1] [@id2] of ... *) + } + + and extension_constructor_kind (*IF_CURRENT = Parsetree.extension_constructor_kind *) = + Pext_decl of constructor_arguments * core_type option + (* + | C of T1 * ... * Tn ([T1; ...; Tn], None) + | C: T0 ([], Some T0) + | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) + *) + | Pext_rebind of Longident.t loc + (* + | C = D + *) + + (** {2 Class language} *) + + (* 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 + (* T -> CT Simple + ~l:T -> CT Labelled l + ?l:T -> CT Optional l + *) + | Pcty_extension of extension + (* [%id] *) + + and class_signature (*IF_CURRENT = Parsetree.class_signature *) = + { + pcsig_self: core_type; + pcsig_fields: class_type_field list; + } + (* object('selfpat) ... end + object ... end (self = 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 (string * mutable_flag * virtual_flag * core_type) + (* val x: T *) + | Pctf_method of (string * private_flag * virtual_flag * core_type) + (* method x: T + + Note: T can be a 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) list; + pci_name: string loc; + pci_expr: 'a; + pci_loc: Location.t; + pci_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + (* class c = ... + class ['a1,...,'an] c = ... + class virtual c = ... + + Also used for "class type" declaration. + *) + + and class_description = class_type class_infos + + and class_type_declaration = class_type class_infos + + (* 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 + ['a1, ..., 'an] c *) + | Pcl_structure of class_structure + (* object ... end *) + | Pcl_fun of arg_label * expression option * pattern * class_expr + (* fun P -> CE (Simple, None) + fun ~l:P -> CE (Labelled l, None) + fun ?l:P -> CE (Optional l, None) + fun ?l:(P = E0) -> CE (Optional l, Some E0) + *) + | Pcl_apply of class_expr * (arg_label * expression) list + (* 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 + (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive) + *) + | Pcl_constraint of class_expr * class_type + (* (CE : CT) *) + | Pcl_extension of extension + (* [%id] *) + + and class_structure (*IF_CURRENT = Parsetree.class_structure *) = + { + pcstr_self: pattern; + pcstr_fields: class_field list; + } + (* object(selfpat) ... end + object ... end (self = 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 option + (* inherit CE + inherit CE as x + inherit! CE + inherit! CE as x + *) + | Pcf_val of (string loc * mutable_flag * class_field_kind) + (* val x = E + val virtual x: T + *) + | Pcf_method of (string loc * private_flag * class_field_kind) + (* method x = E (E can be a Pexp_poly) + method virtual x: T (T can be a 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 + + (** {2 Module language} *) + + (* 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 + (* S *) + | Pmty_signature of signature + (* sig ... end *) + | Pmty_functor of string loc * module_type option * 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 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_typext of type_extension + (* type t1 += ... *) + | Psig_exception of extension_constructor + (* exception C of T *) + | Psig_module of module_declaration + (* module X : MT *) + | Psig_recmodule of module_declaration list + (* module rec X1 : MT1 and ... and Xn : MTn *) + | Psig_modtype of module_type_declaration + (* module type S = MT + 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 loc; + pmd_type: module_type; + pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) + pmd_loc: Location.t; + } + (* S : MT *) + + 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; + } + (* S = MT + S (abstract module type declaration, pmtd_type = None) + *) + + and open_description (*IF_CURRENT = Parsetree.open_description *) = + { + popen_lid: Longident.t loc; + popen_override: override_flag; + popen_loc: Location.t; + popen_attributes: attributes; + } + (* open! X - popen_override = Override (silences the 'used identifier + shadowing' warning) + open X - popen_override = Fresh + *) + + 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 + (* include MT *) + + and include_declaration = module_expr include_infos + (* 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_typesubst of type_declaration + (* with type t := ... *) + | Pwith_modsubst of string loc * Longident.t loc + (* with module X := Z *) + + (* 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 string loc * module_type option * module_expr + (* functor(X : MT1) -> ME *) + | Pmod_apply of module_expr * module_expr + (* ME1(ME2) *) + | 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 + (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN (flag = 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 extension_constructor + (* 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_description + (* 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_binding (*IF_CURRENT = Parsetree.value_binding *) = + { + pvb_pat: pattern; + pvb_expr: expression; + pvb_attributes: attributes; + pvb_loc: Location.t; + } + + and module_binding (*IF_CURRENT = Parsetree.module_binding *) = + { + pmb_name: string loc; + pmb_expr: module_expr; + pmb_attributes: attributes; + pmb_loc: Location.t; + } + (* X = ME *) + + (** {2 Toplevel} *) + + (* Toplevel phrases *) + + type toplevel_phrase (*IF_CURRENT = Parsetree.toplevel_phrase *) = + | Ptop_def of structure + | Ptop_dir of string * directive_argument + (* #use, #load ... *) + + and directive_argument (*IF_CURRENT = Parsetree.directive_argument *) = + | Pdir_none + | 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 = "Caml1999M020" + let ast_intf_magic_number = "Caml1999N018" +end diff -Nru ppxlib-0.15.0/astlib/ast_405.ml ppxlib-0.24.0/astlib/ast_405.ml --- ppxlib-0.15.0/astlib/ast_405.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/ast_405.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,924 @@ +(**************************************************************************) +(* *) +(* OCaml Migrate Parsetree *) +(* *) +(* Frédéric Bour *) +(* Jérémie Dimino and Leo White, Jane Street Europe *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Alain Frisch, LexiFi *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2017 Institut National de Recherche en Informatique et *) +(* en Automatique (INRIA). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module Asttypes = struct + (** Auxiliary AST types used by parsetree and typedtree. *) + + type constant (*IF_CURRENT = Asttypes.constant *) = + Const_int of int + | Const_char of char + | Const_string of string * 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 + | Invariant +end + +module Parsetree = struct + (** Abstract syntax tree produced by parsing *) + + open Asttypes + + type constant (*IF_CURRENT = Parsetree.constant *) = + Pconst_integer of string * char option + (* 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 + (* 'c' *) + | Pconst_string of string * string option + (* "constant" + {delim|other constant|delim} + *) + | Pconst_float of string * char option + (* 3.4 2e5 1.4e-4 + + Suffixes [g-z][G-Z] are accepted by the parser. + Suffixes are rejected by the typechecker. + *) + + (** {2 Extension points} *) + + type attribute = string loc * payload + (* [@id ARG] + [@@id ARG] + + Metadata containers passed around within the AST. + The compiler ignores unknown attributes. + *) + + and extension = string loc * payload + (* [%id ARG] + [%%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 *) + | PTyp of core_type (* : T *) + | PPat of pattern * expression option (* ? P or ? P when E *) + + (** {2 Core language} *) + + (* Type expressions *) + + and core_type (*IF_CURRENT = Parsetree.core_type *) = + { + ptyp_desc: core_type_desc; + ptyp_loc: Location.t; + ptyp_attributes: attributes; (* ... [@id1] [@id2] *) + } + + and core_type_desc (*IF_CURRENT = Parsetree.core_type_desc *) = + | Ptyp_any + (* _ *) + | Ptyp_var of string + (* 'a *) + | Ptyp_arrow of arg_label * core_type * core_type + (* T1 -> T2 Simple + ~l:T1 -> T2 Labelled + ?l:T1 -> T2 Otional + *) + | Ptyp_tuple of core_type list + (* T1 * ... * Tn + + Invariant: n >= 2 + *) + | Ptyp_constr of Longident.t loc * core_type list + (* tconstr + T tconstr + (T1, ..., Tn) tconstr + *) + | Ptyp_object of (string loc * attributes * core_type) list * closed_flag + (* < l1:T1; ...; ln:Tn > (flag = Closed) + < l1:T1; ...; ln:Tn; .. > (flag = Open) + *) + | Ptyp_class of Longident.t loc * core_type list + (* #tconstr + T #tconstr + (T1, ..., Tn) #tconstr + *) + | Ptyp_alias of core_type * string + (* T as 'a *) + | Ptyp_variant of row_field list * closed_flag * label list option + (* [ `A|`B ] (flag = Closed; labels = None) + [> `A|`B ] (flag = Open; labels = None) + [< `A|`B ] (flag = Closed; labels = Some []) + [< `A|`B > `X `Y ](flag = Closed; labels = 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 Ppat_constraint node corresponding + to a constraint on a let-binding: let x : 'a1 ... 'an. T + = e ... + + - Under Cfk_virtual for methods (not values). + + - As the core_type of a Pctf_method node. + + - As the core_type of a Pexp_poly node. + + - As the pld_type field of a label_declaration. + + - As a core_type of a Ptyp_object node. + *) + + | Ptyp_package of package_type + (* (module S) *) + | Ptyp_extension of extension + (* [%id] *) + + and package_type = Longident.t loc * (Longident.t loc * core_type) list + (* + (module S) + (module S with type t1 = T1 and ... and tn = Tn) + *) + + and row_field (*IF_CURRENT = Parsetree.row_field *) = + | Rtag of label * attributes * bool * core_type list + (* [`A] ( true, [] ) + [`A of T] ( false, [T] ) + [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) + [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) + + - The 2nd 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) + + - TODO: switch to a record representation, and keep location + *) + | Rinherit of core_type + (* [ T ] *) + + (* Patterns *) + + and pattern (*IF_CURRENT = Parsetree.pattern *) = + { + ppat_desc: pattern_desc; + ppat_loc: Location.t; + ppat_attributes: attributes; (* ... [@id1] [@id2] *) + } + + and pattern_desc (*IF_CURRENT = Parsetree.pattern_desc *) = + | Ppat_any + (* _ *) + | Ppat_var of string loc + (* x *) + | Ppat_alias of pattern * string loc + (* P as 'a *) + | Ppat_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Ppat_interval of constant * constant + (* 'a'..'z' + + Other forms of interval are recognized by the parser + but rejected by the type-checker. *) + | Ppat_tuple of pattern list + (* (P1, ..., Pn) + + Invariant: n >= 2 + *) + | Ppat_construct of Longident.t loc * pattern option + (* C None + C P Some P + C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) + *) + | Ppat_variant of label * pattern option + (* `A (None) + `A P (Some P) + *) + | Ppat_record of (Longident.t loc * pattern) list * closed_flag + (* { l1=P1; ...; ln=Pn } (flag = Closed) + { l1=P1; ...; ln=Pn; _} (flag = Open) + + Invariant: n > 0 + *) + | Ppat_array of pattern list + (* [| P1; ...; Pn |] *) + | Ppat_or of pattern * pattern + (* P1 | P2 *) + | Ppat_constraint of pattern * core_type + (* (P : T) *) + | Ppat_type of Longident.t loc + (* #tconst *) + | Ppat_lazy of pattern + (* lazy P *) + | Ppat_unpack of string loc + (* (module P) + Note: (module P : S) is represented as + Ppat_constraint(Ppat_unpack, Ptyp_package) + *) + | Ppat_exception of pattern + (* exception P *) + | Ppat_extension of extension + (* [%id] *) + | Ppat_open of Longident.t loc * pattern + (* M.(P) *) + + (* Value expressions *) + + and expression (*IF_CURRENT = Parsetree.expression *) = + { + pexp_desc: expression_desc; + pexp_loc: Location.t; + pexp_attributes: attributes; (* ... [@id1] [@id2] *) + } + + and expression_desc (*IF_CURRENT = Parsetree.expression_desc *) = + | Pexp_ident of Longident.t loc + (* x + M.x + *) + | Pexp_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Pexp_let of rec_flag * value_binding list * expression + (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) + *) + | Pexp_function of case list + (* function P1 -> E1 | ... | Pn -> En *) + | Pexp_fun of arg_label * expression option * pattern * expression + (* fun P -> E1 (Simple, None) + fun ~l:P -> E1 (Labelled l, None) + fun ?l:P -> E1 (Optional l, None) + fun ?l:(P = E0) -> E1 (Optional l, Some E0) + + Notes: + - If E0 is provided, only Optional is allowed. + - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. + - "let f P = E" is represented using Pexp_fun. + *) + | Pexp_apply of expression * (arg_label * expression) list + (* E0 ~l1:E1 ... ~ln:En + li can be empty (non labeled argument) or start with '?' + (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 + (* (E1, ..., En) + + Invariant: n >= 2 + *) + | Pexp_construct of Longident.t loc * expression option + (* C None + C E Some E + C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) + *) + | Pexp_variant of label * expression option + (* `A (None) + `A E (Some E) + *) + | Pexp_record of (Longident.t loc * expression) list * expression option + (* { l1=P1; ...; ln=Pn } (None) + { E0 with l1=P1; ...; ln=Pn } (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 + (* for i = E1 to E2 do E3 done (flag = Upto) + for i = E1 downto E2 do E3 done (flag = Downto) + *) + | Pexp_constraint of expression * core_type + (* (E : T) *) + | Pexp_coerce of expression * core_type option * core_type + (* (E :> T) (None, T) + (E : T0 :> T) (Some T0, T) + *) + | Pexp_send of expression * string loc + (* E # m *) + | Pexp_new of Longident.t loc + (* new M.c *) + | Pexp_setinstvar of string loc * expression + (* x <- 2 *) + | Pexp_override of (string loc * expression) list + (* {< x1 = E1; ...; Xn = En >} *) + | Pexp_letmodule of string 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 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, Ptyp_package S) *) + | Pexp_open of override_flag * Longident.t loc * expression + (* M.(E) + let open M in E + let! open M in E *) + | Pexp_extension of extension + (* [%id] *) + | Pexp_unreachable + (* . *) + + and case (*IF_CURRENT = Parsetree.case *) = (* (P -> E) or (P when E0 -> E) *) + { + pc_lhs: pattern; + pc_guard: expression option; + pc_rhs: expression; + } + + (* 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; + } + + (* + val x: T (prim = []) + external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) + *) + + (* Type declarations *) + + and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = + { + ptype_name: string loc; + ptype_params: (core_type * variance) list; + (* ('a1,...'an) t; None represents _*) + ptype_cstrs: (core_type * core_type * Location.t) list; + (* ... constraint T1=T1' ... constraint Tn=Tn' *) + ptype_kind: type_kind; + ptype_private: private_flag; (* = private ... *) + ptype_manifest: core_type option; (* = T *) + ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) + ptype_loc: Location.t; + } + + (* + type t (abstract, no manifest) + type t = T0 (abstract, manifest=T0) + type t = C of T | ... (variant, no manifest) + type t = T0 = C of T | ... (variant, manifest=T0) + type t = {l: T; ...} (record, no manifest) + type t = T0 = {l : T; ...} (record, manifest=T0) + type t = .. (open, no manifest) + *) + + and type_kind (*IF_CURRENT = Parsetree.type_kind *) = + | Ptype_abstract + | Ptype_variant of constructor_declaration list + (* Invariant: non-empty 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 [@id1] [@id2] : T *) + } + + (* { ...; l: T; ... } (mutable=Immutable) + { ...; mutable l: T; ... } (mutable=Mutable) + + Note: T can be a Ptyp_poly. + *) + + and constructor_declaration (*IF_CURRENT = Parsetree.constructor_declaration *) = + { + pcd_name: string loc; + pcd_args: constructor_arguments; + pcd_res: core_type option; + pcd_loc: Location.t; + pcd_attributes: attributes; (* C [@id1] [@id2] of ... *) + } + + and constructor_arguments (*IF_CURRENT = Parsetree.constructor_arguments *) = + | Pcstr_tuple of core_type list + | Pcstr_record of label_declaration list + + (* + | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) + | C: T0 (res = Some T0, args = []) + | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) + | C of {...} (res = None, args = Pcstr_record) + | C: {...} -> T0 (res = Some T0, args = Pcstr_record) + | C of {...} as t (res = None, args = Pcstr_record) + *) + + and type_extension (*IF_CURRENT = Parsetree.type_extension *) = + { + ptyext_path: Longident.t loc; + ptyext_params: (core_type * variance) list; + ptyext_constructors: extension_constructor list; + ptyext_private: private_flag; + ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + (* + 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 [@id1] [@id2] of ... *) + } + + and extension_constructor_kind (*IF_CURRENT = Parsetree.extension_constructor_kind *) = + Pext_decl of constructor_arguments * core_type option + (* + | C of T1 * ... * Tn ([T1; ...; Tn], None) + | C: T0 ([], Some T0) + | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) + *) + | Pext_rebind of Longident.t loc + (* + | C = D + *) + + (** {2 Class language} *) + + (* 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 + (* T -> CT Simple + ~l:T -> CT Labelled l + ?l:T -> CT Optional l + *) + | Pcty_extension of extension + (* [%id] *) + + and class_signature (*IF_CURRENT = Parsetree.class_signature *) = + { + pcsig_self: core_type; + pcsig_fields: class_type_field list; + } + (* object('selfpat) ... end + object ... end (self = 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 (string loc * mutable_flag * virtual_flag * core_type) + (* val x: T *) + | Pctf_method of (string loc * private_flag * virtual_flag * core_type) + (* method x: T + + Note: T can be a 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) list; + pci_name: string loc; + pci_expr: 'a; + pci_loc: Location.t; + pci_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + (* class c = ... + class ['a1,...,'an] c = ... + class virtual c = ... + + Also used for "class type" declaration. + *) + + and class_description = class_type class_infos + + and class_type_declaration = class_type class_infos + + (* 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 + ['a1, ..., 'an] c *) + | Pcl_structure of class_structure + (* object ... end *) + | Pcl_fun of arg_label * expression option * pattern * class_expr + (* fun P -> CE (Simple, None) + fun ~l:P -> CE (Labelled l, None) + fun ?l:P -> CE (Optional l, None) + fun ?l:(P = E0) -> CE (Optional l, Some E0) + *) + | Pcl_apply of class_expr * (arg_label * expression) list + (* 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 + (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive) + *) + | Pcl_constraint of class_expr * class_type + (* (CE : CT) *) + | Pcl_extension of extension + (* [%id] *) + + and class_structure (*IF_CURRENT = Parsetree.class_structure *) = + { + pcstr_self: pattern; + pcstr_fields: class_field list; + } + (* object(selfpat) ... end + object ... end (self = 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 + (* inherit CE + inherit CE as x + inherit! CE + inherit! CE as x + *) + | Pcf_val of (string loc * mutable_flag * class_field_kind) + (* val x = E + val virtual x: T + *) + | Pcf_method of (string loc * private_flag * class_field_kind) + (* method x = E (E can be a Pexp_poly) + method virtual x: T (T can be a 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 + + (** {2 Module language} *) + + (* 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 + (* S *) + | Pmty_signature of signature + (* sig ... end *) + | Pmty_functor of string loc * module_type option * 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 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_typext of type_extension + (* type t1 += ... *) + | Psig_exception of extension_constructor + (* exception C of T *) + | Psig_module of module_declaration + (* module X : MT *) + | Psig_recmodule of module_declaration list + (* module rec X1 : MT1 and ... and Xn : MTn *) + | Psig_modtype of module_type_declaration + (* module type S = MT + 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 loc; + pmd_type: module_type; + pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) + pmd_loc: Location.t; + } + (* S : MT *) + + 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; + } + (* S = MT + S (abstract module type declaration, pmtd_type = None) + *) + + and open_description (*IF_CURRENT = Parsetree.open_description *) = + { + popen_lid: Longident.t loc; + popen_override: override_flag; + popen_loc: Location.t; + popen_attributes: attributes; + } + (* open! X - popen_override = Override (silences the 'used identifier + shadowing' warning) + open X - popen_override = Fresh + *) + + 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 + (* include MT *) + + and include_declaration = module_expr include_infos + (* 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_typesubst of type_declaration + (* with type t := ... *) + | Pwith_modsubst of string loc * Longident.t loc + (* with module X := Z *) + + (* 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 string loc * module_type option * module_expr + (* functor(X : MT1) -> ME *) + | Pmod_apply of module_expr * module_expr + (* ME1(ME2) *) + | 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 + (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN (flag = 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 extension_constructor + (* 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_description + (* 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_binding (*IF_CURRENT = Parsetree.value_binding *) = + { + pvb_pat: pattern; + pvb_expr: expression; + pvb_attributes: attributes; + pvb_loc: Location.t; + } + + and module_binding (*IF_CURRENT = Parsetree.module_binding *) = + { + pmb_name: string loc; + pmb_expr: module_expr; + pmb_attributes: attributes; + pmb_loc: Location.t; + } + (* X = ME *) + + (** {2 Toplevel} *) + + (* Toplevel phrases *) + + type toplevel_phrase (*IF_CURRENT = Parsetree.toplevel_phrase *) = + | Ptop_def of structure + | Ptop_dir of string * directive_argument + (* #use, #load ... *) + + and directive_argument (*IF_CURRENT = Parsetree.directive_argument *) = + | Pdir_none + | 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 = "Caml1999M020" + let ast_intf_magic_number = "Caml1999N018" +end diff -Nru ppxlib-0.15.0/astlib/ast_406.ml ppxlib-0.24.0/astlib/ast_406.ml --- ppxlib-0.15.0/astlib/ast_406.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/ast_406.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,943 @@ +(**************************************************************************) +(* *) +(* OCaml Migrate Parsetree *) +(* *) +(* Frédéric Bour *) +(* Jérémie Dimino and Leo White, Jane Street Europe *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Alain Frisch, LexiFi *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2017 Institut National de Recherche en Informatique et *) +(* en Automatique (INRIA). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Ast ported on Mon Oct 2 11:25:57 CEST 2017 + OCaml trunk was: + commit 65940a2c6be43c42f75c6c6b255974f7e6de03ca (HEAD -> 4.06, origin/4.06) + Author: Christophe Raffalli + Date: Sun Oct 1 18:27:07 2017 +0200 + + fixed position of last optional last semicolumn in sequence (#1387) +*) + +module Asttypes = struct + (** Auxiliary AST types used by parsetree and typedtree. *) + + type constant (*IF_CURRENT = Asttypes.constant *) = + Const_int of int + | Const_char of char + | Const_string of string * 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 + | Invariant +end + +module Parsetree = struct + (** Abstract syntax tree produced by parsing *) + + open Asttypes + + type constant (*IF_CURRENT = Parsetree.constant *) = + Pconst_integer of string * char option + (* 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 + (* 'c' *) + | Pconst_string of string * string option + (* "constant" + {delim|other constant|delim} + *) + | Pconst_float of string * char option + (* 3.4 2e5 1.4e-4 + + Suffixes [g-z][G-Z] are accepted by the parser. + Suffixes are rejected by the typechecker. + *) + + (** {2 Extension points} *) + + type attribute = string loc * payload + (* [@id ARG] + [@@id ARG] + + Metadata containers passed around within the AST. + The compiler ignores unknown attributes. + *) + + and extension = string loc * payload + (* [%id ARG] + [%%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 *) + | PTyp of core_type (* : T *) + | PPat of pattern * expression option (* ? P or ? P when E *) + + (** {2 Core language} *) + + (* Type expressions *) + + and core_type (*IF_CURRENT = Parsetree.core_type *) = + { + ptyp_desc: core_type_desc; + ptyp_loc: Location.t; + ptyp_attributes: attributes; (* ... [@id1] [@id2] *) + } + + and core_type_desc (*IF_CURRENT = Parsetree.core_type_desc *) = + | Ptyp_any + (* _ *) + | Ptyp_var of string + (* 'a *) + | Ptyp_arrow of arg_label * core_type * core_type + (* T1 -> T2 Simple + ~l:T1 -> T2 Labelled + ?l:T1 -> T2 Optional + *) + | Ptyp_tuple of core_type list + (* T1 * ... * Tn + + Invariant: n >= 2 + *) + | Ptyp_constr of Longident.t loc * core_type list + (* tconstr + T tconstr + (T1, ..., Tn) tconstr + *) + | Ptyp_object of object_field list * closed_flag + (* < l1:T1; ...; ln:Tn > (flag = Closed) + < l1:T1; ...; ln:Tn; .. > (flag = Open) + *) + | Ptyp_class of Longident.t loc * core_type list + (* #tconstr + T #tconstr + (T1, ..., Tn) #tconstr + *) + | Ptyp_alias of core_type * string + (* T as 'a *) + | Ptyp_variant of row_field list * closed_flag * label list option + (* [ `A|`B ] (flag = Closed; labels = None) + [> `A|`B ] (flag = Open; labels = None) + [< `A|`B ] (flag = Closed; labels = Some []) + [< `A|`B > `X `Y ](flag = Closed; labels = 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 Ppat_constraint node corresponding + to a constraint on a let-binding: let x : 'a1 ... 'an. T + = e ... + + - Under Cfk_virtual for methods (not values). + + - As the core_type of a Pctf_method node. + + - As the core_type of a Pexp_poly node. + + - As the pld_type field of a label_declaration. + + - As a core_type of a Ptyp_object node. + *) + + | Ptyp_package of package_type + (* (module S) *) + | Ptyp_extension of extension + (* [%id] *) + + and package_type = Longident.t loc * (Longident.t loc * core_type) list + (* + (module S) + (module S with type t1 = T1 and ... and tn = Tn) + *) + + and row_field (*IF_CURRENT = Parsetree.row_field *) = + | Rtag of label loc * attributes * bool * core_type list + (* [`A] ( true, [] ) + [`A of T] ( false, [T] ) + [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) + [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) + + - The 2nd 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) + + - TODO: switch to a record representation, and keep location + *) + | Rinherit of core_type + (* [ T ] *) + + and object_field (*IF_CURRENT = Parsetree.object_field *) = + | Otag of label loc * attributes * core_type + | Oinherit of core_type + + (* Patterns *) + + and pattern (*IF_CURRENT = Parsetree.pattern *) = + { + ppat_desc: pattern_desc; + ppat_loc: Location.t; + ppat_attributes: attributes; (* ... [@id1] [@id2] *) + } + + and pattern_desc (*IF_CURRENT = Parsetree.pattern_desc *) = + | Ppat_any + (* _ *) + | Ppat_var of string loc + (* x *) + | Ppat_alias of pattern * string loc + (* P as 'a *) + | Ppat_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Ppat_interval of constant * constant + (* 'a'..'z' + + Other forms of interval are recognized by the parser + but rejected by the type-checker. *) + | Ppat_tuple of pattern list + (* (P1, ..., Pn) + + Invariant: n >= 2 + *) + | Ppat_construct of Longident.t loc * pattern option + (* C None + C P Some P + C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) + *) + | Ppat_variant of label * pattern option + (* `A (None) + `A P (Some P) + *) + | Ppat_record of (Longident.t loc * pattern) list * closed_flag + (* { l1=P1; ...; ln=Pn } (flag = Closed) + { l1=P1; ...; ln=Pn; _} (flag = Open) + + Invariant: n > 0 + *) + | Ppat_array of pattern list + (* [| P1; ...; Pn |] *) + | Ppat_or of pattern * pattern + (* P1 | P2 *) + | Ppat_constraint of pattern * core_type + (* (P : T) *) + | Ppat_type of Longident.t loc + (* #tconst *) + | Ppat_lazy of pattern + (* lazy P *) + | Ppat_unpack of string loc + (* (module P) + Note: (module P : S) is represented as + Ppat_constraint(Ppat_unpack, Ptyp_package) + *) + | Ppat_exception of pattern + (* exception P *) + | Ppat_extension of extension + (* [%id] *) + | Ppat_open of Longident.t loc * pattern + (* M.(P) *) + + (* Value expressions *) + + and expression (*IF_CURRENT = Parsetree.expression *) = + { + pexp_desc: expression_desc; + pexp_loc: Location.t; + pexp_attributes: attributes; (* ... [@id1] [@id2] *) + } + + and expression_desc (*IF_CURRENT = Parsetree.expression_desc *) = + | Pexp_ident of Longident.t loc + (* x + M.x + *) + | Pexp_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Pexp_let of rec_flag * value_binding list * expression + (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) + *) + | Pexp_function of case list + (* function P1 -> E1 | ... | Pn -> En *) + | Pexp_fun of arg_label * expression option * pattern * expression + (* fun P -> E1 (Simple, None) + fun ~l:P -> E1 (Labelled l, None) + fun ?l:P -> E1 (Optional l, None) + fun ?l:(P = E0) -> E1 (Optional l, Some E0) + + Notes: + - If E0 is provided, only Optional is allowed. + - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. + - "let f P = E" is represented using Pexp_fun. + *) + | Pexp_apply of expression * (arg_label * expression) list + (* E0 ~l1:E1 ... ~ln:En + li can be empty (non labeled argument) or start with '?' + (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 + (* (E1, ..., En) + + Invariant: n >= 2 + *) + | Pexp_construct of Longident.t loc * expression option + (* C None + C E Some E + C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) + *) + | Pexp_variant of label * expression option + (* `A (None) + `A E (Some E) + *) + | Pexp_record of (Longident.t loc * expression) list * expression option + (* { l1=P1; ...; ln=Pn } (None) + { E0 with l1=P1; ...; ln=Pn } (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 + (* for i = E1 to E2 do E3 done (flag = Upto) + for i = E1 downto E2 do E3 done (flag = Downto) + *) + | Pexp_constraint of expression * core_type + (* (E : T) *) + | Pexp_coerce of expression * core_type option * core_type + (* (E :> T) (None, T) + (E : T0 :> T) (Some T0, T) + *) + | 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 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 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, Ptyp_package S) *) + | Pexp_open of override_flag * Longident.t loc * expression + (* M.(E) + let open M in E + let! open M in E *) + | Pexp_extension of extension + (* [%id] *) + | Pexp_unreachable + (* . *) + + and case (*IF_CURRENT = Parsetree.case *) = (* (P -> E) or (P when E0 -> E) *) + { + pc_lhs: pattern; + pc_guard: expression option; + pc_rhs: expression; + } + + (* 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; + } + + (* + val x: T (prim = []) + external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) + *) + + (* Type declarations *) + + and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = + { + ptype_name: string loc; + ptype_params: (core_type * variance) list; + (* ('a1,...'an) t; None represents _*) + ptype_cstrs: (core_type * core_type * Location.t) list; + (* ... constraint T1=T1' ... constraint Tn=Tn' *) + ptype_kind: type_kind; + ptype_private: private_flag; (* = private ... *) + ptype_manifest: core_type option; (* = T *) + ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) + ptype_loc: Location.t; + } + + (* + type t (abstract, no manifest) + type t = T0 (abstract, manifest=T0) + type t = C of T | ... (variant, no manifest) + type t = T0 = C of T | ... (variant, manifest=T0) + type t = {l: T; ...} (record, no manifest) + type t = T0 = {l : T; ...} (record, manifest=T0) + type t = .. (open, no manifest) + *) + + and type_kind (*IF_CURRENT = Parsetree.type_kind *) = + | Ptype_abstract + | Ptype_variant of constructor_declaration list + (* Invariant: non-empty 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; ... } (mutable=Immutable) + { ...; mutable l: T; ... } (mutable=Mutable) + + Note: T can be a Ptyp_poly. + *) + + and constructor_declaration (*IF_CURRENT = Parsetree.constructor_declaration *) = + { + pcd_name: string loc; + 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 + + (* + | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) + | C: T0 (res = Some T0, args = []) + | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) + | C of {...} (res = None, args = Pcstr_record) + | C: {...} -> T0 (res = Some T0, args = Pcstr_record) + | C of {...} as t (res = None, args = Pcstr_record) + *) + + and type_extension (*IF_CURRENT = Parsetree.type_extension *) = + { + ptyext_path: Longident.t loc; + ptyext_params: (core_type * variance) list; + ptyext_constructors: extension_constructor list; + ptyext_private: private_flag; + ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + (* + 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 extension_constructor_kind (*IF_CURRENT = Parsetree.extension_constructor_kind *) = + Pext_decl of constructor_arguments * core_type option + (* + | C of T1 * ... * Tn ([T1; ...; Tn], None) + | C: T0 ([], Some T0) + | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) + *) + | Pext_rebind of Longident.t loc + (* + | C = D + *) + + (** {2 Class language} *) + + (* 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 + (* T -> CT Simple + ~l:T -> CT Labelled l + ?l:T -> CT Optional l + *) + | Pcty_extension of extension + (* [%id] *) + | Pcty_open of override_flag * Longident.t loc * 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; + } + (* object('selfpat) ... end + object ... end (self = 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 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) list; + pci_name: string loc; + pci_expr: 'a; + pci_loc: Location.t; + pci_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + (* class c = ... + class ['a1,...,'an] c = ... + class virtual c = ... + + Also used for "class type" declaration. + *) + + and class_description = class_type class_infos + + and class_type_declaration = class_type class_infos + + (* 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 + ['a1, ..., 'an] c *) + | Pcl_structure of class_structure + (* object ... end *) + | Pcl_fun of arg_label * expression option * pattern * class_expr + (* fun P -> CE (Simple, None) + fun ~l:P -> CE (Labelled l, None) + fun ?l:P -> CE (Optional l, None) + fun ?l:(P = E0) -> CE (Optional l, Some E0) + *) + | Pcl_apply of class_expr * (arg_label * expression) list + (* 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 + (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive) + *) + | Pcl_constraint of class_expr * class_type + (* (CE : CT) *) + | Pcl_extension of extension + (* [%id] *) + | Pcl_open of override_flag * Longident.t loc * class_expr + (* let open M in CE *) + + + and class_structure (*IF_CURRENT = Parsetree.class_structure *) = + { + pcstr_self: pattern; + pcstr_fields: class_field list; + } + (* object(selfpat) ... end + object ... end (self = 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 + (* inherit CE + inherit CE as x + inherit! CE + inherit! CE as x + *) + | Pcf_val of (label loc * mutable_flag * class_field_kind) + (* val x = E + val virtual x: T + *) + | Pcf_method of (label loc * private_flag * class_field_kind) + (* method x = E (E can be a Pexp_poly) + method virtual x: T (T can be a 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 + + (** {2 Module language} *) + + (* 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 + (* S *) + | Pmty_signature of signature + (* sig ... end *) + | Pmty_functor of string loc * module_type option * 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 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_typext of type_extension + (* type t1 += ... *) + | Psig_exception of extension_constructor + (* exception C of T *) + | Psig_module of module_declaration + (* module X : MT *) + | Psig_recmodule of module_declaration list + (* module rec X1 : MT1 and ... and Xn : MTn *) + | Psig_modtype of module_type_declaration + (* module type S = MT + 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 loc; + pmd_type: module_type; + pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) + pmd_loc: Location.t; + } + (* S : MT *) + + 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; + } + (* S = MT + S (abstract module type declaration, pmtd_type = None) + *) + + and open_description (*IF_CURRENT = Parsetree.open_description *) = + { + popen_lid: Longident.t loc; + popen_override: override_flag; + popen_loc: Location.t; + popen_attributes: attributes; + } + (* open! X - popen_override = Override (silences the 'used identifier + shadowing' warning) + open X - popen_override = Fresh + *) + + 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 + (* include MT *) + + and include_declaration = module_expr include_infos + (* 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_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 *) + + (* 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 string loc * module_type option * module_expr + (* functor(X : MT1) -> ME *) + | Pmod_apply of module_expr * module_expr + (* ME1(ME2) *) + | 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 + (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN (flag = 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 extension_constructor + (* 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_description + (* 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_binding (*IF_CURRENT = Parsetree.value_binding *) = + { + pvb_pat: pattern; + pvb_expr: expression; + pvb_attributes: attributes; + pvb_loc: Location.t; + } + + and module_binding (*IF_CURRENT = Parsetree.module_binding *) = + { + pmb_name: string loc; + pmb_expr: module_expr; + pmb_attributes: attributes; + pmb_loc: Location.t; + } + (* X = ME *) + + (** {2 Toplevel} *) + + (* Toplevel phrases *) + + type toplevel_phrase (*IF_CURRENT = Parsetree.toplevel_phrase *) = + | Ptop_def of structure + | Ptop_dir of string * directive_argument + (* #use, #load ... *) + + and directive_argument (*IF_CURRENT = Parsetree.directive_argument *) = + | Pdir_none + | 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 = "Caml1999M022" + let ast_intf_magic_number = "Caml1999N022" +end diff -Nru ppxlib-0.15.0/astlib/ast_407.ml ppxlib-0.24.0/astlib/ast_407.ml --- ppxlib-0.15.0/astlib/ast_407.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/ast_407.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,941 @@ +(**************************************************************************) +(* *) +(* OCaml Migrate Parsetree *) +(* *) +(* Frédéric Bour, Facebook *) +(* Jérémie Dimino and Leo White, Jane Street Europe *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Alain Frisch, LexiFi *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique (INRIA). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Ast ported on Wed Apr 18 10:33:29 BST 2018 + OCaml trunk was: + commit c0bd6a27e138911560f43dc75d5fde2ade4d6cfe (HEAD, tag: 4.07.0+beta2) + Author: Damien Doligez + Date: Tue Apr 10 14:50:48 2018 +0200 + + change VERSION for 4.07.0+beta2 +*) + +module Asttypes = struct + (** Auxiliary AST types used by parsetree and typedtree. *) + + type constant (*IF_CURRENT = Asttypes.constant *) = + Const_int of int + | Const_char of char + | Const_string of string * 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 + | Invariant +end + +module Parsetree = struct + (** Abstract syntax tree produced by parsing *) + + open Asttypes + + type constant (*IF_CURRENT = Parsetree.constant *) = + Pconst_integer of string * char option + (* 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 + (* 'c' *) + | Pconst_string of string * string option + (* "constant" + {delim|other constant|delim} + *) + | Pconst_float of string * char option + (* 3.4 2e5 1.4e-4 + + Suffixes [g-z][G-Z] are accepted by the parser. + Suffixes are rejected by the typechecker. + *) + + (** {1 Extension points} *) + + type attribute = string loc * payload + (* [@id ARG] + [@@id ARG] + + Metadata containers passed around within the AST. + The compiler ignores unknown attributes. + *) + + and extension = string loc * payload + (* [%id ARG] + [%%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 *) + | PTyp of core_type (* : T *) + | PPat of pattern * expression option (* ? P or ? P when E *) + + (** {1 Core language} *) + + (* Type expressions *) + + and core_type (*IF_CURRENT = Parsetree.core_type *) = + { + ptyp_desc: core_type_desc; + ptyp_loc: Location.t; + ptyp_attributes: attributes; (* ... [@id1] [@id2] *) + } + + and core_type_desc (*IF_CURRENT = Parsetree.core_type_desc *) = + | Ptyp_any + (* _ *) + | Ptyp_var of string + (* 'a *) + | Ptyp_arrow of arg_label * core_type * core_type + (* T1 -> T2 Simple + ~l:T1 -> T2 Labelled + ?l:T1 -> T2 Optional + *) + | Ptyp_tuple of core_type list + (* T1 * ... * Tn + + Invariant: n >= 2 + *) + | Ptyp_constr of Longident.t loc * core_type list + (* tconstr + T tconstr + (T1, ..., Tn) tconstr + *) + | Ptyp_object of object_field list * closed_flag + (* < l1:T1; ...; ln:Tn > (flag = Closed) + < l1:T1; ...; ln:Tn; .. > (flag = Open) + *) + | Ptyp_class of Longident.t loc * core_type list + (* #tconstr + T #tconstr + (T1, ..., Tn) #tconstr + *) + | Ptyp_alias of core_type * string + (* T as 'a *) + | Ptyp_variant of row_field list * closed_flag * label list option + (* [ `A|`B ] (flag = Closed; labels = None) + [> `A|`B ] (flag = Open; labels = None) + [< `A|`B ] (flag = Closed; labels = Some []) + [< `A|`B > `X `Y ](flag = Closed; labels = 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 Ppat_constraint node corresponding + to a constraint on a let-binding: let x : 'a1 ... 'an. T + = e ... + + - Under Cfk_virtual for methods (not values). + + - As the core_type of a Pctf_method node. + + - As the core_type of a Pexp_poly node. + + - As the pld_type field of a label_declaration. + + - As a core_type of a Ptyp_object node. + *) + + | Ptyp_package of package_type + (* (module S) *) + | Ptyp_extension of extension + (* [%id] *) + + and package_type = Longident.t loc * (Longident.t loc * core_type) list + (* + (module S) + (module S with type t1 = T1 and ... and tn = Tn) + *) + + and row_field (*IF_CURRENT = Parsetree.row_field *) = + | Rtag of label loc * attributes * bool * core_type list + (* [`A] ( true, [] ) + [`A of T] ( false, [T] ) + [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) + [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) + + - The 2nd 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) + + - TODO: switch to a record representation, and keep location + *) + | Rinherit of core_type + (* [ T ] *) + + and object_field (*IF_CURRENT = Parsetree.object_field *) = + | Otag of label loc * attributes * core_type + | Oinherit of core_type + + (* Patterns *) + + and pattern (*IF_CURRENT = Parsetree.pattern *) = + { + ppat_desc: pattern_desc; + ppat_loc: Location.t; + ppat_attributes: attributes; (* ... [@id1] [@id2] *) + } + + and pattern_desc (*IF_CURRENT = Parsetree.pattern_desc *) = + | Ppat_any + (* _ *) + | Ppat_var of string loc + (* x *) + | Ppat_alias of pattern * string loc + (* P as 'a *) + | Ppat_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Ppat_interval of constant * constant + (* 'a'..'z' + + Other forms of interval are recognized by the parser + but rejected by the type-checker. *) + | Ppat_tuple of pattern list + (* (P1, ..., Pn) + + Invariant: n >= 2 + *) + | Ppat_construct of Longident.t loc * pattern option + (* C None + C P Some P + C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) + *) + | Ppat_variant of label * pattern option + (* `A (None) + `A P (Some P) + *) + | Ppat_record of (Longident.t loc * pattern) list * closed_flag + (* { l1=P1; ...; ln=Pn } (flag = Closed) + { l1=P1; ...; ln=Pn; _} (flag = Open) + + Invariant: n > 0 + *) + | Ppat_array of pattern list + (* [| P1; ...; Pn |] *) + | Ppat_or of pattern * pattern + (* P1 | P2 *) + | Ppat_constraint of pattern * core_type + (* (P : T) *) + | Ppat_type of Longident.t loc + (* #tconst *) + | Ppat_lazy of pattern + (* lazy P *) + | Ppat_unpack of string loc + (* (module P) + Note: (module P : S) is represented as + Ppat_constraint(Ppat_unpack, Ptyp_package) + *) + | Ppat_exception of pattern + (* exception P *) + | Ppat_extension of extension + (* [%id] *) + | Ppat_open of Longident.t loc * pattern + (* M.(P) *) + + (* Value expressions *) + + and expression (*IF_CURRENT = Parsetree.expression *) = + { + pexp_desc: expression_desc; + pexp_loc: Location.t; + pexp_attributes: attributes; (* ... [@id1] [@id2] *) + } + + and expression_desc (*IF_CURRENT = Parsetree.expression_desc *) = + | Pexp_ident of Longident.t loc + (* x + M.x + *) + | Pexp_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Pexp_let of rec_flag * value_binding list * expression + (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) + *) + | Pexp_function of case list + (* function P1 -> E1 | ... | Pn -> En *) + | Pexp_fun of arg_label * expression option * pattern * expression + (* fun P -> E1 (Simple, None) + fun ~l:P -> E1 (Labelled l, None) + fun ?l:P -> E1 (Optional l, None) + fun ?l:(P = E0) -> E1 (Optional l, Some E0) + + Notes: + - If E0 is provided, only Optional is allowed. + - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. + - "let f P = E" is represented using Pexp_fun. + *) + | Pexp_apply of expression * (arg_label * expression) list + (* E0 ~l1:E1 ... ~ln:En + li can be empty (non labeled argument) or start with '?' + (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 + (* (E1, ..., En) + + Invariant: n >= 2 + *) + | Pexp_construct of Longident.t loc * expression option + (* C None + C E Some E + C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) + *) + | Pexp_variant of label * expression option + (* `A (None) + `A E (Some E) + *) + | Pexp_record of (Longident.t loc * expression) list * expression option + (* { l1=P1; ...; ln=Pn } (None) + { E0 with l1=P1; ...; ln=Pn } (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 + (* for i = E1 to E2 do E3 done (flag = Upto) + for i = E1 downto E2 do E3 done (flag = Downto) + *) + | Pexp_constraint of expression * core_type + (* (E : T) *) + | Pexp_coerce of expression * core_type option * core_type + (* (E :> T) (None, T) + (E : T0 :> T) (Some T0, T) + *) + | 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 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 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, Ptyp_package S) *) + | Pexp_open of override_flag * Longident.t loc * expression + (* M.(E) + let open M in E + let! open M in E *) + | Pexp_extension of extension + (* [%id] *) + | Pexp_unreachable + (* . *) + + and case (*IF_CURRENT = Parsetree.case *) = (* (P -> E) or (P when E0 -> E) *) + { + pc_lhs: pattern; + pc_guard: expression option; + pc_rhs: expression; + } + + (* 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; + } + + (* + val x: T (prim = []) + external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) + *) + + (* Type declarations *) + + and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = + { + ptype_name: string loc; + ptype_params: (core_type * variance) list; + (* ('a1,...'an) t; None represents _*) + ptype_cstrs: (core_type * core_type * Location.t) list; + (* ... constraint T1=T1' ... constraint Tn=Tn' *) + ptype_kind: type_kind; + ptype_private: private_flag; (* = private ... *) + ptype_manifest: core_type option; (* = T *) + ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) + ptype_loc: Location.t; + } + + (* + type t (abstract, no manifest) + type t = T0 (abstract, manifest=T0) + type t = C of T | ... (variant, no manifest) + type t = T0 = C of T | ... (variant, manifest=T0) + type t = {l: T; ...} (record, no manifest) + type t = T0 = {l : T; ...} (record, manifest=T0) + type t = .. (open, no manifest) + *) + + 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; ... } (mutable=Immutable) + { ...; mutable l: T; ... } (mutable=Mutable) + + Note: T can be a Ptyp_poly. + *) + + and constructor_declaration (*IF_CURRENT = Parsetree.constructor_declaration *) = + { + pcd_name: string loc; + 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 + + (* + | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) + | C: T0 (res = Some T0, args = []) + | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) + | C of {...} (res = None, args = Pcstr_record) + | C: {...} -> T0 (res = Some T0, args = Pcstr_record) + | C of {...} as t (res = None, args = Pcstr_record) + *) + + and type_extension (*IF_CURRENT = Parsetree.type_extension *) = + { + ptyext_path: Longident.t loc; + ptyext_params: (core_type * variance) list; + ptyext_constructors: extension_constructor list; + ptyext_private: private_flag; + ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + (* + 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 extension_constructor_kind (*IF_CURRENT = Parsetree.extension_constructor_kind *) = + Pext_decl of constructor_arguments * core_type option + (* + | C of T1 * ... * Tn ([T1; ...; Tn], None) + | C: T0 ([], Some T0) + | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) + *) + | Pext_rebind of Longident.t loc + (* + | C = D + *) + + (** {1 Class language} *) + + (* 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 + (* T -> CT Simple + ~l:T -> CT Labelled l + ?l:T -> CT Optional l + *) + | Pcty_extension of extension + (* [%id] *) + | Pcty_open of override_flag * Longident.t loc * 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; + } + (* object('selfpat) ... end + object ... end (self = 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 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) list; + pci_name: string loc; + pci_expr: 'a; + pci_loc: Location.t; + pci_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + (* class c = ... + class ['a1,...,'an] c = ... + class virtual c = ... + + Also used for "class type" declaration. + *) + + and class_description = class_type class_infos + + and class_type_declaration = class_type class_infos + + (* 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 + ['a1, ..., 'an] c *) + | Pcl_structure of class_structure + (* object ... end *) + | Pcl_fun of arg_label * expression option * pattern * class_expr + (* fun P -> CE (Simple, None) + fun ~l:P -> CE (Labelled l, None) + fun ?l:P -> CE (Optional l, None) + fun ?l:(P = E0) -> CE (Optional l, Some E0) + *) + | Pcl_apply of class_expr * (arg_label * expression) list + (* 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 + (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive) + *) + | Pcl_constraint of class_expr * class_type + (* (CE : CT) *) + | Pcl_extension of extension + (* [%id] *) + | Pcl_open of override_flag * Longident.t loc * class_expr + (* let open M in CE *) + + + and class_structure (*IF_CURRENT = Parsetree.class_structure *) = + { + pcstr_self: pattern; + pcstr_fields: class_field list; + } + (* object(selfpat) ... end + object ... end (self = 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 + (* inherit CE + inherit CE as x + inherit! CE + inherit! CE as x + *) + | Pcf_val of (label loc * mutable_flag * class_field_kind) + (* val x = E + val virtual x: T + *) + | Pcf_method of (label loc * private_flag * class_field_kind) + (* method x = E (E can be a Pexp_poly) + method virtual x: T (T can be a 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} *) + + (* 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 + (* S *) + | Pmty_signature of signature + (* sig ... end *) + | Pmty_functor of string loc * module_type option * 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 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_typext of type_extension + (* type t1 += ... *) + | Psig_exception of extension_constructor + (* exception C of T *) + | Psig_module of module_declaration + (* module X : MT *) + | Psig_recmodule of module_declaration list + (* module rec X1 : MT1 and ... and Xn : MTn *) + | Psig_modtype of module_type_declaration + (* module type S = MT + 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 loc; + pmd_type: module_type; + pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) + pmd_loc: Location.t; + } + (* S : MT *) + + 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; + } + (* S = MT + S (abstract module type declaration, pmtd_type = None) + *) + + and open_description (*IF_CURRENT = Parsetree.open_description *) = + { + popen_lid: Longident.t loc; + popen_override: override_flag; + popen_loc: Location.t; + popen_attributes: attributes; + } + (* open! X - popen_override = Override (silences the 'used identifier + shadowing' warning) + open X - popen_override = Fresh + *) + + 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 + (* include MT *) + + and include_declaration = module_expr include_infos + (* 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_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 *) + + (* 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 string loc * module_type option * module_expr + (* functor(X : MT1) -> ME *) + | Pmod_apply of module_expr * module_expr + (* ME1(ME2) *) + | 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 + (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN (flag = 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 extension_constructor + (* 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_description + (* 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_binding (*IF_CURRENT = Parsetree.value_binding *) = + { + pvb_pat: pattern; + pvb_expr: expression; + pvb_attributes: attributes; + pvb_loc: Location.t; + } + + and module_binding (*IF_CURRENT = Parsetree.module_binding *) = + { + pmb_name: string loc; + pmb_expr: module_expr; + pmb_attributes: attributes; + pmb_loc: Location.t; + } + (* X = ME *) + + (** {1 Toplevel} *) + + (* Toplevel phrases *) + + type toplevel_phrase (*IF_CURRENT = Parsetree.toplevel_phrase *) = + | Ptop_def of structure + | Ptop_dir of string * directive_argument + (* #use, #load ... *) + + and directive_argument (*IF_CURRENT = Parsetree.directive_argument *) = + | Pdir_none + | 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 = "Caml1999M023" + let ast_intf_magic_number = "Caml1999N023" +end diff -Nru ppxlib-0.15.0/astlib/ast_408.ml ppxlib-0.24.0/astlib/ast_408.ml --- ppxlib-0.15.0/astlib/ast_408.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/ast_408.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1028 @@ +(**************************************************************************) +(* *) +(* OCaml Migrate Parsetree *) +(* *) +(* Frédéric Bour, Facebook *) +(* Jérémie Dimino and Leo White, Jane Street Europe *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Alain Frisch, LexiFi *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique (INRIA). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Ast ported on Thu Mar 21 09:50:42 GMT 2019 + OCaml was: + commit 55c9ba466362f303eb4d5ed511f6fda142879137 (HEAD -> 4.08, origin/4.08) + Author: Nicolás Ojeda Bär + Date: Tue Mar 19 08:11:02 2019 +0100 + + Merge pull request #8521 from nojb/fix_unix_tests_408 + + Actually run all lib-unix tests [4.08] +*) + +module Asttypes = struct + + type constant (*IF_CURRENT = Asttypes.constant *) = + Const_int of int + | Const_char of char + | Const_string of string * 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 + | Invariant + +end + +module Parsetree = struct + + open Asttypes + + type constant (*IF_CURRENT = Parsetree.constant *) = + Pconst_integer of string * char option + (* 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 + (* 'c' *) + | Pconst_string of string * string option + (* "constant" + {delim|other constant|delim} + *) + | Pconst_float of string * char option + (* 3.4 2e5 1.4e-4 + + Suffixes [g-z][G-Z] are accepted by the parser. + Suffixes are rejected by the typechecker. + *) + + (** {1 Extension points} *) + + type attribute (*IF_CURRENT = Parsetree.attribute *) = { + attr_name : string loc; + attr_payload : payload; + attr_loc : Location.t; + } + (* [@id ARG] + [@@id ARG] + + Metadata containers passed around within the AST. + The compiler ignores unknown attributes. + *) + + and extension = string loc * payload + (* [%id ARG] + [%%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 *) + | PTyp of core_type (* : T *) + | PPat of pattern * expression option (* ? P or ? P when E *) + + (** {1 Core language} *) + + (* Type expressions *) + + and core_type (*IF_CURRENT = Parsetree.core_type *) = + { + ptyp_desc: core_type_desc; + ptyp_loc: Location.t; + ptyp_loc_stack: Location.t list; + ptyp_attributes: attributes; (* ... [@id1] [@id2] *) + } + + and typ = core_type + + and core_type_desc (*IF_CURRENT = Parsetree.core_type_desc *) = + | Ptyp_any + (* _ *) + | Ptyp_var of string + (* 'a *) + | Ptyp_arrow of arg_label * core_type * core_type + (* T1 -> T2 Simple + ~l:T1 -> T2 Labelled + ?l:T1 -> T2 Optional + *) + | Ptyp_tuple of core_type list + (* T1 * ... * Tn + + Invariant: n >= 2 + *) + | Ptyp_constr of Longident.t loc * core_type list + (* tconstr + T tconstr + (T1, ..., Tn) tconstr + *) + | Ptyp_object of object_field list * closed_flag + (* < l1:T1; ...; ln:Tn > (flag = Closed) + < l1:T1; ...; ln:Tn; .. > (flag = Open) + *) + | Ptyp_class of Longident.t loc * core_type list + (* #tconstr + T #tconstr + (T1, ..., Tn) #tconstr + *) + | Ptyp_alias of core_type * string + (* T as 'a *) + | Ptyp_variant of row_field list * closed_flag * label list option + (* [ `A|`B ] (flag = Closed; labels = None) + [> `A|`B ] (flag = Open; labels = None) + [< `A|`B ] (flag = Closed; labels = Some []) + [< `A|`B > `X `Y ](flag = Closed; labels = 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 Ppat_constraint node corresponding + to a constraint on a let-binding: let x : 'a1 ... 'an. T + = e ... + + - Under Cfk_virtual for methods (not values). + + - As the core_type of a Pctf_method node. + + - As the core_type of a Pexp_poly node. + + - As the pld_type field of a label_declaration. + + - As a core_type of a Ptyp_object node. + *) + + | Ptyp_package of package_type + (* (module S) *) + | Ptyp_extension of extension + (* [%id] *) + + and package_type = Longident.t loc * (Longident.t loc * core_type) list + (* + (module S) + (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 + (* [`A] ( true, [] ) + [`A of T] ( false, [T] ) + [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) + [`A of & T1 & .. & Tn] ( true, [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 + + (* Patterns *) + + and pattern (*IF_CURRENT = Parsetree.pattern *) = + { + ppat_desc: pattern_desc; + ppat_loc: Location.t; + ppat_loc_stack: Location.t list; + ppat_attributes: attributes; (* ... [@id1] [@id2] *) + } + + and pat = pattern + + and pattern_desc (*IF_CURRENT = Parsetree.pattern_desc *) = + | Ppat_any + (* _ *) + | Ppat_var of string loc + (* x *) + | Ppat_alias of pattern * string loc + (* P as 'a *) + | Ppat_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Ppat_interval of constant * constant + (* 'a'..'z' + + Other forms of interval are recognized by the parser + but rejected by the type-checker. *) + | Ppat_tuple of pattern list + (* (P1, ..., Pn) + + Invariant: n >= 2 + *) + | Ppat_construct of Longident.t loc * pattern option + (* C None + C P Some P + C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) + *) + | Ppat_variant of label * pattern option + (* `A (None) + `A P (Some P) + *) + | Ppat_record of (Longident.t loc * pattern) list * closed_flag + (* { l1=P1; ...; ln=Pn } (flag = Closed) + { l1=P1; ...; ln=Pn; _} (flag = Open) + + Invariant: n > 0 + *) + | Ppat_array of pattern list + (* [| P1; ...; Pn |] *) + | Ppat_or of pattern * pattern + (* P1 | P2 *) + | Ppat_constraint of pattern * core_type + (* (P : T) *) + | Ppat_type of Longident.t loc + (* #tconst *) + | Ppat_lazy of pattern + (* lazy P *) + | Ppat_unpack of string loc + (* (module P) + Note: (module P : S) is represented as + Ppat_constraint(Ppat_unpack, Ptyp_package) + *) + | Ppat_exception of pattern + (* exception P *) + | Ppat_extension of extension + (* [%id] *) + | Ppat_open of Longident.t loc * pattern + (* M.(P) *) + + (* Value expressions *) + + and expression (*IF_CURRENT = Parsetree.expression *) = + { + pexp_desc: expression_desc; + pexp_loc: Location.t; + pexp_loc_stack: Location.t list; + pexp_attributes: attributes; (* ... [@id1] [@id2] *) + } + + and expr = expression + + and expression_desc (*IF_CURRENT = Parsetree.expression_desc *) = + | Pexp_ident of Longident.t loc + (* x + M.x + *) + | Pexp_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Pexp_let of rec_flag * value_binding list * expression + (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) + *) + | Pexp_function of cases + (* function P1 -> E1 | ... | Pn -> En *) + | Pexp_fun of arg_label * expression option * pattern * expression + (* fun P -> E1 (Simple, None) + fun ~l:P -> E1 (Labelled l, None) + fun ?l:P -> E1 (Optional l, None) + fun ?l:(P = E0) -> E1 (Optional l, Some E0) + + Notes: + - If E0 is provided, only Optional is allowed. + - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. + - "let f P = E" is represented using Pexp_fun. + *) + | Pexp_apply of expression * (arg_label * expression) list + (* E0 ~l1:E1 ... ~ln:En + li can be empty (non labeled argument) or start with '?' + (optional argument). + + Invariant: n > 0 + *) + | Pexp_match of expression * cases + (* match E0 with P1 -> E1 | ... | Pn -> En *) + | Pexp_try of expression * cases + (* try E0 with P1 -> E1 | ... | Pn -> En *) + | Pexp_tuple of expression list + (* (E1, ..., En) + + Invariant: n >= 2 + *) + | Pexp_construct of Longident.t loc * expression option + (* C None + C E Some E + C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) + *) + | Pexp_variant of label * expression option + (* `A (None) + `A E (Some E) + *) + | Pexp_record of (Longident.t loc * expression) list * expression option + (* { l1=P1; ...; ln=Pn } (None) + { E0 with l1=P1; ...; ln=Pn } (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 + (* for i = E1 to E2 do E3 done (flag = Upto) + for i = E1 downto E2 do E3 done (flag = Downto) + *) + | Pexp_constraint of expression * core_type + (* (E : T) *) + | Pexp_coerce of expression * core_type option * core_type + (* (E :> T) (None, T) + (E : T0 :> T) (Some T0, T) + *) + | 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 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 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, 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 = E in E + let* P = E and* P = E in E *) + | Pexp_extension of extension + (* [%id] *) + | Pexp_unreachable + (* . *) + + and case (*IF_CURRENT = Parsetree.case *) = (* (P -> E) or (P when E0 -> E) *) + { + pc_lhs: pattern; + pc_guard: expression option; + pc_rhs: expression; + } + + and cases = case list + + 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; + } + + (* 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; + } + +(* + val x: T (prim = []) + external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) + *) + + (* Type declarations *) + + and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = + { + ptype_name: string loc; + ptype_params: (core_type * variance) list; + (* ('a1,...'an) t; None represents _*) + ptype_cstrs: (core_type * core_type * Location.t) list; + (* ... constraint T1=T1' ... constraint Tn=Tn' *) + ptype_kind: type_kind; + ptype_private: private_flag; (* = private ... *) + ptype_manifest: core_type option; (* = T *) + ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) + ptype_loc: Location.t; + } + +(* + type t (abstract, no manifest) + type t = T0 (abstract, manifest=T0) + type t = C of T | ... (variant, no manifest) + type t = T0 = C of T | ... (variant, manifest=T0) + type t = {l: T; ...} (record, no manifest) + type t = T0 = {l : T; ...} (record, manifest=T0) + type t = .. (open, no manifest) + *) + + 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; ... } (mutable=Immutable) + { ...; mutable l: T; ... } (mutable=Mutable) + + Note: T can be a Ptyp_poly. + *) + + and constructor_declaration (*IF_CURRENT = Parsetree.constructor_declaration *) = + { + pcd_name: string loc; + 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 + +(* + | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) + | C: T0 (res = Some T0, args = []) + | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) + | C of {...} (res = None, args = Pcstr_record) + | C: {...} -> T0 (res = Some T0, args = Pcstr_record) + | C of {...} as t (res = None, args = Pcstr_record) + *) + + and type_extension (*IF_CURRENT = Parsetree.type_extension *) = + { + ptyext_path: Longident.t loc; + ptyext_params: (core_type * variance) list; + ptyext_constructors: extension_constructor list; + ptyext_private: private_flag; + ptyext_loc: Location.t; + ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) + } +(* + 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] *) + } + + (* exception E *) + and type_exception (*IF_CURRENT = Parsetree.type_exception *) = + { + ptyexn_constructor: extension_constructor; + ptyexn_loc: Location.t; + ptyexn_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + + and extension_constructor_kind (*IF_CURRENT = Parsetree.extension_constructor_kind *) = + Pext_decl of constructor_arguments * core_type option + (* + | C of T1 * ... * Tn ([T1; ...; Tn], None) + | C: T0 ([], Some T0) + | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) + *) + | Pext_rebind of Longident.t loc + (* + | C = D + *) + + (** {1 Class language} *) + + (* 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 + (* T -> CT Simple + ~l:T -> CT Labelled l + ?l:T -> CT 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; + } + (* object('selfpat) ... end + object ... end (self = 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 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) list; + pci_name: string loc; + pci_expr: 'a; + pci_loc: Location.t; + pci_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + (* class c = ... + class ['a1,...,'an] c = ... + class virtual c = ... + + Also used for "class type" declaration. + *) + + and class_description = class_type class_infos + + and class_type_declaration = class_type class_infos + + (* 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 + ['a1, ..., 'an] c *) + | Pcl_structure of class_structure + (* object ... end *) + | Pcl_fun of arg_label * expression option * pattern * class_expr + (* fun P -> CE (Simple, None) + fun ~l:P -> CE (Labelled l, None) + fun ?l:P -> CE (Optional l, None) + fun ?l:(P = E0) -> CE (Optional l, Some E0) + *) + | Pcl_apply of class_expr * (arg_label * expression) list + (* 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 + (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in CE (flag = 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; + } + (* object(selfpat) ... end + object ... end (self = 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 + (* inherit CE + inherit CE as x + inherit! CE + inherit! CE as x + *) + | Pcf_val of (label loc * mutable_flag * class_field_kind) + (* val x = E + val virtual x: T + *) + | Pcf_method of (label loc * private_flag * class_field_kind) + (* method x = E (E can be a Pexp_poly) + method virtual x: T (T can be a 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} *) + + (* 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 + (* S *) + | Pmty_signature of signature + (* sig ... end *) + | Pmty_functor of string loc * module_type option * 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 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 + 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 + 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 loc; + pmd_type: module_type; + pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) + pmd_loc: Location.t; + } + (* 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; + } + + 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; + } + (* S = MT + S (abstract module type declaration, pmtd_type = 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; + } + (* open! X - popen_override = Override (silences the 'used identifier + shadowing' warning) + open X - popen_override = Fresh + *) + + and open_description = Longident.t loc open_infos + (* open M.N + open M(N).O *) + + and open_declaration = module_expr open_infos + (* 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 + (* include MT *) + + and include_declaration = module_expr include_infos + (* 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_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 *) + + (* 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 string loc * module_type option * module_expr + (* functor(X : MT1) -> ME *) + | Pmod_apply of module_expr * module_expr + (* ME1(ME2) *) + | 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 + (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN (flag = 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_binding (*IF_CURRENT = Parsetree.value_binding *) = + { + pvb_pat: pattern; + pvb_expr: expression; + pvb_attributes: attributes; + pvb_loc: Location.t; + } + + and module_binding (*IF_CURRENT = Parsetree.module_binding *) = + { + pmb_name: string loc; + pmb_expr: module_expr; + pmb_attributes: attributes; + pmb_loc: Location.t; + } + (* X = ME *) + + (** {1 Toplevel} *) + + (* 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 = "Caml1999M025" + let ast_intf_magic_number = "Caml1999N025" +end diff -Nru ppxlib-0.15.0/astlib/ast_409.ml ppxlib-0.24.0/astlib/ast_409.ml --- ppxlib-0.15.0/astlib/ast_409.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/ast_409.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1017 @@ +(**************************************************************************) +(* *) +(* OCaml Migrate Parsetree *) +(* *) +(* Frédéric Bour, Facebook *) +(* Jérémie Dimino and Leo White, Jane Street Europe *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Alain Frisch, LexiFi *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique (INRIA). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module Asttypes = struct + + type constant (*IF_CURRENT = Asttypes.constant *) = + Const_int of int + | Const_char of char + | Const_string of string * 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 + | Invariant + +end + +module Parsetree = struct + + open Asttypes + + type constant (*IF_CURRENT = Parsetree.constant *) = + Pconst_integer of string * char option + (* 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 + (* 'c' *) + | Pconst_string of string * string option + (* "constant" + {delim|other constant|delim} + *) + | Pconst_float of string * char option + (* 3.4 2e5 1.4e-4 + + Suffixes [g-z][G-Z] are accepted by the parser. + Suffixes are rejected by the typechecker. + *) + + (** {1 Extension points} *) + + type attribute (*IF_CURRENT = Parsetree.attribute *) = { + attr_name : string loc; + attr_payload : payload; + attr_loc : Location.t; + } + (* [@id ARG] + [@@id ARG] + + Metadata containers passed around within the AST. + The compiler ignores unknown attributes. + *) + + and extension = string loc * payload + (* [%id ARG] + [%%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 *) + | PTyp of core_type (* : T *) + | PPat of pattern * expression option (* ? P or ? P when E *) + + (** {1 Core language} *) + + (* Type expressions *) + + and core_type (*IF_CURRENT = Parsetree.core_type *) = + { + ptyp_desc: core_type_desc; + ptyp_loc: Location.t; + ptyp_loc_stack: Location.t list; + ptyp_attributes: attributes; (* ... [@id1] [@id2] *) + } + + and typ = core_type + + and core_type_desc (*IF_CURRENT = Parsetree.core_type_desc *) = + | Ptyp_any + (* _ *) + | Ptyp_var of string + (* 'a *) + | Ptyp_arrow of arg_label * core_type * core_type + (* T1 -> T2 Simple + ~l:T1 -> T2 Labelled + ?l:T1 -> T2 Optional + *) + | Ptyp_tuple of core_type list + (* T1 * ... * Tn + + Invariant: n >= 2 + *) + | Ptyp_constr of Longident.t loc * core_type list + (* tconstr + T tconstr + (T1, ..., Tn) tconstr + *) + | Ptyp_object of object_field list * closed_flag + (* < l1:T1; ...; ln:Tn > (flag = Closed) + < l1:T1; ...; ln:Tn; .. > (flag = Open) + *) + | Ptyp_class of Longident.t loc * core_type list + (* #tconstr + T #tconstr + (T1, ..., Tn) #tconstr + *) + | Ptyp_alias of core_type * string + (* T as 'a *) + | Ptyp_variant of row_field list * closed_flag * label list option + (* [ `A|`B ] (flag = Closed; labels = None) + [> `A|`B ] (flag = Open; labels = None) + [< `A|`B ] (flag = Closed; labels = Some []) + [< `A|`B > `X `Y ](flag = Closed; labels = 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 Ppat_constraint node corresponding + to a constraint on a let-binding: let x : 'a1 ... 'an. T + = e ... + + - Under Cfk_virtual for methods (not values). + + - As the core_type of a Pctf_method node. + + - As the core_type of a Pexp_poly node. + + - As the pld_type field of a label_declaration. + + - As a core_type of a Ptyp_object node. + *) + + | Ptyp_package of package_type + (* (module S) *) + | Ptyp_extension of extension + (* [%id] *) + + and package_type = Longident.t loc * (Longident.t loc * core_type) list + (* + (module S) + (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 + (* [`A] ( true, [] ) + [`A of T] ( false, [T] ) + [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) + [`A of & T1 & .. & Tn] ( true, [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 + + (* Patterns *) + + and pattern (*IF_CURRENT = Parsetree.pattern *) = + { + ppat_desc: pattern_desc; + ppat_loc: Location.t; + ppat_loc_stack: Location.t list; + ppat_attributes: attributes; (* ... [@id1] [@id2] *) + } + + and pat = pattern + + and pattern_desc (*IF_CURRENT = Parsetree.pattern_desc *) = + | Ppat_any + (* _ *) + | Ppat_var of string loc + (* x *) + | Ppat_alias of pattern * string loc + (* P as 'a *) + | Ppat_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Ppat_interval of constant * constant + (* 'a'..'z' + + Other forms of interval are recognized by the parser + but rejected by the type-checker. *) + | Ppat_tuple of pattern list + (* (P1, ..., Pn) + + Invariant: n >= 2 + *) + | Ppat_construct of Longident.t loc * pattern option + (* C None + C P Some P + C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) + *) + | Ppat_variant of label * pattern option + (* `A (None) + `A P (Some P) + *) + | Ppat_record of (Longident.t loc * pattern) list * closed_flag + (* { l1=P1; ...; ln=Pn } (flag = Closed) + { l1=P1; ...; ln=Pn; _} (flag = Open) + + Invariant: n > 0 + *) + | Ppat_array of pattern list + (* [| P1; ...; Pn |] *) + | Ppat_or of pattern * pattern + (* P1 | P2 *) + | Ppat_constraint of pattern * core_type + (* (P : T) *) + | Ppat_type of Longident.t loc + (* #tconst *) + | Ppat_lazy of pattern + (* lazy P *) + | Ppat_unpack of string loc + (* (module P) + Note: (module P : S) is represented as + Ppat_constraint(Ppat_unpack, Ptyp_package) + *) + | Ppat_exception of pattern + (* exception P *) + | Ppat_extension of extension + (* [%id] *) + | Ppat_open of Longident.t loc * pattern + (* M.(P) *) + + (* Value expressions *) + + and expression (*IF_CURRENT = Parsetree.expression *) = + { + pexp_desc: expression_desc; + pexp_loc: Location.t; + pexp_loc_stack: Location.t list; + pexp_attributes: attributes; (* ... [@id1] [@id2] *) + } + + and expr = expression + + and expression_desc (*IF_CURRENT = Parsetree.expression_desc *) = + | Pexp_ident of Longident.t loc + (* x + M.x + *) + | Pexp_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Pexp_let of rec_flag * value_binding list * expression + (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) + *) + | Pexp_function of cases + (* function P1 -> E1 | ... | Pn -> En *) + | Pexp_fun of arg_label * expression option * pattern * expression + (* fun P -> E1 (Simple, None) + fun ~l:P -> E1 (Labelled l, None) + fun ?l:P -> E1 (Optional l, None) + fun ?l:(P = E0) -> E1 (Optional l, Some E0) + + Notes: + - If E0 is provided, only Optional is allowed. + - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. + - "let f P = E" is represented using Pexp_fun. + *) + | Pexp_apply of expression * (arg_label * expression) list + (* E0 ~l1:E1 ... ~ln:En + li can be empty (non labeled argument) or start with '?' + (optional argument). + + Invariant: n > 0 + *) + | Pexp_match of expression * cases + (* match E0 with P1 -> E1 | ... | Pn -> En *) + | Pexp_try of expression * cases + (* try E0 with P1 -> E1 | ... | Pn -> En *) + | Pexp_tuple of expression list + (* (E1, ..., En) + + Invariant: n >= 2 + *) + | Pexp_construct of Longident.t loc * expression option + (* C None + C E Some E + C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) + *) + | Pexp_variant of label * expression option + (* `A (None) + `A E (Some E) + *) + | Pexp_record of (Longident.t loc * expression) list * expression option + (* { l1=P1; ...; ln=Pn } (None) + { E0 with l1=P1; ...; ln=Pn } (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 + (* for i = E1 to E2 do E3 done (flag = Upto) + for i = E1 downto E2 do E3 done (flag = Downto) + *) + | Pexp_constraint of expression * core_type + (* (E : T) *) + | Pexp_coerce of expression * core_type option * core_type + (* (E :> T) (None, T) + (E : T0 :> T) (Some T0, T) + *) + | 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 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 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, 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 = E in E + let* P = E and* P = E in E *) + | Pexp_extension of extension + (* [%id] *) + | Pexp_unreachable + (* . *) + + and case (*IF_CURRENT = Parsetree.case *) = (* (P -> E) or (P when E0 -> E) *) + { + pc_lhs: pattern; + pc_guard: expression option; + pc_rhs: expression; + } + + and cases = case list + + 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; + } + + (* 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; + } + +(* + val x: T (prim = []) + external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) + *) + + (* Type declarations *) + + and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = + { + ptype_name: string loc; + ptype_params: (core_type * variance) list; + (* ('a1,...'an) t; None represents _*) + ptype_cstrs: (core_type * core_type * Location.t) list; + (* ... constraint T1=T1' ... constraint Tn=Tn' *) + ptype_kind: type_kind; + ptype_private: private_flag; (* = private ... *) + ptype_manifest: core_type option; (* = T *) + ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) + ptype_loc: Location.t; + } + +(* + type t (abstract, no manifest) + type t = T0 (abstract, manifest=T0) + type t = C of T | ... (variant, no manifest) + type t = T0 = C of T | ... (variant, manifest=T0) + type t = {l: T; ...} (record, no manifest) + type t = T0 = {l : T; ...} (record, manifest=T0) + type t = .. (open, no manifest) + *) + + 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; ... } (mutable=Immutable) + { ...; mutable l: T; ... } (mutable=Mutable) + + Note: T can be a Ptyp_poly. + *) + + and constructor_declaration (*IF_CURRENT = Parsetree.constructor_declaration *) = + { + pcd_name: string loc; + 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 + +(* + | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) + | C: T0 (res = Some T0, args = []) + | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) + | C of {...} (res = None, args = Pcstr_record) + | C: {...} -> T0 (res = Some T0, args = Pcstr_record) + | C of {...} as t (res = None, args = Pcstr_record) + *) + + and type_extension (*IF_CURRENT = Parsetree.type_extension *) = + { + ptyext_path: Longident.t loc; + ptyext_params: (core_type * variance) list; + ptyext_constructors: extension_constructor list; + ptyext_private: private_flag; + ptyext_loc: Location.t; + ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) + } +(* + 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] *) + } + + (* exception E *) + and type_exception (*IF_CURRENT = Parsetree.type_exception *) = + { + ptyexn_constructor: extension_constructor; + ptyexn_loc: Location.t; + ptyexn_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + + and extension_constructor_kind (*IF_CURRENT = Parsetree.extension_constructor_kind *) = + Pext_decl of constructor_arguments * core_type option + (* + | C of T1 * ... * Tn ([T1; ...; Tn], None) + | C: T0 ([], Some T0) + | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) + *) + | Pext_rebind of Longident.t loc + (* + | C = D + *) + + (** {1 Class language} *) + + (* 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 + (* T -> CT Simple + ~l:T -> CT Labelled l + ?l:T -> CT 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; + } + (* object('selfpat) ... end + object ... end (self = 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 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) list; + pci_name: string loc; + pci_expr: 'a; + pci_loc: Location.t; + pci_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + (* class c = ... + class ['a1,...,'an] c = ... + class virtual c = ... + + Also used for "class type" declaration. + *) + + and class_description = class_type class_infos + + and class_type_declaration = class_type class_infos + + (* 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 + ['a1, ..., 'an] c *) + | Pcl_structure of class_structure + (* object ... end *) + | Pcl_fun of arg_label * expression option * pattern * class_expr + (* fun P -> CE (Simple, None) + fun ~l:P -> CE (Labelled l, None) + fun ?l:P -> CE (Optional l, None) + fun ?l:(P = E0) -> CE (Optional l, Some E0) + *) + | Pcl_apply of class_expr * (arg_label * expression) list + (* 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 + (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in CE (flag = 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; + } + (* object(selfpat) ... end + object ... end (self = 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 + (* inherit CE + inherit CE as x + inherit! CE + inherit! CE as x + *) + | Pcf_val of (label loc * mutable_flag * class_field_kind) + (* val x = E + val virtual x: T + *) + | Pcf_method of (label loc * private_flag * class_field_kind) + (* method x = E (E can be a Pexp_poly) + method virtual x: T (T can be a 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} *) + + (* 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 + (* S *) + | Pmty_signature of signature + (* sig ... end *) + | Pmty_functor of string loc * module_type option * 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 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 + 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 + 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 loc; + pmd_type: module_type; + pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) + pmd_loc: Location.t; + } + (* 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; + } + + 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; + } + (* S = MT + S (abstract module type declaration, pmtd_type = 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; + } + (* open! X - popen_override = Override (silences the 'used identifier + shadowing' warning) + open X - popen_override = Fresh + *) + + and open_description = Longident.t loc open_infos + (* open M.N + open M(N).O *) + + and open_declaration = module_expr open_infos + (* 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 + (* include MT *) + + and include_declaration = module_expr include_infos + (* 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_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 *) + + (* 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 string loc * module_type option * module_expr + (* functor(X : MT1) -> ME *) + | Pmod_apply of module_expr * module_expr + (* ME1(ME2) *) + | 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 + (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN (flag = 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_binding (*IF_CURRENT = Parsetree.value_binding *) = + { + pvb_pat: pattern; + pvb_expr: expression; + pvb_attributes: attributes; + pvb_loc: Location.t; + } + + and module_binding (*IF_CURRENT = Parsetree.module_binding *) = + { + pmb_name: string loc; + pmb_expr: module_expr; + pmb_attributes: attributes; + pmb_loc: Location.t; + } + (* X = ME *) + + (** {1 Toplevel} *) + + (* 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 = "Caml1999M026" + let ast_intf_magic_number = "Caml1999N026" +end diff -Nru ppxlib-0.15.0/astlib/ast_410.ml ppxlib-0.24.0/astlib/ast_410.ml --- ppxlib-0.15.0/astlib/ast_410.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/ast_410.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1018 @@ +(**************************************************************************) +(* *) +(* OCaml Migrate Parsetree *) +(* *) +(* Frédéric Bour, Facebook *) +(* Jérémie Dimino and Leo White, Jane Street Europe *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Alain Frisch, LexiFi *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique (INRIA). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module Asttypes = struct + type constant (*IF_CURRENT = Asttypes.constant *) = + Const_int of int + | Const_char of char + | Const_string of string * 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 + | Invariant +end + +module Parsetree = struct + + open Asttypes + + type constant (*IF_CURRENT = Parsetree.constant *) = + Pconst_integer of string * char option + (* 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 + (* 'c' *) + | Pconst_string of string * string option + (* "constant" + {delim|other constant|delim} + *) + | Pconst_float of string * char option + (* 3.4 2e5 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; + } + (* [@id ARG] + [@@id ARG] + + Metadata containers passed around within the AST. + The compiler ignores unknown attributes. + *) + + and extension = string loc * payload + (* [%id ARG] + [%%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 *) + | PTyp of core_type (* : T *) + | PPat of pattern * expression option (* ? P or ? P when E *) + + (** {1 Core language} *) + + (* 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 *) + | Ptyp_arrow of arg_label * core_type * core_type + (* T1 -> T2 Simple + ~l:T1 -> T2 Labelled + ?l:T1 -> T2 Optional + *) + | Ptyp_tuple of core_type list + (* T1 * ... * Tn + + Invariant: n >= 2 + *) + | Ptyp_constr of Longident.t loc * core_type list + (* tconstr + T tconstr + (T1, ..., Tn) tconstr + *) + | Ptyp_object of object_field list * closed_flag + (* < l1:T1; ...; ln:Tn > (flag = Closed) + < l1:T1; ...; ln:Tn; .. > (flag = Open) + *) + | Ptyp_class of Longident.t loc * core_type list + (* #tconstr + T #tconstr + (T1, ..., Tn) #tconstr + *) + | Ptyp_alias of core_type * string + (* T as 'a *) + | Ptyp_variant of row_field list * closed_flag * label list option + (* [ `A|`B ] (flag = Closed; labels = None) + [> `A|`B ] (flag = Open; labels = None) + [< `A|`B ] (flag = Closed; labels = Some []) + [< `A|`B > `X `Y ](flag = Closed; labels = 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 Ppat_constraint node corresponding + to a constraint on a let-binding: let x : 'a1 ... 'an. T + = e ... + + - Under Cfk_virtual for methods (not values). + + - As the core_type of a Pctf_method node. + + - As the core_type of a Pexp_poly node. + + - As the pld_type field of a label_declaration. + + - As a core_type of a Ptyp_object node. + *) + + | Ptyp_package of package_type + (* (module S) *) + | Ptyp_extension of extension + (* [%id] *) + + and package_type = Longident.t loc * (Longident.t loc * core_type) list + (* + (module S) + (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 + (* [`A] ( true, [] ) + [`A of T] ( false, [T] ) + [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) + [`A of & T1 & .. & Tn] ( true, [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 + + (* 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 + (* _ *) + | Ppat_var of string loc + (* x *) + | Ppat_alias of pattern * string loc + (* P as 'a *) + | Ppat_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Ppat_interval of constant * constant + (* 'a'..'z' + + Other forms of interval are recognized by the parser + but rejected by the type-checker. *) + | Ppat_tuple of pattern list + (* (P1, ..., Pn) + + Invariant: n >= 2 + *) + | Ppat_construct of Longident.t loc * pattern option + (* C None + C P Some P + C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) + *) + | Ppat_variant of label * pattern option + (* `A (None) + `A P (Some P) + *) + | Ppat_record of (Longident.t loc * pattern) list * closed_flag + (* { l1=P1; ...; ln=Pn } (flag = Closed) + { l1=P1; ...; ln=Pn; _} (flag = Open) + + Invariant: n > 0 + *) + | Ppat_array of pattern list + (* [| P1; ...; Pn |] *) + | Ppat_or of pattern * pattern + (* P1 | P2 *) + | Ppat_constraint of pattern * core_type + (* (P : T) *) + | Ppat_type of Longident.t loc + (* #tconst *) + | Ppat_lazy of pattern + (* lazy P *) + | Ppat_unpack of string option loc + (* (module P) Some "P" + (module _) None + + Note: (module P : S) is represented as + Ppat_constraint(Ppat_unpack, Ptyp_package) + *) + | Ppat_exception of pattern + (* exception P *) + | Ppat_extension of extension + (* [%id] *) + | Ppat_open of Longident.t loc * pattern + (* M.(P) *) + + (* 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 + (* x + M.x + *) + | Pexp_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Pexp_let of rec_flag * value_binding list * expression + (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) + *) + | Pexp_function of case list + (* function P1 -> E1 | ... | Pn -> En *) + | Pexp_fun of arg_label * expression option * pattern * expression + (* fun P -> E1 (Simple, None) + fun ~l:P -> E1 (Labelled l, None) + fun ?l:P -> E1 (Optional l, None) + fun ?l:(P = E0) -> E1 (Optional l, Some E0) + + Notes: + - If E0 is provided, only Optional is allowed. + - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. + - "let f P = E" is represented using Pexp_fun. + *) + | Pexp_apply of expression * (arg_label * expression) list + (* E0 ~l1:E1 ... ~ln:En + li can be empty (non labeled argument) or start with '?' + (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 + (* (E1, ..., En) + + Invariant: n >= 2 + *) + | Pexp_construct of Longident.t loc * expression option + (* C None + C E Some E + C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) + *) + | Pexp_variant of label * expression option + (* `A (None) + `A E (Some E) + *) + | Pexp_record of (Longident.t loc * expression) list * expression option + (* { l1=P1; ...; ln=Pn } (None) + { E0 with l1=P1; ...; ln=Pn } (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 + (* for i = E1 to E2 do E3 done (flag = Upto) + for i = E1 downto E2 do E3 done (flag = Downto) + *) + | Pexp_constraint of expression * core_type + (* (E : T) *) + | Pexp_coerce of expression * core_type option * core_type + (* (E :> T) (None, T) + (E : T0 :> T) (Some T0, T) + *) + | 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 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, 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 = E in E + let* P = E and* P = E in E *) + | Pexp_extension of extension + (* [%id] *) + | Pexp_unreachable + (* . *) + + and case (*IF_CURRENT = Parsetree.case *) = (* (P -> E) or (P when E0 -> E) *) + { + pc_lhs: pattern; + pc_guard: expression option; + pc_rhs: expression; + } + + 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; + } + + (* 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; + } + +(* + val x: T (prim = []) + external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) +*) + + (* Type declarations *) + + and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = + { + ptype_name: string loc; + ptype_params: (core_type * variance) list; + (* ('a1,...'an) t; None represents _*) + ptype_cstrs: (core_type * core_type * Location.t) list; + (* ... constraint T1=T1' ... constraint Tn=Tn' *) + ptype_kind: type_kind; + ptype_private: private_flag; (* = private ... *) + ptype_manifest: core_type option; (* = T *) + ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) + ptype_loc: Location.t; + } + +(* + type t (abstract, no manifest) + type t = T0 (abstract, manifest=T0) + type t = C of T | ... (variant, no manifest) + type t = T0 = C of T | ... (variant, manifest=T0) + type t = {l: T; ...} (record, no manifest) + type t = T0 = {l : T; ...} (record, manifest=T0) + type t = .. (open, no manifest) +*) + + 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; ... } (mutable=Immutable) + { ...; mutable l: T; ... } (mutable=Mutable) + + Note: T can be a Ptyp_poly. + *) + + and constructor_declaration (*IF_CURRENT = Parsetree.constructor_declaration *) = + { + pcd_name: string loc; + 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 + +(* + | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) + | C: T0 (res = Some T0, args = []) + | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) + | C of {...} (res = None, args = Pcstr_record) + | C: {...} -> T0 (res = Some T0, args = Pcstr_record) + | C of {...} as t (res = None, args = Pcstr_record) +*) + + and type_extension (*IF_CURRENT = Parsetree.type_extension *) = + { + ptyext_path: Longident.t loc; + ptyext_params: (core_type * variance) list; + ptyext_constructors: extension_constructor list; + ptyext_private: private_flag; + ptyext_loc: Location.t; + ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) + } +(* + 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] *) + } + + (* exception E *) + and type_exception (*IF_CURRENT = Parsetree.type_exception *) = + { + ptyexn_constructor: extension_constructor; + ptyexn_loc: Location.t; + ptyexn_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + + and extension_constructor_kind (*IF_CURRENT = Parsetree.extension_constructor_kind *) = + Pext_decl of constructor_arguments * core_type option + (* + | C of T1 * ... * Tn ([T1; ...; Tn], None) + | C: T0 ([], Some T0) + | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) + *) + | Pext_rebind of Longident.t loc + (* + | C = D + *) + + (** {1 Class language} *) + + (* 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 + (* T -> CT Simple + ~l:T -> CT Labelled l + ?l:T -> CT 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; + } + (* object('selfpat) ... end + object ... end (self = 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 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) list; + pci_name: string loc; + pci_expr: 'a; + pci_loc: Location.t; + pci_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + (* class c = ... + class ['a1,...,'an] c = ... + class virtual c = ... + + Also used for "class type" declaration. + *) + + and class_description = class_type class_infos + + and class_type_declaration = class_type class_infos + + (* 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 + ['a1, ..., 'an] c *) + | Pcl_structure of class_structure + (* object ... end *) + | Pcl_fun of arg_label * expression option * pattern * class_expr + (* fun P -> CE (Simple, None) + fun ~l:P -> CE (Labelled l, None) + fun ?l:P -> CE (Optional l, None) + fun ?l:(P = E0) -> CE (Optional l, Some E0) + *) + | Pcl_apply of class_expr * (arg_label * expression) list + (* 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 + (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in CE (flag = 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; + } + (* object(selfpat) ... end + object ... end (self = 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 + (* inherit CE + inherit CE as x + inherit! CE + inherit! CE as x + *) + | Pcf_val of (label loc * mutable_flag * class_field_kind) + (* val x = E + val virtual x: T + *) + | Pcf_method of (label loc * private_flag * class_field_kind) + (* method x = E (E can be a Pexp_poly) + method virtual x: T (T can be a 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} *) + + (* 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 + (* 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 + (* (X : MT) Some X, MT + (_ : MT) None, MT *) + + 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 + 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 + 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; + } + (* 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; + } + + 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; + } + (* S = MT + S (abstract module type declaration, pmtd_type = 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; + } + (* open! X - popen_override = Override (silences the 'used identifier + shadowing' warning) + open X - popen_override = Fresh + *) + + and open_description = Longident.t loc open_infos + (* open M.N + open M(N).O *) + + and open_declaration = module_expr open_infos + (* 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 + (* include MT *) + + and include_declaration = module_expr include_infos + (* 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_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 *) + + (* 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_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 + (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN (flag = 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_binding (*IF_CURRENT = Parsetree.value_binding *) = + { + pvb_pat: pattern; + pvb_expr: expression; + 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; + } + (* X = ME *) + + (** {1 Toplevel} *) + + (* 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 = "Caml1999M027" + let ast_intf_magic_number = "Caml1999N027" +end diff -Nru ppxlib-0.15.0/astlib/ast_411.ml ppxlib-0.24.0/astlib/ast_411.ml --- ppxlib-0.15.0/astlib/ast_411.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/ast_411.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1018 @@ +(**************************************************************************) +(* *) +(* OCaml Migrate Parsetree *) +(* *) +(* Frédéric Bour, Facebook *) +(* Jérémie Dimino and Leo White, Jane Street Europe *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Alain Frisch, LexiFi *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique (INRIA). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +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 + | Invariant +end + +module Parsetree = struct + open Asttypes + + type constant (*IF_CURRENT = Parsetree.constant *) = + Pconst_integer of string * char option + (* 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 + (* 'c' *) + | Pconst_string of string * Location.t * string option + (* "constant" + {delim|other constant|delim} + + The location span the content of the string, without the delimiters. + *) + | Pconst_float of string * char option + (* 3.4 2e5 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; + } + (* [@id ARG] + [@@id ARG] + + Metadata containers passed around within the AST. + The compiler ignores unknown attributes. + *) + + and extension = string loc * payload + (* [%id ARG] + [%%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 *) + | PTyp of core_type (* : T *) + | PPat of pattern * expression option (* ? P or ? P when E *) + + (** {1 Core language} *) + + (* 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 *) + | Ptyp_arrow of arg_label * core_type * core_type + (* T1 -> T2 Simple + ~l:T1 -> T2 Labelled + ?l:T1 -> T2 Optional + *) + | Ptyp_tuple of core_type list + (* T1 * ... * Tn + + Invariant: n >= 2 + *) + | Ptyp_constr of Longident.t loc * core_type list + (* tconstr + T tconstr + (T1, ..., Tn) tconstr + *) + | Ptyp_object of object_field list * closed_flag + (* < l1:T1; ...; ln:Tn > (flag = Closed) + < l1:T1; ...; ln:Tn; .. > (flag = Open) + *) + | Ptyp_class of Longident.t loc * core_type list + (* #tconstr + T #tconstr + (T1, ..., Tn) #tconstr + *) + | Ptyp_alias of core_type * string + (* T as 'a *) + | Ptyp_variant of row_field list * closed_flag * label list option + (* [ `A|`B ] (flag = Closed; labels = None) + [> `A|`B ] (flag = Open; labels = None) + [< `A|`B ] (flag = Closed; labels = Some []) + [< `A|`B > `X `Y ](flag = Closed; labels = 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 Ppat_constraint node corresponding + to a constraint on a let-binding: let x : 'a1 ... 'an. T + = e ... + + - Under Cfk_virtual for methods (not values). + + - As the core_type of a Pctf_method node. + + - As the core_type of a Pexp_poly node. + + - As the pld_type field of a label_declaration. + + - As a core_type of a Ptyp_object node. + *) + + | Ptyp_package of package_type + (* (module S) *) + | Ptyp_extension of extension + (* [%id] *) + + and package_type = Longident.t loc * (Longident.t loc * core_type) list + (* + (module S) + (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 + (* [`A] ( true, [] ) + [`A of T] ( false, [T] ) + [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) + [`A of & T1 & .. & Tn] ( true, [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 + + (* 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 + (* _ *) + | Ppat_var of string loc + (* x *) + | Ppat_alias of pattern * string loc + (* P as 'a *) + | Ppat_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Ppat_interval of constant * constant + (* 'a'..'z' + + Other forms of interval are recognized by the parser + but rejected by the type-checker. *) + | Ppat_tuple of pattern list + (* (P1, ..., Pn) + + Invariant: n >= 2 + *) + | Ppat_construct of Longident.t loc * pattern option + (* C None + C P Some P + C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) + *) + | Ppat_variant of label * pattern option + (* `A (None) + `A P (Some P) + *) + | Ppat_record of (Longident.t loc * pattern) list * closed_flag + (* { l1=P1; ...; ln=Pn } (flag = Closed) + { l1=P1; ...; ln=Pn; _} (flag = Open) + + Invariant: n > 0 + *) + | Ppat_array of pattern list + (* [| P1; ...; Pn |] *) + | Ppat_or of pattern * pattern + (* P1 | P2 *) + | Ppat_constraint of pattern * core_type + (* (P : T) *) + | Ppat_type of Longident.t loc + (* #tconst *) + | Ppat_lazy of pattern + (* lazy P *) + | Ppat_unpack of string option loc + (* (module P) Some "P" + (module _) None + + Note: (module P : S) is represented as + Ppat_constraint(Ppat_unpack, Ptyp_package) + *) + | Ppat_exception of pattern + (* exception P *) + | Ppat_extension of extension + (* [%id] *) + | Ppat_open of Longident.t loc * pattern + (* M.(P) *) + + (* 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 + (* x + M.x + *) + | Pexp_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Pexp_let of rec_flag * value_binding list * expression + (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) + *) + | Pexp_function of case list + (* function P1 -> E1 | ... | Pn -> En *) + | Pexp_fun of arg_label * expression option * pattern * expression + (* fun P -> E1 (Simple, None) + fun ~l:P -> E1 (Labelled l, None) + fun ?l:P -> E1 (Optional l, None) + fun ?l:(P = E0) -> E1 (Optional l, Some E0) + + Notes: + - If E0 is provided, only Optional is allowed. + - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. + - "let f P = E" is represented using Pexp_fun. + *) + | Pexp_apply of expression * (arg_label * expression) list + (* E0 ~l1:E1 ... ~ln:En + li can be empty (non labeled argument) or start with '?' + (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 + (* (E1, ..., En) + + Invariant: n >= 2 + *) + | Pexp_construct of Longident.t loc * expression option + (* C None + C E Some E + C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) + *) + | Pexp_variant of label * expression option + (* `A (None) + `A E (Some E) + *) + | Pexp_record of (Longident.t loc * expression) list * expression option + (* { l1=P1; ...; ln=Pn } (None) + { E0 with l1=P1; ...; ln=Pn } (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 + (* for i = E1 to E2 do E3 done (flag = Upto) + for i = E1 downto E2 do E3 done (flag = Downto) + *) + | Pexp_constraint of expression * core_type + (* (E : T) *) + | Pexp_coerce of expression * core_type option * core_type + (* (E :> T) (None, T) + (E : T0 :> T) (Some T0, T) + *) + | 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 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, 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 = E in E + let* P = E and* P = E in E *) + | Pexp_extension of extension + (* [%id] *) + | Pexp_unreachable + (* . *) + + and case (*IF_CURRENT = Parsetree.case *) = (* (P -> E) or (P when E0 -> E) *) + { + pc_lhs: pattern; + pc_guard: expression option; + pc_rhs: expression; + } + + 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; + } + + (* 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; + } + +(* + val x: T (prim = []) + external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) +*) + + (* Type declarations *) + + and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = + { + ptype_name: string loc; + ptype_params: (core_type * variance) list; + (* ('a1,...'an) t; None represents _*) + ptype_cstrs: (core_type * core_type * Location.t) list; + (* ... constraint T1=T1' ... constraint Tn=Tn' *) + ptype_kind: type_kind; + ptype_private: private_flag; (* = private ... *) + ptype_manifest: core_type option; (* = T *) + ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) + ptype_loc: Location.t; + } + +(* + type t (abstract, no manifest) + type t = T0 (abstract, manifest=T0) + type t = C of T | ... (variant, no manifest) + type t = T0 = C of T | ... (variant, manifest=T0) + type t = {l: T; ...} (record, no manifest) + type t = T0 = {l : T; ...} (record, manifest=T0) + type t = .. (open, no manifest) +*) + + 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; ... } (mutable=Immutable) + { ...; mutable l: T; ... } (mutable=Mutable) + + Note: T can be a Ptyp_poly. + *) + + and constructor_declaration (*IF_CURRENT = Parsetree.constructor_declaration *) = + { + pcd_name: string loc; + 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 + +(* + | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) + | C: T0 (res = Some T0, args = []) + | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) + | C of {...} (res = None, args = Pcstr_record) + | C: {...} -> T0 (res = Some T0, args = Pcstr_record) + | C of {...} as t (res = None, args = Pcstr_record) +*) + + and type_extension (*IF_CURRENT = Parsetree.type_extension *) = + { + ptyext_path: Longident.t loc; + ptyext_params: (core_type * variance) list; + ptyext_constructors: extension_constructor list; + ptyext_private: private_flag; + ptyext_loc: Location.t; + ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) + } +(* + 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] *) + } + + (* exception E *) + and type_exception (*IF_CURRENT = Parsetree.type_exception *) = + { + ptyexn_constructor: extension_constructor; + ptyexn_loc: Location.t; + ptyexn_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + + and extension_constructor_kind (*IF_CURRENT = Parsetree.extension_constructor_kind *) = + Pext_decl of constructor_arguments * core_type option + (* + | C of T1 * ... * Tn ([T1; ...; Tn], None) + | C: T0 ([], Some T0) + | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) + *) + | Pext_rebind of Longident.t loc + (* + | C = D + *) + + (** {1 Class language} *) + + (* 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 + (* T -> CT Simple + ~l:T -> CT Labelled l + ?l:T -> CT 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; + } + (* object('selfpat) ... end + object ... end (self = 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 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) list; + pci_name: string loc; + pci_expr: 'a; + pci_loc: Location.t; + pci_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + (* class c = ... + class ['a1,...,'an] c = ... + class virtual c = ... + + Also used for "class type" declaration. + *) + + and class_description = class_type class_infos + + and class_type_declaration = class_type class_infos + + (* 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 + ['a1, ..., 'an] c *) + | Pcl_structure of class_structure + (* object ... end *) + | Pcl_fun of arg_label * expression option * pattern * class_expr + (* fun P -> CE (Simple, None) + fun ~l:P -> CE (Labelled l, None) + fun ?l:P -> CE (Optional l, None) + fun ?l:(P = E0) -> CE (Optional l, Some E0) + *) + | Pcl_apply of class_expr * (arg_label * expression) list + (* 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 + (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in CE (flag = 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; + } + (* object(selfpat) ... end + object ... end (self = 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 + (* inherit CE + inherit CE as x + inherit! CE + inherit! CE as x + *) + | Pcf_val of (label loc * mutable_flag * class_field_kind) + (* val x = E + val virtual x: T + *) + | Pcf_method of (label loc * private_flag * class_field_kind) + (* method x = E (E can be a Pexp_poly) + method virtual x: T (T can be a 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} *) + + (* 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 + (* 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 + (* (X : MT) Some X, MT + (_ : MT) None, MT *) + + 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 + 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 + 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; + } + (* 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; + } + + 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; + } + (* S = MT + S (abstract module type declaration, pmtd_type = 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; + } + (* open! X - popen_override = Override (silences the 'used identifier + shadowing' warning) + open X - popen_override = Fresh + *) + + and open_description = Longident.t loc open_infos + (* open M.N + open M(N).O *) + + and open_declaration = module_expr open_infos + (* 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 + (* include MT *) + + and include_declaration = module_expr include_infos + (* 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_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 *) + + (* 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_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 + (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN (flag = 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_binding (*IF_CURRENT = Parsetree.value_binding *) = + { + pvb_pat: pattern; + pvb_expr: expression; + 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; + } + (* X = ME *) + + (** {1 Toplevel} *) + + (* 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 = "Caml1999M028" + let ast_intf_magic_number = "Caml1999N028" +end diff -Nru ppxlib-0.15.0/astlib/ast_412.ml ppxlib-0.24.0/astlib/ast_412.ml --- ppxlib-0.15.0/astlib/ast_412.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/ast_412.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1021 @@ +(**************************************************************************) +(* *) +(* OCaml Migrate Parsetree *) +(* *) +(* Frédéric Bour, Facebook *) +(* Jérémie Dimino and Leo White, Jane Street Europe *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Alain Frisch, LexiFi *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique (INRIA). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +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 + (* 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 + (* 'c' *) + | Pconst_string of string * Location.t * string option + (* "constant" + {delim|other constant|delim} + + The location span the content of the string, without the delimiters. + *) + | Pconst_float of string * char option + (* 3.4 2e5 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; + } + (* [@id ARG] + [@@id ARG] + + Metadata containers passed around within the AST. + The compiler ignores unknown attributes. + *) + + and extension = string loc * payload + (* [%id ARG] + [%%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 *) + | PTyp of core_type (* : T *) + | PPat of pattern * expression option (* ? P or ? P when E *) + + (** {1 Core language} *) + + (* 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 *) + | Ptyp_arrow of arg_label * core_type * core_type + (* T1 -> T2 Simple + ~l:T1 -> T2 Labelled + ?l:T1 -> T2 Optional + *) + | Ptyp_tuple of core_type list + (* T1 * ... * Tn + + Invariant: n >= 2 + *) + | Ptyp_constr of Longident.t loc * core_type list + (* tconstr + T tconstr + (T1, ..., Tn) tconstr + *) + | Ptyp_object of object_field list * closed_flag + (* < l1:T1; ...; ln:Tn > (flag = Closed) + < l1:T1; ...; ln:Tn; .. > (flag = Open) + *) + | Ptyp_class of Longident.t loc * core_type list + (* #tconstr + T #tconstr + (T1, ..., Tn) #tconstr + *) + | Ptyp_alias of core_type * string + (* T as 'a *) + | Ptyp_variant of row_field list * closed_flag * label list option + (* [ `A|`B ] (flag = Closed; labels = None) + [> `A|`B ] (flag = Open; labels = None) + [< `A|`B ] (flag = Closed; labels = Some []) + [< `A|`B > `X `Y ](flag = Closed; labels = 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 Ppat_constraint node corresponding + to a constraint on a let-binding: let x : 'a1 ... 'an. T + = e ... + + - Under Cfk_virtual for methods (not values). + + - As the core_type of a Pctf_method node. + + - As the core_type of a Pexp_poly node. + + - As the pld_type field of a label_declaration. + + - As a core_type of a Ptyp_object node. + *) + + | Ptyp_package of package_type + (* (module S) *) + | Ptyp_extension of extension + (* [%id] *) + + and package_type = Longident.t loc * (Longident.t loc * core_type) list + (* + (module S) + (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 + (* [`A] ( true, [] ) + [`A of T] ( false, [T] ) + [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) + [`A of & T1 & .. & Tn] ( true, [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 + + (* 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 + (* _ *) + | Ppat_var of string loc + (* x *) + | Ppat_alias of pattern * string loc + (* P as 'a *) + | Ppat_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Ppat_interval of constant * constant + (* 'a'..'z' + + Other forms of interval are recognized by the parser + but rejected by the type-checker. *) + | Ppat_tuple of pattern list + (* (P1, ..., Pn) + + Invariant: n >= 2 + *) + | Ppat_construct of Longident.t loc * pattern option + (* C None + C P Some P + C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) + *) + | Ppat_variant of label * pattern option + (* `A (None) + `A P (Some P) + *) + | Ppat_record of (Longident.t loc * pattern) list * closed_flag + (* { l1=P1; ...; ln=Pn } (flag = Closed) + { l1=P1; ...; ln=Pn; _} (flag = Open) + + Invariant: n > 0 + *) + | Ppat_array of pattern list + (* [| P1; ...; Pn |] *) + | Ppat_or of pattern * pattern + (* P1 | P2 *) + | Ppat_constraint of pattern * core_type + (* (P : T) *) + | Ppat_type of Longident.t loc + (* #tconst *) + | Ppat_lazy of pattern + (* lazy P *) + | Ppat_unpack of string option loc + (* (module P) Some "P" + (module _) None + + Note: (module P : S) is represented as + Ppat_constraint(Ppat_unpack, Ptyp_package) + *) + | Ppat_exception of pattern + (* exception P *) + | Ppat_extension of extension + (* [%id] *) + | Ppat_open of Longident.t loc * pattern + (* M.(P) *) + + (* 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 + (* x + M.x + *) + | Pexp_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Pexp_let of rec_flag * value_binding list * expression + (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) + *) + | Pexp_function of case list + (* function P1 -> E1 | ... | Pn -> En *) + | Pexp_fun of arg_label * expression option * pattern * expression + (* fun P -> E1 (Simple, None) + fun ~l:P -> E1 (Labelled l, None) + fun ?l:P -> E1 (Optional l, None) + fun ?l:(P = E0) -> E1 (Optional l, Some E0) + + Notes: + - If E0 is provided, only Optional is allowed. + - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. + - "let f P = E" is represented using Pexp_fun. + *) + | Pexp_apply of expression * (arg_label * expression) list + (* E0 ~l1:E1 ... ~ln:En + li can be empty (non labeled argument) or start with '?' + (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 + (* (E1, ..., En) + + Invariant: n >= 2 + *) + | Pexp_construct of Longident.t loc * expression option + (* C None + C E Some E + C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) + *) + | Pexp_variant of label * expression option + (* `A (None) + `A E (Some E) + *) + | Pexp_record of (Longident.t loc * expression) list * expression option + (* { l1=P1; ...; ln=Pn } (None) + { E0 with l1=P1; ...; ln=Pn } (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 + (* for i = E1 to E2 do E3 done (flag = Upto) + for i = E1 downto E2 do E3 done (flag = Downto) + *) + | Pexp_constraint of expression * core_type + (* (E : T) *) + | Pexp_coerce of expression * core_type option * core_type + (* (E :> T) (None, T) + (E : T0 :> T) (Some T0, T) + *) + | 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 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, 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 = E in E + let* P = E and* P = E in E *) + | Pexp_extension of extension + (* [%id] *) + | Pexp_unreachable + (* . *) + + and case (*IF_CURRENT = Parsetree.case *) = (* (P -> E) or (P when E0 -> E) *) + { + pc_lhs: pattern; + pc_guard: expression option; + pc_rhs: expression; + } + + 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; + } + + (* 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; + } + +(* + val x: T (prim = []) + external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) +*) + + (* Type declarations *) + + and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = + { + ptype_name: string loc; + ptype_params: (core_type * (variance * injectivity)) list; + (* ('a1,...'an) t; None represents _*) + ptype_cstrs: (core_type * core_type * Location.t) list; + (* ... constraint T1=T1' ... constraint Tn=Tn' *) + ptype_kind: type_kind; + ptype_private: private_flag; (* = private ... *) + ptype_manifest: core_type option; (* = T *) + ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) + ptype_loc: Location.t; + } + +(* + type t (abstract, no manifest) + type t = T0 (abstract, manifest=T0) + type t = C of T | ... (variant, no manifest) + type t = T0 = C of T | ... (variant, manifest=T0) + type t = {l: T; ...} (record, no manifest) + type t = T0 = {l : T; ...} (record, manifest=T0) + type t = .. (open, no manifest) +*) + + 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; ... } (mutable=Immutable) + { ...; mutable l: T; ... } (mutable=Mutable) + + Note: T can be a Ptyp_poly. + *) + + and constructor_declaration (*IF_CURRENT = Parsetree.constructor_declaration *) = + { + pcd_name: string loc; + 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 + +(* + | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) + | C: T0 (res = Some T0, args = []) + | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) + | C of {...} (res = None, args = Pcstr_record) + | C: {...} -> T0 (res = Some T0, args = Pcstr_record) + | C of {...} as t (res = None, 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] *) + } +(* + 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] *) + } + + (* exception E *) + and type_exception (*IF_CURRENT = Parsetree.type_exception *) = + { + ptyexn_constructor: extension_constructor; + ptyexn_loc: Location.t; + ptyexn_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + + and extension_constructor_kind (*IF_CURRENT = Parsetree.extension_constructor_kind *) = + Pext_decl of constructor_arguments * core_type option + (* + | C of T1 * ... * Tn ([T1; ...; Tn], None) + | C: T0 ([], Some T0) + | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) + *) + | Pext_rebind of Longident.t loc + (* + | C = D + *) + + (** {1 Class language} *) + + (* 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 + (* T -> CT Simple + ~l:T -> CT Labelled l + ?l:T -> CT 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; + } + (* object('selfpat) ... end + object ... end (self = 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 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] *) + } + (* class c = ... + class ['a1,...,'an] c = ... + class virtual c = ... + + Also used for "class type" declaration. + *) + + and class_description = class_type class_infos + + and class_type_declaration = class_type class_infos + + (* 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 + ['a1, ..., 'an] c *) + | Pcl_structure of class_structure + (* object ... end *) + | Pcl_fun of arg_label * expression option * pattern * class_expr + (* fun P -> CE (Simple, None) + fun ~l:P -> CE (Labelled l, None) + fun ?l:P -> CE (Optional l, None) + fun ?l:(P = E0) -> CE (Optional l, Some E0) + *) + | Pcl_apply of class_expr * (arg_label * expression) list + (* 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 + (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in CE (flag = 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; + } + (* object(selfpat) ... end + object ... end (self = 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 + (* inherit CE + inherit CE as x + inherit! CE + inherit! CE as x + *) + | Pcf_val of (label loc * mutable_flag * class_field_kind) + (* val x = E + val virtual x: T + *) + | Pcf_method of (label loc * private_flag * class_field_kind) + (* method x = E (E can be a Pexp_poly) + method virtual x: T (T can be a 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} *) + + (* 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 + (* 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 + (* (X : MT) Some X, MT + (_ : MT) None, MT *) + + 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 + 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 + 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; + } + (* 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; + } + + 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; + } + (* S = MT + S (abstract module type declaration, pmtd_type = 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; + } + (* open! X - popen_override = Override (silences the 'used identifier + shadowing' warning) + open X - popen_override = Fresh + *) + + and open_description = Longident.t loc open_infos + (* open M.N + open M(N).O *) + + and open_declaration = module_expr open_infos + (* 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 + (* include MT *) + + and include_declaration = module_expr include_infos + (* 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_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 *) + + (* 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_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 + (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN (flag = 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_binding (*IF_CURRENT = Parsetree.value_binding *) = + { + pvb_pat: pattern; + pvb_expr: expression; + 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; + } + (* X = ME *) + + (** {1 Toplevel} *) + + (* 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 = "Caml1999M029" + let ast_intf_magic_number = "Caml1999N029" +end diff -Nru ppxlib-0.15.0/astlib/ast_413.ml ppxlib-0.24.0/astlib/ast_413.ml --- ppxlib-0.15.0/astlib/ast_413.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/ast_413.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1028 @@ +(**************************************************************************) +(* *) +(* OCaml Migrate Parsetree *) +(* *) +(* Frédéric Bour, Facebook *) +(* Jérémie Dimino and Leo White, Jane Street Europe *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Alain Frisch, LexiFi *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique (INRIA). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +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 + (* 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 + (* 'c' *) + | Pconst_string of string * Location.t * string option + (* "constant" + {delim|other constant|delim} + + The location span the content of the string, without the delimiters. + *) + | Pconst_float of string * char option + (* 3.4 2e5 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; + } + (* [@id ARG] + [@@id ARG] + + Metadata containers passed around within the AST. + The compiler ignores unknown attributes. + *) + + and extension = string loc * payload + (* [%id ARG] + [%%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 *) + | PTyp of core_type (* : T *) + | PPat of pattern * expression option (* ? P or ? P when E *) + + (** {1 Core language} *) + + (* 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 *) + | Ptyp_arrow of arg_label * core_type * core_type + (* T1 -> T2 Simple + ~l:T1 -> T2 Labelled + ?l:T1 -> T2 Optional + *) + | Ptyp_tuple of core_type list + (* T1 * ... * Tn + + Invariant: n >= 2 + *) + | Ptyp_constr of Longident.t loc * core_type list + (* tconstr + T tconstr + (T1, ..., Tn) tconstr + *) + | Ptyp_object of object_field list * closed_flag + (* < l1:T1; ...; ln:Tn > (flag = Closed) + < l1:T1; ...; ln:Tn; .. > (flag = Open) + *) + | Ptyp_class of Longident.t loc * core_type list + (* #tconstr + T #tconstr + (T1, ..., Tn) #tconstr + *) + | Ptyp_alias of core_type * string + (* T as 'a *) + | Ptyp_variant of row_field list * closed_flag * label list option + (* [ `A|`B ] (flag = Closed; labels = None) + [> `A|`B ] (flag = Open; labels = None) + [< `A|`B ] (flag = Closed; labels = Some []) + [< `A|`B > `X `Y ](flag = Closed; labels = 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 Ppat_constraint node corresponding + to a constraint on a let-binding: let x : 'a1 ... 'an. T + = e ... + + - Under Cfk_virtual for methods (not values). + + - As the core_type of a Pctf_method node. + + - As the core_type of a Pexp_poly node. + + - As the pld_type field of a label_declaration. + + - As a core_type of a Ptyp_object node. + *) + + | Ptyp_package of package_type + (* (module S) *) + | Ptyp_extension of extension + (* [%id] *) + + and package_type = Longident.t loc * (Longident.t loc * core_type) list + (* + (module S) + (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 + (* [`A] ( true, [] ) + [`A of T] ( false, [T] ) + [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) + [`A of & T1 & .. & Tn] ( true, [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 + + (* 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 + (* _ *) + | Ppat_var of string loc + (* x *) + | Ppat_alias of pattern * string loc + (* P as 'a *) + | Ppat_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Ppat_interval of constant * constant + (* 'a'..'z' + + Other forms of interval are recognized by the parser + but rejected by the type-checker. *) + | Ppat_tuple of pattern list + (* (P1, ..., Pn) + + Invariant: n >= 2 + *) + | Ppat_construct of Longident.t loc * (string loc list * pattern) option + (* C None + C P Some ([], P) + C (P1, ..., Pn) Some ([], Ppat_tuple [P1; ...; Pn]) + C (type a b) P Some ([a; b], P) + *) + | Ppat_variant of label * pattern option + (* `A (None) + `A P (Some P) + *) + | Ppat_record of (Longident.t loc * pattern) list * closed_flag + (* { l1=P1; ...; ln=Pn } (flag = Closed) + { l1=P1; ...; ln=Pn; _} (flag = Open) + + Invariant: n > 0 + *) + | Ppat_array of pattern list + (* [| P1; ...; Pn |] *) + | Ppat_or of pattern * pattern + (* P1 | P2 *) + | Ppat_constraint of pattern * core_type + (* (P : T) *) + | Ppat_type of Longident.t loc + (* #tconst *) + | Ppat_lazy of pattern + (* lazy P *) + | Ppat_unpack of string option loc + (* (module P) Some "P" + (module _) None + + Note: (module P : S) is represented as + Ppat_constraint(Ppat_unpack, Ptyp_package) + *) + | Ppat_exception of pattern + (* exception P *) + | Ppat_extension of extension + (* [%id] *) + | Ppat_open of Longident.t loc * pattern + (* M.(P) *) + + (* 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 + (* x + M.x + *) + | Pexp_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Pexp_let of rec_flag * value_binding list * expression + (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) + *) + | Pexp_function of case list + (* function P1 -> E1 | ... | Pn -> En *) + | Pexp_fun of arg_label * expression option * pattern * expression + (* fun P -> E1 (Simple, None) + fun ~l:P -> E1 (Labelled l, None) + fun ?l:P -> E1 (Optional l, None) + fun ?l:(P = E0) -> E1 (Optional l, Some E0) + + Notes: + - If E0 is provided, only Optional is allowed. + - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. + - "let f P = E" is represented using Pexp_fun. + *) + | Pexp_apply of expression * (arg_label * expression) list + (* E0 ~l1:E1 ... ~ln:En + li can be empty (non labeled argument) or start with '?' + (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 + (* (E1, ..., En) + + Invariant: n >= 2 + *) + | Pexp_construct of Longident.t loc * expression option + (* C None + C E Some E + C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) + *) + | Pexp_variant of label * expression option + (* `A (None) + `A E (Some E) + *) + | Pexp_record of (Longident.t loc * expression) list * expression option + (* { l1=P1; ...; ln=Pn } (None) + { E0 with l1=P1; ...; ln=Pn } (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 + (* for i = E1 to E2 do E3 done (flag = Upto) + for i = E1 downto E2 do E3 done (flag = Downto) + *) + | Pexp_constraint of expression * core_type + (* (E : T) *) + | Pexp_coerce of expression * core_type option * core_type + (* (E :> T) (None, T) + (E : T0 :> T) (Some T0, T) + *) + | 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 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, 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 = E in E + let* P = E and* P = E in E *) + | Pexp_extension of extension + (* [%id] *) + | Pexp_unreachable + (* . *) + + and case (*IF_CURRENT = Parsetree.case *) = (* (P -> E) or (P when E0 -> E) *) + { + pc_lhs: pattern; + pc_guard: expression option; + pc_rhs: expression; + } + + 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; + } + + (* 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; + } + +(* + val x: T (prim = []) + external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) +*) + + (* Type declarations *) + + and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = + { + ptype_name: string loc; + ptype_params: (core_type * (variance * injectivity)) list; + (* ('a1,...'an) t; None represents _*) + ptype_cstrs: (core_type * core_type * Location.t) list; + (* ... constraint T1=T1' ... constraint Tn=Tn' *) + ptype_kind: type_kind; + ptype_private: private_flag; (* = private ... *) + ptype_manifest: core_type option; (* = T *) + ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) + ptype_loc: Location.t; + } + +(* + type t (abstract, no manifest) + type t = T0 (abstract, manifest=T0) + type t = C of T | ... (variant, no manifest) + type t = T0 = C of T | ... (variant, manifest=T0) + type t = {l: T; ...} (record, no manifest) + type t = T0 = {l : T; ...} (record, manifest=T0) + type t = .. (open, no manifest) +*) + + 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; ... } (mutable=Immutable) + { ...; mutable l: T; ... } (mutable=Mutable) + + Note: T can be a Ptyp_poly. + *) + + and constructor_declaration (*IF_CURRENT = Parsetree.constructor_declaration *) = + { + pcd_name: string loc; + 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 + +(* + | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) + | C: T0 (res = Some T0, args = []) + | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) + | C of {...} (res = None, args = Pcstr_record) + | C: {...} -> T0 (res = Some T0, args = Pcstr_record) + | C of {...} as t (res = None, 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] *) + } +(* + 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] *) + } + + (* exception E *) + and type_exception (*IF_CURRENT = Parsetree.type_exception *) = + { + ptyexn_constructor: extension_constructor; + ptyexn_loc: Location.t; + ptyexn_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + + and extension_constructor_kind (*IF_CURRENT = Parsetree.extension_constructor_kind *) = + Pext_decl of constructor_arguments * core_type option + (* + | C of T1 * ... * Tn ([T1; ...; Tn], None) + | C: T0 ([], Some T0) + | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) + *) + | Pext_rebind of Longident.t loc + (* + | C = D + *) + + (** {1 Class language} *) + + (* 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 + (* T -> CT Simple + ~l:T -> CT Labelled l + ?l:T -> CT 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; + } + (* object('selfpat) ... end + object ... end (self = 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 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] *) + } + (* class c = ... + class ['a1,...,'an] c = ... + class virtual c = ... + + Also used for "class type" declaration. + *) + + and class_description = class_type class_infos + + and class_type_declaration = class_type class_infos + + (* 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 + ['a1, ..., 'an] c *) + | Pcl_structure of class_structure + (* object ... end *) + | Pcl_fun of arg_label * expression option * pattern * class_expr + (* fun P -> CE (Simple, None) + fun ~l:P -> CE (Labelled l, None) + fun ?l:P -> CE (Optional l, None) + fun ?l:(P = E0) -> CE (Optional l, Some E0) + *) + | Pcl_apply of class_expr * (arg_label * expression) list + (* 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 + (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in CE (flag = 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; + } + (* object(selfpat) ... end + object ... end (self = 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 + (* inherit CE + inherit CE as x + inherit! CE + inherit! CE as x + *) + | Pcf_val of (label loc * mutable_flag * class_field_kind) + (* val x = E + val virtual x: T + *) + | Pcf_method of (label loc * private_flag * class_field_kind) + (* method x = E (E can be a Pexp_poly) + method virtual x: T (T can be a 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} *) + + (* 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 + (* 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 + (* (X : MT) Some X, MT + (_ : MT) None, MT *) + + 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 + 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 + 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; + } + (* 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; + } + + 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; + } + (* S = MT + S (abstract module type declaration, pmtd_type = 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; + } + (* open! X - popen_override = Override (silences the 'used identifier + shadowing' warning) + open X - popen_override = Fresh + *) + + and open_description = Longident.t loc open_infos + (* open M.N + open M(N).O *) + + and open_declaration = module_expr open_infos + (* 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 + (* include MT *) + + and include_declaration = module_expr include_infos + (* 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 *) + + (* 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_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 + (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN (flag = 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_binding (*IF_CURRENT = Parsetree.value_binding *) = + { + pvb_pat: pattern; + pvb_expr: expression; + 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; + } + (* X = ME *) + + (** {1 Toplevel} *) + + (* 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 = "Caml1999M030" + let ast_intf_magic_number = "Caml1999N030" +end diff -Nru ppxlib-0.15.0/astlib/ast_414.ml ppxlib-0.24.0/astlib/ast_414.ml --- ppxlib-0.15.0/astlib/ast_414.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/ast_414.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1032 @@ +(**************************************************************************) +(* *) +(* OCaml Migrate Parsetree *) +(* *) +(* Frédéric Bour, Facebook *) +(* Jérémie Dimino and Leo White, Jane Street Europe *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Alain Frisch, LexiFi *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique (INRIA). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +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 + (* 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 + (* 'c' *) + | Pconst_string of string * Location.t * string option + (* "constant" + {delim|other constant|delim} + + The location span the content of the string, without the delimiters. + *) + | Pconst_float of string * char option + (* 3.4 2e5 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; + } + (* [@id ARG] + [@@id ARG] + + Metadata containers passed around within the AST. + The compiler ignores unknown attributes. + *) + + and extension = string loc * payload + (* [%id ARG] + [%%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 *) + | PTyp of core_type (* : T *) + | PPat of pattern * expression option (* ? P or ? P when E *) + + (** {1 Core language} *) + + (* 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 *) + | Ptyp_arrow of arg_label * core_type * core_type + (* T1 -> T2 Simple + ~l:T1 -> T2 Labelled + ?l:T1 -> T2 Optional + *) + | Ptyp_tuple of core_type list + (* T1 * ... * Tn + + Invariant: n >= 2 + *) + | Ptyp_constr of Longident.t loc * core_type list + (* tconstr + T tconstr + (T1, ..., Tn) tconstr + *) + | Ptyp_object of object_field list * closed_flag + (* < l1:T1; ...; ln:Tn > (flag = Closed) + < l1:T1; ...; ln:Tn; .. > (flag = Open) + *) + | Ptyp_class of Longident.t loc * core_type list + (* #tconstr + T #tconstr + (T1, ..., Tn) #tconstr + *) + | Ptyp_alias of core_type * string + (* T as 'a *) + | Ptyp_variant of row_field list * closed_flag * label list option + (* [ `A|`B ] (flag = Closed; labels = None) + [> `A|`B ] (flag = Open; labels = None) + [< `A|`B ] (flag = Closed; labels = Some []) + [< `A|`B > `X `Y ](flag = Closed; labels = 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 Ppat_constraint node corresponding + to a constraint on a let-binding: let x : 'a1 ... 'an. T + = e ... + + - Under Cfk_virtual for methods (not values). + + - As the core_type of a Pctf_method node. + + - As the core_type of a Pexp_poly node. + + - As the pld_type field of a label_declaration. + + - As a core_type of a Ptyp_object node. + + - As the 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 + (* + (module S) + (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 + (* [`A] ( true, [] ) + [`A of T] ( false, [T] ) + [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) + [`A of & T1 & .. & Tn] ( true, [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 + + (* 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 + (* _ *) + | Ppat_var of string loc + (* x *) + | Ppat_alias of pattern * string loc + (* P as 'a *) + | Ppat_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Ppat_interval of constant * constant + (* 'a'..'z' + + Other forms of interval are recognized by the parser + but rejected by the type-checker. *) + | Ppat_tuple of pattern list + (* (P1, ..., Pn) + + Invariant: n >= 2 + *) + | Ppat_construct of Longident.t loc * (string loc list * pattern) option + (* C None + C P Some ([], P) + C (P1, ..., Pn) Some ([], Ppat_tuple [P1; ...; Pn]) + C (type a b) P Some ([a; b], P) + *) + | Ppat_variant of label * pattern option + (* `A (None) + `A P (Some P) + *) + | Ppat_record of (Longident.t loc * pattern) list * closed_flag + (* { l1=P1; ...; ln=Pn } (flag = Closed) + { l1=P1; ...; ln=Pn; _} (flag = Open) + + Invariant: n > 0 + *) + | Ppat_array of pattern list + (* [| P1; ...; Pn |] *) + | Ppat_or of pattern * pattern + (* P1 | P2 *) + | Ppat_constraint of pattern * core_type + (* (P : T) *) + | Ppat_type of Longident.t loc + (* #tconst *) + | Ppat_lazy of pattern + (* lazy P *) + | Ppat_unpack of string option loc + (* (module P) Some "P" + (module _) None + + Note: (module P : S) is represented as + Ppat_constraint(Ppat_unpack, Ptyp_package) + *) + | Ppat_exception of pattern + (* exception P *) + | Ppat_extension of extension + (* [%id] *) + | Ppat_open of Longident.t loc * pattern + (* M.(P) *) + + (* 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 + (* x + M.x + *) + | Pexp_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Pexp_let of rec_flag * value_binding list * expression + (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) + *) + | Pexp_function of case list + (* function P1 -> E1 | ... | Pn -> En *) + | Pexp_fun of arg_label * expression option * pattern * expression + (* fun P -> E1 (Simple, None) + fun ~l:P -> E1 (Labelled l, None) + fun ?l:P -> E1 (Optional l, None) + fun ?l:(P = E0) -> E1 (Optional l, Some E0) + + Notes: + - If E0 is provided, only Optional is allowed. + - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. + - "let f P = E" is represented using Pexp_fun. + *) + | Pexp_apply of expression * (arg_label * expression) list + (* E0 ~l1:E1 ... ~ln:En + li can be empty (non labeled argument) or start with '?' + (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 + (* (E1, ..., En) + + Invariant: n >= 2 + *) + | Pexp_construct of Longident.t loc * expression option + (* C None + C E Some E + C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) + *) + | Pexp_variant of label * expression option + (* `A (None) + `A E (Some E) + *) + | Pexp_record of (Longident.t loc * expression) list * expression option + (* { l1=P1; ...; ln=Pn } (None) + { E0 with l1=P1; ...; ln=Pn } (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 + (* for i = E1 to E2 do E3 done (flag = Upto) + for i = E1 downto E2 do E3 done (flag = Downto) + *) + | Pexp_constraint of expression * core_type + (* (E : T) *) + | Pexp_coerce of expression * core_type option * core_type + (* (E :> T) (None, T) + (E : T0 :> T) (Some T0, T) + *) + | 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 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, 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 = E in E + let* P = E and* P = E in E *) + | Pexp_extension of extension + (* [%id] *) + | Pexp_unreachable + (* . *) + + and case (*IF_CURRENT = Parsetree.case *) = (* (P -> E) or (P when E0 -> E) *) + { + pc_lhs: pattern; + pc_guard: expression option; + pc_rhs: expression; + } + + 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; + } + + (* 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; + } + +(* + val x: T (prim = []) + external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) +*) + + (* Type declarations *) + + and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = + { + ptype_name: string loc; + ptype_params: (core_type * (variance * injectivity)) list; + (* ('a1,...'an) t; None represents _*) + ptype_cstrs: (core_type * core_type * Location.t) list; + (* ... constraint T1=T1' ... constraint Tn=Tn' *) + ptype_kind: type_kind; + ptype_private: private_flag; (* = private ... *) + ptype_manifest: core_type option; (* = T *) + ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) + ptype_loc: Location.t; + } + +(* + type t (abstract, no manifest) + type t = T0 (abstract, manifest=T0) + type t = C of T | ... (variant, no manifest) + type t = T0 = C of T | ... (variant, manifest=T0) + type t = {l: T; ...} (record, no manifest) + type t = T0 = {l : T; ...} (record, manifest=T0) + type t = .. (open, no manifest) +*) + + 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; ... } (mutable=Immutable) + { ...; mutable l: T; ... } (mutable=Mutable) + + Note: T can be a 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 + +(* + | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) + | C: T0 (res = Some T0, args = []) + | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) + | C of {...} (res = None, args = Pcstr_record) + | C: {...} -> T0 (res = Some T0, args = Pcstr_record) + | C of {...} as t (res = None, 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] *) + } +(* + 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] *) + } + + (* exception E *) + and type_exception (*IF_CURRENT = Parsetree.type_exception *) = + { + ptyexn_constructor: extension_constructor; + ptyexn_loc: Location.t; + ptyexn_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + + and extension_constructor_kind (*IF_CURRENT = Parsetree.extension_constructor_kind *) = + Pext_decl of string loc list * constructor_arguments * core_type option + (* + | C of T1 * ... * Tn ([], [T1; ...; Tn], None) + | C: T0 ([], [], Some T0) + | C: T1 * ... * Tn -> T0 ([], [T1; ...; Tn], Some T0) + | C: 'a... . T1... -> T0 (['a;...]; [T1;...], Some T0) + *) + | Pext_rebind of Longident.t loc + (* + | C = D + *) + + (** {1 Class language} *) + + (* 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 + (* T -> CT Simple + ~l:T -> CT Labelled l + ?l:T -> CT 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; + } + (* object('selfpat) ... end + object ... end (self = 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 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] *) + } + (* class c = ... + class ['a1,...,'an] c = ... + class virtual c = ... + + Also used for "class type" declaration. + *) + + and class_description = class_type class_infos + + and class_type_declaration = class_type class_infos + + (* 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 + ['a1, ..., 'an] c *) + | Pcl_structure of class_structure + (* object ... end *) + | Pcl_fun of arg_label * expression option * pattern * class_expr + (* fun P -> CE (Simple, None) + fun ~l:P -> CE (Labelled l, None) + fun ?l:P -> CE (Optional l, None) + fun ?l:(P = E0) -> CE (Optional l, Some E0) + *) + | Pcl_apply of class_expr * (arg_label * expression) list + (* 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 + (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in CE (flag = 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; + } + (* object(selfpat) ... end + object ... end (self = 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 + (* inherit CE + inherit CE as x + inherit! CE + inherit! CE as x + *) + | Pcf_val of (label loc * mutable_flag * class_field_kind) + (* val x = E + val virtual x: T + *) + | Pcf_method of (label loc * private_flag * class_field_kind) + (* method x = E (E can be a Pexp_poly) + method virtual x: T (T can be a 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} *) + + (* 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 + (* 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 + (* (X : MT) Some X, MT + (_ : MT) None, MT *) + + 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 + 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 + 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; + } + (* 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; + } + + 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; + } + (* S = MT + S (abstract module type declaration, pmtd_type = 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; + } + (* open! X - popen_override = Override (silences the 'used identifier + shadowing' warning) + open X - popen_override = Fresh + *) + + and open_description = Longident.t loc open_infos + (* open M.N + open M(N).O *) + + and open_declaration = module_expr open_infos + (* 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 + (* include MT *) + + and include_declaration = module_expr include_infos + (* 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 *) + + (* 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_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 + (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN (flag = 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_binding (*IF_CURRENT = Parsetree.value_binding *) = + { + pvb_pat: pattern; + pvb_expr: expression; + 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; + } + (* X = ME *) + + (** {1 Toplevel} *) + + (* 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 = "Caml1999M031" + let ast_intf_magic_number = "Caml1999N031" +end diff -Nru ppxlib-0.15.0/astlib/astlib.ml ppxlib-0.24.0/astlib/astlib.ml --- ppxlib-0.15.0/astlib/astlib.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/astlib.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,84 @@ +(**************************************************************************) +(* *) +(* OCaml Migrate Parsetree *) +(* *) +(* Frédéric Bour *) +(* Jérémie Dimino, Jane Street Europe *) +(* *) +(* Copyright 2017 Institut National de Recherche en Informatique et *) +(* en Automatique (INRIA). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(*$ open Astlib_cinaps_helpers + open Printf $*) + +(* Copy of OCaml parsetrees *) +(*$ + foreach_version (fun suffix _ -> + printf "module Ast_%s = Ast_%s\n" suffix suffix) +*) +module Ast_402 = Ast_402 +module Ast_403 = Ast_403 +module Ast_404 = Ast_404 +module Ast_405 = Ast_405 +module Ast_406 = Ast_406 +module Ast_407 = Ast_407 +module Ast_408 = Ast_408 +module Ast_409 = Ast_409 +module Ast_410 = Ast_410 +module Ast_411 = Ast_411 +module Ast_412 = Ast_412 +module Ast_413 = Ast_413 +module Ast_414 = Ast_414 +(*$*) + +(* Manual migration between versions *) +(*$ + foreach_version_pair (fun x y -> + printf "module Migrate_%s_%s = Migrate_%s_%s\n" x y x y; + printf "module Migrate_%s_%s = Migrate_%s_%s\n" y x y x) +*) +module Migrate_402_403 = Migrate_402_403 +module Migrate_403_402 = Migrate_403_402 +module Migrate_403_404 = Migrate_403_404 +module Migrate_404_403 = Migrate_404_403 +module Migrate_404_405 = Migrate_404_405 +module Migrate_405_404 = Migrate_405_404 +module Migrate_405_406 = Migrate_405_406 +module Migrate_406_405 = Migrate_406_405 +module Migrate_406_407 = Migrate_406_407 +module Migrate_407_406 = Migrate_407_406 +module Migrate_407_408 = Migrate_407_408 +module Migrate_408_407 = Migrate_408_407 +module Migrate_408_409 = Migrate_408_409 +module Migrate_409_408 = Migrate_409_408 +module Migrate_409_410 = Migrate_409_410 +module Migrate_410_409 = Migrate_410_409 +module Migrate_410_411 = Migrate_410_411 +module Migrate_411_410 = Migrate_411_410 +module Migrate_411_412 = Migrate_411_412 +module Migrate_412_411 = Migrate_412_411 +module Migrate_412_413 = Migrate_412_413 +module Migrate_413_412 = Migrate_413_412 +module Migrate_413_414 = Migrate_413_414 +module Migrate_414_413 = Migrate_414_413 +(*$*) + +(* Compiler modules *) +module Ast_metadata = Ast_metadata +module Config = Config +module Keyword = Keyword +module Location = Location +module Longident = Longident +module Parse = Parse +module Pprintast = Pprintast + +let init_error_reporting_style_using_env_vars () = + (*IF_AT_LEAST 408 Ocaml_common.Compmisc.read_clflags_from_env () *) + (*IF_NOT_AT_LEAST 408 () *) +(** Adjust the reporting style of error messages to the environment variables OCAML_COLOR and OCAML_ERROR_STYLE. *) diff -Nru ppxlib-0.15.0/astlib/ast_metadata.ml ppxlib-0.24.0/astlib/ast_metadata.ml --- ppxlib-0.15.0/astlib/ast_metadata.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/ast_metadata.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1 @@ +include Ocaml_common.Ast_mapper diff -Nru ppxlib-0.15.0/astlib/ast_metadata.mli ppxlib-0.24.0/astlib/ast_metadata.mli --- ppxlib-0.15.0/astlib/ast_metadata.mli 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/ast_metadata.mli 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,40 @@ +(** Meta data related interface for a ppx rewriter *) + +val add_ppx_context_str : + tool_name:string -> + Parsetree.structure_item list -> + Parsetree.structure_item list +(** Extract information from the current environment and encode it into an + attribute which is prepended to the list of structure items in order to pass + the information to an external processor. *) + +val drop_ppx_context_str : + restore:bool -> Parsetree.structure_item list -> Parsetree.structure_item list +(** Drop the ocaml.ppx.context attribute from a structure. If [restore] is true, + also restore the associated data in the current process. *) + +val add_ppx_context_sig : + tool_name:string -> + Parsetree.signature_item list -> + Parsetree.signature_item list +(** Same as [add_ppx_context_str], but for signatures. *) + +val drop_ppx_context_sig : + restore:bool -> Parsetree.signature_item list -> Parsetree.signature_item list +(** Same as [drop_ppx_context_str], but for signatures. *) + +val tool_name : unit -> string +(** Can be used within a ppx preprocessor to know which tool is calling it + ["ocamlc"], ["ocamlopt"], ["ocamldoc"], ["ocamldep"], ["ocaml"], ... *) + +(** {1 Cookies} *) + +(** Cookies are used to pass information from a ppx processor to a further + invocation of itself, when called from the OCaml toplevel (or other tools + that support cookies). *) + +val set_cookie : string -> Parsetree.expression -> unit +(* [set_cookie name expr] registers a cookie with name [name] and value [expr]. *) + +val get_cookie : string -> Parsetree.expression option +(* Returns the registered cookie with name [name], if any. *) diff -Nru ppxlib-0.15.0/astlib/cinaps/astlib_cinaps_helpers.ml ppxlib-0.24.0/astlib/cinaps/astlib_cinaps_helpers.ml --- ppxlib-0.15.0/astlib/cinaps/astlib_cinaps_helpers.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/cinaps/astlib_cinaps_helpers.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,37 @@ +(* -*- tuareg -*- *) + +open StdLabels +open Printf + +let nl () = printf "\n" + +let supported_versions = + [ + ("402", "4.02"); + ("403", "4.03"); + ("404", "4.04"); + ("405", "4.05"); + ("406", "4.06"); + ("407", "4.07"); + ("408", "4.08"); + ("409", "4.09"); + ("410", "4.10"); + ("411", "4.11"); + ("412", "4.12"); + ("413", "4.13"); + ("414", "4.14"); + ] + +let foreach_version f = + nl (); + List.iter supported_versions ~f:(fun (suffix, version) -> f suffix version) + +let foreach_version_pair f = + nl (); + let rec aux = function + | (x, _) :: ((y, _) :: _ as tail) -> + f x y; + aux tail + | [ _ ] | [] -> () + in + aux supported_versions diff -Nru ppxlib-0.15.0/astlib/cinaps/dune ppxlib-0.24.0/astlib/cinaps/dune --- ppxlib-0.15.0/astlib/cinaps/dune 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/cinaps/dune 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,2 @@ +(library + (name astlib_cinaps_helpers)) diff -Nru ppxlib-0.15.0/astlib/config/gen.ml ppxlib-0.24.0/astlib/config/gen.ml --- ppxlib-0.15.0/astlib/config/gen.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/config/gen.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,28 @@ +let write fn s = + let oc = open_out fn in + output_string oc s; + close_out oc + +let () = + let ocaml_version_str = Sys.argv.(1) in + let ocaml_version = + Scanf.sscanf ocaml_version_str "%u.%u" (fun a b -> (a, b)) + in + write "ast-version" + (match ocaml_version with + | 4, 02 -> "402" + | 4, 03 -> "403" + | 4, 04 -> "404" + | 4, 05 -> "405" + | 4, 06 -> "406" + | 4, 07 -> "407" + | 4, 08 -> "408" + | 4, 09 -> "409" + | 4, 10 -> "410" + | 4, 11 -> "411" + | 4, 12 -> "412" + | 4, 13 -> "413" + | 4, 14 -> "414" + | _ -> + Printf.eprintf "Unkown OCaml version %s\n" ocaml_version_str; + exit 1) diff -Nru ppxlib-0.15.0/astlib/config.ml ppxlib-0.24.0/astlib/config.ml --- ppxlib-0.15.0/astlib/config.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/config.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1 @@ +include Ocaml_common.Config diff -Nru ppxlib-0.15.0/astlib/config.mli ppxlib-0.24.0/astlib/config.mli --- ppxlib-0.15.0/astlib/config.mli 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/config.mli 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,7 @@ +(** Magic numbers *) + +val ast_intf_magic_number : string +(** Magic number for file holding an interface syntax tree *) + +val ast_impl_magic_number : string +(** Magic number for file holding an implementation syntax tree *) diff -Nru ppxlib-0.15.0/astlib/dune ppxlib-0.24.0/astlib/dune --- ppxlib-0.15.0/astlib/dune 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/dune 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,17 @@ +(library + (name astlib) + (public_name ppxlib.astlib) + (libraries ocaml-compiler-libs.common compiler-libs.common) + (flags -w -9) + (preprocess + (action + (run %{exe:pp/pp.exe} %{read:ast-version} %{input-file})))) + +(rule + (targets ast-version) + (action + (run %{ocaml} %{dep:config/gen.ml} %{ocaml_version}))) + +(cinaps + (files *.ml *.mli) + (libraries astlib_cinaps_helpers)) diff -Nru ppxlib-0.15.0/astlib/keyword.ml ppxlib-0.24.0/astlib/keyword.ml --- ppxlib-0.15.0/astlib/keyword.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/keyword.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,59 @@ +let is_keyword = function + | "and" -> true + | "as" -> true + | "assert" -> true + | "begin" -> true + | "class" -> true + | "constraint" -> true + | "do" -> true + | "done" -> true + | "downto" -> true + | "else" -> true + | "end" -> true + | "exception" -> true + | "external" -> true + | "false" -> true + | "for" -> true + | "fun" -> true + | "function" -> true + | "functor" -> true + | "if" -> true + | "in" -> true + | "include" -> true + | "inherit" -> true + | "initializer" -> true + | "lazy" -> true + | "let" -> true + | "match" -> true + | "method" -> true + | "module" -> true + | "mutable" -> true + | "new" -> true + | "nonrec" -> true + | "object" -> true + | "of" -> true + | "open" -> true + | "or" -> true + (* | "parser" -> true *) + | "private" -> true + | "rec" -> true + | "sig" -> true + | "struct" -> true + | "then" -> true + | "to" -> true + | "true" -> true + | "try" -> true + | "type" -> true + | "val" -> true + | "virtual" -> true + | "when" -> true + | "while" -> true + | "with" -> true + | "lor" -> true + | "lxor" -> true + | "mod" -> true + | "land" -> true + | "lsl" -> true + | "lsr" -> true + | "asr" -> true + | _ -> false diff -Nru ppxlib-0.15.0/astlib/keyword.mli ppxlib-0.24.0/astlib/keyword.mli --- ppxlib-0.15.0/astlib/keyword.mli 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/keyword.mli 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,2 @@ +val is_keyword : string -> bool +(** Check if a string is an OCaml keyword. *) diff -Nru ppxlib-0.15.0/astlib/location.ml ppxlib-0.24.0/astlib/location.ml --- ppxlib-0.15.0/astlib/location.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/location.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,114 @@ +include Ocaml_common.Location + +let set_input_name name = input_name := name + +module Error = struct + [@@@warning "-37"] + + type old_t (*IF_NOT_AT_LEAST 408 = Ocaml_common.Location.error *) = { + loc: t; + msg: string; + sub: old_t list; + if_highlight: string; + } + + type location_report_kind (*IF_AT_LEAST 408 = Ocaml_common.Location.report_kind *) = + | Report_error + | Report_warning of string + | Report_warning_as_error of string + | Report_alert of string + | Report_alert_as_error of string + + type location_msg = (Format.formatter -> unit) loc + + type location_report (*IF_AT_LEAST 408 = Ocaml_common.Location.report *) = { + kind : location_report_kind; + main : location_msg; + sub : location_msg list; + } + + type t (*IF_AT_LEAST 408 = Ocaml_common.Location.error *) (*IF_NOT_AT_LEAST 408 = old_t *) + (** On ocaml >= 4.08: [t] is a [location_report] for which [location_report_kind] must be [Report_error]. *) + + type version_specific_t = [`New_error of location_report | `Old_error of old_t] + + let version_specific_t_of_t : t -> version_specific_t = fun x -> + (*IF_AT_LEAST 408 `New_error x *) + (*IF_NOT_AT_LEAST 408 `Old_error x *) + + let is_well_formed error = + match version_specific_t_of_t error with + | `New_error { kind = Report_error; _ } -> true + | `New_error _ -> false + | `Old_error _ -> true + + let string_of_location_msg (msg : location_msg) = Format.asprintf "%t" msg.txt + + let main_msg error = + match version_specific_t_of_t error with + | `New_error { main; _ } -> + { txt = string_of_location_msg main; loc = main.loc } + | `Old_error { msg; loc; _ } -> { txt = msg; loc } + + let sub_msgs error = + match version_specific_t_of_t error with + | `New_error { sub; _ } -> + List.map + (fun err -> { txt = string_of_location_msg err; loc = err.loc }) + sub + | `Old_error { sub; _ } -> + let rec deeply_flattened_sub_msgs acc = function + | [] -> acc + | { loc; msg; sub; _ } :: tail -> + deeply_flattened_sub_msgs ({ txt = msg; loc } :: acc) (sub @ tail) + in + deeply_flattened_sub_msgs [] sub + + let of_exn exn = + (*IF_AT_LEAST 406 match error_of_exn exn with | Some (`Ok e) -> Some e | None | Some `Already_displayed -> None *) + (*IF_NOT_AT_LEAST 406 error_of_exn exn*) + + let _set_main_msg_old error msg = { error with msg } + + let _set_main_msg_new error msg = + let txt ppf = Format.pp_print_string ppf msg in + let main = { error.main with txt } in + { error with main } + + let set_main_msg error msg = + (*IF_NOT_AT_LEAST 408 _set_main_msg_old error msg*) + (*IF_AT_LEAST 408 _set_main_msg_new error msg*) + + let _make_error_of_message_old ~sub { loc; txt } = + let sub = + List.map + (fun { loc; txt } -> { loc; msg = txt; sub = []; if_highlight = txt }) + sub + in + { loc; msg = txt; sub; if_highlight = txt } + + let _make_error_of_message_new ~sub { loc; txt } = + let mk_txt x ppf = Format.pp_print_string ppf x in + let mk loc x = { loc; txt = mk_txt x } in + { + kind = Report_error; + main = mk loc txt; + sub = List.map (fun { loc; txt } -> mk loc txt) sub; + } + + let make ~sub msg = + (*IF_NOT_AT_LEAST 408 _make_error_of_message_old ~sub msg*) + (*IF_AT_LEAST 408 _make_error_of_message_new ~sub msg*) + + let _set_main_loc_old error loc = { error with loc } + + let _set_main_loc_new error loc = + let main = { error.main with loc } in + { error with main } + + let set_main_loc error loc = + (*IF_NOT_AT_LEAST 408 _set_main_loc_old error loc*) + (*IF_AT_LEAST 408 _set_main_loc_new error loc*) +end + +let raise_errorf ?loc msg = raise_errorf ?loc msg diff -Nru ppxlib-0.15.0/astlib/location.mli ppxlib-0.24.0/astlib/location.mli --- ppxlib-0.15.0/astlib/location.mli 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/location.mli 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,68 @@ +(** Source code locations (ranges of positions), used in parsetrees *) + +type t = Ocaml_common.Location.t = { + loc_start : Lexing.position; + loc_end : Lexing.position; + loc_ghost : bool; +} +(** The location type *) + +type 'a loc = 'a Ocaml_common.Location.loc = { txt : 'a; loc : t } +(** A located type *) + +module Error : sig + type location + + type t + (** The location error type. It contains a located main message and a + (possibly empty) list of located submessages. *) + + val is_well_formed : t -> bool + (** A location error constructed via [make] is always well-formed. A malformed + location error is a value of type [location_report] on compilers >= 4.08, + whose [kind] is different from [Report_error]. Notice that + [location_report] does not explicitly form part of Astlib. *) + + val main_msg : t -> string loc + (** Get the located error main message. *) + + val sub_msgs : t -> string loc list + (** Get the located error sub-messages. *) + + val set_main_msg : t -> string -> t + (** Set the text of the error's main message. The location stays as is. *) + + val set_main_loc : t -> location -> t + (** Set the location of the error's main message. The text satys as is. *) + + val make : sub:string loc list -> string loc -> t + (** Construct a location error. *) + + val of_exn : exn -> t option + (** Turn an exception into a location error, if possible. *) +end +with type location := t + +val set_input_name : string -> unit +(** Set the name of the input source, e.g. the file name. *) + +val none : t +(** An arbitrary value of type [t]; describes an empty ghost range. *) + +(** {1 Automatically reporting errors for raised exceptions} *) + +val register_error_of_exn : (exn -> Error.t option) -> unit +(** Each compiler module which defines a custom type of exception which can + surface as a user-visible error should register a "printer" for this + exception using [register_error_of_exn]. The result of the printer is an + [error] value containing a location, a message, and optionally sub-messages + (each of them being located as well). *) + +exception Error of Error.t +(** Located exception. *) + +val raise_errorf : ?loc:t -> ('a, Format.formatter, unit, 'b) format4 -> 'a +(** Raise a located exception. *) + +val report_exception : Format.formatter -> exn -> unit +(** Report an exception on the given formatter *) diff -Nru ppxlib-0.15.0/astlib/longident.ml ppxlib-0.24.0/astlib/longident.ml --- ppxlib-0.15.0/astlib/longident.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/longident.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,5 @@ +include Ocaml_common.Longident + +let parse s = + (*IF_NOT_AT_LEAST 411 parse s *) + (*IF_AT_LEAST 411 Ocaml_common.Parse.longident @@ Lexing.from_string @@ s *) diff -Nru ppxlib-0.15.0/astlib/longident.mli ppxlib-0.24.0/astlib/longident.mli --- ppxlib-0.15.0/astlib/longident.mli 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/longident.mli 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,14 @@ +(** Long identifiers, used in parsetrees. *) + +(** The long identifier type *) +type t = Ocaml_common.Longident.t = + | Lident of string + | Ldot of t * string + | Lapply of t * t + +val flatten : t -> string list +(** Flatten a long identifier built upon [Lident] and [Ldot]. Raise when hitting + [Lapply].*) + +val parse : string -> t +(** Parse a string into a long identifier built upon [Lident] and [Ldot]. *) diff -Nru ppxlib-0.15.0/astlib/migrate_402_403.ml ppxlib-0.24.0/astlib/migrate_402_403.ml --- ppxlib-0.15.0/astlib/migrate_402_403.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/migrate_402_403.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1025 @@ +(**************************************************************************) +(* *) +(* OCaml Migrate Parsetree *) +(* *) +(* Frédéric Bour *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2017 Institut National de Recherche en Informatique et *) +(* en Automatique (INRIA). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module From = Ast_402 +module To = Ast_403 + +let extract_predef_option label typ = + let open From in + let open Longident in + match (label, typ.Parsetree.ptyp_desc) with + | ( To.Asttypes.Optional _, + From.Parsetree.Ptyp_constr + ({ Location.txt = Ldot (Lident "*predef*", "option"); _ }, [ d ]) ) -> + d + | _ -> typ + +let rec copy_expression : From.Parsetree.expression -> To.Parsetree.expression = + fun { + From.Parsetree.pexp_desc; + From.Parsetree.pexp_loc; + From.Parsetree.pexp_attributes; + } -> + { + To.Parsetree.pexp_desc = copy_expression_desc pexp_desc; + To.Parsetree.pexp_loc = copy_location pexp_loc; + To.Parsetree.pexp_attributes = copy_attributes pexp_attributes; + } + +and copy_expression_desc : + From.Parsetree.expression_desc -> To.Parsetree.expression_desc = function + | From.Parsetree.Pexp_ident x0 -> + To.Parsetree.Pexp_ident (copy_loc copy_longident x0) + | From.Parsetree.Pexp_constant x0 -> + To.Parsetree.Pexp_constant (copy_constant x0) + | From.Parsetree.Pexp_let (x0, x1, x2) -> + To.Parsetree.Pexp_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_expression x2) + | From.Parsetree.Pexp_function x0 -> + To.Parsetree.Pexp_function (List.map copy_case x0) + | From.Parsetree.Pexp_fun (x0, x1, x2, x3) -> + To.Parsetree.Pexp_fun + ( copy_arg_label x0, + copy_option copy_expression x1, + copy_pattern x2, + copy_expression x3 ) + | From.Parsetree.Pexp_apply (x0, x1) -> + To.Parsetree.Pexp_apply + ( copy_expression x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | From.Parsetree.Pexp_match (x0, x1) -> + To.Parsetree.Pexp_match (copy_expression x0, List.map copy_case x1) + | From.Parsetree.Pexp_try (x0, x1) -> + To.Parsetree.Pexp_try (copy_expression x0, List.map copy_case x1) + | From.Parsetree.Pexp_tuple x0 -> + To.Parsetree.Pexp_tuple (List.map copy_expression x0) + | From.Parsetree.Pexp_construct (x0, x1) -> + To.Parsetree.Pexp_construct + (copy_loc copy_longident x0, copy_option copy_expression x1) + | From.Parsetree.Pexp_variant (x0, x1) -> + To.Parsetree.Pexp_variant (copy_label x0, copy_option copy_expression x1) + | From.Parsetree.Pexp_record (x0, x1) -> + To.Parsetree.Pexp_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_expression x1)) + x0, + copy_option copy_expression x1 ) + | From.Parsetree.Pexp_field (x0, x1) -> + To.Parsetree.Pexp_field (copy_expression x0, copy_loc copy_longident x1) + | From.Parsetree.Pexp_setfield (x0, x1, x2) -> + To.Parsetree.Pexp_setfield + (copy_expression x0, copy_loc copy_longident x1, copy_expression x2) + | From.Parsetree.Pexp_array x0 -> + To.Parsetree.Pexp_array (List.map copy_expression x0) + | From.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> + To.Parsetree.Pexp_ifthenelse + (copy_expression x0, copy_expression x1, copy_option copy_expression x2) + | From.Parsetree.Pexp_sequence (x0, x1) -> + To.Parsetree.Pexp_sequence (copy_expression x0, copy_expression x1) + | From.Parsetree.Pexp_while (x0, x1) -> + To.Parsetree.Pexp_while (copy_expression x0, copy_expression x1) + | From.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> + To.Parsetree.Pexp_for + ( copy_pattern x0, + copy_expression x1, + copy_expression x2, + copy_direction_flag x3, + copy_expression x4 ) + | From.Parsetree.Pexp_constraint (x0, x1) -> + To.Parsetree.Pexp_constraint (copy_expression x0, copy_core_type x1) + | From.Parsetree.Pexp_coerce (x0, x1, x2) -> + To.Parsetree.Pexp_coerce + (copy_expression x0, copy_option copy_core_type x1, copy_core_type x2) + | From.Parsetree.Pexp_send (x0, x1) -> + To.Parsetree.Pexp_send (copy_expression x0, x1) + | From.Parsetree.Pexp_new x0 -> + To.Parsetree.Pexp_new (copy_loc copy_longident x0) + | From.Parsetree.Pexp_setinstvar (x0, x1) -> + To.Parsetree.Pexp_setinstvar (copy_loc (fun x -> x) x0, copy_expression x1) + | From.Parsetree.Pexp_override x0 -> + To.Parsetree.Pexp_override + (List.map + (fun x -> + let x0, x1 = x in + (copy_loc (fun x -> x) x0, copy_expression x1)) + x0) + | From.Parsetree.Pexp_letmodule (x0, x1, x2) -> + To.Parsetree.Pexp_letmodule + (copy_loc (fun x -> x) x0, copy_module_expr x1, copy_expression x2) + | From.Parsetree.Pexp_assert x0 -> + To.Parsetree.Pexp_assert (copy_expression x0) + | From.Parsetree.Pexp_lazy x0 -> To.Parsetree.Pexp_lazy (copy_expression x0) + | From.Parsetree.Pexp_poly (x0, x1) -> + To.Parsetree.Pexp_poly (copy_expression x0, copy_option copy_core_type x1) + | From.Parsetree.Pexp_object x0 -> + To.Parsetree.Pexp_object (copy_class_structure x0) + | From.Parsetree.Pexp_newtype (x0, x1) -> + To.Parsetree.Pexp_newtype (x0, copy_expression x1) + | From.Parsetree.Pexp_pack x0 -> To.Parsetree.Pexp_pack (copy_module_expr x0) + | From.Parsetree.Pexp_open (x0, x1, x2) -> + To.Parsetree.Pexp_open + (copy_override_flag x0, copy_loc copy_longident x1, copy_expression x2) + | From.Parsetree.Pexp_extension x0 -> + To.Parsetree.Pexp_extension (copy_extension x0) + +and copy_direction_flag : + From.Asttypes.direction_flag -> To.Asttypes.direction_flag = function + | From.Asttypes.Upto -> To.Asttypes.Upto + | From.Asttypes.Downto -> To.Asttypes.Downto + +and copy_case : From.Parsetree.case -> To.Parsetree.case = + fun { From.Parsetree.pc_lhs; From.Parsetree.pc_guard; From.Parsetree.pc_rhs } -> + { + To.Parsetree.pc_lhs = copy_pattern pc_lhs; + To.Parsetree.pc_guard = copy_option copy_expression pc_guard; + To.Parsetree.pc_rhs = copy_expression pc_rhs; + } + +and copy_value_binding : + From.Parsetree.value_binding -> To.Parsetree.value_binding = + fun { + From.Parsetree.pvb_pat; + From.Parsetree.pvb_expr; + From.Parsetree.pvb_attributes; + From.Parsetree.pvb_loc; + } -> + { + To.Parsetree.pvb_pat = copy_pattern pvb_pat; + To.Parsetree.pvb_expr = copy_expression pvb_expr; + To.Parsetree.pvb_attributes = copy_attributes pvb_attributes; + To.Parsetree.pvb_loc = copy_location pvb_loc; + } + +and copy_pattern : From.Parsetree.pattern -> To.Parsetree.pattern = + fun { + From.Parsetree.ppat_desc; + From.Parsetree.ppat_loc; + From.Parsetree.ppat_attributes; + } -> + { + To.Parsetree.ppat_desc = copy_pattern_desc ppat_desc; + To.Parsetree.ppat_loc = copy_location ppat_loc; + To.Parsetree.ppat_attributes = copy_attributes ppat_attributes; + } + +and copy_pattern_desc : From.Parsetree.pattern_desc -> To.Parsetree.pattern_desc + = function + | From.Parsetree.Ppat_any -> To.Parsetree.Ppat_any + | From.Parsetree.Ppat_var x0 -> + To.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) + | From.Parsetree.Ppat_alias (x0, x1) -> + To.Parsetree.Ppat_alias (copy_pattern x0, copy_loc (fun x -> x) x1) + | From.Parsetree.Ppat_constant x0 -> + To.Parsetree.Ppat_constant (copy_constant x0) + | From.Parsetree.Ppat_interval (x0, x1) -> + To.Parsetree.Ppat_interval (copy_constant x0, copy_constant x1) + | From.Parsetree.Ppat_tuple x0 -> + To.Parsetree.Ppat_tuple (List.map copy_pattern x0) + | From.Parsetree.Ppat_construct (x0, x1) -> + To.Parsetree.Ppat_construct + (copy_loc copy_longident x0, copy_option copy_pattern x1) + | From.Parsetree.Ppat_variant (x0, x1) -> + To.Parsetree.Ppat_variant (copy_label x0, copy_option copy_pattern x1) + | From.Parsetree.Ppat_record (x0, x1) -> + To.Parsetree.Ppat_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_pattern x1)) + x0, + copy_closed_flag x1 ) + | From.Parsetree.Ppat_array x0 -> + To.Parsetree.Ppat_array (List.map copy_pattern x0) + | From.Parsetree.Ppat_or (x0, x1) -> + To.Parsetree.Ppat_or (copy_pattern x0, copy_pattern x1) + | From.Parsetree.Ppat_constraint (x0, x1) -> + To.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1) + | From.Parsetree.Ppat_type x0 -> + To.Parsetree.Ppat_type (copy_loc copy_longident x0) + | From.Parsetree.Ppat_lazy x0 -> To.Parsetree.Ppat_lazy (copy_pattern x0) + | From.Parsetree.Ppat_unpack x0 -> + To.Parsetree.Ppat_unpack (copy_loc (fun x -> x) x0) + | From.Parsetree.Ppat_exception x0 -> + To.Parsetree.Ppat_exception (copy_pattern x0) + | From.Parsetree.Ppat_extension x0 -> + To.Parsetree.Ppat_extension (copy_extension x0) + +and copy_core_type : From.Parsetree.core_type -> To.Parsetree.core_type = + fun { + From.Parsetree.ptyp_desc; + From.Parsetree.ptyp_loc; + From.Parsetree.ptyp_attributes; + } -> + { + To.Parsetree.ptyp_desc = copy_core_type_desc ptyp_desc; + To.Parsetree.ptyp_loc = copy_location ptyp_loc; + To.Parsetree.ptyp_attributes = copy_attributes ptyp_attributes; + } + +and copy_core_type_desc : + From.Parsetree.core_type_desc -> To.Parsetree.core_type_desc = function + | From.Parsetree.Ptyp_any -> To.Parsetree.Ptyp_any + | From.Parsetree.Ptyp_var x0 -> To.Parsetree.Ptyp_var x0 + | From.Parsetree.Ptyp_arrow (x0, x1, x2) -> + let label = copy_arg_label x0 in + To.Parsetree.Ptyp_arrow + ( label, + copy_core_type (extract_predef_option label x1), + copy_core_type x2 ) + | From.Parsetree.Ptyp_tuple x0 -> + To.Parsetree.Ptyp_tuple (List.map copy_core_type x0) + | From.Parsetree.Ptyp_constr (x0, x1) -> + To.Parsetree.Ptyp_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Ptyp_object (x0, x1) -> + To.Parsetree.Ptyp_object + ( List.map + (fun x -> + let x0, x1, x2 = x in + (x0, copy_attributes x1, copy_core_type x2)) + x0, + copy_closed_flag x1 ) + | From.Parsetree.Ptyp_class (x0, x1) -> + To.Parsetree.Ptyp_class + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Ptyp_alias (x0, x1) -> + To.Parsetree.Ptyp_alias (copy_core_type x0, x1) + | From.Parsetree.Ptyp_variant (x0, x1, x2) -> + To.Parsetree.Ptyp_variant + ( List.map copy_row_field x0, + copy_closed_flag x1, + copy_option (fun x -> List.map copy_label x) x2 ) + | From.Parsetree.Ptyp_poly (x0, x1) -> + To.Parsetree.Ptyp_poly (List.map (fun x -> x) x0, copy_core_type x1) + | From.Parsetree.Ptyp_package x0 -> + To.Parsetree.Ptyp_package (copy_package_type x0) + | From.Parsetree.Ptyp_extension x0 -> + To.Parsetree.Ptyp_extension (copy_extension x0) + +and copy_package_type : From.Parsetree.package_type -> To.Parsetree.package_type + = + fun x -> + let x0, x1 = x in + ( copy_loc copy_longident x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_core_type x1)) + x1 ) + +and copy_row_field : From.Parsetree.row_field -> To.Parsetree.row_field = + function + | From.Parsetree.Rtag (x0, x1, x2, x3) -> + To.Parsetree.Rtag + ( copy_label x0, + copy_attributes x1, + copy_bool x2, + List.map copy_core_type x3 ) + | From.Parsetree.Rinherit x0 -> To.Parsetree.Rinherit (copy_core_type x0) + +and copy_attributes : From.Parsetree.attributes -> To.Parsetree.attributes = + fun x -> List.map copy_attribute x + +and copy_attribute : From.Parsetree.attribute -> To.Parsetree.attribute = + fun x -> + let x0, x1 = x in + (copy_loc (fun x -> x) x0, copy_payload x1) + +and copy_payload : From.Parsetree.payload -> To.Parsetree.payload = function + | From.Parsetree.PStr x0 -> To.Parsetree.PStr (copy_structure x0) + | From.Parsetree.PTyp x0 -> To.Parsetree.PTyp (copy_core_type x0) + | From.Parsetree.PPat (x0, x1) -> + To.Parsetree.PPat (copy_pattern x0, copy_option copy_expression x1) + +and copy_structure : From.Parsetree.structure -> To.Parsetree.structure = + fun x -> List.map copy_structure_item x + +and copy_structure_item : + From.Parsetree.structure_item -> To.Parsetree.structure_item = + fun { From.Parsetree.pstr_desc; From.Parsetree.pstr_loc } -> + { + To.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc; + To.Parsetree.pstr_loc = copy_location pstr_loc; + } + +and copy_structure_item_desc : + From.Parsetree.structure_item_desc -> To.Parsetree.structure_item_desc = + function + | From.Parsetree.Pstr_eval (x0, x1) -> + To.Parsetree.Pstr_eval (copy_expression x0, copy_attributes x1) + | From.Parsetree.Pstr_value (x0, x1) -> + To.Parsetree.Pstr_value (copy_rec_flag x0, List.map copy_value_binding x1) + | From.Parsetree.Pstr_primitive x0 -> + To.Parsetree.Pstr_primitive (copy_value_description x0) + | From.Parsetree.Pstr_type x0 -> + let recflag, types = type_declarations x0 in + To.Parsetree.Pstr_type (recflag, types) + | From.Parsetree.Pstr_typext x0 -> + To.Parsetree.Pstr_typext (copy_type_extension x0) + | From.Parsetree.Pstr_exception x0 -> + To.Parsetree.Pstr_exception (copy_extension_constructor x0) + | From.Parsetree.Pstr_module x0 -> + To.Parsetree.Pstr_module (copy_module_binding x0) + | From.Parsetree.Pstr_recmodule x0 -> + To.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) + | From.Parsetree.Pstr_modtype x0 -> + To.Parsetree.Pstr_modtype (copy_module_type_declaration x0) + | From.Parsetree.Pstr_open x0 -> + To.Parsetree.Pstr_open (copy_open_description x0) + | From.Parsetree.Pstr_class x0 -> + To.Parsetree.Pstr_class (List.map copy_class_declaration x0) + | From.Parsetree.Pstr_class_type x0 -> + To.Parsetree.Pstr_class_type (List.map copy_class_type_declaration x0) + | From.Parsetree.Pstr_include x0 -> + To.Parsetree.Pstr_include (copy_include_declaration x0) + | From.Parsetree.Pstr_attribute x0 -> + To.Parsetree.Pstr_attribute (copy_attribute x0) + | From.Parsetree.Pstr_extension (x0, x1) -> + To.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1) + +and copy_include_declaration : + From.Parsetree.include_declaration -> To.Parsetree.include_declaration = + fun x -> copy_include_infos copy_module_expr x + +and copy_class_declaration : + From.Parsetree.class_declaration -> To.Parsetree.class_declaration = + fun x -> copy_class_infos copy_class_expr x + +and copy_class_expr : From.Parsetree.class_expr -> To.Parsetree.class_expr = + fun { + From.Parsetree.pcl_desc; + From.Parsetree.pcl_loc; + From.Parsetree.pcl_attributes; + } -> + { + To.Parsetree.pcl_desc = copy_class_expr_desc pcl_desc; + To.Parsetree.pcl_loc = copy_location pcl_loc; + To.Parsetree.pcl_attributes = copy_attributes pcl_attributes; + } + +and copy_class_expr_desc : + From.Parsetree.class_expr_desc -> To.Parsetree.class_expr_desc = function + | From.Parsetree.Pcl_constr (x0, x1) -> + To.Parsetree.Pcl_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Pcl_structure x0 -> + To.Parsetree.Pcl_structure (copy_class_structure x0) + | From.Parsetree.Pcl_fun (x0, x1, x2, x3) -> + To.Parsetree.Pcl_fun + ( copy_arg_label x0, + copy_option copy_expression x1, + copy_pattern x2, + copy_class_expr x3 ) + | From.Parsetree.Pcl_apply (x0, x1) -> + To.Parsetree.Pcl_apply + ( copy_class_expr x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | From.Parsetree.Pcl_let (x0, x1, x2) -> + To.Parsetree.Pcl_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_class_expr x2) + | From.Parsetree.Pcl_constraint (x0, x1) -> + To.Parsetree.Pcl_constraint (copy_class_expr x0, copy_class_type x1) + | From.Parsetree.Pcl_extension x0 -> + To.Parsetree.Pcl_extension (copy_extension x0) + +and copy_class_structure : + From.Parsetree.class_structure -> To.Parsetree.class_structure = + fun { From.Parsetree.pcstr_self; From.Parsetree.pcstr_fields } -> + { + To.Parsetree.pcstr_self = copy_pattern pcstr_self; + To.Parsetree.pcstr_fields = List.map copy_class_field pcstr_fields; + } + +and copy_class_field : From.Parsetree.class_field -> To.Parsetree.class_field = + fun { + From.Parsetree.pcf_desc; + From.Parsetree.pcf_loc; + From.Parsetree.pcf_attributes; + } -> + { + To.Parsetree.pcf_desc = copy_class_field_desc pcf_desc; + To.Parsetree.pcf_loc = copy_location pcf_loc; + To.Parsetree.pcf_attributes = copy_attributes pcf_attributes; + } + +and copy_class_field_desc : + From.Parsetree.class_field_desc -> To.Parsetree.class_field_desc = function + | From.Parsetree.Pcf_inherit (x0, x1, x2) -> + To.Parsetree.Pcf_inherit + (copy_override_flag x0, copy_class_expr x1, copy_option (fun x -> x) x2) + | From.Parsetree.Pcf_val x0 -> + To.Parsetree.Pcf_val + (let x0, x1, x2 = x0 in + ( copy_loc (fun x -> x) x0, + copy_mutable_flag x1, + copy_class_field_kind x2 )) + | From.Parsetree.Pcf_method x0 -> + To.Parsetree.Pcf_method + (let x0, x1, x2 = x0 in + ( copy_loc (fun x -> x) x0, + copy_private_flag x1, + copy_class_field_kind x2 )) + | From.Parsetree.Pcf_constraint x0 -> + To.Parsetree.Pcf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | From.Parsetree.Pcf_initializer x0 -> + To.Parsetree.Pcf_initializer (copy_expression x0) + | From.Parsetree.Pcf_attribute x0 -> + To.Parsetree.Pcf_attribute (copy_attribute x0) + | From.Parsetree.Pcf_extension x0 -> + To.Parsetree.Pcf_extension (copy_extension x0) + +and copy_class_field_kind : + From.Parsetree.class_field_kind -> To.Parsetree.class_field_kind = function + | From.Parsetree.Cfk_virtual x0 -> + To.Parsetree.Cfk_virtual (copy_core_type x0) + | From.Parsetree.Cfk_concrete (x0, x1) -> + To.Parsetree.Cfk_concrete (copy_override_flag x0, copy_expression x1) + +and copy_module_binding : + From.Parsetree.module_binding -> To.Parsetree.module_binding = + fun { + From.Parsetree.pmb_name; + From.Parsetree.pmb_expr; + From.Parsetree.pmb_attributes; + From.Parsetree.pmb_loc; + } -> + { + To.Parsetree.pmb_name = copy_loc (fun x -> x) pmb_name; + To.Parsetree.pmb_expr = copy_module_expr pmb_expr; + To.Parsetree.pmb_attributes = copy_attributes pmb_attributes; + To.Parsetree.pmb_loc = copy_location pmb_loc; + } + +and copy_module_expr : From.Parsetree.module_expr -> To.Parsetree.module_expr = + fun { + From.Parsetree.pmod_desc; + From.Parsetree.pmod_loc; + From.Parsetree.pmod_attributes; + } -> + { + To.Parsetree.pmod_desc = copy_module_expr_desc pmod_desc; + To.Parsetree.pmod_loc = copy_location pmod_loc; + To.Parsetree.pmod_attributes = copy_attributes pmod_attributes; + } + +and copy_module_expr_desc : + From.Parsetree.module_expr_desc -> To.Parsetree.module_expr_desc = function + | From.Parsetree.Pmod_ident x0 -> + To.Parsetree.Pmod_ident (copy_loc copy_longident x0) + | From.Parsetree.Pmod_structure x0 -> + To.Parsetree.Pmod_structure (copy_structure x0) + | From.Parsetree.Pmod_functor (x0, x1, x2) -> + To.Parsetree.Pmod_functor + ( copy_loc (fun x -> x) x0, + copy_option copy_module_type x1, + copy_module_expr x2 ) + | From.Parsetree.Pmod_apply (x0, x1) -> + To.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) + | From.Parsetree.Pmod_constraint (x0, x1) -> + To.Parsetree.Pmod_constraint (copy_module_expr x0, copy_module_type x1) + | From.Parsetree.Pmod_unpack x0 -> + To.Parsetree.Pmod_unpack (copy_expression x0) + | From.Parsetree.Pmod_extension x0 -> + To.Parsetree.Pmod_extension (copy_extension x0) + +and copy_module_type : From.Parsetree.module_type -> To.Parsetree.module_type = + fun { + From.Parsetree.pmty_desc; + From.Parsetree.pmty_loc; + From.Parsetree.pmty_attributes; + } -> + { + To.Parsetree.pmty_desc = copy_module_type_desc pmty_desc; + To.Parsetree.pmty_loc = copy_location pmty_loc; + To.Parsetree.pmty_attributes = copy_attributes pmty_attributes; + } + +and copy_module_type_desc : + From.Parsetree.module_type_desc -> To.Parsetree.module_type_desc = function + | From.Parsetree.Pmty_ident x0 -> + To.Parsetree.Pmty_ident (copy_loc copy_longident x0) + | From.Parsetree.Pmty_signature x0 -> + To.Parsetree.Pmty_signature (copy_signature x0) + | From.Parsetree.Pmty_functor (x0, x1, x2) -> + To.Parsetree.Pmty_functor + ( copy_loc (fun x -> x) x0, + copy_option copy_module_type x1, + copy_module_type x2 ) + | From.Parsetree.Pmty_with (x0, x1) -> + To.Parsetree.Pmty_with + (copy_module_type x0, List.map copy_with_constraint x1) + | From.Parsetree.Pmty_typeof x0 -> + To.Parsetree.Pmty_typeof (copy_module_expr x0) + | From.Parsetree.Pmty_extension x0 -> + To.Parsetree.Pmty_extension (copy_extension x0) + | From.Parsetree.Pmty_alias x0 -> + To.Parsetree.Pmty_alias (copy_loc copy_longident x0) + +and copy_with_constraint : + From.Parsetree.with_constraint -> To.Parsetree.with_constraint = function + | From.Parsetree.Pwith_type (x0, x1) -> + To.Parsetree.Pwith_type + (copy_loc copy_longident x0, copy_type_declaration x1) + | From.Parsetree.Pwith_module (x0, x1) -> + To.Parsetree.Pwith_module + (copy_loc copy_longident x0, copy_loc copy_longident x1) + | From.Parsetree.Pwith_typesubst x0 -> + To.Parsetree.Pwith_typesubst (copy_type_declaration x0) + | From.Parsetree.Pwith_modsubst (x0, x1) -> + To.Parsetree.Pwith_modsubst + (copy_loc (fun x -> x) x0, copy_loc copy_longident x1) + +and copy_signature : From.Parsetree.signature -> To.Parsetree.signature = + fun x -> List.map copy_signature_item x + +and copy_signature_item : + From.Parsetree.signature_item -> To.Parsetree.signature_item = + fun { From.Parsetree.psig_desc; From.Parsetree.psig_loc } -> + { + To.Parsetree.psig_desc = copy_signature_item_desc psig_desc; + To.Parsetree.psig_loc = copy_location psig_loc; + } + +and copy_signature_item_desc : + From.Parsetree.signature_item_desc -> To.Parsetree.signature_item_desc = + function + | From.Parsetree.Psig_value x0 -> + To.Parsetree.Psig_value (copy_value_description x0) + | From.Parsetree.Psig_type x0 -> + let recflag, types = type_declarations x0 in + To.Parsetree.Psig_type (recflag, types) + | From.Parsetree.Psig_typext x0 -> + To.Parsetree.Psig_typext (copy_type_extension x0) + | From.Parsetree.Psig_exception x0 -> + To.Parsetree.Psig_exception (copy_extension_constructor x0) + | From.Parsetree.Psig_module x0 -> + To.Parsetree.Psig_module (copy_module_declaration x0) + | From.Parsetree.Psig_recmodule x0 -> + To.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) + | From.Parsetree.Psig_modtype x0 -> + To.Parsetree.Psig_modtype (copy_module_type_declaration x0) + | From.Parsetree.Psig_open x0 -> + To.Parsetree.Psig_open (copy_open_description x0) + | From.Parsetree.Psig_include x0 -> + To.Parsetree.Psig_include (copy_include_description x0) + | From.Parsetree.Psig_class x0 -> + To.Parsetree.Psig_class (List.map copy_class_description x0) + | From.Parsetree.Psig_class_type x0 -> + To.Parsetree.Psig_class_type (List.map copy_class_type_declaration x0) + | From.Parsetree.Psig_attribute x0 -> + To.Parsetree.Psig_attribute (copy_attribute x0) + | From.Parsetree.Psig_extension (x0, x1) -> + To.Parsetree.Psig_extension (copy_extension x0, copy_attributes x1) + +and copy_class_type_declaration : + From.Parsetree.class_type_declaration -> To.Parsetree.class_type_declaration + = + fun x -> copy_class_infos copy_class_type x + +and copy_class_description : + From.Parsetree.class_description -> To.Parsetree.class_description = + fun x -> copy_class_infos copy_class_type x + +and copy_class_type : From.Parsetree.class_type -> To.Parsetree.class_type = + fun { + From.Parsetree.pcty_desc; + From.Parsetree.pcty_loc; + From.Parsetree.pcty_attributes; + } -> + { + To.Parsetree.pcty_desc = copy_class_type_desc pcty_desc; + To.Parsetree.pcty_loc = copy_location pcty_loc; + To.Parsetree.pcty_attributes = copy_attributes pcty_attributes; + } + +and copy_class_type_desc : + From.Parsetree.class_type_desc -> To.Parsetree.class_type_desc = function + | From.Parsetree.Pcty_constr (x0, x1) -> + To.Parsetree.Pcty_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Pcty_signature x0 -> + To.Parsetree.Pcty_signature (copy_class_signature x0) + | From.Parsetree.Pcty_arrow (x0, x1, x2) -> + let label = copy_arg_label x0 in + To.Parsetree.Pcty_arrow + ( label, + copy_core_type (extract_predef_option label x1), + copy_class_type x2 ) + | From.Parsetree.Pcty_extension x0 -> + To.Parsetree.Pcty_extension (copy_extension x0) + +and copy_class_signature : + From.Parsetree.class_signature -> To.Parsetree.class_signature = + fun { From.Parsetree.pcsig_self; From.Parsetree.pcsig_fields } -> + { + To.Parsetree.pcsig_self = copy_core_type pcsig_self; + To.Parsetree.pcsig_fields = List.map copy_class_type_field pcsig_fields; + } + +and copy_class_type_field : + From.Parsetree.class_type_field -> To.Parsetree.class_type_field = + fun { + From.Parsetree.pctf_desc; + From.Parsetree.pctf_loc; + From.Parsetree.pctf_attributes; + } -> + { + To.Parsetree.pctf_desc = copy_class_type_field_desc pctf_desc; + To.Parsetree.pctf_loc = copy_location pctf_loc; + To.Parsetree.pctf_attributes = copy_attributes pctf_attributes; + } + +and copy_class_type_field_desc : + From.Parsetree.class_type_field_desc -> To.Parsetree.class_type_field_desc = + function + | From.Parsetree.Pctf_inherit x0 -> + To.Parsetree.Pctf_inherit (copy_class_type x0) + | From.Parsetree.Pctf_val x0 -> + To.Parsetree.Pctf_val + (let x0, x1, x2, x3 = x0 in + (x0, copy_mutable_flag x1, copy_virtual_flag x2, copy_core_type x3)) + | From.Parsetree.Pctf_method x0 -> + To.Parsetree.Pctf_method + (let x0, x1, x2, x3 = x0 in + (x0, copy_private_flag x1, copy_virtual_flag x2, copy_core_type x3)) + | From.Parsetree.Pctf_constraint x0 -> + To.Parsetree.Pctf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | From.Parsetree.Pctf_attribute x0 -> + To.Parsetree.Pctf_attribute (copy_attribute x0) + | From.Parsetree.Pctf_extension x0 -> + To.Parsetree.Pctf_extension (copy_extension x0) + +and copy_extension : From.Parsetree.extension -> To.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 From.Parsetree.class_infos -> + 'g0 To.Parsetree.class_infos = + fun f0 + { + From.Parsetree.pci_virt; + From.Parsetree.pci_params; + From.Parsetree.pci_name; + From.Parsetree.pci_expr; + From.Parsetree.pci_loc; + From.Parsetree.pci_attributes; + } -> + { + To.Parsetree.pci_virt = copy_virtual_flag pci_virt; + To.Parsetree.pci_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + pci_params; + To.Parsetree.pci_name = copy_loc (fun x -> x) pci_name; + To.Parsetree.pci_expr = f0 pci_expr; + To.Parsetree.pci_loc = copy_location pci_loc; + To.Parsetree.pci_attributes = copy_attributes pci_attributes; + } + +and copy_virtual_flag : From.Asttypes.virtual_flag -> To.Asttypes.virtual_flag = + function + | From.Asttypes.Virtual -> To.Asttypes.Virtual + | From.Asttypes.Concrete -> To.Asttypes.Concrete + +and copy_include_description : + From.Parsetree.include_description -> To.Parsetree.include_description = + fun x -> copy_include_infos copy_module_type x + +and copy_include_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 From.Parsetree.include_infos -> + 'g0 To.Parsetree.include_infos = + fun f0 + { + From.Parsetree.pincl_mod; + From.Parsetree.pincl_loc; + From.Parsetree.pincl_attributes; + } -> + { + To.Parsetree.pincl_mod = f0 pincl_mod; + To.Parsetree.pincl_loc = copy_location pincl_loc; + To.Parsetree.pincl_attributes = copy_attributes pincl_attributes; + } + +and copy_open_description : + From.Parsetree.open_description -> To.Parsetree.open_description = + fun { + From.Parsetree.popen_lid; + From.Parsetree.popen_override; + From.Parsetree.popen_loc; + From.Parsetree.popen_attributes; + } -> + { + To.Parsetree.popen_lid = copy_loc copy_longident popen_lid; + To.Parsetree.popen_override = copy_override_flag popen_override; + To.Parsetree.popen_loc = copy_location popen_loc; + To.Parsetree.popen_attributes = copy_attributes popen_attributes; + } + +and copy_override_flag : + From.Asttypes.override_flag -> To.Asttypes.override_flag = function + | From.Asttypes.Override -> To.Asttypes.Override + | From.Asttypes.Fresh -> To.Asttypes.Fresh + +and copy_module_type_declaration : + From.Parsetree.module_type_declaration -> + To.Parsetree.module_type_declaration = + fun { + From.Parsetree.pmtd_name; + From.Parsetree.pmtd_type; + From.Parsetree.pmtd_attributes; + From.Parsetree.pmtd_loc; + } -> + { + To.Parsetree.pmtd_name = copy_loc (fun x -> x) pmtd_name; + To.Parsetree.pmtd_type = copy_option copy_module_type pmtd_type; + To.Parsetree.pmtd_attributes = copy_attributes pmtd_attributes; + To.Parsetree.pmtd_loc = copy_location pmtd_loc; + } + +and copy_module_declaration : + From.Parsetree.module_declaration -> To.Parsetree.module_declaration = + fun { + From.Parsetree.pmd_name; + From.Parsetree.pmd_type; + From.Parsetree.pmd_attributes; + From.Parsetree.pmd_loc; + } -> + { + To.Parsetree.pmd_name = copy_loc (fun x -> x) pmd_name; + To.Parsetree.pmd_type = copy_module_type pmd_type; + To.Parsetree.pmd_attributes = copy_attributes pmd_attributes; + To.Parsetree.pmd_loc = copy_location pmd_loc; + } + +and copy_type_extension : + From.Parsetree.type_extension -> To.Parsetree.type_extension = + fun { + From.Parsetree.ptyext_path; + From.Parsetree.ptyext_params; + From.Parsetree.ptyext_constructors; + From.Parsetree.ptyext_private; + From.Parsetree.ptyext_attributes; + } -> + { + To.Parsetree.ptyext_path = copy_loc copy_longident ptyext_path; + To.Parsetree.ptyext_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptyext_params; + To.Parsetree.ptyext_constructors = + List.map copy_extension_constructor ptyext_constructors; + To.Parsetree.ptyext_private = copy_private_flag ptyext_private; + To.Parsetree.ptyext_attributes = copy_attributes ptyext_attributes; + } + +and copy_extension_constructor : + From.Parsetree.extension_constructor -> To.Parsetree.extension_constructor = + fun { + From.Parsetree.pext_name; + From.Parsetree.pext_kind; + From.Parsetree.pext_loc; + From.Parsetree.pext_attributes; + } -> + { + To.Parsetree.pext_name = copy_loc (fun x -> x) pext_name; + To.Parsetree.pext_kind = copy_extension_constructor_kind pext_kind; + To.Parsetree.pext_loc = copy_location pext_loc; + To.Parsetree.pext_attributes = copy_attributes pext_attributes; + } + +and copy_extension_constructor_kind : + From.Parsetree.extension_constructor_kind -> + To.Parsetree.extension_constructor_kind = function + | From.Parsetree.Pext_decl (x0, x1) -> + To.Parsetree.Pext_decl + ( To.Parsetree.Pcstr_tuple (List.map copy_core_type x0), + copy_option copy_core_type x1 ) + | From.Parsetree.Pext_rebind x0 -> + To.Parsetree.Pext_rebind (copy_loc copy_longident x0) + +and copy_type_declaration : + From.Parsetree.type_declaration -> To.Parsetree.type_declaration = + fun { + From.Parsetree.ptype_name; + From.Parsetree.ptype_params; + From.Parsetree.ptype_cstrs; + From.Parsetree.ptype_kind; + From.Parsetree.ptype_private; + From.Parsetree.ptype_manifest; + From.Parsetree.ptype_attributes; + From.Parsetree.ptype_loc; + } -> + { + To.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name; + To.Parsetree.ptype_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptype_params; + To.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; + To.Parsetree.ptype_kind = copy_type_kind ptype_kind; + To.Parsetree.ptype_private = copy_private_flag ptype_private; + To.Parsetree.ptype_manifest = copy_option copy_core_type ptype_manifest; + To.Parsetree.ptype_attributes = copy_attributes ptype_attributes; + To.Parsetree.ptype_loc = copy_location ptype_loc; + } + +and copy_private_flag : From.Asttypes.private_flag -> To.Asttypes.private_flag = + function + | From.Asttypes.Private -> To.Asttypes.Private + | From.Asttypes.Public -> To.Asttypes.Public + +and copy_type_kind : From.Parsetree.type_kind -> To.Parsetree.type_kind = + function + | From.Parsetree.Ptype_abstract -> To.Parsetree.Ptype_abstract + | From.Parsetree.Ptype_variant x0 -> + To.Parsetree.Ptype_variant (List.map copy_constructor_declaration x0) + | From.Parsetree.Ptype_record x0 -> + To.Parsetree.Ptype_record (List.map copy_label_declaration x0) + | From.Parsetree.Ptype_open -> To.Parsetree.Ptype_open + +and copy_label_declaration : + From.Parsetree.label_declaration -> To.Parsetree.label_declaration = + fun { + From.Parsetree.pld_name; + From.Parsetree.pld_mutable; + From.Parsetree.pld_type; + From.Parsetree.pld_loc; + From.Parsetree.pld_attributes; + } -> + { + To.Parsetree.pld_name = copy_loc (fun x -> x) pld_name; + To.Parsetree.pld_mutable = copy_mutable_flag pld_mutable; + To.Parsetree.pld_type = copy_core_type pld_type; + To.Parsetree.pld_loc = copy_location pld_loc; + To.Parsetree.pld_attributes = copy_attributes pld_attributes; + } + +and copy_mutable_flag : From.Asttypes.mutable_flag -> To.Asttypes.mutable_flag = + function + | From.Asttypes.Immutable -> To.Asttypes.Immutable + | From.Asttypes.Mutable -> To.Asttypes.Mutable + +and copy_constructor_declaration : + From.Parsetree.constructor_declaration -> + To.Parsetree.constructor_declaration = + fun { + From.Parsetree.pcd_name; + From.Parsetree.pcd_args; + From.Parsetree.pcd_res; + From.Parsetree.pcd_loc; + From.Parsetree.pcd_attributes; + } -> + { + To.Parsetree.pcd_name = copy_loc (fun x -> x) pcd_name; + To.Parsetree.pcd_args = + To.Parsetree.Pcstr_tuple (List.map copy_core_type pcd_args); + To.Parsetree.pcd_res = copy_option copy_core_type pcd_res; + To.Parsetree.pcd_loc = copy_location pcd_loc; + To.Parsetree.pcd_attributes = copy_attributes pcd_attributes; + } + +and copy_variance : From.Asttypes.variance -> To.Asttypes.variance = function + | From.Asttypes.Covariant -> To.Asttypes.Covariant + | From.Asttypes.Contravariant -> To.Asttypes.Contravariant + | From.Asttypes.Invariant -> To.Asttypes.Invariant + +and copy_value_description : + From.Parsetree.value_description -> To.Parsetree.value_description = + fun { + From.Parsetree.pval_name; + From.Parsetree.pval_type; + From.Parsetree.pval_prim; + From.Parsetree.pval_attributes; + From.Parsetree.pval_loc; + } -> + { + To.Parsetree.pval_name = copy_loc (fun x -> x) pval_name; + To.Parsetree.pval_type = copy_core_type pval_type; + To.Parsetree.pval_prim = List.map (fun x -> x) pval_prim; + To.Parsetree.pval_attributes = copy_attributes pval_attributes; + To.Parsetree.pval_loc = copy_location pval_loc; + } + +and copy_closed_flag : From.Asttypes.closed_flag -> To.Asttypes.closed_flag = + function + | From.Asttypes.Closed -> To.Asttypes.Closed + | From.Asttypes.Open -> To.Asttypes.Open + +and copy_label : From.Asttypes.label -> To.Asttypes.label = fun x -> x + +and copy_arg_label : From.Asttypes.label -> To.Asttypes.arg_label = + fun x -> + if x <> "" then + if x.[0] = '?' then + To.Asttypes.Optional (String.sub x 1 (String.length x - 1)) + else To.Asttypes.Labelled x + else To.Asttypes.Nolabel + +and copy_rec_flag : From.Asttypes.rec_flag -> To.Asttypes.rec_flag = function + | From.Asttypes.Nonrecursive -> To.Asttypes.Nonrecursive + | From.Asttypes.Recursive -> To.Asttypes.Recursive + +and copy_constant : From.Asttypes.constant -> To.Parsetree.constant = function + | From.Asttypes.Const_int x0 -> + To.Parsetree.Pconst_integer (string_of_int x0, None) + | From.Asttypes.Const_char x0 -> To.Parsetree.Pconst_char x0 + | From.Asttypes.Const_string (x0, x1) -> + To.Parsetree.Pconst_string (x0, copy_option (fun x -> x) x1) + | From.Asttypes.Const_float x0 -> To.Parsetree.Pconst_float (x0, None) + | From.Asttypes.Const_int32 x0 -> + To.Parsetree.Pconst_integer (Int32.to_string x0, Some 'l') + | From.Asttypes.Const_int64 x0 -> + To.Parsetree.Pconst_integer (Int64.to_string x0, Some 'L') + | From.Asttypes.Const_nativeint x0 -> + To.Parsetree.Pconst_integer (Nativeint.to_string x0, Some 'n') + +and copy_option : 'f0 'g0. ('f0 -> 'g0) -> 'f0 option -> 'g0 option = + fun f0 -> function None -> None | Some x0 -> Some (f0 x0) + +and copy_longident : Longident.t -> Longident.t = fun x -> x + +and copy_loc : + 'f0 'g0. ('f0 -> 'g0) -> 'f0 From.Asttypes.loc -> 'g0 To.Asttypes.loc = + fun f0 { From.Asttypes.txt; From.Asttypes.loc } -> + { To.Asttypes.txt = f0 txt; To.Asttypes.loc = copy_location loc } + +and copy_location : Location.t -> Location.t = fun x -> x + +and copy_bool : bool -> bool = function false -> false | true -> true + +and type_declarations types = + let is_nonrec (attr, _) = attr.Location.txt = "nonrec" in + match List.map copy_type_declaration types with + | x :: xs when List.exists is_nonrec x.To.Parsetree.ptype_attributes -> + let ptype_attributes = + List.filter (fun x -> not (is_nonrec x)) x.To.Parsetree.ptype_attributes + in + (To.Asttypes.Nonrecursive, { x with To.Parsetree.ptype_attributes } :: xs) + | types -> (To.Asttypes.Recursive, types) + +let rec copy_toplevel_phrase : + From.Parsetree.toplevel_phrase -> To.Parsetree.toplevel_phrase = function + | From.Parsetree.Ptop_def x0 -> To.Parsetree.Ptop_def (copy_structure x0) + | From.Parsetree.Ptop_dir (x0, x1) -> + To.Parsetree.Ptop_dir (x0, copy_directive_argument x1) + +and copy_directive_argument : + From.Parsetree.directive_argument -> To.Parsetree.directive_argument = + function + | From.Parsetree.Pdir_none -> To.Parsetree.Pdir_none + | From.Parsetree.Pdir_string x0 -> To.Parsetree.Pdir_string x0 + | From.Parsetree.Pdir_int x0 -> To.Parsetree.Pdir_int (string_of_int x0, None) + | From.Parsetree.Pdir_ident x0 -> To.Parsetree.Pdir_ident (copy_longident x0) + | From.Parsetree.Pdir_bool x0 -> To.Parsetree.Pdir_bool (copy_bool x0) + +let copy_cases x = List.map copy_case x + +let copy_pat = copy_pattern + +let copy_expr = copy_expression + +let copy_typ = copy_core_type diff -Nru ppxlib-0.15.0/astlib/migrate_403_402.ml ppxlib-0.24.0/astlib/migrate_403_402.ml --- ppxlib-0.15.0/astlib/migrate_403_402.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/migrate_403_402.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1051 @@ +(**************************************************************************) +(* *) +(* OCaml Migrate Parsetree *) +(* *) +(* Frédéric Bour *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2017 Institut National de Recherche en Informatique et *) +(* en Automatique (INRIA). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module From = Ast_403 +module To = Ast_402 + +let inject_predef_option label d = + let open To in + let open Parsetree in + match label with + | From.Asttypes.Optional _ -> + let loc = { d.ptyp_loc with Location.loc_ghost = true } in + let txt = Longident.Ldot (Longident.Lident "*predef*", "option") in + let ident = { Location.txt; loc } in + { + ptyp_desc = Ptyp_constr (ident, [ d ]); + ptyp_loc = loc; + ptyp_attributes = []; + } + | _ -> d + +let from_loc { Location.txt = _; loc } = loc + +let migration_error loc missing_feature = + Location.raise_errorf ~loc + "migration error: %s is not supported before OCaml 4.03" missing_feature + +let rec copy_expression : From.Parsetree.expression -> To.Parsetree.expression = + fun { + From.Parsetree.pexp_desc; + From.Parsetree.pexp_loc; + From.Parsetree.pexp_attributes; + } -> + { + To.Parsetree.pexp_desc = copy_expression_desc pexp_loc pexp_desc; + To.Parsetree.pexp_loc = copy_location pexp_loc; + To.Parsetree.pexp_attributes = copy_attributes pexp_attributes; + } + +and copy_expression_desc loc : + From.Parsetree.expression_desc -> To.Parsetree.expression_desc = function + | From.Parsetree.Pexp_ident x0 -> + To.Parsetree.Pexp_ident (copy_loc copy_longident x0) + | From.Parsetree.Pexp_constant x0 -> + To.Parsetree.Pexp_constant (copy_constant loc x0) + | From.Parsetree.Pexp_let (x0, x1, x2) -> + To.Parsetree.Pexp_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_expression x2) + | From.Parsetree.Pexp_function x0 -> + To.Parsetree.Pexp_function (List.map copy_case x0) + | From.Parsetree.Pexp_fun (x0, x1, x2, x3) -> + To.Parsetree.Pexp_fun + ( copy_arg_label x0, + copy_option copy_expression x1, + copy_pattern x2, + copy_expression x3 ) + | From.Parsetree.Pexp_apply (x0, x1) -> + To.Parsetree.Pexp_apply + ( copy_expression x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | From.Parsetree.Pexp_match (x0, x1) -> + To.Parsetree.Pexp_match (copy_expression x0, List.map copy_case x1) + | From.Parsetree.Pexp_try (x0, x1) -> + To.Parsetree.Pexp_try (copy_expression x0, List.map copy_case x1) + | From.Parsetree.Pexp_tuple x0 -> + To.Parsetree.Pexp_tuple (List.map copy_expression x0) + | From.Parsetree.Pexp_construct (x0, x1) -> + To.Parsetree.Pexp_construct + (copy_loc copy_longident x0, copy_option copy_expression x1) + | From.Parsetree.Pexp_variant (x0, x1) -> + To.Parsetree.Pexp_variant (copy_label x0, copy_option copy_expression x1) + | From.Parsetree.Pexp_record (x0, x1) -> + To.Parsetree.Pexp_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_expression x1)) + x0, + copy_option copy_expression x1 ) + | From.Parsetree.Pexp_field (x0, x1) -> + To.Parsetree.Pexp_field (copy_expression x0, copy_loc copy_longident x1) + | From.Parsetree.Pexp_setfield (x0, x1, x2) -> + To.Parsetree.Pexp_setfield + (copy_expression x0, copy_loc copy_longident x1, copy_expression x2) + | From.Parsetree.Pexp_array x0 -> + To.Parsetree.Pexp_array (List.map copy_expression x0) + | From.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> + To.Parsetree.Pexp_ifthenelse + (copy_expression x0, copy_expression x1, copy_option copy_expression x2) + | From.Parsetree.Pexp_sequence (x0, x1) -> + To.Parsetree.Pexp_sequence (copy_expression x0, copy_expression x1) + | From.Parsetree.Pexp_while (x0, x1) -> + To.Parsetree.Pexp_while (copy_expression x0, copy_expression x1) + | From.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> + To.Parsetree.Pexp_for + ( copy_pattern x0, + copy_expression x1, + copy_expression x2, + copy_direction_flag x3, + copy_expression x4 ) + | From.Parsetree.Pexp_constraint (x0, x1) -> + To.Parsetree.Pexp_constraint (copy_expression x0, copy_core_type x1) + | From.Parsetree.Pexp_coerce (x0, x1, x2) -> + To.Parsetree.Pexp_coerce + (copy_expression x0, copy_option copy_core_type x1, copy_core_type x2) + | From.Parsetree.Pexp_send (x0, x1) -> + To.Parsetree.Pexp_send (copy_expression x0, x1) + | From.Parsetree.Pexp_new x0 -> + To.Parsetree.Pexp_new (copy_loc copy_longident x0) + | From.Parsetree.Pexp_setinstvar (x0, x1) -> + To.Parsetree.Pexp_setinstvar (copy_loc (fun x -> x) x0, copy_expression x1) + | From.Parsetree.Pexp_override x0 -> + To.Parsetree.Pexp_override + (List.map + (fun x -> + let x0, x1 = x in + (copy_loc (fun x -> x) x0, copy_expression x1)) + x0) + | From.Parsetree.Pexp_letmodule (x0, x1, x2) -> + To.Parsetree.Pexp_letmodule + (copy_loc (fun x -> x) x0, copy_module_expr x1, copy_expression x2) + | From.Parsetree.Pexp_assert x0 -> + To.Parsetree.Pexp_assert (copy_expression x0) + | From.Parsetree.Pexp_lazy x0 -> To.Parsetree.Pexp_lazy (copy_expression x0) + | From.Parsetree.Pexp_poly (x0, x1) -> + To.Parsetree.Pexp_poly (copy_expression x0, copy_option copy_core_type x1) + | From.Parsetree.Pexp_object x0 -> + To.Parsetree.Pexp_object (copy_class_structure x0) + | From.Parsetree.Pexp_newtype (x0, x1) -> + To.Parsetree.Pexp_newtype (x0, copy_expression x1) + | From.Parsetree.Pexp_pack x0 -> To.Parsetree.Pexp_pack (copy_module_expr x0) + | From.Parsetree.Pexp_open (x0, x1, x2) -> + To.Parsetree.Pexp_open + (copy_override_flag x0, copy_loc copy_longident x1, copy_expression x2) + | From.Parsetree.Pexp_extension x0 -> + To.Parsetree.Pexp_extension (copy_extension x0) + | From.Parsetree.Pexp_unreachable -> + migration_error loc "unreachable patterns" + +and copy_direction_flag : + From.Asttypes.direction_flag -> To.Asttypes.direction_flag = function + | From.Asttypes.Upto -> To.Asttypes.Upto + | From.Asttypes.Downto -> To.Asttypes.Downto + +and copy_case : From.Parsetree.case -> To.Parsetree.case = + fun { From.Parsetree.pc_lhs; From.Parsetree.pc_guard; From.Parsetree.pc_rhs } -> + { + To.Parsetree.pc_lhs = copy_pattern pc_lhs; + To.Parsetree.pc_guard = copy_option copy_expression pc_guard; + To.Parsetree.pc_rhs = copy_expression pc_rhs; + } + +and copy_value_binding : + From.Parsetree.value_binding -> To.Parsetree.value_binding = + fun { + From.Parsetree.pvb_pat; + From.Parsetree.pvb_expr; + From.Parsetree.pvb_attributes; + From.Parsetree.pvb_loc; + } -> + { + To.Parsetree.pvb_pat = copy_pattern pvb_pat; + To.Parsetree.pvb_expr = copy_expression pvb_expr; + To.Parsetree.pvb_attributes = copy_attributes pvb_attributes; + To.Parsetree.pvb_loc = copy_location pvb_loc; + } + +and copy_pattern : From.Parsetree.pattern -> To.Parsetree.pattern = + fun { + From.Parsetree.ppat_desc; + From.Parsetree.ppat_loc; + From.Parsetree.ppat_attributes; + } -> + { + To.Parsetree.ppat_desc = copy_pattern_desc ppat_loc ppat_desc; + To.Parsetree.ppat_loc = copy_location ppat_loc; + To.Parsetree.ppat_attributes = copy_attributes ppat_attributes; + } + +and copy_pattern_desc loc : + From.Parsetree.pattern_desc -> To.Parsetree.pattern_desc = function + | From.Parsetree.Ppat_any -> To.Parsetree.Ppat_any + | From.Parsetree.Ppat_var x0 -> + To.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) + | From.Parsetree.Ppat_alias (x0, x1) -> + To.Parsetree.Ppat_alias (copy_pattern x0, copy_loc (fun x -> x) x1) + | From.Parsetree.Ppat_constant x0 -> + To.Parsetree.Ppat_constant (copy_constant loc x0) + | From.Parsetree.Ppat_interval (x0, x1) -> + To.Parsetree.Ppat_interval (copy_constant loc x0, copy_constant loc x1) + | From.Parsetree.Ppat_tuple x0 -> + To.Parsetree.Ppat_tuple (List.map copy_pattern x0) + | From.Parsetree.Ppat_construct (x0, x1) -> + To.Parsetree.Ppat_construct + (copy_loc copy_longident x0, copy_option copy_pattern x1) + | From.Parsetree.Ppat_variant (x0, x1) -> + To.Parsetree.Ppat_variant (copy_label x0, copy_option copy_pattern x1) + | From.Parsetree.Ppat_record (x0, x1) -> + To.Parsetree.Ppat_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_pattern x1)) + x0, + copy_closed_flag x1 ) + | From.Parsetree.Ppat_array x0 -> + To.Parsetree.Ppat_array (List.map copy_pattern x0) + | From.Parsetree.Ppat_or (x0, x1) -> + To.Parsetree.Ppat_or (copy_pattern x0, copy_pattern x1) + | From.Parsetree.Ppat_constraint (x0, x1) -> + To.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1) + | From.Parsetree.Ppat_type x0 -> + To.Parsetree.Ppat_type (copy_loc copy_longident x0) + | From.Parsetree.Ppat_lazy x0 -> To.Parsetree.Ppat_lazy (copy_pattern x0) + | From.Parsetree.Ppat_unpack x0 -> + To.Parsetree.Ppat_unpack (copy_loc (fun x -> x) x0) + | From.Parsetree.Ppat_exception x0 -> + To.Parsetree.Ppat_exception (copy_pattern x0) + | From.Parsetree.Ppat_extension x0 -> + To.Parsetree.Ppat_extension (copy_extension x0) + +and copy_core_type : From.Parsetree.core_type -> To.Parsetree.core_type = + fun { + From.Parsetree.ptyp_desc; + From.Parsetree.ptyp_loc; + From.Parsetree.ptyp_attributes; + } -> + { + To.Parsetree.ptyp_desc = copy_core_type_desc ptyp_desc; + To.Parsetree.ptyp_loc = copy_location ptyp_loc; + To.Parsetree.ptyp_attributes = copy_attributes ptyp_attributes; + } + +and copy_core_type_desc : + From.Parsetree.core_type_desc -> To.Parsetree.core_type_desc = function + | From.Parsetree.Ptyp_any -> To.Parsetree.Ptyp_any + | From.Parsetree.Ptyp_var x0 -> To.Parsetree.Ptyp_var x0 + | From.Parsetree.Ptyp_arrow (x0, x1, x2) -> + To.Parsetree.Ptyp_arrow + ( copy_arg_label x0, + inject_predef_option x0 (copy_core_type x1), + copy_core_type x2 ) + | From.Parsetree.Ptyp_tuple x0 -> + To.Parsetree.Ptyp_tuple (List.map copy_core_type x0) + | From.Parsetree.Ptyp_constr (x0, x1) -> + To.Parsetree.Ptyp_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Ptyp_object (x0, x1) -> + To.Parsetree.Ptyp_object + ( List.map + (fun x -> + let x0, x1, x2 = x in + (x0, copy_attributes x1, copy_core_type x2)) + x0, + copy_closed_flag x1 ) + | From.Parsetree.Ptyp_class (x0, x1) -> + To.Parsetree.Ptyp_class + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Ptyp_alias (x0, x1) -> + To.Parsetree.Ptyp_alias (copy_core_type x0, x1) + | From.Parsetree.Ptyp_variant (x0, x1, x2) -> + To.Parsetree.Ptyp_variant + ( List.map copy_row_field x0, + copy_closed_flag x1, + copy_option (fun x -> List.map copy_label x) x2 ) + | From.Parsetree.Ptyp_poly (x0, x1) -> + To.Parsetree.Ptyp_poly (List.map (fun x -> x) x0, copy_core_type x1) + | From.Parsetree.Ptyp_package x0 -> + To.Parsetree.Ptyp_package (copy_package_type x0) + | From.Parsetree.Ptyp_extension x0 -> + To.Parsetree.Ptyp_extension (copy_extension x0) + +and copy_package_type : From.Parsetree.package_type -> To.Parsetree.package_type + = + fun x -> + let x0, x1 = x in + ( copy_loc copy_longident x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_core_type x1)) + x1 ) + +and copy_row_field : From.Parsetree.row_field -> To.Parsetree.row_field = + function + | From.Parsetree.Rtag (x0, x1, x2, x3) -> + To.Parsetree.Rtag + ( copy_label x0, + copy_attributes x1, + copy_bool x2, + List.map copy_core_type x3 ) + | From.Parsetree.Rinherit x0 -> To.Parsetree.Rinherit (copy_core_type x0) + +and copy_attributes : From.Parsetree.attributes -> To.Parsetree.attributes = + fun x -> List.map copy_attribute x + +and copy_attribute : From.Parsetree.attribute -> To.Parsetree.attribute = + fun x -> + let x0, x1 = x in + (copy_loc (fun x -> x) x0, copy_payload (from_loc x0) x1) + +and copy_payload loc : From.Parsetree.payload -> To.Parsetree.payload = function + | From.Parsetree.PStr x0 -> To.Parsetree.PStr (copy_structure x0) + | From.Parsetree.PSig _x0 -> migration_error loc "signatures in attribute" + | From.Parsetree.PTyp x0 -> To.Parsetree.PTyp (copy_core_type x0) + | From.Parsetree.PPat (x0, x1) -> + To.Parsetree.PPat (copy_pattern x0, copy_option copy_expression x1) + +and copy_structure : From.Parsetree.structure -> To.Parsetree.structure = + fun x -> List.map copy_structure_item x + +and copy_structure_item : + From.Parsetree.structure_item -> To.Parsetree.structure_item = + fun { From.Parsetree.pstr_desc; From.Parsetree.pstr_loc } -> + { + To.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc; + To.Parsetree.pstr_loc = copy_location pstr_loc; + } + +and copy_structure_item_desc : + From.Parsetree.structure_item_desc -> To.Parsetree.structure_item_desc = + function + | From.Parsetree.Pstr_eval (x0, x1) -> + To.Parsetree.Pstr_eval (copy_expression x0, copy_attributes x1) + | From.Parsetree.Pstr_value (x0, x1) -> + To.Parsetree.Pstr_value (copy_rec_flag x0, List.map copy_value_binding x1) + | From.Parsetree.Pstr_primitive x0 -> + To.Parsetree.Pstr_primitive (copy_value_description x0) + | From.Parsetree.Pstr_type (x0, x1) -> + To.Parsetree.Pstr_type (type_declarations x0 x1) + | From.Parsetree.Pstr_typext x0 -> + To.Parsetree.Pstr_typext (copy_type_extension x0) + | From.Parsetree.Pstr_exception x0 -> + To.Parsetree.Pstr_exception (copy_extension_constructor x0) + | From.Parsetree.Pstr_module x0 -> + To.Parsetree.Pstr_module (copy_module_binding x0) + | From.Parsetree.Pstr_recmodule x0 -> + To.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) + | From.Parsetree.Pstr_modtype x0 -> + To.Parsetree.Pstr_modtype (copy_module_type_declaration x0) + | From.Parsetree.Pstr_open x0 -> + To.Parsetree.Pstr_open (copy_open_description x0) + | From.Parsetree.Pstr_class x0 -> + To.Parsetree.Pstr_class (List.map copy_class_declaration x0) + | From.Parsetree.Pstr_class_type x0 -> + To.Parsetree.Pstr_class_type (List.map copy_class_type_declaration x0) + | From.Parsetree.Pstr_include x0 -> + To.Parsetree.Pstr_include (copy_include_declaration x0) + | From.Parsetree.Pstr_attribute x0 -> + To.Parsetree.Pstr_attribute (copy_attribute x0) + | From.Parsetree.Pstr_extension (x0, x1) -> + To.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1) + +and copy_include_declaration : + From.Parsetree.include_declaration -> To.Parsetree.include_declaration = + fun x -> copy_include_infos copy_module_expr x + +and copy_class_declaration : + From.Parsetree.class_declaration -> To.Parsetree.class_declaration = + fun x -> copy_class_infos copy_class_expr x + +and copy_class_expr : From.Parsetree.class_expr -> To.Parsetree.class_expr = + fun { + From.Parsetree.pcl_desc; + From.Parsetree.pcl_loc; + From.Parsetree.pcl_attributes; + } -> + { + To.Parsetree.pcl_desc = copy_class_expr_desc pcl_desc; + To.Parsetree.pcl_loc = copy_location pcl_loc; + To.Parsetree.pcl_attributes = copy_attributes pcl_attributes; + } + +and copy_class_expr_desc : + From.Parsetree.class_expr_desc -> To.Parsetree.class_expr_desc = function + | From.Parsetree.Pcl_constr (x0, x1) -> + To.Parsetree.Pcl_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Pcl_structure x0 -> + To.Parsetree.Pcl_structure (copy_class_structure x0) + | From.Parsetree.Pcl_fun (x0, x1, x2, x3) -> + To.Parsetree.Pcl_fun + ( copy_arg_label x0, + copy_option copy_expression x1, + copy_pattern x2, + copy_class_expr x3 ) + | From.Parsetree.Pcl_apply (x0, x1) -> + To.Parsetree.Pcl_apply + ( copy_class_expr x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | From.Parsetree.Pcl_let (x0, x1, x2) -> + To.Parsetree.Pcl_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_class_expr x2) + | From.Parsetree.Pcl_constraint (x0, x1) -> + To.Parsetree.Pcl_constraint (copy_class_expr x0, copy_class_type x1) + | From.Parsetree.Pcl_extension x0 -> + To.Parsetree.Pcl_extension (copy_extension x0) + +and copy_class_structure : + From.Parsetree.class_structure -> To.Parsetree.class_structure = + fun { From.Parsetree.pcstr_self; From.Parsetree.pcstr_fields } -> + { + To.Parsetree.pcstr_self = copy_pattern pcstr_self; + To.Parsetree.pcstr_fields = List.map copy_class_field pcstr_fields; + } + +and copy_class_field : From.Parsetree.class_field -> To.Parsetree.class_field = + fun { + From.Parsetree.pcf_desc; + From.Parsetree.pcf_loc; + From.Parsetree.pcf_attributes; + } -> + { + To.Parsetree.pcf_desc = copy_class_field_desc pcf_desc; + To.Parsetree.pcf_loc = copy_location pcf_loc; + To.Parsetree.pcf_attributes = copy_attributes pcf_attributes; + } + +and copy_class_field_desc : + From.Parsetree.class_field_desc -> To.Parsetree.class_field_desc = function + | From.Parsetree.Pcf_inherit (x0, x1, x2) -> + To.Parsetree.Pcf_inherit + (copy_override_flag x0, copy_class_expr x1, copy_option (fun x -> x) x2) + | From.Parsetree.Pcf_val x0 -> + To.Parsetree.Pcf_val + (let x0, x1, x2 = x0 in + ( copy_loc (fun x -> x) x0, + copy_mutable_flag x1, + copy_class_field_kind x2 )) + | From.Parsetree.Pcf_method x0 -> + To.Parsetree.Pcf_method + (let x0, x1, x2 = x0 in + ( copy_loc (fun x -> x) x0, + copy_private_flag x1, + copy_class_field_kind x2 )) + | From.Parsetree.Pcf_constraint x0 -> + To.Parsetree.Pcf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | From.Parsetree.Pcf_initializer x0 -> + To.Parsetree.Pcf_initializer (copy_expression x0) + | From.Parsetree.Pcf_attribute x0 -> + To.Parsetree.Pcf_attribute (copy_attribute x0) + | From.Parsetree.Pcf_extension x0 -> + To.Parsetree.Pcf_extension (copy_extension x0) + +and copy_class_field_kind : + From.Parsetree.class_field_kind -> To.Parsetree.class_field_kind = function + | From.Parsetree.Cfk_virtual x0 -> + To.Parsetree.Cfk_virtual (copy_core_type x0) + | From.Parsetree.Cfk_concrete (x0, x1) -> + To.Parsetree.Cfk_concrete (copy_override_flag x0, copy_expression x1) + +and copy_module_binding : + From.Parsetree.module_binding -> To.Parsetree.module_binding = + fun { + From.Parsetree.pmb_name; + From.Parsetree.pmb_expr; + From.Parsetree.pmb_attributes; + From.Parsetree.pmb_loc; + } -> + { + To.Parsetree.pmb_name = copy_loc (fun x -> x) pmb_name; + To.Parsetree.pmb_expr = copy_module_expr pmb_expr; + To.Parsetree.pmb_attributes = copy_attributes pmb_attributes; + To.Parsetree.pmb_loc = copy_location pmb_loc; + } + +and copy_module_expr : From.Parsetree.module_expr -> To.Parsetree.module_expr = + fun { + From.Parsetree.pmod_desc; + From.Parsetree.pmod_loc; + From.Parsetree.pmod_attributes; + } -> + { + To.Parsetree.pmod_desc = copy_module_expr_desc pmod_desc; + To.Parsetree.pmod_loc = copy_location pmod_loc; + To.Parsetree.pmod_attributes = copy_attributes pmod_attributes; + } + +and copy_module_expr_desc : + From.Parsetree.module_expr_desc -> To.Parsetree.module_expr_desc = function + | From.Parsetree.Pmod_ident x0 -> + To.Parsetree.Pmod_ident (copy_loc copy_longident x0) + | From.Parsetree.Pmod_structure x0 -> + To.Parsetree.Pmod_structure (copy_structure x0) + | From.Parsetree.Pmod_functor (x0, x1, x2) -> + To.Parsetree.Pmod_functor + ( copy_loc (fun x -> x) x0, + copy_option copy_module_type x1, + copy_module_expr x2 ) + | From.Parsetree.Pmod_apply (x0, x1) -> + To.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) + | From.Parsetree.Pmod_constraint (x0, x1) -> + To.Parsetree.Pmod_constraint (copy_module_expr x0, copy_module_type x1) + | From.Parsetree.Pmod_unpack x0 -> + To.Parsetree.Pmod_unpack (copy_expression x0) + | From.Parsetree.Pmod_extension x0 -> + To.Parsetree.Pmod_extension (copy_extension x0) + +and copy_module_type : From.Parsetree.module_type -> To.Parsetree.module_type = + fun { + From.Parsetree.pmty_desc; + From.Parsetree.pmty_loc; + From.Parsetree.pmty_attributes; + } -> + { + To.Parsetree.pmty_desc = copy_module_type_desc pmty_desc; + To.Parsetree.pmty_loc = copy_location pmty_loc; + To.Parsetree.pmty_attributes = copy_attributes pmty_attributes; + } + +and copy_module_type_desc : + From.Parsetree.module_type_desc -> To.Parsetree.module_type_desc = function + | From.Parsetree.Pmty_ident x0 -> + To.Parsetree.Pmty_ident (copy_loc copy_longident x0) + | From.Parsetree.Pmty_signature x0 -> + To.Parsetree.Pmty_signature (copy_signature x0) + | From.Parsetree.Pmty_functor (x0, x1, x2) -> + To.Parsetree.Pmty_functor + ( copy_loc (fun x -> x) x0, + copy_option copy_module_type x1, + copy_module_type x2 ) + | From.Parsetree.Pmty_with (x0, x1) -> + To.Parsetree.Pmty_with + (copy_module_type x0, List.map copy_with_constraint x1) + | From.Parsetree.Pmty_typeof x0 -> + To.Parsetree.Pmty_typeof (copy_module_expr x0) + | From.Parsetree.Pmty_extension x0 -> + To.Parsetree.Pmty_extension (copy_extension x0) + | From.Parsetree.Pmty_alias x0 -> + To.Parsetree.Pmty_alias (copy_loc copy_longident x0) + +and copy_with_constraint : + From.Parsetree.with_constraint -> To.Parsetree.with_constraint = function + | From.Parsetree.Pwith_type (x0, x1) -> + To.Parsetree.Pwith_type + (copy_loc copy_longident x0, copy_type_declaration x1) + | From.Parsetree.Pwith_module (x0, x1) -> + To.Parsetree.Pwith_module + (copy_loc copy_longident x0, copy_loc copy_longident x1) + | From.Parsetree.Pwith_typesubst x0 -> + To.Parsetree.Pwith_typesubst (copy_type_declaration x0) + | From.Parsetree.Pwith_modsubst (x0, x1) -> + To.Parsetree.Pwith_modsubst + (copy_loc (fun x -> x) x0, copy_loc copy_longident x1) + +and copy_signature : From.Parsetree.signature -> To.Parsetree.signature = + fun x -> List.map copy_signature_item x + +and copy_signature_item : + From.Parsetree.signature_item -> To.Parsetree.signature_item = + fun { From.Parsetree.psig_desc; From.Parsetree.psig_loc } -> + { + To.Parsetree.psig_desc = copy_signature_item_desc psig_desc; + To.Parsetree.psig_loc = copy_location psig_loc; + } + +and copy_signature_item_desc : + From.Parsetree.signature_item_desc -> To.Parsetree.signature_item_desc = + function + | From.Parsetree.Psig_value x0 -> + To.Parsetree.Psig_value (copy_value_description x0) + | From.Parsetree.Psig_type (x0, x1) -> + To.Parsetree.Psig_type (type_declarations x0 x1) + | From.Parsetree.Psig_typext x0 -> + To.Parsetree.Psig_typext (copy_type_extension x0) + | From.Parsetree.Psig_exception x0 -> + To.Parsetree.Psig_exception (copy_extension_constructor x0) + | From.Parsetree.Psig_module x0 -> + To.Parsetree.Psig_module (copy_module_declaration x0) + | From.Parsetree.Psig_recmodule x0 -> + To.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) + | From.Parsetree.Psig_modtype x0 -> + To.Parsetree.Psig_modtype (copy_module_type_declaration x0) + | From.Parsetree.Psig_open x0 -> + To.Parsetree.Psig_open (copy_open_description x0) + | From.Parsetree.Psig_include x0 -> + To.Parsetree.Psig_include (copy_include_description x0) + | From.Parsetree.Psig_class x0 -> + To.Parsetree.Psig_class (List.map copy_class_description x0) + | From.Parsetree.Psig_class_type x0 -> + To.Parsetree.Psig_class_type (List.map copy_class_type_declaration x0) + | From.Parsetree.Psig_attribute x0 -> + To.Parsetree.Psig_attribute (copy_attribute x0) + | From.Parsetree.Psig_extension (x0, x1) -> + To.Parsetree.Psig_extension (copy_extension x0, copy_attributes x1) + +and copy_class_type_declaration : + From.Parsetree.class_type_declaration -> To.Parsetree.class_type_declaration + = + fun x -> copy_class_infos copy_class_type x + +and copy_class_description : + From.Parsetree.class_description -> To.Parsetree.class_description = + fun x -> copy_class_infos copy_class_type x + +and copy_class_type : From.Parsetree.class_type -> To.Parsetree.class_type = + fun { + From.Parsetree.pcty_desc; + From.Parsetree.pcty_loc; + From.Parsetree.pcty_attributes; + } -> + { + To.Parsetree.pcty_desc = copy_class_type_desc pcty_desc; + To.Parsetree.pcty_loc = copy_location pcty_loc; + To.Parsetree.pcty_attributes = copy_attributes pcty_attributes; + } + +and copy_class_type_desc : + From.Parsetree.class_type_desc -> To.Parsetree.class_type_desc = function + | From.Parsetree.Pcty_constr (x0, x1) -> + To.Parsetree.Pcty_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Pcty_signature x0 -> + To.Parsetree.Pcty_signature (copy_class_signature x0) + | From.Parsetree.Pcty_arrow (x0, x1, x2) -> + To.Parsetree.Pcty_arrow + ( copy_arg_label x0, + inject_predef_option x0 (copy_core_type x1), + copy_class_type x2 ) + | From.Parsetree.Pcty_extension x0 -> + To.Parsetree.Pcty_extension (copy_extension x0) + +and copy_class_signature : + From.Parsetree.class_signature -> To.Parsetree.class_signature = + fun { From.Parsetree.pcsig_self; From.Parsetree.pcsig_fields } -> + { + To.Parsetree.pcsig_self = copy_core_type pcsig_self; + To.Parsetree.pcsig_fields = List.map copy_class_type_field pcsig_fields; + } + +and copy_class_type_field : + From.Parsetree.class_type_field -> To.Parsetree.class_type_field = + fun { + From.Parsetree.pctf_desc; + From.Parsetree.pctf_loc; + From.Parsetree.pctf_attributes; + } -> + { + To.Parsetree.pctf_desc = copy_class_type_field_desc pctf_desc; + To.Parsetree.pctf_loc = copy_location pctf_loc; + To.Parsetree.pctf_attributes = copy_attributes pctf_attributes; + } + +and copy_class_type_field_desc : + From.Parsetree.class_type_field_desc -> To.Parsetree.class_type_field_desc = + function + | From.Parsetree.Pctf_inherit x0 -> + To.Parsetree.Pctf_inherit (copy_class_type x0) + | From.Parsetree.Pctf_val x0 -> + To.Parsetree.Pctf_val + (let x0, x1, x2, x3 = x0 in + (x0, copy_mutable_flag x1, copy_virtual_flag x2, copy_core_type x3)) + | From.Parsetree.Pctf_method x0 -> + To.Parsetree.Pctf_method + (let x0, x1, x2, x3 = x0 in + (x0, copy_private_flag x1, copy_virtual_flag x2, copy_core_type x3)) + | From.Parsetree.Pctf_constraint x0 -> + To.Parsetree.Pctf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | From.Parsetree.Pctf_attribute x0 -> + To.Parsetree.Pctf_attribute (copy_attribute x0) + | From.Parsetree.Pctf_extension x0 -> + To.Parsetree.Pctf_extension (copy_extension x0) + +and copy_extension : From.Parsetree.extension -> To.Parsetree.extension = + fun x -> + let x0, x1 = x in + (copy_loc (fun x -> x) x0, copy_payload (from_loc x0) x1) + +and copy_class_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 From.Parsetree.class_infos -> + 'g0 To.Parsetree.class_infos = + fun f0 + { + From.Parsetree.pci_virt; + From.Parsetree.pci_params; + From.Parsetree.pci_name; + From.Parsetree.pci_expr; + From.Parsetree.pci_loc; + From.Parsetree.pci_attributes; + } -> + { + To.Parsetree.pci_virt = copy_virtual_flag pci_virt; + To.Parsetree.pci_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + pci_params; + To.Parsetree.pci_name = copy_loc (fun x -> x) pci_name; + To.Parsetree.pci_expr = f0 pci_expr; + To.Parsetree.pci_loc = copy_location pci_loc; + To.Parsetree.pci_attributes = copy_attributes pci_attributes; + } + +and copy_virtual_flag : From.Asttypes.virtual_flag -> To.Asttypes.virtual_flag = + function + | From.Asttypes.Virtual -> To.Asttypes.Virtual + | From.Asttypes.Concrete -> To.Asttypes.Concrete + +and copy_include_description : + From.Parsetree.include_description -> To.Parsetree.include_description = + fun x -> copy_include_infos copy_module_type x + +and copy_include_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 From.Parsetree.include_infos -> + 'g0 To.Parsetree.include_infos = + fun f0 + { + From.Parsetree.pincl_mod; + From.Parsetree.pincl_loc; + From.Parsetree.pincl_attributes; + } -> + { + To.Parsetree.pincl_mod = f0 pincl_mod; + To.Parsetree.pincl_loc = copy_location pincl_loc; + To.Parsetree.pincl_attributes = copy_attributes pincl_attributes; + } + +and copy_open_description : + From.Parsetree.open_description -> To.Parsetree.open_description = + fun { + From.Parsetree.popen_lid; + From.Parsetree.popen_override; + From.Parsetree.popen_loc; + From.Parsetree.popen_attributes; + } -> + { + To.Parsetree.popen_lid = copy_loc copy_longident popen_lid; + To.Parsetree.popen_override = copy_override_flag popen_override; + To.Parsetree.popen_loc = copy_location popen_loc; + To.Parsetree.popen_attributes = copy_attributes popen_attributes; + } + +and copy_override_flag : + From.Asttypes.override_flag -> To.Asttypes.override_flag = function + | From.Asttypes.Override -> To.Asttypes.Override + | From.Asttypes.Fresh -> To.Asttypes.Fresh + +and copy_module_type_declaration : + From.Parsetree.module_type_declaration -> + To.Parsetree.module_type_declaration = + fun { + From.Parsetree.pmtd_name; + From.Parsetree.pmtd_type; + From.Parsetree.pmtd_attributes; + From.Parsetree.pmtd_loc; + } -> + { + To.Parsetree.pmtd_name = copy_loc (fun x -> x) pmtd_name; + To.Parsetree.pmtd_type = copy_option copy_module_type pmtd_type; + To.Parsetree.pmtd_attributes = copy_attributes pmtd_attributes; + To.Parsetree.pmtd_loc = copy_location pmtd_loc; + } + +and copy_module_declaration : + From.Parsetree.module_declaration -> To.Parsetree.module_declaration = + fun { + From.Parsetree.pmd_name; + From.Parsetree.pmd_type; + From.Parsetree.pmd_attributes; + From.Parsetree.pmd_loc; + } -> + { + To.Parsetree.pmd_name = copy_loc (fun x -> x) pmd_name; + To.Parsetree.pmd_type = copy_module_type pmd_type; + To.Parsetree.pmd_attributes = copy_attributes pmd_attributes; + To.Parsetree.pmd_loc = copy_location pmd_loc; + } + +and copy_type_extension : + From.Parsetree.type_extension -> To.Parsetree.type_extension = + fun { + From.Parsetree.ptyext_path; + From.Parsetree.ptyext_params; + From.Parsetree.ptyext_constructors; + From.Parsetree.ptyext_private; + From.Parsetree.ptyext_attributes; + } -> + { + To.Parsetree.ptyext_path = copy_loc copy_longident ptyext_path; + To.Parsetree.ptyext_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptyext_params; + To.Parsetree.ptyext_constructors = + List.map copy_extension_constructor ptyext_constructors; + To.Parsetree.ptyext_private = copy_private_flag ptyext_private; + To.Parsetree.ptyext_attributes = copy_attributes ptyext_attributes; + } + +and copy_extension_constructor : + From.Parsetree.extension_constructor -> To.Parsetree.extension_constructor = + fun { + From.Parsetree.pext_name; + From.Parsetree.pext_kind; + From.Parsetree.pext_loc; + From.Parsetree.pext_attributes; + } -> + { + To.Parsetree.pext_name = copy_loc (fun x -> x) pext_name; + To.Parsetree.pext_kind = + copy_extension_constructor_kind (from_loc pext_name) pext_kind; + To.Parsetree.pext_loc = copy_location pext_loc; + To.Parsetree.pext_attributes = copy_attributes pext_attributes; + } + +and copy_extension_constructor_kind loc : + From.Parsetree.extension_constructor_kind -> + To.Parsetree.extension_constructor_kind = function + | From.Parsetree.Pext_decl (x0, x1) -> + To.Parsetree.Pext_decl + (copy_constructor_arguments loc x0, copy_option copy_core_type x1) + | From.Parsetree.Pext_rebind x0 -> + To.Parsetree.Pext_rebind (copy_loc copy_longident x0) + +and copy_type_declaration : + From.Parsetree.type_declaration -> To.Parsetree.type_declaration = + fun { + From.Parsetree.ptype_name; + From.Parsetree.ptype_params; + From.Parsetree.ptype_cstrs; + From.Parsetree.ptype_kind; + From.Parsetree.ptype_private; + From.Parsetree.ptype_manifest; + From.Parsetree.ptype_attributes; + From.Parsetree.ptype_loc; + } -> + { + To.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name; + To.Parsetree.ptype_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptype_params; + To.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; + To.Parsetree.ptype_kind = copy_type_kind ptype_kind; + To.Parsetree.ptype_private = copy_private_flag ptype_private; + To.Parsetree.ptype_manifest = copy_option copy_core_type ptype_manifest; + To.Parsetree.ptype_attributes = copy_attributes ptype_attributes; + To.Parsetree.ptype_loc = copy_location ptype_loc; + } + +and copy_private_flag : From.Asttypes.private_flag -> To.Asttypes.private_flag = + function + | From.Asttypes.Private -> To.Asttypes.Private + | From.Asttypes.Public -> To.Asttypes.Public + +and copy_type_kind : From.Parsetree.type_kind -> To.Parsetree.type_kind = + function + | From.Parsetree.Ptype_abstract -> To.Parsetree.Ptype_abstract + | From.Parsetree.Ptype_variant x0 -> + To.Parsetree.Ptype_variant (List.map copy_constructor_declaration x0) + | From.Parsetree.Ptype_record x0 -> + To.Parsetree.Ptype_record (List.map copy_label_declaration x0) + | From.Parsetree.Ptype_open -> To.Parsetree.Ptype_open + +and copy_constructor_declaration : + From.Parsetree.constructor_declaration -> + To.Parsetree.constructor_declaration = + fun { + From.Parsetree.pcd_name; + From.Parsetree.pcd_args; + From.Parsetree.pcd_res; + From.Parsetree.pcd_loc; + From.Parsetree.pcd_attributes; + } -> + { + To.Parsetree.pcd_name = copy_loc (fun x -> x) pcd_name; + To.Parsetree.pcd_args = + copy_constructor_arguments (from_loc pcd_name) pcd_args; + To.Parsetree.pcd_res = copy_option copy_core_type pcd_res; + To.Parsetree.pcd_loc = copy_location pcd_loc; + To.Parsetree.pcd_attributes = copy_attributes pcd_attributes; + } + +and copy_constructor_arguments loc : + From.Parsetree.constructor_arguments -> To.Parsetree.core_type list = + function + | From.Parsetree.Pcstr_tuple x0 -> List.map copy_core_type x0 + | From.Parsetree.Pcstr_record _x0 -> migration_error loc "inline records" + +and copy_label_declaration : + From.Parsetree.label_declaration -> To.Parsetree.label_declaration = + fun { + From.Parsetree.pld_name; + From.Parsetree.pld_mutable; + From.Parsetree.pld_type; + From.Parsetree.pld_loc; + From.Parsetree.pld_attributes; + } -> + { + To.Parsetree.pld_name = copy_loc (fun x -> x) pld_name; + To.Parsetree.pld_mutable = copy_mutable_flag pld_mutable; + To.Parsetree.pld_type = copy_core_type pld_type; + To.Parsetree.pld_loc = copy_location pld_loc; + To.Parsetree.pld_attributes = copy_attributes pld_attributes; + } + +and copy_mutable_flag : From.Asttypes.mutable_flag -> To.Asttypes.mutable_flag = + function + | From.Asttypes.Immutable -> To.Asttypes.Immutable + | From.Asttypes.Mutable -> To.Asttypes.Mutable + +and copy_variance : From.Asttypes.variance -> To.Asttypes.variance = function + | From.Asttypes.Covariant -> To.Asttypes.Covariant + | From.Asttypes.Contravariant -> To.Asttypes.Contravariant + | From.Asttypes.Invariant -> To.Asttypes.Invariant + +and copy_value_description : + From.Parsetree.value_description -> To.Parsetree.value_description = + fun { + From.Parsetree.pval_name; + From.Parsetree.pval_type; + From.Parsetree.pval_prim; + From.Parsetree.pval_attributes; + From.Parsetree.pval_loc; + } -> + { + To.Parsetree.pval_name = copy_loc (fun x -> x) pval_name; + To.Parsetree.pval_type = copy_core_type pval_type; + To.Parsetree.pval_prim = List.map (fun x -> x) pval_prim; + To.Parsetree.pval_attributes = copy_attributes pval_attributes; + To.Parsetree.pval_loc = copy_location pval_loc; + } + +and copy_arg_label : From.Asttypes.arg_label -> string = function + | From.Asttypes.Nolabel -> "" + | From.Asttypes.Labelled x0 -> x0 + | From.Asttypes.Optional x0 -> "?" ^ x0 + +and copy_closed_flag : From.Asttypes.closed_flag -> To.Asttypes.closed_flag = + function + | From.Asttypes.Closed -> To.Asttypes.Closed + | From.Asttypes.Open -> To.Asttypes.Open + +and copy_label : From.Asttypes.label -> To.Asttypes.label = fun x -> x + +and copy_rec_flag : From.Asttypes.rec_flag -> To.Asttypes.rec_flag = function + | From.Asttypes.Nonrecursive -> To.Asttypes.Nonrecursive + | From.Asttypes.Recursive -> To.Asttypes.Recursive + +and copy_constant loc : From.Parsetree.constant -> To.Asttypes.constant = + function + | From.Parsetree.Pconst_integer (x0, x1) -> ( + match x1 with + | None -> To.Asttypes.Const_int (int_of_string x0) + | Some 'l' -> To.Asttypes.Const_int32 (Int32.of_string x0) + | Some 'L' -> To.Asttypes.Const_int64 (Int64.of_string x0) + | Some 'n' -> To.Asttypes.Const_nativeint (Nativeint.of_string x0) + | Some _ -> migration_error loc "custom integer literals") + | From.Parsetree.Pconst_char x0 -> To.Asttypes.Const_char x0 + | From.Parsetree.Pconst_string (x0, x1) -> To.Asttypes.Const_string (x0, x1) + | From.Parsetree.Pconst_float (x0, x1) -> ( + match x1 with + | None -> To.Asttypes.Const_float x0 + | Some _ -> migration_error loc "custom float literals") + +and copy_option : 'f0 'g0. ('f0 -> 'g0) -> 'f0 option -> 'g0 option = + fun f0 -> function None -> None | Some x0 -> Some (f0 x0) + +and copy_longident : Longident.t -> Longident.t = fun x -> x + +and copy_loc : + 'f0 'g0. ('f0 -> 'g0) -> 'f0 From.Asttypes.loc -> 'g0 To.Asttypes.loc = + fun f0 { From.Asttypes.txt; From.Asttypes.loc } -> + { To.Asttypes.txt = f0 txt; To.Asttypes.loc = copy_location loc } + +and copy_location : Location.t -> Location.t = fun x -> x + +and copy_bool : bool -> bool = function false -> false | true -> true + +and type_declarations recflag types = + match (recflag, List.map copy_type_declaration types) with + | From.Asttypes.Recursive, types -> types + | From.Asttypes.Nonrecursive, [] -> [] + | From.Asttypes.Nonrecursive, x :: xs -> + let pos = + { + Lexing.pos_fname = "_none_"; + pos_lnum = 1; + pos_bol = 0; + pos_cnum = -1; + } + in + let loc = { Location.loc_start = pos; loc_end = pos; loc_ghost = true } in + let ptype_attributes = + ({ To.Asttypes.txt = "nonrec"; loc }, To.Parsetree.PStr []) + :: x.To.Parsetree.ptype_attributes + in + { x with To.Parsetree.ptype_attributes } :: xs + +let rec copy_toplevel_phrase : + From.Parsetree.toplevel_phrase -> To.Parsetree.toplevel_phrase = function + | From.Parsetree.Ptop_def x0 -> To.Parsetree.Ptop_def (copy_structure x0) + | From.Parsetree.Ptop_dir (x0, x1) -> + To.Parsetree.Ptop_dir (x0, copy_directive_argument x1) + +and copy_directive_argument : + From.Parsetree.directive_argument -> To.Parsetree.directive_argument = + function + | From.Parsetree.Pdir_none -> To.Parsetree.Pdir_none + | From.Parsetree.Pdir_string x0 -> To.Parsetree.Pdir_string x0 + | From.Parsetree.Pdir_int (x0, _x1) -> + To.Parsetree.Pdir_int (int_of_string x0) + | From.Parsetree.Pdir_ident x0 -> To.Parsetree.Pdir_ident (copy_longident x0) + | From.Parsetree.Pdir_bool x0 -> To.Parsetree.Pdir_bool (copy_bool x0) + +let copy_cases x = List.map copy_case x + +let copy_pat = copy_pattern + +let copy_expr = copy_expression + +let copy_typ = copy_core_type diff -Nru ppxlib-0.15.0/astlib/migrate_403_404.ml ppxlib-0.24.0/astlib/migrate_403_404.ml --- ppxlib-0.15.0/astlib/migrate_403_404.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/migrate_403_404.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1000 @@ +(**************************************************************************) +(* *) +(* OCaml Migrate Parsetree *) +(* *) +(* Frédéric Bour *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2017 Institut National de Recherche en Informatique et *) +(* en Automatique (INRIA). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module From = Ast_403 +module To = Ast_404 + +let rec copy_expression : From.Parsetree.expression -> To.Parsetree.expression = + fun { + From.Parsetree.pexp_desc; + From.Parsetree.pexp_loc; + From.Parsetree.pexp_attributes; + } -> + { + To.Parsetree.pexp_desc = copy_expression_desc pexp_desc; + To.Parsetree.pexp_loc = copy_location pexp_loc; + To.Parsetree.pexp_attributes = copy_attributes pexp_attributes; + } + +and copy_expression_desc : + From.Parsetree.expression_desc -> To.Parsetree.expression_desc = function + | From.Parsetree.Pexp_ident x0 -> + To.Parsetree.Pexp_ident (copy_loc copy_longident x0) + | From.Parsetree.Pexp_constant x0 -> + To.Parsetree.Pexp_constant (copy_constant x0) + | From.Parsetree.Pexp_let (x0, x1, x2) -> + To.Parsetree.Pexp_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_expression x2) + | From.Parsetree.Pexp_function x0 -> + To.Parsetree.Pexp_function (List.map copy_case x0) + | From.Parsetree.Pexp_fun (x0, x1, x2, x3) -> + To.Parsetree.Pexp_fun + ( copy_arg_label x0, + copy_option copy_expression x1, + copy_pattern x2, + copy_expression x3 ) + | From.Parsetree.Pexp_apply (x0, x1) -> + To.Parsetree.Pexp_apply + ( copy_expression x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | From.Parsetree.Pexp_match (x0, x1) -> + To.Parsetree.Pexp_match (copy_expression x0, List.map copy_case x1) + | From.Parsetree.Pexp_try (x0, x1) -> + To.Parsetree.Pexp_try (copy_expression x0, List.map copy_case x1) + | From.Parsetree.Pexp_tuple x0 -> + To.Parsetree.Pexp_tuple (List.map copy_expression x0) + | From.Parsetree.Pexp_construct (x0, x1) -> + To.Parsetree.Pexp_construct + (copy_loc copy_longident x0, copy_option copy_expression x1) + | From.Parsetree.Pexp_variant (x0, x1) -> + To.Parsetree.Pexp_variant (copy_label x0, copy_option copy_expression x1) + | From.Parsetree.Pexp_record (x0, x1) -> + To.Parsetree.Pexp_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_expression x1)) + x0, + copy_option copy_expression x1 ) + | From.Parsetree.Pexp_field (x0, x1) -> + To.Parsetree.Pexp_field (copy_expression x0, copy_loc copy_longident x1) + | From.Parsetree.Pexp_setfield (x0, x1, x2) -> + To.Parsetree.Pexp_setfield + (copy_expression x0, copy_loc copy_longident x1, copy_expression x2) + | From.Parsetree.Pexp_array x0 -> + To.Parsetree.Pexp_array (List.map copy_expression x0) + | From.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> + To.Parsetree.Pexp_ifthenelse + (copy_expression x0, copy_expression x1, copy_option copy_expression x2) + | From.Parsetree.Pexp_sequence (x0, x1) -> + To.Parsetree.Pexp_sequence (copy_expression x0, copy_expression x1) + | From.Parsetree.Pexp_while (x0, x1) -> + To.Parsetree.Pexp_while (copy_expression x0, copy_expression x1) + | From.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> + To.Parsetree.Pexp_for + ( copy_pattern x0, + copy_expression x1, + copy_expression x2, + copy_direction_flag x3, + copy_expression x4 ) + | From.Parsetree.Pexp_constraint (x0, x1) -> + To.Parsetree.Pexp_constraint (copy_expression x0, copy_core_type x1) + | From.Parsetree.Pexp_coerce (x0, x1, x2) -> + To.Parsetree.Pexp_coerce + (copy_expression x0, copy_option copy_core_type x1, copy_core_type x2) + | From.Parsetree.Pexp_send (x0, x1) -> + To.Parsetree.Pexp_send (copy_expression x0, x1) + | From.Parsetree.Pexp_new x0 -> + To.Parsetree.Pexp_new (copy_loc copy_longident x0) + | From.Parsetree.Pexp_setinstvar (x0, x1) -> + To.Parsetree.Pexp_setinstvar (copy_loc (fun x -> x) x0, copy_expression x1) + | From.Parsetree.Pexp_override x0 -> + To.Parsetree.Pexp_override + (List.map + (fun x -> + let x0, x1 = x in + (copy_loc (fun x -> x) x0, copy_expression x1)) + x0) + | From.Parsetree.Pexp_letmodule (x0, x1, x2) -> + To.Parsetree.Pexp_letmodule + (copy_loc (fun x -> x) x0, copy_module_expr x1, copy_expression x2) + | From.Parsetree.Pexp_assert x0 -> + To.Parsetree.Pexp_assert (copy_expression x0) + | From.Parsetree.Pexp_lazy x0 -> To.Parsetree.Pexp_lazy (copy_expression x0) + | From.Parsetree.Pexp_poly (x0, x1) -> + To.Parsetree.Pexp_poly (copy_expression x0, copy_option copy_core_type x1) + | From.Parsetree.Pexp_object x0 -> + To.Parsetree.Pexp_object (copy_class_structure x0) + | From.Parsetree.Pexp_newtype (x0, x1) -> + To.Parsetree.Pexp_newtype (x0, copy_expression x1) + | From.Parsetree.Pexp_pack x0 -> To.Parsetree.Pexp_pack (copy_module_expr x0) + | From.Parsetree.Pexp_open (x0, x1, x2) -> + To.Parsetree.Pexp_open + (copy_override_flag x0, copy_loc copy_longident x1, copy_expression x2) + | From.Parsetree.Pexp_extension x0 -> + To.Parsetree.Pexp_extension (copy_extension x0) + | From.Parsetree.Pexp_unreachable -> To.Parsetree.Pexp_unreachable + +and copy_direction_flag : + From.Asttypes.direction_flag -> To.Asttypes.direction_flag = function + | From.Asttypes.Upto -> To.Asttypes.Upto + | From.Asttypes.Downto -> To.Asttypes.Downto + +and copy_case : From.Parsetree.case -> To.Parsetree.case = + fun { From.Parsetree.pc_lhs; From.Parsetree.pc_guard; From.Parsetree.pc_rhs } -> + { + To.Parsetree.pc_lhs = copy_pattern pc_lhs; + To.Parsetree.pc_guard = copy_option copy_expression pc_guard; + To.Parsetree.pc_rhs = copy_expression pc_rhs; + } + +and copy_value_binding : + From.Parsetree.value_binding -> To.Parsetree.value_binding = + fun { + From.Parsetree.pvb_pat; + From.Parsetree.pvb_expr; + From.Parsetree.pvb_attributes; + From.Parsetree.pvb_loc; + } -> + { + To.Parsetree.pvb_pat = copy_pattern pvb_pat; + To.Parsetree.pvb_expr = copy_expression pvb_expr; + To.Parsetree.pvb_attributes = copy_attributes pvb_attributes; + To.Parsetree.pvb_loc = copy_location pvb_loc; + } + +and copy_pattern : From.Parsetree.pattern -> To.Parsetree.pattern = + fun { + From.Parsetree.ppat_desc; + From.Parsetree.ppat_loc; + From.Parsetree.ppat_attributes; + } -> + { + To.Parsetree.ppat_desc = copy_pattern_desc ppat_desc; + To.Parsetree.ppat_loc = copy_location ppat_loc; + To.Parsetree.ppat_attributes = copy_attributes ppat_attributes; + } + +and copy_pattern_desc : From.Parsetree.pattern_desc -> To.Parsetree.pattern_desc + = function + | From.Parsetree.Ppat_any -> To.Parsetree.Ppat_any + | From.Parsetree.Ppat_var x0 -> + To.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) + | From.Parsetree.Ppat_alias (x0, x1) -> + To.Parsetree.Ppat_alias (copy_pattern x0, copy_loc (fun x -> x) x1) + | From.Parsetree.Ppat_constant x0 -> + To.Parsetree.Ppat_constant (copy_constant x0) + | From.Parsetree.Ppat_interval (x0, x1) -> + To.Parsetree.Ppat_interval (copy_constant x0, copy_constant x1) + | From.Parsetree.Ppat_tuple x0 -> + To.Parsetree.Ppat_tuple (List.map copy_pattern x0) + | From.Parsetree.Ppat_construct (x0, x1) -> + To.Parsetree.Ppat_construct + (copy_loc copy_longident x0, copy_option copy_pattern x1) + | From.Parsetree.Ppat_variant (x0, x1) -> + To.Parsetree.Ppat_variant (copy_label x0, copy_option copy_pattern x1) + | From.Parsetree.Ppat_record (x0, x1) -> + To.Parsetree.Ppat_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_pattern x1)) + x0, + copy_closed_flag x1 ) + | From.Parsetree.Ppat_array x0 -> + To.Parsetree.Ppat_array (List.map copy_pattern x0) + | From.Parsetree.Ppat_or (x0, x1) -> + To.Parsetree.Ppat_or (copy_pattern x0, copy_pattern x1) + | From.Parsetree.Ppat_constraint (x0, x1) -> + To.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1) + | From.Parsetree.Ppat_type x0 -> + To.Parsetree.Ppat_type (copy_loc copy_longident x0) + | From.Parsetree.Ppat_lazy x0 -> To.Parsetree.Ppat_lazy (copy_pattern x0) + | From.Parsetree.Ppat_unpack x0 -> + To.Parsetree.Ppat_unpack (copy_loc (fun x -> x) x0) + | From.Parsetree.Ppat_exception x0 -> + To.Parsetree.Ppat_exception (copy_pattern x0) + | From.Parsetree.Ppat_extension x0 -> + To.Parsetree.Ppat_extension (copy_extension x0) + +and copy_core_type : From.Parsetree.core_type -> To.Parsetree.core_type = + fun { + From.Parsetree.ptyp_desc; + From.Parsetree.ptyp_loc; + From.Parsetree.ptyp_attributes; + } -> + { + To.Parsetree.ptyp_desc = copy_core_type_desc ptyp_desc; + To.Parsetree.ptyp_loc = copy_location ptyp_loc; + To.Parsetree.ptyp_attributes = copy_attributes ptyp_attributes; + } + +and copy_core_type_desc : + From.Parsetree.core_type_desc -> To.Parsetree.core_type_desc = function + | From.Parsetree.Ptyp_any -> To.Parsetree.Ptyp_any + | From.Parsetree.Ptyp_var x0 -> To.Parsetree.Ptyp_var x0 + | From.Parsetree.Ptyp_arrow (x0, x1, x2) -> + To.Parsetree.Ptyp_arrow + (copy_arg_label x0, copy_core_type x1, copy_core_type x2) + | From.Parsetree.Ptyp_tuple x0 -> + To.Parsetree.Ptyp_tuple (List.map copy_core_type x0) + | From.Parsetree.Ptyp_constr (x0, x1) -> + To.Parsetree.Ptyp_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Ptyp_object (x0, x1) -> + To.Parsetree.Ptyp_object + ( List.map + (fun x -> + let x0, x1, x2 = x in + (x0, copy_attributes x1, copy_core_type x2)) + x0, + copy_closed_flag x1 ) + | From.Parsetree.Ptyp_class (x0, x1) -> + To.Parsetree.Ptyp_class + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Ptyp_alias (x0, x1) -> + To.Parsetree.Ptyp_alias (copy_core_type x0, x1) + | From.Parsetree.Ptyp_variant (x0, x1, x2) -> + To.Parsetree.Ptyp_variant + ( List.map copy_row_field x0, + copy_closed_flag x1, + copy_option (fun x -> List.map copy_label x) x2 ) + | From.Parsetree.Ptyp_poly (x0, x1) -> + To.Parsetree.Ptyp_poly (List.map (fun x -> x) x0, copy_core_type x1) + | From.Parsetree.Ptyp_package x0 -> + To.Parsetree.Ptyp_package (copy_package_type x0) + | From.Parsetree.Ptyp_extension x0 -> + To.Parsetree.Ptyp_extension (copy_extension x0) + +and copy_package_type : From.Parsetree.package_type -> To.Parsetree.package_type + = + fun x -> + let x0, x1 = x in + ( copy_loc copy_longident x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_core_type x1)) + x1 ) + +and copy_row_field : From.Parsetree.row_field -> To.Parsetree.row_field = + function + | From.Parsetree.Rtag (x0, x1, x2, x3) -> + To.Parsetree.Rtag + ( copy_label x0, + copy_attributes x1, + copy_bool x2, + List.map copy_core_type x3 ) + | From.Parsetree.Rinherit x0 -> To.Parsetree.Rinherit (copy_core_type x0) + +and copy_attributes : From.Parsetree.attributes -> To.Parsetree.attributes = + fun x -> List.map copy_attribute x + +and copy_attribute : From.Parsetree.attribute -> To.Parsetree.attribute = + fun x -> + let x0, x1 = x in + (copy_loc (fun x -> x) x0, copy_payload x1) + +and copy_payload : From.Parsetree.payload -> To.Parsetree.payload = function + | From.Parsetree.PStr x0 -> To.Parsetree.PStr (copy_structure x0) + | From.Parsetree.PSig x0 -> To.Parsetree.PSig (copy_signature x0) + | From.Parsetree.PTyp x0 -> To.Parsetree.PTyp (copy_core_type x0) + | From.Parsetree.PPat (x0, x1) -> + To.Parsetree.PPat (copy_pattern x0, copy_option copy_expression x1) + +and copy_structure : From.Parsetree.structure -> To.Parsetree.structure = + fun x -> List.map copy_structure_item x + +and copy_structure_item : + From.Parsetree.structure_item -> To.Parsetree.structure_item = + fun { From.Parsetree.pstr_desc; From.Parsetree.pstr_loc } -> + { + To.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc; + To.Parsetree.pstr_loc = copy_location pstr_loc; + } + +and copy_structure_item_desc : + From.Parsetree.structure_item_desc -> To.Parsetree.structure_item_desc = + function + | From.Parsetree.Pstr_eval (x0, x1) -> + To.Parsetree.Pstr_eval (copy_expression x0, copy_attributes x1) + | From.Parsetree.Pstr_value (x0, x1) -> + To.Parsetree.Pstr_value (copy_rec_flag x0, List.map copy_value_binding x1) + | From.Parsetree.Pstr_primitive x0 -> + To.Parsetree.Pstr_primitive (copy_value_description x0) + | From.Parsetree.Pstr_type (x0, x1) -> + To.Parsetree.Pstr_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | From.Parsetree.Pstr_typext x0 -> + To.Parsetree.Pstr_typext (copy_type_extension x0) + | From.Parsetree.Pstr_exception x0 -> + To.Parsetree.Pstr_exception (copy_extension_constructor x0) + | From.Parsetree.Pstr_module x0 -> + To.Parsetree.Pstr_module (copy_module_binding x0) + | From.Parsetree.Pstr_recmodule x0 -> + To.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) + | From.Parsetree.Pstr_modtype x0 -> + To.Parsetree.Pstr_modtype (copy_module_type_declaration x0) + | From.Parsetree.Pstr_open x0 -> + To.Parsetree.Pstr_open (copy_open_description x0) + | From.Parsetree.Pstr_class x0 -> + To.Parsetree.Pstr_class (List.map copy_class_declaration x0) + | From.Parsetree.Pstr_class_type x0 -> + To.Parsetree.Pstr_class_type (List.map copy_class_type_declaration x0) + | From.Parsetree.Pstr_include x0 -> + To.Parsetree.Pstr_include (copy_include_declaration x0) + | From.Parsetree.Pstr_attribute x0 -> + To.Parsetree.Pstr_attribute (copy_attribute x0) + | From.Parsetree.Pstr_extension (x0, x1) -> + To.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1) + +and copy_include_declaration : + From.Parsetree.include_declaration -> To.Parsetree.include_declaration = + fun x -> copy_include_infos copy_module_expr x + +and copy_class_declaration : + From.Parsetree.class_declaration -> To.Parsetree.class_declaration = + fun x -> copy_class_infos copy_class_expr x + +and copy_class_expr : From.Parsetree.class_expr -> To.Parsetree.class_expr = + fun { + From.Parsetree.pcl_desc; + From.Parsetree.pcl_loc; + From.Parsetree.pcl_attributes; + } -> + { + To.Parsetree.pcl_desc = copy_class_expr_desc pcl_desc; + To.Parsetree.pcl_loc = copy_location pcl_loc; + To.Parsetree.pcl_attributes = copy_attributes pcl_attributes; + } + +and copy_class_expr_desc : + From.Parsetree.class_expr_desc -> To.Parsetree.class_expr_desc = function + | From.Parsetree.Pcl_constr (x0, x1) -> + To.Parsetree.Pcl_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Pcl_structure x0 -> + To.Parsetree.Pcl_structure (copy_class_structure x0) + | From.Parsetree.Pcl_fun (x0, x1, x2, x3) -> + To.Parsetree.Pcl_fun + ( copy_arg_label x0, + copy_option copy_expression x1, + copy_pattern x2, + copy_class_expr x3 ) + | From.Parsetree.Pcl_apply (x0, x1) -> + To.Parsetree.Pcl_apply + ( copy_class_expr x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | From.Parsetree.Pcl_let (x0, x1, x2) -> + To.Parsetree.Pcl_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_class_expr x2) + | From.Parsetree.Pcl_constraint (x0, x1) -> + To.Parsetree.Pcl_constraint (copy_class_expr x0, copy_class_type x1) + | From.Parsetree.Pcl_extension x0 -> + To.Parsetree.Pcl_extension (copy_extension x0) + +and copy_class_structure : + From.Parsetree.class_structure -> To.Parsetree.class_structure = + fun { From.Parsetree.pcstr_self; From.Parsetree.pcstr_fields } -> + { + To.Parsetree.pcstr_self = copy_pattern pcstr_self; + To.Parsetree.pcstr_fields = List.map copy_class_field pcstr_fields; + } + +and copy_class_field : From.Parsetree.class_field -> To.Parsetree.class_field = + fun { + From.Parsetree.pcf_desc; + From.Parsetree.pcf_loc; + From.Parsetree.pcf_attributes; + } -> + { + To.Parsetree.pcf_desc = copy_class_field_desc pcf_desc; + To.Parsetree.pcf_loc = copy_location pcf_loc; + To.Parsetree.pcf_attributes = copy_attributes pcf_attributes; + } + +and copy_class_field_desc : + From.Parsetree.class_field_desc -> To.Parsetree.class_field_desc = function + | From.Parsetree.Pcf_inherit (x0, x1, x2) -> + To.Parsetree.Pcf_inherit + (copy_override_flag x0, copy_class_expr x1, copy_option (fun x -> x) x2) + | From.Parsetree.Pcf_val x0 -> + To.Parsetree.Pcf_val + (let x0, x1, x2 = x0 in + ( copy_loc (fun x -> x) x0, + copy_mutable_flag x1, + copy_class_field_kind x2 )) + | From.Parsetree.Pcf_method x0 -> + To.Parsetree.Pcf_method + (let x0, x1, x2 = x0 in + ( copy_loc (fun x -> x) x0, + copy_private_flag x1, + copy_class_field_kind x2 )) + | From.Parsetree.Pcf_constraint x0 -> + To.Parsetree.Pcf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | From.Parsetree.Pcf_initializer x0 -> + To.Parsetree.Pcf_initializer (copy_expression x0) + | From.Parsetree.Pcf_attribute x0 -> + To.Parsetree.Pcf_attribute (copy_attribute x0) + | From.Parsetree.Pcf_extension x0 -> + To.Parsetree.Pcf_extension (copy_extension x0) + +and copy_class_field_kind : + From.Parsetree.class_field_kind -> To.Parsetree.class_field_kind = function + | From.Parsetree.Cfk_virtual x0 -> + To.Parsetree.Cfk_virtual (copy_core_type x0) + | From.Parsetree.Cfk_concrete (x0, x1) -> + To.Parsetree.Cfk_concrete (copy_override_flag x0, copy_expression x1) + +and copy_module_binding : + From.Parsetree.module_binding -> To.Parsetree.module_binding = + fun { + From.Parsetree.pmb_name; + From.Parsetree.pmb_expr; + From.Parsetree.pmb_attributes; + From.Parsetree.pmb_loc; + } -> + { + To.Parsetree.pmb_name = copy_loc (fun x -> x) pmb_name; + To.Parsetree.pmb_expr = copy_module_expr pmb_expr; + To.Parsetree.pmb_attributes = copy_attributes pmb_attributes; + To.Parsetree.pmb_loc = copy_location pmb_loc; + } + +and copy_module_expr : From.Parsetree.module_expr -> To.Parsetree.module_expr = + fun { + From.Parsetree.pmod_desc; + From.Parsetree.pmod_loc; + From.Parsetree.pmod_attributes; + } -> + { + To.Parsetree.pmod_desc = copy_module_expr_desc pmod_desc; + To.Parsetree.pmod_loc = copy_location pmod_loc; + To.Parsetree.pmod_attributes = copy_attributes pmod_attributes; + } + +and copy_module_expr_desc : + From.Parsetree.module_expr_desc -> To.Parsetree.module_expr_desc = function + | From.Parsetree.Pmod_ident x0 -> + To.Parsetree.Pmod_ident (copy_loc copy_longident x0) + | From.Parsetree.Pmod_structure x0 -> + To.Parsetree.Pmod_structure (copy_structure x0) + | From.Parsetree.Pmod_functor (x0, x1, x2) -> + To.Parsetree.Pmod_functor + ( copy_loc (fun x -> x) x0, + copy_option copy_module_type x1, + copy_module_expr x2 ) + | From.Parsetree.Pmod_apply (x0, x1) -> + To.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) + | From.Parsetree.Pmod_constraint (x0, x1) -> + To.Parsetree.Pmod_constraint (copy_module_expr x0, copy_module_type x1) + | From.Parsetree.Pmod_unpack x0 -> + To.Parsetree.Pmod_unpack (copy_expression x0) + | From.Parsetree.Pmod_extension x0 -> + To.Parsetree.Pmod_extension (copy_extension x0) + +and copy_module_type : From.Parsetree.module_type -> To.Parsetree.module_type = + fun { + From.Parsetree.pmty_desc; + From.Parsetree.pmty_loc; + From.Parsetree.pmty_attributes; + } -> + { + To.Parsetree.pmty_desc = copy_module_type_desc pmty_desc; + To.Parsetree.pmty_loc = copy_location pmty_loc; + To.Parsetree.pmty_attributes = copy_attributes pmty_attributes; + } + +and copy_module_type_desc : + From.Parsetree.module_type_desc -> To.Parsetree.module_type_desc = function + | From.Parsetree.Pmty_ident x0 -> + To.Parsetree.Pmty_ident (copy_loc copy_longident x0) + | From.Parsetree.Pmty_signature x0 -> + To.Parsetree.Pmty_signature (copy_signature x0) + | From.Parsetree.Pmty_functor (x0, x1, x2) -> + To.Parsetree.Pmty_functor + ( copy_loc (fun x -> x) x0, + copy_option copy_module_type x1, + copy_module_type x2 ) + | From.Parsetree.Pmty_with (x0, x1) -> + To.Parsetree.Pmty_with + (copy_module_type x0, List.map copy_with_constraint x1) + | From.Parsetree.Pmty_typeof x0 -> + To.Parsetree.Pmty_typeof (copy_module_expr x0) + | From.Parsetree.Pmty_extension x0 -> + To.Parsetree.Pmty_extension (copy_extension x0) + | From.Parsetree.Pmty_alias x0 -> + To.Parsetree.Pmty_alias (copy_loc copy_longident x0) + +and copy_with_constraint : + From.Parsetree.with_constraint -> To.Parsetree.with_constraint = function + | From.Parsetree.Pwith_type (x0, x1) -> + To.Parsetree.Pwith_type + (copy_loc copy_longident x0, copy_type_declaration x1) + | From.Parsetree.Pwith_module (x0, x1) -> + To.Parsetree.Pwith_module + (copy_loc copy_longident x0, copy_loc copy_longident x1) + | From.Parsetree.Pwith_typesubst x0 -> + To.Parsetree.Pwith_typesubst (copy_type_declaration x0) + | From.Parsetree.Pwith_modsubst (x0, x1) -> + To.Parsetree.Pwith_modsubst + (copy_loc (fun x -> x) x0, copy_loc copy_longident x1) + +and copy_signature : From.Parsetree.signature -> To.Parsetree.signature = + fun x -> List.map copy_signature_item x + +and copy_signature_item : + From.Parsetree.signature_item -> To.Parsetree.signature_item = + fun { From.Parsetree.psig_desc; From.Parsetree.psig_loc } -> + { + To.Parsetree.psig_desc = copy_signature_item_desc psig_desc; + To.Parsetree.psig_loc = copy_location psig_loc; + } + +and copy_signature_item_desc : + From.Parsetree.signature_item_desc -> To.Parsetree.signature_item_desc = + function + | From.Parsetree.Psig_value x0 -> + To.Parsetree.Psig_value (copy_value_description x0) + | From.Parsetree.Psig_type (x0, x1) -> + To.Parsetree.Psig_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | From.Parsetree.Psig_typext x0 -> + To.Parsetree.Psig_typext (copy_type_extension x0) + | From.Parsetree.Psig_exception x0 -> + To.Parsetree.Psig_exception (copy_extension_constructor x0) + | From.Parsetree.Psig_module x0 -> + To.Parsetree.Psig_module (copy_module_declaration x0) + | From.Parsetree.Psig_recmodule x0 -> + To.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) + | From.Parsetree.Psig_modtype x0 -> + To.Parsetree.Psig_modtype (copy_module_type_declaration x0) + | From.Parsetree.Psig_open x0 -> + To.Parsetree.Psig_open (copy_open_description x0) + | From.Parsetree.Psig_include x0 -> + To.Parsetree.Psig_include (copy_include_description x0) + | From.Parsetree.Psig_class x0 -> + To.Parsetree.Psig_class (List.map copy_class_description x0) + | From.Parsetree.Psig_class_type x0 -> + To.Parsetree.Psig_class_type (List.map copy_class_type_declaration x0) + | From.Parsetree.Psig_attribute x0 -> + To.Parsetree.Psig_attribute (copy_attribute x0) + | From.Parsetree.Psig_extension (x0, x1) -> + To.Parsetree.Psig_extension (copy_extension x0, copy_attributes x1) + +and copy_class_type_declaration : + From.Parsetree.class_type_declaration -> To.Parsetree.class_type_declaration + = + fun x -> copy_class_infos copy_class_type x + +and copy_class_description : + From.Parsetree.class_description -> To.Parsetree.class_description = + fun x -> copy_class_infos copy_class_type x + +and copy_class_type : From.Parsetree.class_type -> To.Parsetree.class_type = + fun { + From.Parsetree.pcty_desc; + From.Parsetree.pcty_loc; + From.Parsetree.pcty_attributes; + } -> + { + To.Parsetree.pcty_desc = copy_class_type_desc pcty_desc; + To.Parsetree.pcty_loc = copy_location pcty_loc; + To.Parsetree.pcty_attributes = copy_attributes pcty_attributes; + } + +and copy_class_type_desc : + From.Parsetree.class_type_desc -> To.Parsetree.class_type_desc = function + | From.Parsetree.Pcty_constr (x0, x1) -> + To.Parsetree.Pcty_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Pcty_signature x0 -> + To.Parsetree.Pcty_signature (copy_class_signature x0) + | From.Parsetree.Pcty_arrow (x0, x1, x2) -> + To.Parsetree.Pcty_arrow + (copy_arg_label x0, copy_core_type x1, copy_class_type x2) + | From.Parsetree.Pcty_extension x0 -> + To.Parsetree.Pcty_extension (copy_extension x0) + +and copy_class_signature : + From.Parsetree.class_signature -> To.Parsetree.class_signature = + fun { From.Parsetree.pcsig_self; From.Parsetree.pcsig_fields } -> + { + To.Parsetree.pcsig_self = copy_core_type pcsig_self; + To.Parsetree.pcsig_fields = List.map copy_class_type_field pcsig_fields; + } + +and copy_class_type_field : + From.Parsetree.class_type_field -> To.Parsetree.class_type_field = + fun { + From.Parsetree.pctf_desc; + From.Parsetree.pctf_loc; + From.Parsetree.pctf_attributes; + } -> + { + To.Parsetree.pctf_desc = copy_class_type_field_desc pctf_desc; + To.Parsetree.pctf_loc = copy_location pctf_loc; + To.Parsetree.pctf_attributes = copy_attributes pctf_attributes; + } + +and copy_class_type_field_desc : + From.Parsetree.class_type_field_desc -> To.Parsetree.class_type_field_desc = + function + | From.Parsetree.Pctf_inherit x0 -> + To.Parsetree.Pctf_inherit (copy_class_type x0) + | From.Parsetree.Pctf_val x0 -> + To.Parsetree.Pctf_val + (let x0, x1, x2, x3 = x0 in + (x0, copy_mutable_flag x1, copy_virtual_flag x2, copy_core_type x3)) + | From.Parsetree.Pctf_method x0 -> + To.Parsetree.Pctf_method + (let x0, x1, x2, x3 = x0 in + (x0, copy_private_flag x1, copy_virtual_flag x2, copy_core_type x3)) + | From.Parsetree.Pctf_constraint x0 -> + To.Parsetree.Pctf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | From.Parsetree.Pctf_attribute x0 -> + To.Parsetree.Pctf_attribute (copy_attribute x0) + | From.Parsetree.Pctf_extension x0 -> + To.Parsetree.Pctf_extension (copy_extension x0) + +and copy_extension : From.Parsetree.extension -> To.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 From.Parsetree.class_infos -> + 'g0 To.Parsetree.class_infos = + fun f0 + { + From.Parsetree.pci_virt; + From.Parsetree.pci_params; + From.Parsetree.pci_name; + From.Parsetree.pci_expr; + From.Parsetree.pci_loc; + From.Parsetree.pci_attributes; + } -> + { + To.Parsetree.pci_virt = copy_virtual_flag pci_virt; + To.Parsetree.pci_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + pci_params; + To.Parsetree.pci_name = copy_loc (fun x -> x) pci_name; + To.Parsetree.pci_expr = f0 pci_expr; + To.Parsetree.pci_loc = copy_location pci_loc; + To.Parsetree.pci_attributes = copy_attributes pci_attributes; + } + +and copy_virtual_flag : From.Asttypes.virtual_flag -> To.Asttypes.virtual_flag = + function + | From.Asttypes.Virtual -> To.Asttypes.Virtual + | From.Asttypes.Concrete -> To.Asttypes.Concrete + +and copy_include_description : + From.Parsetree.include_description -> To.Parsetree.include_description = + fun x -> copy_include_infos copy_module_type x + +and copy_include_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 From.Parsetree.include_infos -> + 'g0 To.Parsetree.include_infos = + fun f0 + { + From.Parsetree.pincl_mod; + From.Parsetree.pincl_loc; + From.Parsetree.pincl_attributes; + } -> + { + To.Parsetree.pincl_mod = f0 pincl_mod; + To.Parsetree.pincl_loc = copy_location pincl_loc; + To.Parsetree.pincl_attributes = copy_attributes pincl_attributes; + } + +and copy_open_description : + From.Parsetree.open_description -> To.Parsetree.open_description = + fun { + From.Parsetree.popen_lid; + From.Parsetree.popen_override; + From.Parsetree.popen_loc; + From.Parsetree.popen_attributes; + } -> + { + To.Parsetree.popen_lid = copy_loc copy_longident popen_lid; + To.Parsetree.popen_override = copy_override_flag popen_override; + To.Parsetree.popen_loc = copy_location popen_loc; + To.Parsetree.popen_attributes = copy_attributes popen_attributes; + } + +and copy_override_flag : + From.Asttypes.override_flag -> To.Asttypes.override_flag = function + | From.Asttypes.Override -> To.Asttypes.Override + | From.Asttypes.Fresh -> To.Asttypes.Fresh + +and copy_module_type_declaration : + From.Parsetree.module_type_declaration -> + To.Parsetree.module_type_declaration = + fun { + From.Parsetree.pmtd_name; + From.Parsetree.pmtd_type; + From.Parsetree.pmtd_attributes; + From.Parsetree.pmtd_loc; + } -> + { + To.Parsetree.pmtd_name = copy_loc (fun x -> x) pmtd_name; + To.Parsetree.pmtd_type = copy_option copy_module_type pmtd_type; + To.Parsetree.pmtd_attributes = copy_attributes pmtd_attributes; + To.Parsetree.pmtd_loc = copy_location pmtd_loc; + } + +and copy_module_declaration : + From.Parsetree.module_declaration -> To.Parsetree.module_declaration = + fun { + From.Parsetree.pmd_name; + From.Parsetree.pmd_type; + From.Parsetree.pmd_attributes; + From.Parsetree.pmd_loc; + } -> + { + To.Parsetree.pmd_name = copy_loc (fun x -> x) pmd_name; + To.Parsetree.pmd_type = copy_module_type pmd_type; + To.Parsetree.pmd_attributes = copy_attributes pmd_attributes; + To.Parsetree.pmd_loc = copy_location pmd_loc; + } + +and copy_type_extension : + From.Parsetree.type_extension -> To.Parsetree.type_extension = + fun { + From.Parsetree.ptyext_path; + From.Parsetree.ptyext_params; + From.Parsetree.ptyext_constructors; + From.Parsetree.ptyext_private; + From.Parsetree.ptyext_attributes; + } -> + { + To.Parsetree.ptyext_path = copy_loc copy_longident ptyext_path; + To.Parsetree.ptyext_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptyext_params; + To.Parsetree.ptyext_constructors = + List.map copy_extension_constructor ptyext_constructors; + To.Parsetree.ptyext_private = copy_private_flag ptyext_private; + To.Parsetree.ptyext_attributes = copy_attributes ptyext_attributes; + } + +and copy_extension_constructor : + From.Parsetree.extension_constructor -> To.Parsetree.extension_constructor = + fun { + From.Parsetree.pext_name; + From.Parsetree.pext_kind; + From.Parsetree.pext_loc; + From.Parsetree.pext_attributes; + } -> + { + To.Parsetree.pext_name = copy_loc (fun x -> x) pext_name; + To.Parsetree.pext_kind = copy_extension_constructor_kind pext_kind; + To.Parsetree.pext_loc = copy_location pext_loc; + To.Parsetree.pext_attributes = copy_attributes pext_attributes; + } + +and copy_extension_constructor_kind : + From.Parsetree.extension_constructor_kind -> + To.Parsetree.extension_constructor_kind = function + | From.Parsetree.Pext_decl (x0, x1) -> + To.Parsetree.Pext_decl + (copy_constructor_arguments x0, copy_option copy_core_type x1) + | From.Parsetree.Pext_rebind x0 -> + To.Parsetree.Pext_rebind (copy_loc copy_longident x0) + +and copy_type_declaration : + From.Parsetree.type_declaration -> To.Parsetree.type_declaration = + fun { + From.Parsetree.ptype_name; + From.Parsetree.ptype_params; + From.Parsetree.ptype_cstrs; + From.Parsetree.ptype_kind; + From.Parsetree.ptype_private; + From.Parsetree.ptype_manifest; + From.Parsetree.ptype_attributes; + From.Parsetree.ptype_loc; + } -> + { + To.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name; + To.Parsetree.ptype_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptype_params; + To.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; + To.Parsetree.ptype_kind = copy_type_kind ptype_kind; + To.Parsetree.ptype_private = copy_private_flag ptype_private; + To.Parsetree.ptype_manifest = copy_option copy_core_type ptype_manifest; + To.Parsetree.ptype_attributes = copy_attributes ptype_attributes; + To.Parsetree.ptype_loc = copy_location ptype_loc; + } + +and copy_private_flag : From.Asttypes.private_flag -> To.Asttypes.private_flag = + function + | From.Asttypes.Private -> To.Asttypes.Private + | From.Asttypes.Public -> To.Asttypes.Public + +and copy_type_kind : From.Parsetree.type_kind -> To.Parsetree.type_kind = + function + | From.Parsetree.Ptype_abstract -> To.Parsetree.Ptype_abstract + | From.Parsetree.Ptype_variant x0 -> + To.Parsetree.Ptype_variant (List.map copy_constructor_declaration x0) + | From.Parsetree.Ptype_record x0 -> + To.Parsetree.Ptype_record (List.map copy_label_declaration x0) + | From.Parsetree.Ptype_open -> To.Parsetree.Ptype_open + +and copy_constructor_declaration : + From.Parsetree.constructor_declaration -> + To.Parsetree.constructor_declaration = + fun { + From.Parsetree.pcd_name; + From.Parsetree.pcd_args; + From.Parsetree.pcd_res; + From.Parsetree.pcd_loc; + From.Parsetree.pcd_attributes; + } -> + { + To.Parsetree.pcd_name = copy_loc (fun x -> x) pcd_name; + To.Parsetree.pcd_args = copy_constructor_arguments pcd_args; + To.Parsetree.pcd_res = copy_option copy_core_type pcd_res; + To.Parsetree.pcd_loc = copy_location pcd_loc; + To.Parsetree.pcd_attributes = copy_attributes pcd_attributes; + } + +and copy_constructor_arguments : + From.Parsetree.constructor_arguments -> To.Parsetree.constructor_arguments = + function + | From.Parsetree.Pcstr_tuple x0 -> + To.Parsetree.Pcstr_tuple (List.map copy_core_type x0) + | From.Parsetree.Pcstr_record x0 -> + To.Parsetree.Pcstr_record (List.map copy_label_declaration x0) + +and copy_label_declaration : + From.Parsetree.label_declaration -> To.Parsetree.label_declaration = + fun { + From.Parsetree.pld_name; + From.Parsetree.pld_mutable; + From.Parsetree.pld_type; + From.Parsetree.pld_loc; + From.Parsetree.pld_attributes; + } -> + { + To.Parsetree.pld_name = copy_loc (fun x -> x) pld_name; + To.Parsetree.pld_mutable = copy_mutable_flag pld_mutable; + To.Parsetree.pld_type = copy_core_type pld_type; + To.Parsetree.pld_loc = copy_location pld_loc; + To.Parsetree.pld_attributes = copy_attributes pld_attributes; + } + +and copy_mutable_flag : From.Asttypes.mutable_flag -> To.Asttypes.mutable_flag = + function + | From.Asttypes.Immutable -> To.Asttypes.Immutable + | From.Asttypes.Mutable -> To.Asttypes.Mutable + +and copy_variance : From.Asttypes.variance -> To.Asttypes.variance = function + | From.Asttypes.Covariant -> To.Asttypes.Covariant + | From.Asttypes.Contravariant -> To.Asttypes.Contravariant + | From.Asttypes.Invariant -> To.Asttypes.Invariant + +and copy_value_description : + From.Parsetree.value_description -> To.Parsetree.value_description = + fun { + From.Parsetree.pval_name; + From.Parsetree.pval_type; + From.Parsetree.pval_prim; + From.Parsetree.pval_attributes; + From.Parsetree.pval_loc; + } -> + { + To.Parsetree.pval_name = copy_loc (fun x -> x) pval_name; + To.Parsetree.pval_type = copy_core_type pval_type; + To.Parsetree.pval_prim = List.map (fun x -> x) pval_prim; + To.Parsetree.pval_attributes = copy_attributes pval_attributes; + To.Parsetree.pval_loc = copy_location pval_loc; + } + +and copy_arg_label : From.Asttypes.arg_label -> To.Asttypes.arg_label = function + | From.Asttypes.Nolabel -> To.Asttypes.Nolabel + | From.Asttypes.Labelled x0 -> To.Asttypes.Labelled x0 + | From.Asttypes.Optional x0 -> To.Asttypes.Optional x0 + +and copy_closed_flag : From.Asttypes.closed_flag -> To.Asttypes.closed_flag = + function + | From.Asttypes.Closed -> To.Asttypes.Closed + | From.Asttypes.Open -> To.Asttypes.Open + +and copy_label : From.Asttypes.label -> To.Asttypes.label = fun x -> x + +and copy_rec_flag : From.Asttypes.rec_flag -> To.Asttypes.rec_flag = function + | From.Asttypes.Nonrecursive -> To.Asttypes.Nonrecursive + | From.Asttypes.Recursive -> To.Asttypes.Recursive + +and copy_constant : From.Parsetree.constant -> To.Parsetree.constant = function + | From.Parsetree.Pconst_integer (x0, x1) -> + To.Parsetree.Pconst_integer (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pconst_char x0 -> To.Parsetree.Pconst_char x0 + | From.Parsetree.Pconst_string (x0, x1) -> + To.Parsetree.Pconst_string (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pconst_float (x0, x1) -> + To.Parsetree.Pconst_float (x0, copy_option (fun x -> x) x1) + +and copy_option : 'f0 'g0. ('f0 -> 'g0) -> 'f0 option -> 'g0 option = + fun f0 -> function None -> None | Some x0 -> Some (f0 x0) + +and copy_longident : Longident.t -> Longident.t = fun x -> x + +and copy_loc : + 'f0 'g0. ('f0 -> 'g0) -> 'f0 From.Asttypes.loc -> 'g0 To.Asttypes.loc = + fun f0 { From.Asttypes.txt; From.Asttypes.loc } -> + { To.Asttypes.txt = f0 txt; To.Asttypes.loc = copy_location loc } + +and copy_location : Location.t -> Location.t = fun x -> x + +and copy_bool : bool -> bool = function false -> false | true -> true + +let rec copy_toplevel_phrase : + From.Parsetree.toplevel_phrase -> To.Parsetree.toplevel_phrase = function + | From.Parsetree.Ptop_def x0 -> To.Parsetree.Ptop_def (copy_structure x0) + | From.Parsetree.Ptop_dir (x0, x1) -> + To.Parsetree.Ptop_dir (x0, copy_directive_argument x1) + +and copy_directive_argument : + From.Parsetree.directive_argument -> To.Parsetree.directive_argument = + function + | From.Parsetree.Pdir_none -> To.Parsetree.Pdir_none + | From.Parsetree.Pdir_string x0 -> To.Parsetree.Pdir_string x0 + | From.Parsetree.Pdir_int (x0, x1) -> + To.Parsetree.Pdir_int (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pdir_ident x0 -> To.Parsetree.Pdir_ident (copy_longident x0) + | From.Parsetree.Pdir_bool x0 -> To.Parsetree.Pdir_bool (copy_bool x0) + +let copy_cases x = List.map copy_case x + +let copy_pat = copy_pattern + +let copy_expr = copy_expression + +let copy_typ = copy_core_type diff -Nru ppxlib-0.15.0/astlib/migrate_404_403.ml ppxlib-0.24.0/astlib/migrate_404_403.ml --- ppxlib-0.15.0/astlib/migrate_404_403.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/migrate_404_403.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1008 @@ +(**************************************************************************) +(* *) +(* OCaml Migrate Parsetree *) +(* *) +(* Frédéric Bour *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2017 Institut National de Recherche en Informatique et *) +(* en Automatique (INRIA). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module From = Ast_404 +module To = Ast_403 + +let from_loc { Location.txt = _; loc } = loc + +let migration_error loc missing_feature = + Location.raise_errorf ~loc + "migration error: %s is not supported before OCaml 4.04" missing_feature + +let rec copy_expression : From.Parsetree.expression -> To.Parsetree.expression = + fun { + From.Parsetree.pexp_desc; + From.Parsetree.pexp_loc; + From.Parsetree.pexp_attributes; + } -> + { + To.Parsetree.pexp_desc = copy_expression_desc pexp_loc pexp_desc; + To.Parsetree.pexp_loc = copy_location pexp_loc; + To.Parsetree.pexp_attributes = copy_attributes pexp_attributes; + } + +and copy_expression_desc loc : + From.Parsetree.expression_desc -> To.Parsetree.expression_desc = function + | From.Parsetree.Pexp_ident x0 -> + To.Parsetree.Pexp_ident (copy_loc copy_longident x0) + | From.Parsetree.Pexp_constant x0 -> + To.Parsetree.Pexp_constant (copy_constant x0) + | From.Parsetree.Pexp_let (x0, x1, x2) -> + To.Parsetree.Pexp_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_expression x2) + | From.Parsetree.Pexp_function x0 -> + To.Parsetree.Pexp_function (List.map copy_case x0) + | From.Parsetree.Pexp_fun (x0, x1, x2, x3) -> + To.Parsetree.Pexp_fun + ( copy_arg_label x0, + copy_option copy_expression x1, + copy_pattern x2, + copy_expression x3 ) + | From.Parsetree.Pexp_apply (x0, x1) -> + To.Parsetree.Pexp_apply + ( copy_expression x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | From.Parsetree.Pexp_match (x0, x1) -> + To.Parsetree.Pexp_match (copy_expression x0, List.map copy_case x1) + | From.Parsetree.Pexp_try (x0, x1) -> + To.Parsetree.Pexp_try (copy_expression x0, List.map copy_case x1) + | From.Parsetree.Pexp_tuple x0 -> + To.Parsetree.Pexp_tuple (List.map copy_expression x0) + | From.Parsetree.Pexp_construct (x0, x1) -> + To.Parsetree.Pexp_construct + (copy_loc copy_longident x0, copy_option copy_expression x1) + | From.Parsetree.Pexp_variant (x0, x1) -> + To.Parsetree.Pexp_variant (copy_label x0, copy_option copy_expression x1) + | From.Parsetree.Pexp_record (x0, x1) -> + To.Parsetree.Pexp_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_expression x1)) + x0, + copy_option copy_expression x1 ) + | From.Parsetree.Pexp_field (x0, x1) -> + To.Parsetree.Pexp_field (copy_expression x0, copy_loc copy_longident x1) + | From.Parsetree.Pexp_setfield (x0, x1, x2) -> + To.Parsetree.Pexp_setfield + (copy_expression x0, copy_loc copy_longident x1, copy_expression x2) + | From.Parsetree.Pexp_array x0 -> + To.Parsetree.Pexp_array (List.map copy_expression x0) + | From.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> + To.Parsetree.Pexp_ifthenelse + (copy_expression x0, copy_expression x1, copy_option copy_expression x2) + | From.Parsetree.Pexp_sequence (x0, x1) -> + To.Parsetree.Pexp_sequence (copy_expression x0, copy_expression x1) + | From.Parsetree.Pexp_while (x0, x1) -> + To.Parsetree.Pexp_while (copy_expression x0, copy_expression x1) + | From.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> + To.Parsetree.Pexp_for + ( copy_pattern x0, + copy_expression x1, + copy_expression x2, + copy_direction_flag x3, + copy_expression x4 ) + | From.Parsetree.Pexp_constraint (x0, x1) -> + To.Parsetree.Pexp_constraint (copy_expression x0, copy_core_type x1) + | From.Parsetree.Pexp_coerce (x0, x1, x2) -> + To.Parsetree.Pexp_coerce + (copy_expression x0, copy_option copy_core_type x1, copy_core_type x2) + | From.Parsetree.Pexp_send (x0, x1) -> + To.Parsetree.Pexp_send (copy_expression x0, x1) + | From.Parsetree.Pexp_new x0 -> + To.Parsetree.Pexp_new (copy_loc copy_longident x0) + | From.Parsetree.Pexp_setinstvar (x0, x1) -> + To.Parsetree.Pexp_setinstvar (copy_loc (fun x -> x) x0, copy_expression x1) + | From.Parsetree.Pexp_override x0 -> + To.Parsetree.Pexp_override + (List.map + (fun x -> + let x0, x1 = x in + (copy_loc (fun x -> x) x0, copy_expression x1)) + x0) + | From.Parsetree.Pexp_letmodule (x0, x1, x2) -> + To.Parsetree.Pexp_letmodule + (copy_loc (fun x -> x) x0, copy_module_expr x1, copy_expression x2) + | From.Parsetree.Pexp_letexception _ -> migration_error loc "local exceptions" + | From.Parsetree.Pexp_assert x0 -> + To.Parsetree.Pexp_assert (copy_expression x0) + | From.Parsetree.Pexp_lazy x0 -> To.Parsetree.Pexp_lazy (copy_expression x0) + | From.Parsetree.Pexp_poly (x0, x1) -> + To.Parsetree.Pexp_poly (copy_expression x0, copy_option copy_core_type x1) + | From.Parsetree.Pexp_object x0 -> + To.Parsetree.Pexp_object (copy_class_structure x0) + | From.Parsetree.Pexp_newtype (x0, x1) -> + To.Parsetree.Pexp_newtype (x0, copy_expression x1) + | From.Parsetree.Pexp_pack x0 -> To.Parsetree.Pexp_pack (copy_module_expr x0) + | From.Parsetree.Pexp_open (x0, x1, x2) -> + To.Parsetree.Pexp_open + (copy_override_flag x0, copy_loc copy_longident x1, copy_expression x2) + | From.Parsetree.Pexp_extension x0 -> + To.Parsetree.Pexp_extension (copy_extension x0) + | From.Parsetree.Pexp_unreachable -> To.Parsetree.Pexp_unreachable + +and copy_direction_flag : + From.Asttypes.direction_flag -> To.Asttypes.direction_flag = function + | From.Asttypes.Upto -> To.Asttypes.Upto + | From.Asttypes.Downto -> To.Asttypes.Downto + +and copy_case : From.Parsetree.case -> To.Parsetree.case = + fun { From.Parsetree.pc_lhs; From.Parsetree.pc_guard; From.Parsetree.pc_rhs } -> + { + To.Parsetree.pc_lhs = copy_pattern pc_lhs; + To.Parsetree.pc_guard = copy_option copy_expression pc_guard; + To.Parsetree.pc_rhs = copy_expression pc_rhs; + } + +and copy_value_binding : + From.Parsetree.value_binding -> To.Parsetree.value_binding = + fun { + From.Parsetree.pvb_pat; + From.Parsetree.pvb_expr; + From.Parsetree.pvb_attributes; + From.Parsetree.pvb_loc; + } -> + { + To.Parsetree.pvb_pat = copy_pattern pvb_pat; + To.Parsetree.pvb_expr = copy_expression pvb_expr; + To.Parsetree.pvb_attributes = copy_attributes pvb_attributes; + To.Parsetree.pvb_loc = copy_location pvb_loc; + } + +and copy_pattern : From.Parsetree.pattern -> To.Parsetree.pattern = + fun { + From.Parsetree.ppat_desc; + From.Parsetree.ppat_loc; + From.Parsetree.ppat_attributes; + } -> + { + To.Parsetree.ppat_desc = copy_pattern_desc ppat_loc ppat_desc; + To.Parsetree.ppat_loc = copy_location ppat_loc; + To.Parsetree.ppat_attributes = copy_attributes ppat_attributes; + } + +and copy_pattern_desc loc : + From.Parsetree.pattern_desc -> To.Parsetree.pattern_desc = function + | From.Parsetree.Ppat_any -> To.Parsetree.Ppat_any + | From.Parsetree.Ppat_var x0 -> + To.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) + | From.Parsetree.Ppat_alias (x0, x1) -> + To.Parsetree.Ppat_alias (copy_pattern x0, copy_loc (fun x -> x) x1) + | From.Parsetree.Ppat_constant x0 -> + To.Parsetree.Ppat_constant (copy_constant x0) + | From.Parsetree.Ppat_interval (x0, x1) -> + To.Parsetree.Ppat_interval (copy_constant x0, copy_constant x1) + | From.Parsetree.Ppat_tuple x0 -> + To.Parsetree.Ppat_tuple (List.map copy_pattern x0) + | From.Parsetree.Ppat_construct (x0, x1) -> + To.Parsetree.Ppat_construct + (copy_loc copy_longident x0, copy_option copy_pattern x1) + | From.Parsetree.Ppat_variant (x0, x1) -> + To.Parsetree.Ppat_variant (copy_label x0, copy_option copy_pattern x1) + | From.Parsetree.Ppat_record (x0, x1) -> + To.Parsetree.Ppat_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_pattern x1)) + x0, + copy_closed_flag x1 ) + | From.Parsetree.Ppat_array x0 -> + To.Parsetree.Ppat_array (List.map copy_pattern x0) + | From.Parsetree.Ppat_or (x0, x1) -> + To.Parsetree.Ppat_or (copy_pattern x0, copy_pattern x1) + | From.Parsetree.Ppat_constraint (x0, x1) -> + To.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1) + | From.Parsetree.Ppat_type x0 -> + To.Parsetree.Ppat_type (copy_loc copy_longident x0) + | From.Parsetree.Ppat_lazy x0 -> To.Parsetree.Ppat_lazy (copy_pattern x0) + | From.Parsetree.Ppat_unpack x0 -> + To.Parsetree.Ppat_unpack (copy_loc (fun x -> x) x0) + | From.Parsetree.Ppat_exception x0 -> + To.Parsetree.Ppat_exception (copy_pattern x0) + | From.Parsetree.Ppat_extension x0 -> + To.Parsetree.Ppat_extension (copy_extension x0) + | From.Parsetree.Ppat_open _ -> migration_error loc "module open in patterns" + +and copy_core_type : From.Parsetree.core_type -> To.Parsetree.core_type = + fun { + From.Parsetree.ptyp_desc; + From.Parsetree.ptyp_loc; + From.Parsetree.ptyp_attributes; + } -> + { + To.Parsetree.ptyp_desc = copy_core_type_desc ptyp_desc; + To.Parsetree.ptyp_loc = copy_location ptyp_loc; + To.Parsetree.ptyp_attributes = copy_attributes ptyp_attributes; + } + +and copy_core_type_desc : + From.Parsetree.core_type_desc -> To.Parsetree.core_type_desc = function + | From.Parsetree.Ptyp_any -> To.Parsetree.Ptyp_any + | From.Parsetree.Ptyp_var x0 -> To.Parsetree.Ptyp_var x0 + | From.Parsetree.Ptyp_arrow (x0, x1, x2) -> + To.Parsetree.Ptyp_arrow + (copy_arg_label x0, copy_core_type x1, copy_core_type x2) + | From.Parsetree.Ptyp_tuple x0 -> + To.Parsetree.Ptyp_tuple (List.map copy_core_type x0) + | From.Parsetree.Ptyp_constr (x0, x1) -> + To.Parsetree.Ptyp_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Ptyp_object (x0, x1) -> + To.Parsetree.Ptyp_object + ( List.map + (fun x -> + let x0, x1, x2 = x in + (x0, copy_attributes x1, copy_core_type x2)) + x0, + copy_closed_flag x1 ) + | From.Parsetree.Ptyp_class (x0, x1) -> + To.Parsetree.Ptyp_class + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Ptyp_alias (x0, x1) -> + To.Parsetree.Ptyp_alias (copy_core_type x0, x1) + | From.Parsetree.Ptyp_variant (x0, x1, x2) -> + To.Parsetree.Ptyp_variant + ( List.map copy_row_field x0, + copy_closed_flag x1, + copy_option (fun x -> List.map copy_label x) x2 ) + | From.Parsetree.Ptyp_poly (x0, x1) -> + To.Parsetree.Ptyp_poly (List.map (fun x -> x) x0, copy_core_type x1) + | From.Parsetree.Ptyp_package x0 -> + To.Parsetree.Ptyp_package (copy_package_type x0) + | From.Parsetree.Ptyp_extension x0 -> + To.Parsetree.Ptyp_extension (copy_extension x0) + +and copy_package_type : From.Parsetree.package_type -> To.Parsetree.package_type + = + fun x -> + let x0, x1 = x in + ( copy_loc copy_longident x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_core_type x1)) + x1 ) + +and copy_row_field : From.Parsetree.row_field -> To.Parsetree.row_field = + function + | From.Parsetree.Rtag (x0, x1, x2, x3) -> + To.Parsetree.Rtag + ( copy_label x0, + copy_attributes x1, + copy_bool x2, + List.map copy_core_type x3 ) + | From.Parsetree.Rinherit x0 -> To.Parsetree.Rinherit (copy_core_type x0) + +and copy_attributes : From.Parsetree.attributes -> To.Parsetree.attributes = + fun x -> List.map copy_attribute x + +and copy_attribute : From.Parsetree.attribute -> To.Parsetree.attribute = + fun x -> + let x0, x1 = x in + (copy_loc (fun x -> x) x0, copy_payload x1) + +and copy_payload : From.Parsetree.payload -> To.Parsetree.payload = function + | From.Parsetree.PStr x0 -> To.Parsetree.PStr (copy_structure x0) + | From.Parsetree.PSig x0 -> To.Parsetree.PSig (copy_signature x0) + | From.Parsetree.PTyp x0 -> To.Parsetree.PTyp (copy_core_type x0) + | From.Parsetree.PPat (x0, x1) -> + To.Parsetree.PPat (copy_pattern x0, copy_option copy_expression x1) + +and copy_structure : From.Parsetree.structure -> To.Parsetree.structure = + fun x -> List.map copy_structure_item x + +and copy_structure_item : + From.Parsetree.structure_item -> To.Parsetree.structure_item = + fun { From.Parsetree.pstr_desc; From.Parsetree.pstr_loc } -> + { + To.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc; + To.Parsetree.pstr_loc = copy_location pstr_loc; + } + +and copy_structure_item_desc : + From.Parsetree.structure_item_desc -> To.Parsetree.structure_item_desc = + function + | From.Parsetree.Pstr_eval (x0, x1) -> + To.Parsetree.Pstr_eval (copy_expression x0, copy_attributes x1) + | From.Parsetree.Pstr_value (x0, x1) -> + To.Parsetree.Pstr_value (copy_rec_flag x0, List.map copy_value_binding x1) + | From.Parsetree.Pstr_primitive x0 -> + To.Parsetree.Pstr_primitive (copy_value_description x0) + | From.Parsetree.Pstr_type (x0, x1) -> + To.Parsetree.Pstr_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | From.Parsetree.Pstr_typext x0 -> + To.Parsetree.Pstr_typext (copy_type_extension x0) + | From.Parsetree.Pstr_exception x0 -> + To.Parsetree.Pstr_exception (copy_extension_constructor x0) + | From.Parsetree.Pstr_module x0 -> + To.Parsetree.Pstr_module (copy_module_binding x0) + | From.Parsetree.Pstr_recmodule x0 -> + To.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) + | From.Parsetree.Pstr_modtype x0 -> + To.Parsetree.Pstr_modtype (copy_module_type_declaration x0) + | From.Parsetree.Pstr_open x0 -> + To.Parsetree.Pstr_open (copy_open_description x0) + | From.Parsetree.Pstr_class x0 -> + To.Parsetree.Pstr_class (List.map copy_class_declaration x0) + | From.Parsetree.Pstr_class_type x0 -> + To.Parsetree.Pstr_class_type (List.map copy_class_type_declaration x0) + | From.Parsetree.Pstr_include x0 -> + To.Parsetree.Pstr_include (copy_include_declaration x0) + | From.Parsetree.Pstr_attribute x0 -> + To.Parsetree.Pstr_attribute (copy_attribute x0) + | From.Parsetree.Pstr_extension (x0, x1) -> + To.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1) + +and copy_include_declaration : + From.Parsetree.include_declaration -> To.Parsetree.include_declaration = + fun x -> copy_include_infos copy_module_expr x + +and copy_class_declaration : + From.Parsetree.class_declaration -> To.Parsetree.class_declaration = + fun x -> copy_class_infos copy_class_expr x + +and copy_class_expr : From.Parsetree.class_expr -> To.Parsetree.class_expr = + fun { + From.Parsetree.pcl_desc; + From.Parsetree.pcl_loc; + From.Parsetree.pcl_attributes; + } -> + { + To.Parsetree.pcl_desc = copy_class_expr_desc pcl_desc; + To.Parsetree.pcl_loc = copy_location pcl_loc; + To.Parsetree.pcl_attributes = copy_attributes pcl_attributes; + } + +and copy_class_expr_desc : + From.Parsetree.class_expr_desc -> To.Parsetree.class_expr_desc = function + | From.Parsetree.Pcl_constr (x0, x1) -> + To.Parsetree.Pcl_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Pcl_structure x0 -> + To.Parsetree.Pcl_structure (copy_class_structure x0) + | From.Parsetree.Pcl_fun (x0, x1, x2, x3) -> + To.Parsetree.Pcl_fun + ( copy_arg_label x0, + copy_option copy_expression x1, + copy_pattern x2, + copy_class_expr x3 ) + | From.Parsetree.Pcl_apply (x0, x1) -> + To.Parsetree.Pcl_apply + ( copy_class_expr x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | From.Parsetree.Pcl_let (x0, x1, x2) -> + To.Parsetree.Pcl_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_class_expr x2) + | From.Parsetree.Pcl_constraint (x0, x1) -> + To.Parsetree.Pcl_constraint (copy_class_expr x0, copy_class_type x1) + | From.Parsetree.Pcl_extension x0 -> + To.Parsetree.Pcl_extension (copy_extension x0) + +and copy_class_structure : + From.Parsetree.class_structure -> To.Parsetree.class_structure = + fun { From.Parsetree.pcstr_self; From.Parsetree.pcstr_fields } -> + { + To.Parsetree.pcstr_self = copy_pattern pcstr_self; + To.Parsetree.pcstr_fields = List.map copy_class_field pcstr_fields; + } + +and copy_class_field : From.Parsetree.class_field -> To.Parsetree.class_field = + fun { + From.Parsetree.pcf_desc; + From.Parsetree.pcf_loc; + From.Parsetree.pcf_attributes; + } -> + { + To.Parsetree.pcf_desc = copy_class_field_desc pcf_desc; + To.Parsetree.pcf_loc = copy_location pcf_loc; + To.Parsetree.pcf_attributes = copy_attributes pcf_attributes; + } + +and copy_class_field_desc : + From.Parsetree.class_field_desc -> To.Parsetree.class_field_desc = function + | From.Parsetree.Pcf_inherit (x0, x1, x2) -> + To.Parsetree.Pcf_inherit + (copy_override_flag x0, copy_class_expr x1, copy_option (fun x -> x) x2) + | From.Parsetree.Pcf_val x0 -> + To.Parsetree.Pcf_val + (let x0, x1, x2 = x0 in + ( copy_loc (fun x -> x) x0, + copy_mutable_flag x1, + copy_class_field_kind x2 )) + | From.Parsetree.Pcf_method x0 -> + To.Parsetree.Pcf_method + (let x0, x1, x2 = x0 in + ( copy_loc (fun x -> x) x0, + copy_private_flag x1, + copy_class_field_kind x2 )) + | From.Parsetree.Pcf_constraint x0 -> + To.Parsetree.Pcf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | From.Parsetree.Pcf_initializer x0 -> + To.Parsetree.Pcf_initializer (copy_expression x0) + | From.Parsetree.Pcf_attribute x0 -> + To.Parsetree.Pcf_attribute (copy_attribute x0) + | From.Parsetree.Pcf_extension x0 -> + To.Parsetree.Pcf_extension (copy_extension x0) + +and copy_class_field_kind : + From.Parsetree.class_field_kind -> To.Parsetree.class_field_kind = function + | From.Parsetree.Cfk_virtual x0 -> + To.Parsetree.Cfk_virtual (copy_core_type x0) + | From.Parsetree.Cfk_concrete (x0, x1) -> + To.Parsetree.Cfk_concrete (copy_override_flag x0, copy_expression x1) + +and copy_module_binding : + From.Parsetree.module_binding -> To.Parsetree.module_binding = + fun { + From.Parsetree.pmb_name; + From.Parsetree.pmb_expr; + From.Parsetree.pmb_attributes; + From.Parsetree.pmb_loc; + } -> + { + To.Parsetree.pmb_name = copy_loc (fun x -> x) pmb_name; + To.Parsetree.pmb_expr = copy_module_expr pmb_expr; + To.Parsetree.pmb_attributes = copy_attributes pmb_attributes; + To.Parsetree.pmb_loc = copy_location pmb_loc; + } + +and copy_module_expr : From.Parsetree.module_expr -> To.Parsetree.module_expr = + fun { + From.Parsetree.pmod_desc; + From.Parsetree.pmod_loc; + From.Parsetree.pmod_attributes; + } -> + { + To.Parsetree.pmod_desc = copy_module_expr_desc pmod_desc; + To.Parsetree.pmod_loc = copy_location pmod_loc; + To.Parsetree.pmod_attributes = copy_attributes pmod_attributes; + } + +and copy_module_expr_desc : + From.Parsetree.module_expr_desc -> To.Parsetree.module_expr_desc = function + | From.Parsetree.Pmod_ident x0 -> + To.Parsetree.Pmod_ident (copy_loc copy_longident x0) + | From.Parsetree.Pmod_structure x0 -> + To.Parsetree.Pmod_structure (copy_structure x0) + | From.Parsetree.Pmod_functor (x0, x1, x2) -> + To.Parsetree.Pmod_functor + ( copy_loc (fun x -> x) x0, + copy_option copy_module_type x1, + copy_module_expr x2 ) + | From.Parsetree.Pmod_apply (x0, x1) -> + To.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) + | From.Parsetree.Pmod_constraint (x0, x1) -> + To.Parsetree.Pmod_constraint (copy_module_expr x0, copy_module_type x1) + | From.Parsetree.Pmod_unpack x0 -> + To.Parsetree.Pmod_unpack (copy_expression x0) + | From.Parsetree.Pmod_extension x0 -> + To.Parsetree.Pmod_extension (copy_extension x0) + +and copy_module_type : From.Parsetree.module_type -> To.Parsetree.module_type = + fun { + From.Parsetree.pmty_desc; + From.Parsetree.pmty_loc; + From.Parsetree.pmty_attributes; + } -> + { + To.Parsetree.pmty_desc = copy_module_type_desc pmty_desc; + To.Parsetree.pmty_loc = copy_location pmty_loc; + To.Parsetree.pmty_attributes = copy_attributes pmty_attributes; + } + +and copy_module_type_desc : + From.Parsetree.module_type_desc -> To.Parsetree.module_type_desc = function + | From.Parsetree.Pmty_ident x0 -> + To.Parsetree.Pmty_ident (copy_loc copy_longident x0) + | From.Parsetree.Pmty_signature x0 -> + To.Parsetree.Pmty_signature (copy_signature x0) + | From.Parsetree.Pmty_functor (x0, x1, x2) -> + To.Parsetree.Pmty_functor + ( copy_loc (fun x -> x) x0, + copy_option copy_module_type x1, + copy_module_type x2 ) + | From.Parsetree.Pmty_with (x0, x1) -> + To.Parsetree.Pmty_with + (copy_module_type x0, List.map copy_with_constraint x1) + | From.Parsetree.Pmty_typeof x0 -> + To.Parsetree.Pmty_typeof (copy_module_expr x0) + | From.Parsetree.Pmty_extension x0 -> + To.Parsetree.Pmty_extension (copy_extension x0) + | From.Parsetree.Pmty_alias x0 -> + To.Parsetree.Pmty_alias (copy_loc copy_longident x0) + +and copy_with_constraint : + From.Parsetree.with_constraint -> To.Parsetree.with_constraint = function + | From.Parsetree.Pwith_type (x0, x1) -> + To.Parsetree.Pwith_type + (copy_loc copy_longident x0, copy_type_declaration x1) + | From.Parsetree.Pwith_module (x0, x1) -> + To.Parsetree.Pwith_module + (copy_loc copy_longident x0, copy_loc copy_longident x1) + | From.Parsetree.Pwith_typesubst x0 -> + To.Parsetree.Pwith_typesubst (copy_type_declaration x0) + | From.Parsetree.Pwith_modsubst (x0, x1) -> + To.Parsetree.Pwith_modsubst + (copy_loc (fun x -> x) x0, copy_loc copy_longident x1) + +and copy_signature : From.Parsetree.signature -> To.Parsetree.signature = + fun x -> List.map copy_signature_item x + +and copy_signature_item : + From.Parsetree.signature_item -> To.Parsetree.signature_item = + fun { From.Parsetree.psig_desc; From.Parsetree.psig_loc } -> + { + To.Parsetree.psig_desc = copy_signature_item_desc psig_desc; + To.Parsetree.psig_loc = copy_location psig_loc; + } + +and copy_signature_item_desc : + From.Parsetree.signature_item_desc -> To.Parsetree.signature_item_desc = + function + | From.Parsetree.Psig_value x0 -> + To.Parsetree.Psig_value (copy_value_description x0) + | From.Parsetree.Psig_type (x0, x1) -> + To.Parsetree.Psig_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | From.Parsetree.Psig_typext x0 -> + To.Parsetree.Psig_typext (copy_type_extension x0) + | From.Parsetree.Psig_exception x0 -> + To.Parsetree.Psig_exception (copy_extension_constructor x0) + | From.Parsetree.Psig_module x0 -> + To.Parsetree.Psig_module (copy_module_declaration x0) + | From.Parsetree.Psig_recmodule x0 -> + To.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) + | From.Parsetree.Psig_modtype x0 -> + To.Parsetree.Psig_modtype (copy_module_type_declaration x0) + | From.Parsetree.Psig_open x0 -> + To.Parsetree.Psig_open (copy_open_description x0) + | From.Parsetree.Psig_include x0 -> + To.Parsetree.Psig_include (copy_include_description x0) + | From.Parsetree.Psig_class x0 -> + To.Parsetree.Psig_class (List.map copy_class_description x0) + | From.Parsetree.Psig_class_type x0 -> + To.Parsetree.Psig_class_type (List.map copy_class_type_declaration x0) + | From.Parsetree.Psig_attribute x0 -> + To.Parsetree.Psig_attribute (copy_attribute x0) + | From.Parsetree.Psig_extension (x0, x1) -> + To.Parsetree.Psig_extension (copy_extension x0, copy_attributes x1) + +and copy_class_type_declaration : + From.Parsetree.class_type_declaration -> To.Parsetree.class_type_declaration + = + fun x -> copy_class_infos copy_class_type x + +and copy_class_description : + From.Parsetree.class_description -> To.Parsetree.class_description = + fun x -> copy_class_infos copy_class_type x + +and copy_class_type : From.Parsetree.class_type -> To.Parsetree.class_type = + fun { + From.Parsetree.pcty_desc; + From.Parsetree.pcty_loc; + From.Parsetree.pcty_attributes; + } -> + { + To.Parsetree.pcty_desc = copy_class_type_desc pcty_desc; + To.Parsetree.pcty_loc = copy_location pcty_loc; + To.Parsetree.pcty_attributes = copy_attributes pcty_attributes; + } + +and copy_class_type_desc : + From.Parsetree.class_type_desc -> To.Parsetree.class_type_desc = function + | From.Parsetree.Pcty_constr (x0, x1) -> + To.Parsetree.Pcty_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Pcty_signature x0 -> + To.Parsetree.Pcty_signature (copy_class_signature x0) + | From.Parsetree.Pcty_arrow (x0, x1, x2) -> + To.Parsetree.Pcty_arrow + (copy_arg_label x0, copy_core_type x1, copy_class_type x2) + | From.Parsetree.Pcty_extension x0 -> + To.Parsetree.Pcty_extension (copy_extension x0) + +and copy_class_signature : + From.Parsetree.class_signature -> To.Parsetree.class_signature = + fun { From.Parsetree.pcsig_self; From.Parsetree.pcsig_fields } -> + { + To.Parsetree.pcsig_self = copy_core_type pcsig_self; + To.Parsetree.pcsig_fields = List.map copy_class_type_field pcsig_fields; + } + +and copy_class_type_field : + From.Parsetree.class_type_field -> To.Parsetree.class_type_field = + fun { + From.Parsetree.pctf_desc; + From.Parsetree.pctf_loc; + From.Parsetree.pctf_attributes; + } -> + { + To.Parsetree.pctf_desc = copy_class_type_field_desc pctf_desc; + To.Parsetree.pctf_loc = copy_location pctf_loc; + To.Parsetree.pctf_attributes = copy_attributes pctf_attributes; + } + +and copy_class_type_field_desc : + From.Parsetree.class_type_field_desc -> To.Parsetree.class_type_field_desc = + function + | From.Parsetree.Pctf_inherit x0 -> + To.Parsetree.Pctf_inherit (copy_class_type x0) + | From.Parsetree.Pctf_val x0 -> + To.Parsetree.Pctf_val + (let x0, x1, x2, x3 = x0 in + (x0, copy_mutable_flag x1, copy_virtual_flag x2, copy_core_type x3)) + | From.Parsetree.Pctf_method x0 -> + To.Parsetree.Pctf_method + (let x0, x1, x2, x3 = x0 in + (x0, copy_private_flag x1, copy_virtual_flag x2, copy_core_type x3)) + | From.Parsetree.Pctf_constraint x0 -> + To.Parsetree.Pctf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | From.Parsetree.Pctf_attribute x0 -> + To.Parsetree.Pctf_attribute (copy_attribute x0) + | From.Parsetree.Pctf_extension x0 -> + To.Parsetree.Pctf_extension (copy_extension x0) + +and copy_extension : From.Parsetree.extension -> To.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 From.Parsetree.class_infos -> + 'g0 To.Parsetree.class_infos = + fun f0 + { + From.Parsetree.pci_virt; + From.Parsetree.pci_params; + From.Parsetree.pci_name; + From.Parsetree.pci_expr; + From.Parsetree.pci_loc; + From.Parsetree.pci_attributes; + } -> + { + To.Parsetree.pci_virt = copy_virtual_flag pci_virt; + To.Parsetree.pci_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + pci_params; + To.Parsetree.pci_name = copy_loc (fun x -> x) pci_name; + To.Parsetree.pci_expr = f0 pci_expr; + To.Parsetree.pci_loc = copy_location pci_loc; + To.Parsetree.pci_attributes = copy_attributes pci_attributes; + } + +and copy_virtual_flag : From.Asttypes.virtual_flag -> To.Asttypes.virtual_flag = + function + | From.Asttypes.Virtual -> To.Asttypes.Virtual + | From.Asttypes.Concrete -> To.Asttypes.Concrete + +and copy_include_description : + From.Parsetree.include_description -> To.Parsetree.include_description = + fun x -> copy_include_infos copy_module_type x + +and copy_include_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 From.Parsetree.include_infos -> + 'g0 To.Parsetree.include_infos = + fun f0 + { + From.Parsetree.pincl_mod; + From.Parsetree.pincl_loc; + From.Parsetree.pincl_attributes; + } -> + { + To.Parsetree.pincl_mod = f0 pincl_mod; + To.Parsetree.pincl_loc = copy_location pincl_loc; + To.Parsetree.pincl_attributes = copy_attributes pincl_attributes; + } + +and copy_open_description : + From.Parsetree.open_description -> To.Parsetree.open_description = + fun { + From.Parsetree.popen_lid; + From.Parsetree.popen_override; + From.Parsetree.popen_loc; + From.Parsetree.popen_attributes; + } -> + { + To.Parsetree.popen_lid = copy_loc copy_longident popen_lid; + To.Parsetree.popen_override = copy_override_flag popen_override; + To.Parsetree.popen_loc = copy_location popen_loc; + To.Parsetree.popen_attributes = copy_attributes popen_attributes; + } + +and copy_override_flag : + From.Asttypes.override_flag -> To.Asttypes.override_flag = function + | From.Asttypes.Override -> To.Asttypes.Override + | From.Asttypes.Fresh -> To.Asttypes.Fresh + +and copy_module_type_declaration : + From.Parsetree.module_type_declaration -> + To.Parsetree.module_type_declaration = + fun { + From.Parsetree.pmtd_name; + From.Parsetree.pmtd_type; + From.Parsetree.pmtd_attributes; + From.Parsetree.pmtd_loc; + } -> + { + To.Parsetree.pmtd_name = copy_loc (fun x -> x) pmtd_name; + To.Parsetree.pmtd_type = copy_option copy_module_type pmtd_type; + To.Parsetree.pmtd_attributes = copy_attributes pmtd_attributes; + To.Parsetree.pmtd_loc = copy_location pmtd_loc; + } + +and copy_module_declaration : + From.Parsetree.module_declaration -> To.Parsetree.module_declaration = + fun { + From.Parsetree.pmd_name; + From.Parsetree.pmd_type; + From.Parsetree.pmd_attributes; + From.Parsetree.pmd_loc; + } -> + { + To.Parsetree.pmd_name = copy_loc (fun x -> x) pmd_name; + To.Parsetree.pmd_type = copy_module_type pmd_type; + To.Parsetree.pmd_attributes = copy_attributes pmd_attributes; + To.Parsetree.pmd_loc = copy_location pmd_loc; + } + +and copy_type_extension : + From.Parsetree.type_extension -> To.Parsetree.type_extension = + fun { + From.Parsetree.ptyext_path; + From.Parsetree.ptyext_params; + From.Parsetree.ptyext_constructors; + From.Parsetree.ptyext_private; + From.Parsetree.ptyext_attributes; + } -> + { + To.Parsetree.ptyext_path = copy_loc copy_longident ptyext_path; + To.Parsetree.ptyext_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptyext_params; + To.Parsetree.ptyext_constructors = + List.map copy_extension_constructor ptyext_constructors; + To.Parsetree.ptyext_private = copy_private_flag ptyext_private; + To.Parsetree.ptyext_attributes = copy_attributes ptyext_attributes; + } + +and copy_extension_constructor : + From.Parsetree.extension_constructor -> To.Parsetree.extension_constructor = + fun { + From.Parsetree.pext_name; + From.Parsetree.pext_kind; + From.Parsetree.pext_loc; + From.Parsetree.pext_attributes; + } -> + { + To.Parsetree.pext_name = copy_loc (fun x -> x) pext_name; + To.Parsetree.pext_kind = copy_extension_constructor_kind pext_kind; + To.Parsetree.pext_loc = copy_location pext_loc; + To.Parsetree.pext_attributes = copy_attributes pext_attributes; + } + +and copy_extension_constructor_kind : + From.Parsetree.extension_constructor_kind -> + To.Parsetree.extension_constructor_kind = function + | From.Parsetree.Pext_decl (x0, x1) -> + To.Parsetree.Pext_decl + (copy_constructor_arguments x0, copy_option copy_core_type x1) + | From.Parsetree.Pext_rebind x0 -> + To.Parsetree.Pext_rebind (copy_loc copy_longident x0) + +and copy_type_declaration : + From.Parsetree.type_declaration -> To.Parsetree.type_declaration = + fun { + From.Parsetree.ptype_name; + From.Parsetree.ptype_params; + From.Parsetree.ptype_cstrs; + From.Parsetree.ptype_kind; + From.Parsetree.ptype_private; + From.Parsetree.ptype_manifest; + From.Parsetree.ptype_attributes; + From.Parsetree.ptype_loc; + } -> + { + To.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name; + To.Parsetree.ptype_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptype_params; + To.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; + To.Parsetree.ptype_kind = copy_type_kind ptype_kind; + To.Parsetree.ptype_private = copy_private_flag ptype_private; + To.Parsetree.ptype_manifest = copy_option copy_core_type ptype_manifest; + To.Parsetree.ptype_attributes = copy_attributes ptype_attributes; + To.Parsetree.ptype_loc = copy_location ptype_loc; + } + +and copy_private_flag : From.Asttypes.private_flag -> To.Asttypes.private_flag = + function + | From.Asttypes.Private -> To.Asttypes.Private + | From.Asttypes.Public -> To.Asttypes.Public + +and copy_type_kind : From.Parsetree.type_kind -> To.Parsetree.type_kind = + function + | From.Parsetree.Ptype_abstract -> To.Parsetree.Ptype_abstract + | From.Parsetree.Ptype_variant x0 -> + To.Parsetree.Ptype_variant (List.map copy_constructor_declaration x0) + | From.Parsetree.Ptype_record x0 -> + To.Parsetree.Ptype_record (List.map copy_label_declaration x0) + | From.Parsetree.Ptype_open -> To.Parsetree.Ptype_open + +and copy_constructor_declaration : + From.Parsetree.constructor_declaration -> + To.Parsetree.constructor_declaration = + fun { + From.Parsetree.pcd_name; + From.Parsetree.pcd_args; + From.Parsetree.pcd_res; + From.Parsetree.pcd_loc; + From.Parsetree.pcd_attributes; + } -> + { + To.Parsetree.pcd_name = copy_loc (fun x -> x) pcd_name; + To.Parsetree.pcd_args = copy_constructor_arguments pcd_args; + To.Parsetree.pcd_res = copy_option copy_core_type pcd_res; + To.Parsetree.pcd_loc = copy_location pcd_loc; + To.Parsetree.pcd_attributes = copy_attributes pcd_attributes; + } + +and copy_constructor_arguments : + From.Parsetree.constructor_arguments -> To.Parsetree.constructor_arguments = + function + | From.Parsetree.Pcstr_tuple x0 -> + To.Parsetree.Pcstr_tuple (List.map copy_core_type x0) + | From.Parsetree.Pcstr_record x0 -> + To.Parsetree.Pcstr_record (List.map copy_label_declaration x0) + +and copy_label_declaration : + From.Parsetree.label_declaration -> To.Parsetree.label_declaration = + fun { + From.Parsetree.pld_name; + From.Parsetree.pld_mutable; + From.Parsetree.pld_type; + From.Parsetree.pld_loc; + From.Parsetree.pld_attributes; + } -> + { + To.Parsetree.pld_name = copy_loc (fun x -> x) pld_name; + To.Parsetree.pld_mutable = copy_mutable_flag pld_mutable; + To.Parsetree.pld_type = copy_core_type pld_type; + To.Parsetree.pld_loc = copy_location pld_loc; + To.Parsetree.pld_attributes = copy_attributes pld_attributes; + } + +and copy_mutable_flag : From.Asttypes.mutable_flag -> To.Asttypes.mutable_flag = + function + | From.Asttypes.Immutable -> To.Asttypes.Immutable + | From.Asttypes.Mutable -> To.Asttypes.Mutable + +and copy_variance : From.Asttypes.variance -> To.Asttypes.variance = function + | From.Asttypes.Covariant -> To.Asttypes.Covariant + | From.Asttypes.Contravariant -> To.Asttypes.Contravariant + | From.Asttypes.Invariant -> To.Asttypes.Invariant + +and copy_value_description : + From.Parsetree.value_description -> To.Parsetree.value_description = + fun { + From.Parsetree.pval_name; + From.Parsetree.pval_type; + From.Parsetree.pval_prim; + From.Parsetree.pval_attributes; + From.Parsetree.pval_loc; + } -> + { + To.Parsetree.pval_name = copy_loc (fun x -> x) pval_name; + To.Parsetree.pval_type = copy_core_type pval_type; + To.Parsetree.pval_prim = List.map (fun x -> x) pval_prim; + To.Parsetree.pval_attributes = copy_attributes pval_attributes; + To.Parsetree.pval_loc = copy_location pval_loc; + } + +and copy_arg_label : From.Asttypes.arg_label -> To.Asttypes.arg_label = function + | From.Asttypes.Nolabel -> To.Asttypes.Nolabel + | From.Asttypes.Labelled x0 -> To.Asttypes.Labelled x0 + | From.Asttypes.Optional x0 -> To.Asttypes.Optional x0 + +and copy_closed_flag : From.Asttypes.closed_flag -> To.Asttypes.closed_flag = + function + | From.Asttypes.Closed -> To.Asttypes.Closed + | From.Asttypes.Open -> To.Asttypes.Open + +and copy_label : From.Asttypes.label -> To.Asttypes.label = fun x -> x + +and copy_rec_flag : From.Asttypes.rec_flag -> To.Asttypes.rec_flag = function + | From.Asttypes.Nonrecursive -> To.Asttypes.Nonrecursive + | From.Asttypes.Recursive -> To.Asttypes.Recursive + +and copy_constant : From.Parsetree.constant -> To.Parsetree.constant = function + | From.Parsetree.Pconst_integer (x0, x1) -> + To.Parsetree.Pconst_integer (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pconst_char x0 -> To.Parsetree.Pconst_char x0 + | From.Parsetree.Pconst_string (x0, x1) -> + To.Parsetree.Pconst_string (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pconst_float (x0, x1) -> + To.Parsetree.Pconst_float (x0, copy_option (fun x -> x) x1) + +and copy_option : 'f0 'g0. ('f0 -> 'g0) -> 'f0 option -> 'g0 option = + fun f0 -> function None -> None | Some x0 -> Some (f0 x0) + +and copy_longident : Longident.t -> Longident.t = fun x -> x + +and copy_loc : + 'f0 'g0. ('f0 -> 'g0) -> 'f0 From.Asttypes.loc -> 'g0 To.Asttypes.loc = + fun f0 { From.Asttypes.txt; From.Asttypes.loc } -> + { To.Asttypes.txt = f0 txt; To.Asttypes.loc = copy_location loc } + +and copy_location : Location.t -> Location.t = fun x -> x + +and copy_bool : bool -> bool = function false -> false | true -> true + +let rec copy_toplevel_phrase : + From.Parsetree.toplevel_phrase -> To.Parsetree.toplevel_phrase = function + | From.Parsetree.Ptop_def x0 -> To.Parsetree.Ptop_def (copy_structure x0) + | From.Parsetree.Ptop_dir (x0, x1) -> + To.Parsetree.Ptop_dir (x0, copy_directive_argument x1) + +and copy_directive_argument : + From.Parsetree.directive_argument -> To.Parsetree.directive_argument = + function + | From.Parsetree.Pdir_none -> To.Parsetree.Pdir_none + | From.Parsetree.Pdir_string x0 -> To.Parsetree.Pdir_string x0 + | From.Parsetree.Pdir_int (x0, x1) -> + To.Parsetree.Pdir_int (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pdir_ident x0 -> To.Parsetree.Pdir_ident (copy_longident x0) + | From.Parsetree.Pdir_bool x0 -> To.Parsetree.Pdir_bool (copy_bool x0) + +let copy_cases x = List.map copy_case x + +let copy_pat = copy_pattern + +let copy_expr = copy_expression + +let copy_typ = copy_core_type diff -Nru ppxlib-0.15.0/astlib/migrate_404_405.ml ppxlib-0.24.0/astlib/migrate_404_405.ml --- ppxlib-0.15.0/astlib/migrate_404_405.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/migrate_404_405.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1015 @@ +(**************************************************************************) +(* *) +(* OCaml Migrate Parsetree *) +(* *) +(* Frédéric Bour *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2017 Institut National de Recherche en Informatique et *) +(* en Automatique (INRIA). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module From = Ast_404 +module To = Ast_405 + +let noloc x = { Location.txt = x; loc = Location.none } + +let rec copy_expression : From.Parsetree.expression -> To.Parsetree.expression = + fun { + From.Parsetree.pexp_desc; + From.Parsetree.pexp_loc; + From.Parsetree.pexp_attributes; + } -> + { + To.Parsetree.pexp_desc = copy_expression_desc pexp_desc; + To.Parsetree.pexp_loc = copy_location pexp_loc; + To.Parsetree.pexp_attributes = copy_attributes pexp_attributes; + } + +and copy_expression_desc : + From.Parsetree.expression_desc -> To.Parsetree.expression_desc = function + | From.Parsetree.Pexp_ident x0 -> + To.Parsetree.Pexp_ident (copy_loc copy_longident x0) + | From.Parsetree.Pexp_constant x0 -> + To.Parsetree.Pexp_constant (copy_constant x0) + | From.Parsetree.Pexp_let (x0, x1, x2) -> + To.Parsetree.Pexp_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_expression x2) + | From.Parsetree.Pexp_function x0 -> + To.Parsetree.Pexp_function (List.map copy_case x0) + | From.Parsetree.Pexp_fun (x0, x1, x2, x3) -> + To.Parsetree.Pexp_fun + ( copy_arg_label x0, + copy_option copy_expression x1, + copy_pattern x2, + copy_expression x3 ) + | From.Parsetree.Pexp_apply (x0, x1) -> + To.Parsetree.Pexp_apply + ( copy_expression x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | From.Parsetree.Pexp_match (x0, x1) -> + To.Parsetree.Pexp_match (copy_expression x0, List.map copy_case x1) + | From.Parsetree.Pexp_try (x0, x1) -> + To.Parsetree.Pexp_try (copy_expression x0, List.map copy_case x1) + | From.Parsetree.Pexp_tuple x0 -> + To.Parsetree.Pexp_tuple (List.map copy_expression x0) + | From.Parsetree.Pexp_construct (x0, x1) -> + To.Parsetree.Pexp_construct + (copy_loc copy_longident x0, copy_option copy_expression x1) + | From.Parsetree.Pexp_variant (x0, x1) -> + To.Parsetree.Pexp_variant (copy_label x0, copy_option copy_expression x1) + | From.Parsetree.Pexp_record (x0, x1) -> + To.Parsetree.Pexp_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_expression x1)) + x0, + copy_option copy_expression x1 ) + | From.Parsetree.Pexp_field (x0, x1) -> + To.Parsetree.Pexp_field (copy_expression x0, copy_loc copy_longident x1) + | From.Parsetree.Pexp_setfield (x0, x1, x2) -> + To.Parsetree.Pexp_setfield + (copy_expression x0, copy_loc copy_longident x1, copy_expression x2) + | From.Parsetree.Pexp_array x0 -> + To.Parsetree.Pexp_array (List.map copy_expression x0) + | From.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> + To.Parsetree.Pexp_ifthenelse + (copy_expression x0, copy_expression x1, copy_option copy_expression x2) + | From.Parsetree.Pexp_sequence (x0, x1) -> + To.Parsetree.Pexp_sequence (copy_expression x0, copy_expression x1) + | From.Parsetree.Pexp_while (x0, x1) -> + To.Parsetree.Pexp_while (copy_expression x0, copy_expression x1) + | From.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> + To.Parsetree.Pexp_for + ( copy_pattern x0, + copy_expression x1, + copy_expression x2, + copy_direction_flag x3, + copy_expression x4 ) + | From.Parsetree.Pexp_constraint (x0, x1) -> + To.Parsetree.Pexp_constraint (copy_expression x0, copy_core_type x1) + | From.Parsetree.Pexp_coerce (x0, x1, x2) -> + To.Parsetree.Pexp_coerce + (copy_expression x0, copy_option copy_core_type x1, copy_core_type x2) + | From.Parsetree.Pexp_send (x0, x1) -> + To.Parsetree.Pexp_send (copy_expression x0, noloc x1) + | From.Parsetree.Pexp_new x0 -> + To.Parsetree.Pexp_new (copy_loc copy_longident x0) + | From.Parsetree.Pexp_setinstvar (x0, x1) -> + To.Parsetree.Pexp_setinstvar (copy_loc (fun x -> x) x0, copy_expression x1) + | From.Parsetree.Pexp_override x0 -> + To.Parsetree.Pexp_override + (List.map + (fun x -> + let x0, x1 = x in + (copy_loc (fun x -> x) x0, copy_expression x1)) + x0) + | From.Parsetree.Pexp_letmodule (x0, x1, x2) -> + To.Parsetree.Pexp_letmodule + (copy_loc (fun x -> x) x0, copy_module_expr x1, copy_expression x2) + | From.Parsetree.Pexp_letexception (x0, x1) -> + To.Parsetree.Pexp_letexception + (copy_extension_constructor x0, copy_expression x1) + | From.Parsetree.Pexp_assert x0 -> + To.Parsetree.Pexp_assert (copy_expression x0) + | From.Parsetree.Pexp_lazy x0 -> To.Parsetree.Pexp_lazy (copy_expression x0) + | From.Parsetree.Pexp_poly (x0, x1) -> + To.Parsetree.Pexp_poly (copy_expression x0, copy_option copy_core_type x1) + | From.Parsetree.Pexp_object x0 -> + To.Parsetree.Pexp_object (copy_class_structure x0) + | From.Parsetree.Pexp_newtype (x0, x1) -> + To.Parsetree.Pexp_newtype (noloc x0, copy_expression x1) + | From.Parsetree.Pexp_pack x0 -> To.Parsetree.Pexp_pack (copy_module_expr x0) + | From.Parsetree.Pexp_open (x0, x1, x2) -> + To.Parsetree.Pexp_open + (copy_override_flag x0, copy_loc copy_longident x1, copy_expression x2) + | From.Parsetree.Pexp_extension x0 -> + To.Parsetree.Pexp_extension (copy_extension x0) + | From.Parsetree.Pexp_unreachable -> To.Parsetree.Pexp_unreachable + +and copy_direction_flag : + From.Asttypes.direction_flag -> To.Asttypes.direction_flag = function + | From.Asttypes.Upto -> To.Asttypes.Upto + | From.Asttypes.Downto -> To.Asttypes.Downto + +and copy_case : From.Parsetree.case -> To.Parsetree.case = + fun { From.Parsetree.pc_lhs; From.Parsetree.pc_guard; From.Parsetree.pc_rhs } -> + { + To.Parsetree.pc_lhs = copy_pattern pc_lhs; + To.Parsetree.pc_guard = copy_option copy_expression pc_guard; + To.Parsetree.pc_rhs = copy_expression pc_rhs; + } + +and copy_value_binding : + From.Parsetree.value_binding -> To.Parsetree.value_binding = + fun { + From.Parsetree.pvb_pat; + From.Parsetree.pvb_expr; + From.Parsetree.pvb_attributes; + From.Parsetree.pvb_loc; + } -> + { + To.Parsetree.pvb_pat = copy_pattern pvb_pat; + To.Parsetree.pvb_expr = copy_expression pvb_expr; + To.Parsetree.pvb_attributes = copy_attributes pvb_attributes; + To.Parsetree.pvb_loc = copy_location pvb_loc; + } + +and copy_pattern : From.Parsetree.pattern -> To.Parsetree.pattern = + fun { + From.Parsetree.ppat_desc; + From.Parsetree.ppat_loc; + From.Parsetree.ppat_attributes; + } -> + { + To.Parsetree.ppat_desc = copy_pattern_desc ppat_desc; + To.Parsetree.ppat_loc = copy_location ppat_loc; + To.Parsetree.ppat_attributes = copy_attributes ppat_attributes; + } + +and copy_pattern_desc : From.Parsetree.pattern_desc -> To.Parsetree.pattern_desc + = function + | From.Parsetree.Ppat_any -> To.Parsetree.Ppat_any + | From.Parsetree.Ppat_var x0 -> + To.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) + | From.Parsetree.Ppat_alias (x0, x1) -> + To.Parsetree.Ppat_alias (copy_pattern x0, copy_loc (fun x -> x) x1) + | From.Parsetree.Ppat_constant x0 -> + To.Parsetree.Ppat_constant (copy_constant x0) + | From.Parsetree.Ppat_interval (x0, x1) -> + To.Parsetree.Ppat_interval (copy_constant x0, copy_constant x1) + | From.Parsetree.Ppat_tuple x0 -> + To.Parsetree.Ppat_tuple (List.map copy_pattern x0) + | From.Parsetree.Ppat_construct (x0, x1) -> + To.Parsetree.Ppat_construct + (copy_loc copy_longident x0, copy_option copy_pattern x1) + | From.Parsetree.Ppat_variant (x0, x1) -> + To.Parsetree.Ppat_variant (copy_label x0, copy_option copy_pattern x1) + | From.Parsetree.Ppat_record (x0, x1) -> + To.Parsetree.Ppat_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_pattern x1)) + x0, + copy_closed_flag x1 ) + | From.Parsetree.Ppat_array x0 -> + To.Parsetree.Ppat_array (List.map copy_pattern x0) + | From.Parsetree.Ppat_or (x0, x1) -> + To.Parsetree.Ppat_or (copy_pattern x0, copy_pattern x1) + | From.Parsetree.Ppat_constraint (x0, x1) -> + To.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1) + | From.Parsetree.Ppat_type x0 -> + To.Parsetree.Ppat_type (copy_loc copy_longident x0) + | From.Parsetree.Ppat_lazy x0 -> To.Parsetree.Ppat_lazy (copy_pattern x0) + | From.Parsetree.Ppat_unpack x0 -> + To.Parsetree.Ppat_unpack (copy_loc (fun x -> x) x0) + | From.Parsetree.Ppat_exception x0 -> + To.Parsetree.Ppat_exception (copy_pattern x0) + | From.Parsetree.Ppat_extension x0 -> + To.Parsetree.Ppat_extension (copy_extension x0) + | From.Parsetree.Ppat_open (x0, x1) -> + To.Parsetree.Ppat_open (copy_loc copy_longident x0, copy_pattern x1) + +and copy_core_type : From.Parsetree.core_type -> To.Parsetree.core_type = + fun { + From.Parsetree.ptyp_desc; + From.Parsetree.ptyp_loc; + From.Parsetree.ptyp_attributes; + } -> + { + To.Parsetree.ptyp_desc = copy_core_type_desc ptyp_desc; + To.Parsetree.ptyp_loc = copy_location ptyp_loc; + To.Parsetree.ptyp_attributes = copy_attributes ptyp_attributes; + } + +and copy_core_type_desc : + From.Parsetree.core_type_desc -> To.Parsetree.core_type_desc = function + | From.Parsetree.Ptyp_any -> To.Parsetree.Ptyp_any + | From.Parsetree.Ptyp_var x0 -> To.Parsetree.Ptyp_var x0 + | From.Parsetree.Ptyp_arrow (x0, x1, x2) -> + To.Parsetree.Ptyp_arrow + (copy_arg_label x0, copy_core_type x1, copy_core_type x2) + | From.Parsetree.Ptyp_tuple x0 -> + To.Parsetree.Ptyp_tuple (List.map copy_core_type x0) + | From.Parsetree.Ptyp_constr (x0, x1) -> + To.Parsetree.Ptyp_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Ptyp_object (x0, x1) -> + To.Parsetree.Ptyp_object + ( List.map + (fun x -> + let x0, x1, x2 = x in + (noloc x0, copy_attributes x1, copy_core_type x2)) + x0, + copy_closed_flag x1 ) + | From.Parsetree.Ptyp_class (x0, x1) -> + To.Parsetree.Ptyp_class + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Ptyp_alias (x0, x1) -> + To.Parsetree.Ptyp_alias (copy_core_type x0, x1) + | From.Parsetree.Ptyp_variant (x0, x1, x2) -> + To.Parsetree.Ptyp_variant + ( List.map copy_row_field x0, + copy_closed_flag x1, + copy_option (fun x -> List.map copy_label x) x2 ) + | From.Parsetree.Ptyp_poly (x0, x1) -> + To.Parsetree.Ptyp_poly (List.map (fun x -> noloc x) x0, copy_core_type x1) + | From.Parsetree.Ptyp_package x0 -> + To.Parsetree.Ptyp_package (copy_package_type x0) + | From.Parsetree.Ptyp_extension x0 -> + To.Parsetree.Ptyp_extension (copy_extension x0) + +and copy_package_type : From.Parsetree.package_type -> To.Parsetree.package_type + = + fun x -> + let x0, x1 = x in + ( copy_loc copy_longident x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_core_type x1)) + x1 ) + +and copy_row_field : From.Parsetree.row_field -> To.Parsetree.row_field = + function + | From.Parsetree.Rtag (x0, x1, x2, x3) -> + To.Parsetree.Rtag + ( copy_label x0, + copy_attributes x1, + copy_bool x2, + List.map copy_core_type x3 ) + | From.Parsetree.Rinherit x0 -> To.Parsetree.Rinherit (copy_core_type x0) + +and copy_attributes : From.Parsetree.attributes -> To.Parsetree.attributes = + fun x -> List.map copy_attribute x + +and copy_attribute : From.Parsetree.attribute -> To.Parsetree.attribute = + fun x -> + let x0, x1 = x in + (copy_loc (fun x -> x) x0, copy_payload x1) + +and copy_payload : From.Parsetree.payload -> To.Parsetree.payload = function + | From.Parsetree.PStr x0 -> To.Parsetree.PStr (copy_structure x0) + | From.Parsetree.PSig x0 -> To.Parsetree.PSig (copy_signature x0) + | From.Parsetree.PTyp x0 -> To.Parsetree.PTyp (copy_core_type x0) + | From.Parsetree.PPat (x0, x1) -> + To.Parsetree.PPat (copy_pattern x0, copy_option copy_expression x1) + +and copy_structure : From.Parsetree.structure -> To.Parsetree.structure = + fun x -> List.map copy_structure_item x + +and copy_structure_item : + From.Parsetree.structure_item -> To.Parsetree.structure_item = + fun { From.Parsetree.pstr_desc; From.Parsetree.pstr_loc } -> + { + To.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc; + To.Parsetree.pstr_loc = copy_location pstr_loc; + } + +and copy_structure_item_desc : + From.Parsetree.structure_item_desc -> To.Parsetree.structure_item_desc = + function + | From.Parsetree.Pstr_eval (x0, x1) -> + To.Parsetree.Pstr_eval (copy_expression x0, copy_attributes x1) + | From.Parsetree.Pstr_value (x0, x1) -> + To.Parsetree.Pstr_value (copy_rec_flag x0, List.map copy_value_binding x1) + | From.Parsetree.Pstr_primitive x0 -> + To.Parsetree.Pstr_primitive (copy_value_description x0) + | From.Parsetree.Pstr_type (x0, x1) -> + To.Parsetree.Pstr_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | From.Parsetree.Pstr_typext x0 -> + To.Parsetree.Pstr_typext (copy_type_extension x0) + | From.Parsetree.Pstr_exception x0 -> + To.Parsetree.Pstr_exception (copy_extension_constructor x0) + | From.Parsetree.Pstr_module x0 -> + To.Parsetree.Pstr_module (copy_module_binding x0) + | From.Parsetree.Pstr_recmodule x0 -> + To.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) + | From.Parsetree.Pstr_modtype x0 -> + To.Parsetree.Pstr_modtype (copy_module_type_declaration x0) + | From.Parsetree.Pstr_open x0 -> + To.Parsetree.Pstr_open (copy_open_description x0) + | From.Parsetree.Pstr_class x0 -> + To.Parsetree.Pstr_class (List.map copy_class_declaration x0) + | From.Parsetree.Pstr_class_type x0 -> + To.Parsetree.Pstr_class_type (List.map copy_class_type_declaration x0) + | From.Parsetree.Pstr_include x0 -> + To.Parsetree.Pstr_include (copy_include_declaration x0) + | From.Parsetree.Pstr_attribute x0 -> + To.Parsetree.Pstr_attribute (copy_attribute x0) + | From.Parsetree.Pstr_extension (x0, x1) -> + To.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1) + +and copy_include_declaration : + From.Parsetree.include_declaration -> To.Parsetree.include_declaration = + fun x -> copy_include_infos copy_module_expr x + +and copy_class_declaration : + From.Parsetree.class_declaration -> To.Parsetree.class_declaration = + fun x -> copy_class_infos copy_class_expr x + +and copy_class_expr : From.Parsetree.class_expr -> To.Parsetree.class_expr = + fun { + From.Parsetree.pcl_desc; + From.Parsetree.pcl_loc; + From.Parsetree.pcl_attributes; + } -> + { + To.Parsetree.pcl_desc = copy_class_expr_desc pcl_desc; + To.Parsetree.pcl_loc = copy_location pcl_loc; + To.Parsetree.pcl_attributes = copy_attributes pcl_attributes; + } + +and copy_class_expr_desc : + From.Parsetree.class_expr_desc -> To.Parsetree.class_expr_desc = function + | From.Parsetree.Pcl_constr (x0, x1) -> + To.Parsetree.Pcl_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Pcl_structure x0 -> + To.Parsetree.Pcl_structure (copy_class_structure x0) + | From.Parsetree.Pcl_fun (x0, x1, x2, x3) -> + To.Parsetree.Pcl_fun + ( copy_arg_label x0, + copy_option copy_expression x1, + copy_pattern x2, + copy_class_expr x3 ) + | From.Parsetree.Pcl_apply (x0, x1) -> + To.Parsetree.Pcl_apply + ( copy_class_expr x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | From.Parsetree.Pcl_let (x0, x1, x2) -> + To.Parsetree.Pcl_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_class_expr x2) + | From.Parsetree.Pcl_constraint (x0, x1) -> + To.Parsetree.Pcl_constraint (copy_class_expr x0, copy_class_type x1) + | From.Parsetree.Pcl_extension x0 -> + To.Parsetree.Pcl_extension (copy_extension x0) + +and copy_class_structure : + From.Parsetree.class_structure -> To.Parsetree.class_structure = + fun { From.Parsetree.pcstr_self; From.Parsetree.pcstr_fields } -> + { + To.Parsetree.pcstr_self = copy_pattern pcstr_self; + To.Parsetree.pcstr_fields = List.map copy_class_field pcstr_fields; + } + +and copy_class_field : From.Parsetree.class_field -> To.Parsetree.class_field = + fun { + From.Parsetree.pcf_desc; + From.Parsetree.pcf_loc; + From.Parsetree.pcf_attributes; + } -> + { + To.Parsetree.pcf_desc = copy_class_field_desc pcf_desc; + To.Parsetree.pcf_loc = copy_location pcf_loc; + To.Parsetree.pcf_attributes = copy_attributes pcf_attributes; + } + +and copy_class_field_desc : + From.Parsetree.class_field_desc -> To.Parsetree.class_field_desc = function + | From.Parsetree.Pcf_inherit (x0, x1, x2) -> + To.Parsetree.Pcf_inherit + ( copy_override_flag x0, + copy_class_expr x1, + copy_option (fun x -> noloc x) x2 ) + | From.Parsetree.Pcf_val x0 -> + To.Parsetree.Pcf_val + (let x0, x1, x2 = x0 in + ( copy_loc (fun x -> x) x0, + copy_mutable_flag x1, + copy_class_field_kind x2 )) + | From.Parsetree.Pcf_method x0 -> + To.Parsetree.Pcf_method + (let x0, x1, x2 = x0 in + ( copy_loc (fun x -> x) x0, + copy_private_flag x1, + copy_class_field_kind x2 )) + | From.Parsetree.Pcf_constraint x0 -> + To.Parsetree.Pcf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | From.Parsetree.Pcf_initializer x0 -> + To.Parsetree.Pcf_initializer (copy_expression x0) + | From.Parsetree.Pcf_attribute x0 -> + To.Parsetree.Pcf_attribute (copy_attribute x0) + | From.Parsetree.Pcf_extension x0 -> + To.Parsetree.Pcf_extension (copy_extension x0) + +and copy_class_field_kind : + From.Parsetree.class_field_kind -> To.Parsetree.class_field_kind = function + | From.Parsetree.Cfk_virtual x0 -> + To.Parsetree.Cfk_virtual (copy_core_type x0) + | From.Parsetree.Cfk_concrete (x0, x1) -> + To.Parsetree.Cfk_concrete (copy_override_flag x0, copy_expression x1) + +and copy_module_binding : + From.Parsetree.module_binding -> To.Parsetree.module_binding = + fun { + From.Parsetree.pmb_name; + From.Parsetree.pmb_expr; + From.Parsetree.pmb_attributes; + From.Parsetree.pmb_loc; + } -> + { + To.Parsetree.pmb_name = copy_loc (fun x -> x) pmb_name; + To.Parsetree.pmb_expr = copy_module_expr pmb_expr; + To.Parsetree.pmb_attributes = copy_attributes pmb_attributes; + To.Parsetree.pmb_loc = copy_location pmb_loc; + } + +and copy_module_expr : From.Parsetree.module_expr -> To.Parsetree.module_expr = + fun { + From.Parsetree.pmod_desc; + From.Parsetree.pmod_loc; + From.Parsetree.pmod_attributes; + } -> + { + To.Parsetree.pmod_desc = copy_module_expr_desc pmod_desc; + To.Parsetree.pmod_loc = copy_location pmod_loc; + To.Parsetree.pmod_attributes = copy_attributes pmod_attributes; + } + +and copy_module_expr_desc : + From.Parsetree.module_expr_desc -> To.Parsetree.module_expr_desc = function + | From.Parsetree.Pmod_ident x0 -> + To.Parsetree.Pmod_ident (copy_loc copy_longident x0) + | From.Parsetree.Pmod_structure x0 -> + To.Parsetree.Pmod_structure (copy_structure x0) + | From.Parsetree.Pmod_functor (x0, x1, x2) -> + To.Parsetree.Pmod_functor + ( copy_loc (fun x -> x) x0, + copy_option copy_module_type x1, + copy_module_expr x2 ) + | From.Parsetree.Pmod_apply (x0, x1) -> + To.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) + | From.Parsetree.Pmod_constraint (x0, x1) -> + To.Parsetree.Pmod_constraint (copy_module_expr x0, copy_module_type x1) + | From.Parsetree.Pmod_unpack x0 -> + To.Parsetree.Pmod_unpack (copy_expression x0) + | From.Parsetree.Pmod_extension x0 -> + To.Parsetree.Pmod_extension (copy_extension x0) + +and copy_module_type : From.Parsetree.module_type -> To.Parsetree.module_type = + fun { + From.Parsetree.pmty_desc; + From.Parsetree.pmty_loc; + From.Parsetree.pmty_attributes; + } -> + { + To.Parsetree.pmty_desc = copy_module_type_desc pmty_desc; + To.Parsetree.pmty_loc = copy_location pmty_loc; + To.Parsetree.pmty_attributes = copy_attributes pmty_attributes; + } + +and copy_module_type_desc : + From.Parsetree.module_type_desc -> To.Parsetree.module_type_desc = function + | From.Parsetree.Pmty_ident x0 -> + To.Parsetree.Pmty_ident (copy_loc copy_longident x0) + | From.Parsetree.Pmty_signature x0 -> + To.Parsetree.Pmty_signature (copy_signature x0) + | From.Parsetree.Pmty_functor (x0, x1, x2) -> + To.Parsetree.Pmty_functor + ( copy_loc (fun x -> x) x0, + copy_option copy_module_type x1, + copy_module_type x2 ) + | From.Parsetree.Pmty_with (x0, x1) -> + To.Parsetree.Pmty_with + (copy_module_type x0, List.map copy_with_constraint x1) + | From.Parsetree.Pmty_typeof x0 -> + To.Parsetree.Pmty_typeof (copy_module_expr x0) + | From.Parsetree.Pmty_extension x0 -> + To.Parsetree.Pmty_extension (copy_extension x0) + | From.Parsetree.Pmty_alias x0 -> + To.Parsetree.Pmty_alias (copy_loc copy_longident x0) + +and copy_with_constraint : + From.Parsetree.with_constraint -> To.Parsetree.with_constraint = function + | From.Parsetree.Pwith_type (x0, x1) -> + To.Parsetree.Pwith_type + (copy_loc copy_longident x0, copy_type_declaration x1) + | From.Parsetree.Pwith_module (x0, x1) -> + To.Parsetree.Pwith_module + (copy_loc copy_longident x0, copy_loc copy_longident x1) + | From.Parsetree.Pwith_typesubst x0 -> + To.Parsetree.Pwith_typesubst (copy_type_declaration x0) + | From.Parsetree.Pwith_modsubst (x0, x1) -> + To.Parsetree.Pwith_modsubst + (copy_loc (fun x -> x) x0, copy_loc copy_longident x1) + +and copy_signature : From.Parsetree.signature -> To.Parsetree.signature = + fun x -> List.map copy_signature_item x + +and copy_signature_item : + From.Parsetree.signature_item -> To.Parsetree.signature_item = + fun { From.Parsetree.psig_desc; From.Parsetree.psig_loc } -> + { + To.Parsetree.psig_desc = copy_signature_item_desc psig_desc; + To.Parsetree.psig_loc = copy_location psig_loc; + } + +and copy_signature_item_desc : + From.Parsetree.signature_item_desc -> To.Parsetree.signature_item_desc = + function + | From.Parsetree.Psig_value x0 -> + To.Parsetree.Psig_value (copy_value_description x0) + | From.Parsetree.Psig_type (x0, x1) -> + To.Parsetree.Psig_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | From.Parsetree.Psig_typext x0 -> + To.Parsetree.Psig_typext (copy_type_extension x0) + | From.Parsetree.Psig_exception x0 -> + To.Parsetree.Psig_exception (copy_extension_constructor x0) + | From.Parsetree.Psig_module x0 -> + To.Parsetree.Psig_module (copy_module_declaration x0) + | From.Parsetree.Psig_recmodule x0 -> + To.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) + | From.Parsetree.Psig_modtype x0 -> + To.Parsetree.Psig_modtype (copy_module_type_declaration x0) + | From.Parsetree.Psig_open x0 -> + To.Parsetree.Psig_open (copy_open_description x0) + | From.Parsetree.Psig_include x0 -> + To.Parsetree.Psig_include (copy_include_description x0) + | From.Parsetree.Psig_class x0 -> + To.Parsetree.Psig_class (List.map copy_class_description x0) + | From.Parsetree.Psig_class_type x0 -> + To.Parsetree.Psig_class_type (List.map copy_class_type_declaration x0) + | From.Parsetree.Psig_attribute x0 -> + To.Parsetree.Psig_attribute (copy_attribute x0) + | From.Parsetree.Psig_extension (x0, x1) -> + To.Parsetree.Psig_extension (copy_extension x0, copy_attributes x1) + +and copy_class_type_declaration : + From.Parsetree.class_type_declaration -> To.Parsetree.class_type_declaration + = + fun x -> copy_class_infos copy_class_type x + +and copy_class_description : + From.Parsetree.class_description -> To.Parsetree.class_description = + fun x -> copy_class_infos copy_class_type x + +and copy_class_type : From.Parsetree.class_type -> To.Parsetree.class_type = + fun { + From.Parsetree.pcty_desc; + From.Parsetree.pcty_loc; + From.Parsetree.pcty_attributes; + } -> + { + To.Parsetree.pcty_desc = copy_class_type_desc pcty_desc; + To.Parsetree.pcty_loc = copy_location pcty_loc; + To.Parsetree.pcty_attributes = copy_attributes pcty_attributes; + } + +and copy_class_type_desc : + From.Parsetree.class_type_desc -> To.Parsetree.class_type_desc = function + | From.Parsetree.Pcty_constr (x0, x1) -> + To.Parsetree.Pcty_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Pcty_signature x0 -> + To.Parsetree.Pcty_signature (copy_class_signature x0) + | From.Parsetree.Pcty_arrow (x0, x1, x2) -> + To.Parsetree.Pcty_arrow + (copy_arg_label x0, copy_core_type x1, copy_class_type x2) + | From.Parsetree.Pcty_extension x0 -> + To.Parsetree.Pcty_extension (copy_extension x0) + +and copy_class_signature : + From.Parsetree.class_signature -> To.Parsetree.class_signature = + fun { From.Parsetree.pcsig_self; From.Parsetree.pcsig_fields } -> + { + To.Parsetree.pcsig_self = copy_core_type pcsig_self; + To.Parsetree.pcsig_fields = List.map copy_class_type_field pcsig_fields; + } + +and copy_class_type_field : + From.Parsetree.class_type_field -> To.Parsetree.class_type_field = + fun { + From.Parsetree.pctf_desc; + From.Parsetree.pctf_loc; + From.Parsetree.pctf_attributes; + } -> + { + To.Parsetree.pctf_desc = copy_class_type_field_desc pctf_desc; + To.Parsetree.pctf_loc = copy_location pctf_loc; + To.Parsetree.pctf_attributes = copy_attributes pctf_attributes; + } + +and copy_class_type_field_desc : + From.Parsetree.class_type_field_desc -> To.Parsetree.class_type_field_desc = + function + | From.Parsetree.Pctf_inherit x0 -> + To.Parsetree.Pctf_inherit (copy_class_type x0) + | From.Parsetree.Pctf_val x0 -> + To.Parsetree.Pctf_val + (let x0, x1, x2, x3 = x0 in + ( noloc x0, + copy_mutable_flag x1, + copy_virtual_flag x2, + copy_core_type x3 )) + | From.Parsetree.Pctf_method x0 -> + To.Parsetree.Pctf_method + (let x0, x1, x2, x3 = x0 in + ( noloc x0, + copy_private_flag x1, + copy_virtual_flag x2, + copy_core_type x3 )) + | From.Parsetree.Pctf_constraint x0 -> + To.Parsetree.Pctf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | From.Parsetree.Pctf_attribute x0 -> + To.Parsetree.Pctf_attribute (copy_attribute x0) + | From.Parsetree.Pctf_extension x0 -> + To.Parsetree.Pctf_extension (copy_extension x0) + +and copy_extension : From.Parsetree.extension -> To.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 From.Parsetree.class_infos -> + 'g0 To.Parsetree.class_infos = + fun f0 + { + From.Parsetree.pci_virt; + From.Parsetree.pci_params; + From.Parsetree.pci_name; + From.Parsetree.pci_expr; + From.Parsetree.pci_loc; + From.Parsetree.pci_attributes; + } -> + { + To.Parsetree.pci_virt = copy_virtual_flag pci_virt; + To.Parsetree.pci_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + pci_params; + To.Parsetree.pci_name = copy_loc (fun x -> x) pci_name; + To.Parsetree.pci_expr = f0 pci_expr; + To.Parsetree.pci_loc = copy_location pci_loc; + To.Parsetree.pci_attributes = copy_attributes pci_attributes; + } + +and copy_virtual_flag : From.Asttypes.virtual_flag -> To.Asttypes.virtual_flag = + function + | From.Asttypes.Virtual -> To.Asttypes.Virtual + | From.Asttypes.Concrete -> To.Asttypes.Concrete + +and copy_include_description : + From.Parsetree.include_description -> To.Parsetree.include_description = + fun x -> copy_include_infos copy_module_type x + +and copy_include_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 From.Parsetree.include_infos -> + 'g0 To.Parsetree.include_infos = + fun f0 + { + From.Parsetree.pincl_mod; + From.Parsetree.pincl_loc; + From.Parsetree.pincl_attributes; + } -> + { + To.Parsetree.pincl_mod = f0 pincl_mod; + To.Parsetree.pincl_loc = copy_location pincl_loc; + To.Parsetree.pincl_attributes = copy_attributes pincl_attributes; + } + +and copy_open_description : + From.Parsetree.open_description -> To.Parsetree.open_description = + fun { + From.Parsetree.popen_lid; + From.Parsetree.popen_override; + From.Parsetree.popen_loc; + From.Parsetree.popen_attributes; + } -> + { + To.Parsetree.popen_lid = copy_loc copy_longident popen_lid; + To.Parsetree.popen_override = copy_override_flag popen_override; + To.Parsetree.popen_loc = copy_location popen_loc; + To.Parsetree.popen_attributes = copy_attributes popen_attributes; + } + +and copy_override_flag : + From.Asttypes.override_flag -> To.Asttypes.override_flag = function + | From.Asttypes.Override -> To.Asttypes.Override + | From.Asttypes.Fresh -> To.Asttypes.Fresh + +and copy_module_type_declaration : + From.Parsetree.module_type_declaration -> + To.Parsetree.module_type_declaration = + fun { + From.Parsetree.pmtd_name; + From.Parsetree.pmtd_type; + From.Parsetree.pmtd_attributes; + From.Parsetree.pmtd_loc; + } -> + { + To.Parsetree.pmtd_name = copy_loc (fun x -> x) pmtd_name; + To.Parsetree.pmtd_type = copy_option copy_module_type pmtd_type; + To.Parsetree.pmtd_attributes = copy_attributes pmtd_attributes; + To.Parsetree.pmtd_loc = copy_location pmtd_loc; + } + +and copy_module_declaration : + From.Parsetree.module_declaration -> To.Parsetree.module_declaration = + fun { + From.Parsetree.pmd_name; + From.Parsetree.pmd_type; + From.Parsetree.pmd_attributes; + From.Parsetree.pmd_loc; + } -> + { + To.Parsetree.pmd_name = copy_loc (fun x -> x) pmd_name; + To.Parsetree.pmd_type = copy_module_type pmd_type; + To.Parsetree.pmd_attributes = copy_attributes pmd_attributes; + To.Parsetree.pmd_loc = copy_location pmd_loc; + } + +and copy_type_extension : + From.Parsetree.type_extension -> To.Parsetree.type_extension = + fun { + From.Parsetree.ptyext_path; + From.Parsetree.ptyext_params; + From.Parsetree.ptyext_constructors; + From.Parsetree.ptyext_private; + From.Parsetree.ptyext_attributes; + } -> + { + To.Parsetree.ptyext_path = copy_loc copy_longident ptyext_path; + To.Parsetree.ptyext_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptyext_params; + To.Parsetree.ptyext_constructors = + List.map copy_extension_constructor ptyext_constructors; + To.Parsetree.ptyext_private = copy_private_flag ptyext_private; + To.Parsetree.ptyext_attributes = copy_attributes ptyext_attributes; + } + +and copy_extension_constructor : + From.Parsetree.extension_constructor -> To.Parsetree.extension_constructor = + fun { + From.Parsetree.pext_name; + From.Parsetree.pext_kind; + From.Parsetree.pext_loc; + From.Parsetree.pext_attributes; + } -> + { + To.Parsetree.pext_name = copy_loc (fun x -> x) pext_name; + To.Parsetree.pext_kind = copy_extension_constructor_kind pext_kind; + To.Parsetree.pext_loc = copy_location pext_loc; + To.Parsetree.pext_attributes = copy_attributes pext_attributes; + } + +and copy_extension_constructor_kind : + From.Parsetree.extension_constructor_kind -> + To.Parsetree.extension_constructor_kind = function + | From.Parsetree.Pext_decl (x0, x1) -> + To.Parsetree.Pext_decl + (copy_constructor_arguments x0, copy_option copy_core_type x1) + | From.Parsetree.Pext_rebind x0 -> + To.Parsetree.Pext_rebind (copy_loc copy_longident x0) + +and copy_type_declaration : + From.Parsetree.type_declaration -> To.Parsetree.type_declaration = + fun { + From.Parsetree.ptype_name; + From.Parsetree.ptype_params; + From.Parsetree.ptype_cstrs; + From.Parsetree.ptype_kind; + From.Parsetree.ptype_private; + From.Parsetree.ptype_manifest; + From.Parsetree.ptype_attributes; + From.Parsetree.ptype_loc; + } -> + { + To.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name; + To.Parsetree.ptype_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptype_params; + To.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; + To.Parsetree.ptype_kind = copy_type_kind ptype_kind; + To.Parsetree.ptype_private = copy_private_flag ptype_private; + To.Parsetree.ptype_manifest = copy_option copy_core_type ptype_manifest; + To.Parsetree.ptype_attributes = copy_attributes ptype_attributes; + To.Parsetree.ptype_loc = copy_location ptype_loc; + } + +and copy_private_flag : From.Asttypes.private_flag -> To.Asttypes.private_flag = + function + | From.Asttypes.Private -> To.Asttypes.Private + | From.Asttypes.Public -> To.Asttypes.Public + +and copy_type_kind : From.Parsetree.type_kind -> To.Parsetree.type_kind = + function + | From.Parsetree.Ptype_abstract -> To.Parsetree.Ptype_abstract + | From.Parsetree.Ptype_variant x0 -> + To.Parsetree.Ptype_variant (List.map copy_constructor_declaration x0) + | From.Parsetree.Ptype_record x0 -> + To.Parsetree.Ptype_record (List.map copy_label_declaration x0) + | From.Parsetree.Ptype_open -> To.Parsetree.Ptype_open + +and copy_constructor_declaration : + From.Parsetree.constructor_declaration -> + To.Parsetree.constructor_declaration = + fun { + From.Parsetree.pcd_name; + From.Parsetree.pcd_args; + From.Parsetree.pcd_res; + From.Parsetree.pcd_loc; + From.Parsetree.pcd_attributes; + } -> + { + To.Parsetree.pcd_name = copy_loc (fun x -> x) pcd_name; + To.Parsetree.pcd_args = copy_constructor_arguments pcd_args; + To.Parsetree.pcd_res = copy_option copy_core_type pcd_res; + To.Parsetree.pcd_loc = copy_location pcd_loc; + To.Parsetree.pcd_attributes = copy_attributes pcd_attributes; + } + +and copy_constructor_arguments : + From.Parsetree.constructor_arguments -> To.Parsetree.constructor_arguments = + function + | From.Parsetree.Pcstr_tuple x0 -> + To.Parsetree.Pcstr_tuple (List.map copy_core_type x0) + | From.Parsetree.Pcstr_record x0 -> + To.Parsetree.Pcstr_record (List.map copy_label_declaration x0) + +and copy_label_declaration : + From.Parsetree.label_declaration -> To.Parsetree.label_declaration = + fun { + From.Parsetree.pld_name; + From.Parsetree.pld_mutable; + From.Parsetree.pld_type; + From.Parsetree.pld_loc; + From.Parsetree.pld_attributes; + } -> + { + To.Parsetree.pld_name = copy_loc (fun x -> x) pld_name; + To.Parsetree.pld_mutable = copy_mutable_flag pld_mutable; + To.Parsetree.pld_type = copy_core_type pld_type; + To.Parsetree.pld_loc = copy_location pld_loc; + To.Parsetree.pld_attributes = copy_attributes pld_attributes; + } + +and copy_mutable_flag : From.Asttypes.mutable_flag -> To.Asttypes.mutable_flag = + function + | From.Asttypes.Immutable -> To.Asttypes.Immutable + | From.Asttypes.Mutable -> To.Asttypes.Mutable + +and copy_variance : From.Asttypes.variance -> To.Asttypes.variance = function + | From.Asttypes.Covariant -> To.Asttypes.Covariant + | From.Asttypes.Contravariant -> To.Asttypes.Contravariant + | From.Asttypes.Invariant -> To.Asttypes.Invariant + +and copy_value_description : + From.Parsetree.value_description -> To.Parsetree.value_description = + fun { + From.Parsetree.pval_name; + From.Parsetree.pval_type; + From.Parsetree.pval_prim; + From.Parsetree.pval_attributes; + From.Parsetree.pval_loc; + } -> + { + To.Parsetree.pval_name = copy_loc (fun x -> x) pval_name; + To.Parsetree.pval_type = copy_core_type pval_type; + To.Parsetree.pval_prim = List.map (fun x -> x) pval_prim; + To.Parsetree.pval_attributes = copy_attributes pval_attributes; + To.Parsetree.pval_loc = copy_location pval_loc; + } + +and copy_arg_label : From.Asttypes.arg_label -> To.Asttypes.arg_label = function + | From.Asttypes.Nolabel -> To.Asttypes.Nolabel + | From.Asttypes.Labelled x0 -> To.Asttypes.Labelled x0 + | From.Asttypes.Optional x0 -> To.Asttypes.Optional x0 + +and copy_closed_flag : From.Asttypes.closed_flag -> To.Asttypes.closed_flag = + function + | From.Asttypes.Closed -> To.Asttypes.Closed + | From.Asttypes.Open -> To.Asttypes.Open + +and copy_label : From.Asttypes.label -> To.Asttypes.label = fun x -> x + +and copy_rec_flag : From.Asttypes.rec_flag -> To.Asttypes.rec_flag = function + | From.Asttypes.Nonrecursive -> To.Asttypes.Nonrecursive + | From.Asttypes.Recursive -> To.Asttypes.Recursive + +and copy_constant : From.Parsetree.constant -> To.Parsetree.constant = function + | From.Parsetree.Pconst_integer (x0, x1) -> + To.Parsetree.Pconst_integer (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pconst_char x0 -> To.Parsetree.Pconst_char x0 + | From.Parsetree.Pconst_string (x0, x1) -> + To.Parsetree.Pconst_string (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pconst_float (x0, x1) -> + To.Parsetree.Pconst_float (x0, copy_option (fun x -> x) x1) + +and copy_option : 'f0 'g0. ('f0 -> 'g0) -> 'f0 option -> 'g0 option = + fun f0 -> function None -> None | Some x0 -> Some (f0 x0) + +and copy_longident : Longident.t -> Longident.t = fun x -> x + +and copy_loc : + 'f0 'g0. ('f0 -> 'g0) -> 'f0 From.Asttypes.loc -> 'g0 To.Asttypes.loc = + fun f0 { From.Asttypes.txt; From.Asttypes.loc } -> + { To.Asttypes.txt = f0 txt; To.Asttypes.loc = copy_location loc } + +and copy_location : Location.t -> Location.t = fun x -> x + +and copy_bool : bool -> bool = function false -> false | true -> true + +let rec copy_toplevel_phrase : + From.Parsetree.toplevel_phrase -> To.Parsetree.toplevel_phrase = function + | From.Parsetree.Ptop_def x0 -> To.Parsetree.Ptop_def (copy_structure x0) + | From.Parsetree.Ptop_dir (x0, x1) -> + To.Parsetree.Ptop_dir (x0, copy_directive_argument x1) + +and copy_directive_argument : + From.Parsetree.directive_argument -> To.Parsetree.directive_argument = + function + | From.Parsetree.Pdir_none -> To.Parsetree.Pdir_none + | From.Parsetree.Pdir_string x0 -> To.Parsetree.Pdir_string x0 + | From.Parsetree.Pdir_int (x0, x1) -> + To.Parsetree.Pdir_int (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pdir_ident x0 -> To.Parsetree.Pdir_ident (copy_longident x0) + | From.Parsetree.Pdir_bool x0 -> To.Parsetree.Pdir_bool (copy_bool x0) + +let copy_cases x = List.map copy_case x + +let copy_pat = copy_pattern + +let copy_expr = copy_expression + +let copy_typ = copy_core_type diff -Nru ppxlib-0.15.0/astlib/migrate_405_404.ml ppxlib-0.24.0/astlib/migrate_405_404.ml --- ppxlib-0.15.0/astlib/migrate_405_404.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/migrate_405_404.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1014 @@ +(**************************************************************************) +(* *) +(* OCaml Migrate Parsetree *) +(* *) +(* Frédéric Bour *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2017 Institut National de Recherche en Informatique et *) +(* en Automatique (INRIA). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module From = Ast_405 +module To = Ast_404 + +let rec copy_expression : From.Parsetree.expression -> To.Parsetree.expression = + fun { + From.Parsetree.pexp_desc; + From.Parsetree.pexp_loc; + From.Parsetree.pexp_attributes; + } -> + { + To.Parsetree.pexp_desc = copy_expression_desc pexp_desc; + To.Parsetree.pexp_loc = copy_location pexp_loc; + To.Parsetree.pexp_attributes = copy_attributes pexp_attributes; + } + +and copy_expression_desc : + From.Parsetree.expression_desc -> To.Parsetree.expression_desc = function + | From.Parsetree.Pexp_ident x0 -> + To.Parsetree.Pexp_ident (copy_loc copy_longident x0) + | From.Parsetree.Pexp_constant x0 -> + To.Parsetree.Pexp_constant (copy_constant x0) + | From.Parsetree.Pexp_let (x0, x1, x2) -> + To.Parsetree.Pexp_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_expression x2) + | From.Parsetree.Pexp_function x0 -> + To.Parsetree.Pexp_function (List.map copy_case x0) + | From.Parsetree.Pexp_fun (x0, x1, x2, x3) -> + To.Parsetree.Pexp_fun + ( copy_arg_label x0, + copy_option copy_expression x1, + copy_pattern x2, + copy_expression x3 ) + | From.Parsetree.Pexp_apply (x0, x1) -> + To.Parsetree.Pexp_apply + ( copy_expression x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | From.Parsetree.Pexp_match (x0, x1) -> + To.Parsetree.Pexp_match (copy_expression x0, List.map copy_case x1) + | From.Parsetree.Pexp_try (x0, x1) -> + To.Parsetree.Pexp_try (copy_expression x0, List.map copy_case x1) + | From.Parsetree.Pexp_tuple x0 -> + To.Parsetree.Pexp_tuple (List.map copy_expression x0) + | From.Parsetree.Pexp_construct (x0, x1) -> + To.Parsetree.Pexp_construct + (copy_loc copy_longident x0, copy_option copy_expression x1) + | From.Parsetree.Pexp_variant (x0, x1) -> + To.Parsetree.Pexp_variant (copy_label x0, copy_option copy_expression x1) + | From.Parsetree.Pexp_record (x0, x1) -> + To.Parsetree.Pexp_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_expression x1)) + x0, + copy_option copy_expression x1 ) + | From.Parsetree.Pexp_field (x0, x1) -> + To.Parsetree.Pexp_field (copy_expression x0, copy_loc copy_longident x1) + | From.Parsetree.Pexp_setfield (x0, x1, x2) -> + To.Parsetree.Pexp_setfield + (copy_expression x0, copy_loc copy_longident x1, copy_expression x2) + | From.Parsetree.Pexp_array x0 -> + To.Parsetree.Pexp_array (List.map copy_expression x0) + | From.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> + To.Parsetree.Pexp_ifthenelse + (copy_expression x0, copy_expression x1, copy_option copy_expression x2) + | From.Parsetree.Pexp_sequence (x0, x1) -> + To.Parsetree.Pexp_sequence (copy_expression x0, copy_expression x1) + | From.Parsetree.Pexp_while (x0, x1) -> + To.Parsetree.Pexp_while (copy_expression x0, copy_expression x1) + | From.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> + To.Parsetree.Pexp_for + ( copy_pattern x0, + copy_expression x1, + copy_expression x2, + copy_direction_flag x3, + copy_expression x4 ) + | From.Parsetree.Pexp_constraint (x0, x1) -> + To.Parsetree.Pexp_constraint (copy_expression x0, copy_core_type x1) + | From.Parsetree.Pexp_coerce (x0, x1, x2) -> + To.Parsetree.Pexp_coerce + (copy_expression x0, copy_option copy_core_type x1, copy_core_type x2) + | From.Parsetree.Pexp_send (x0, x1) -> + To.Parsetree.Pexp_send (copy_expression x0, x1.From.Asttypes.txt) + | From.Parsetree.Pexp_new x0 -> + To.Parsetree.Pexp_new (copy_loc copy_longident x0) + | From.Parsetree.Pexp_setinstvar (x0, x1) -> + To.Parsetree.Pexp_setinstvar (copy_loc (fun x -> x) x0, copy_expression x1) + | From.Parsetree.Pexp_override x0 -> + To.Parsetree.Pexp_override + (List.map + (fun x -> + let x0, x1 = x in + (copy_loc (fun x -> x) x0, copy_expression x1)) + x0) + | From.Parsetree.Pexp_letmodule (x0, x1, x2) -> + To.Parsetree.Pexp_letmodule + (copy_loc (fun x -> x) x0, copy_module_expr x1, copy_expression x2) + | From.Parsetree.Pexp_letexception (x0, x1) -> + To.Parsetree.Pexp_letexception + (copy_extension_constructor x0, copy_expression x1) + | From.Parsetree.Pexp_assert x0 -> + To.Parsetree.Pexp_assert (copy_expression x0) + | From.Parsetree.Pexp_lazy x0 -> To.Parsetree.Pexp_lazy (copy_expression x0) + | From.Parsetree.Pexp_poly (x0, x1) -> + To.Parsetree.Pexp_poly (copy_expression x0, copy_option copy_core_type x1) + | From.Parsetree.Pexp_object x0 -> + To.Parsetree.Pexp_object (copy_class_structure x0) + | From.Parsetree.Pexp_newtype (x0, x1) -> + To.Parsetree.Pexp_newtype (x0.From.Asttypes.txt, copy_expression x1) + | From.Parsetree.Pexp_pack x0 -> To.Parsetree.Pexp_pack (copy_module_expr x0) + | From.Parsetree.Pexp_open (x0, x1, x2) -> + To.Parsetree.Pexp_open + (copy_override_flag x0, copy_loc copy_longident x1, copy_expression x2) + | From.Parsetree.Pexp_extension x0 -> + To.Parsetree.Pexp_extension (copy_extension x0) + | From.Parsetree.Pexp_unreachable -> To.Parsetree.Pexp_unreachable + +and copy_direction_flag : + From.Asttypes.direction_flag -> To.Asttypes.direction_flag = function + | From.Asttypes.Upto -> To.Asttypes.Upto + | From.Asttypes.Downto -> To.Asttypes.Downto + +and copy_case : From.Parsetree.case -> To.Parsetree.case = + fun { From.Parsetree.pc_lhs; From.Parsetree.pc_guard; From.Parsetree.pc_rhs } -> + { + To.Parsetree.pc_lhs = copy_pattern pc_lhs; + To.Parsetree.pc_guard = copy_option copy_expression pc_guard; + To.Parsetree.pc_rhs = copy_expression pc_rhs; + } + +and copy_value_binding : + From.Parsetree.value_binding -> To.Parsetree.value_binding = + fun { + From.Parsetree.pvb_pat; + From.Parsetree.pvb_expr; + From.Parsetree.pvb_attributes; + From.Parsetree.pvb_loc; + } -> + { + To.Parsetree.pvb_pat = copy_pattern pvb_pat; + To.Parsetree.pvb_expr = copy_expression pvb_expr; + To.Parsetree.pvb_attributes = copy_attributes pvb_attributes; + To.Parsetree.pvb_loc = copy_location pvb_loc; + } + +and copy_pattern : From.Parsetree.pattern -> To.Parsetree.pattern = + fun { + From.Parsetree.ppat_desc; + From.Parsetree.ppat_loc; + From.Parsetree.ppat_attributes; + } -> + { + To.Parsetree.ppat_desc = copy_pattern_desc ppat_desc; + To.Parsetree.ppat_loc = copy_location ppat_loc; + To.Parsetree.ppat_attributes = copy_attributes ppat_attributes; + } + +and copy_pattern_desc : From.Parsetree.pattern_desc -> To.Parsetree.pattern_desc + = function + | From.Parsetree.Ppat_any -> To.Parsetree.Ppat_any + | From.Parsetree.Ppat_var x0 -> + To.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) + | From.Parsetree.Ppat_alias (x0, x1) -> + To.Parsetree.Ppat_alias (copy_pattern x0, copy_loc (fun x -> x) x1) + | From.Parsetree.Ppat_constant x0 -> + To.Parsetree.Ppat_constant (copy_constant x0) + | From.Parsetree.Ppat_interval (x0, x1) -> + To.Parsetree.Ppat_interval (copy_constant x0, copy_constant x1) + | From.Parsetree.Ppat_tuple x0 -> + To.Parsetree.Ppat_tuple (List.map copy_pattern x0) + | From.Parsetree.Ppat_construct (x0, x1) -> + To.Parsetree.Ppat_construct + (copy_loc copy_longident x0, copy_option copy_pattern x1) + | From.Parsetree.Ppat_variant (x0, x1) -> + To.Parsetree.Ppat_variant (copy_label x0, copy_option copy_pattern x1) + | From.Parsetree.Ppat_record (x0, x1) -> + To.Parsetree.Ppat_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_pattern x1)) + x0, + copy_closed_flag x1 ) + | From.Parsetree.Ppat_array x0 -> + To.Parsetree.Ppat_array (List.map copy_pattern x0) + | From.Parsetree.Ppat_or (x0, x1) -> + To.Parsetree.Ppat_or (copy_pattern x0, copy_pattern x1) + | From.Parsetree.Ppat_constraint (x0, x1) -> + To.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1) + | From.Parsetree.Ppat_type x0 -> + To.Parsetree.Ppat_type (copy_loc copy_longident x0) + | From.Parsetree.Ppat_lazy x0 -> To.Parsetree.Ppat_lazy (copy_pattern x0) + | From.Parsetree.Ppat_unpack x0 -> + To.Parsetree.Ppat_unpack (copy_loc (fun x -> x) x0) + | From.Parsetree.Ppat_exception x0 -> + To.Parsetree.Ppat_exception (copy_pattern x0) + | From.Parsetree.Ppat_extension x0 -> + To.Parsetree.Ppat_extension (copy_extension x0) + | From.Parsetree.Ppat_open (x0, x1) -> + To.Parsetree.Ppat_open (copy_loc copy_longident x0, copy_pattern x1) + +and copy_core_type : From.Parsetree.core_type -> To.Parsetree.core_type = + fun { + From.Parsetree.ptyp_desc; + From.Parsetree.ptyp_loc; + From.Parsetree.ptyp_attributes; + } -> + { + To.Parsetree.ptyp_desc = copy_core_type_desc ptyp_desc; + To.Parsetree.ptyp_loc = copy_location ptyp_loc; + To.Parsetree.ptyp_attributes = copy_attributes ptyp_attributes; + } + +and copy_core_type_desc : + From.Parsetree.core_type_desc -> To.Parsetree.core_type_desc = function + | From.Parsetree.Ptyp_any -> To.Parsetree.Ptyp_any + | From.Parsetree.Ptyp_var x0 -> To.Parsetree.Ptyp_var x0 + | From.Parsetree.Ptyp_arrow (x0, x1, x2) -> + To.Parsetree.Ptyp_arrow + (copy_arg_label x0, copy_core_type x1, copy_core_type x2) + | From.Parsetree.Ptyp_tuple x0 -> + To.Parsetree.Ptyp_tuple (List.map copy_core_type x0) + | From.Parsetree.Ptyp_constr (x0, x1) -> + To.Parsetree.Ptyp_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Ptyp_object (x0, x1) -> + To.Parsetree.Ptyp_object + ( List.map + (fun x -> + let x0, x1, x2 = x in + (x0.From.Asttypes.txt, copy_attributes x1, copy_core_type x2)) + x0, + copy_closed_flag x1 ) + | From.Parsetree.Ptyp_class (x0, x1) -> + To.Parsetree.Ptyp_class + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Ptyp_alias (x0, x1) -> + To.Parsetree.Ptyp_alias (copy_core_type x0, x1) + | From.Parsetree.Ptyp_variant (x0, x1, x2) -> + To.Parsetree.Ptyp_variant + ( List.map copy_row_field x0, + copy_closed_flag x1, + copy_option (fun x -> List.map copy_label x) x2 ) + | From.Parsetree.Ptyp_poly (x0, x1) -> + To.Parsetree.Ptyp_poly + (List.map (fun x -> x.From.Asttypes.txt) x0, copy_core_type x1) + | From.Parsetree.Ptyp_package x0 -> + To.Parsetree.Ptyp_package (copy_package_type x0) + | From.Parsetree.Ptyp_extension x0 -> + To.Parsetree.Ptyp_extension (copy_extension x0) + +and copy_package_type : From.Parsetree.package_type -> To.Parsetree.package_type + = + fun x -> + let x0, x1 = x in + ( copy_loc copy_longident x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_core_type x1)) + x1 ) + +and copy_row_field : From.Parsetree.row_field -> To.Parsetree.row_field = + function + | From.Parsetree.Rtag (x0, x1, x2, x3) -> + To.Parsetree.Rtag + ( copy_label x0, + copy_attributes x1, + copy_bool x2, + List.map copy_core_type x3 ) + | From.Parsetree.Rinherit x0 -> To.Parsetree.Rinherit (copy_core_type x0) + +and copy_attributes : From.Parsetree.attributes -> To.Parsetree.attributes = + fun x -> List.map copy_attribute x + +and copy_attribute : From.Parsetree.attribute -> To.Parsetree.attribute = + fun x -> + let x0, x1 = x in + (copy_loc (fun x -> x) x0, copy_payload x1) + +and copy_payload : From.Parsetree.payload -> To.Parsetree.payload = function + | From.Parsetree.PStr x0 -> To.Parsetree.PStr (copy_structure x0) + | From.Parsetree.PSig x0 -> To.Parsetree.PSig (copy_signature x0) + | From.Parsetree.PTyp x0 -> To.Parsetree.PTyp (copy_core_type x0) + | From.Parsetree.PPat (x0, x1) -> + To.Parsetree.PPat (copy_pattern x0, copy_option copy_expression x1) + +and copy_structure : From.Parsetree.structure -> To.Parsetree.structure = + fun x -> List.map copy_structure_item x + +and copy_structure_item : + From.Parsetree.structure_item -> To.Parsetree.structure_item = + fun { From.Parsetree.pstr_desc; From.Parsetree.pstr_loc } -> + { + To.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc; + To.Parsetree.pstr_loc = copy_location pstr_loc; + } + +and copy_structure_item_desc : + From.Parsetree.structure_item_desc -> To.Parsetree.structure_item_desc = + function + | From.Parsetree.Pstr_eval (x0, x1) -> + To.Parsetree.Pstr_eval (copy_expression x0, copy_attributes x1) + | From.Parsetree.Pstr_value (x0, x1) -> + To.Parsetree.Pstr_value (copy_rec_flag x0, List.map copy_value_binding x1) + | From.Parsetree.Pstr_primitive x0 -> + To.Parsetree.Pstr_primitive (copy_value_description x0) + | From.Parsetree.Pstr_type (x0, x1) -> + To.Parsetree.Pstr_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | From.Parsetree.Pstr_typext x0 -> + To.Parsetree.Pstr_typext (copy_type_extension x0) + | From.Parsetree.Pstr_exception x0 -> + To.Parsetree.Pstr_exception (copy_extension_constructor x0) + | From.Parsetree.Pstr_module x0 -> + To.Parsetree.Pstr_module (copy_module_binding x0) + | From.Parsetree.Pstr_recmodule x0 -> + To.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) + | From.Parsetree.Pstr_modtype x0 -> + To.Parsetree.Pstr_modtype (copy_module_type_declaration x0) + | From.Parsetree.Pstr_open x0 -> + To.Parsetree.Pstr_open (copy_open_description x0) + | From.Parsetree.Pstr_class x0 -> + To.Parsetree.Pstr_class (List.map copy_class_declaration x0) + | From.Parsetree.Pstr_class_type x0 -> + To.Parsetree.Pstr_class_type (List.map copy_class_type_declaration x0) + | From.Parsetree.Pstr_include x0 -> + To.Parsetree.Pstr_include (copy_include_declaration x0) + | From.Parsetree.Pstr_attribute x0 -> + To.Parsetree.Pstr_attribute (copy_attribute x0) + | From.Parsetree.Pstr_extension (x0, x1) -> + To.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1) + +and copy_include_declaration : + From.Parsetree.include_declaration -> To.Parsetree.include_declaration = + fun x -> copy_include_infos copy_module_expr x + +and copy_class_declaration : + From.Parsetree.class_declaration -> To.Parsetree.class_declaration = + fun x -> copy_class_infos copy_class_expr x + +and copy_class_expr : From.Parsetree.class_expr -> To.Parsetree.class_expr = + fun { + From.Parsetree.pcl_desc; + From.Parsetree.pcl_loc; + From.Parsetree.pcl_attributes; + } -> + { + To.Parsetree.pcl_desc = copy_class_expr_desc pcl_desc; + To.Parsetree.pcl_loc = copy_location pcl_loc; + To.Parsetree.pcl_attributes = copy_attributes pcl_attributes; + } + +and copy_class_expr_desc : + From.Parsetree.class_expr_desc -> To.Parsetree.class_expr_desc = function + | From.Parsetree.Pcl_constr (x0, x1) -> + To.Parsetree.Pcl_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Pcl_structure x0 -> + To.Parsetree.Pcl_structure (copy_class_structure x0) + | From.Parsetree.Pcl_fun (x0, x1, x2, x3) -> + To.Parsetree.Pcl_fun + ( copy_arg_label x0, + copy_option copy_expression x1, + copy_pattern x2, + copy_class_expr x3 ) + | From.Parsetree.Pcl_apply (x0, x1) -> + To.Parsetree.Pcl_apply + ( copy_class_expr x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | From.Parsetree.Pcl_let (x0, x1, x2) -> + To.Parsetree.Pcl_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_class_expr x2) + | From.Parsetree.Pcl_constraint (x0, x1) -> + To.Parsetree.Pcl_constraint (copy_class_expr x0, copy_class_type x1) + | From.Parsetree.Pcl_extension x0 -> + To.Parsetree.Pcl_extension (copy_extension x0) + +and copy_class_structure : + From.Parsetree.class_structure -> To.Parsetree.class_structure = + fun { From.Parsetree.pcstr_self; From.Parsetree.pcstr_fields } -> + { + To.Parsetree.pcstr_self = copy_pattern pcstr_self; + To.Parsetree.pcstr_fields = List.map copy_class_field pcstr_fields; + } + +and copy_class_field : From.Parsetree.class_field -> To.Parsetree.class_field = + fun { + From.Parsetree.pcf_desc; + From.Parsetree.pcf_loc; + From.Parsetree.pcf_attributes; + } -> + { + To.Parsetree.pcf_desc = copy_class_field_desc pcf_desc; + To.Parsetree.pcf_loc = copy_location pcf_loc; + To.Parsetree.pcf_attributes = copy_attributes pcf_attributes; + } + +and copy_class_field_desc : + From.Parsetree.class_field_desc -> To.Parsetree.class_field_desc = function + | From.Parsetree.Pcf_inherit (x0, x1, x2) -> + To.Parsetree.Pcf_inherit + ( copy_override_flag x0, + copy_class_expr x1, + copy_option (fun x -> x.From.Asttypes.txt) x2 ) + | From.Parsetree.Pcf_val x0 -> + To.Parsetree.Pcf_val + (let x0, x1, x2 = x0 in + ( copy_loc (fun x -> x) x0, + copy_mutable_flag x1, + copy_class_field_kind x2 )) + | From.Parsetree.Pcf_method x0 -> + To.Parsetree.Pcf_method + (let x0, x1, x2 = x0 in + ( copy_loc (fun x -> x) x0, + copy_private_flag x1, + copy_class_field_kind x2 )) + | From.Parsetree.Pcf_constraint x0 -> + To.Parsetree.Pcf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | From.Parsetree.Pcf_initializer x0 -> + To.Parsetree.Pcf_initializer (copy_expression x0) + | From.Parsetree.Pcf_attribute x0 -> + To.Parsetree.Pcf_attribute (copy_attribute x0) + | From.Parsetree.Pcf_extension x0 -> + To.Parsetree.Pcf_extension (copy_extension x0) + +and copy_class_field_kind : + From.Parsetree.class_field_kind -> To.Parsetree.class_field_kind = function + | From.Parsetree.Cfk_virtual x0 -> + To.Parsetree.Cfk_virtual (copy_core_type x0) + | From.Parsetree.Cfk_concrete (x0, x1) -> + To.Parsetree.Cfk_concrete (copy_override_flag x0, copy_expression x1) + +and copy_module_binding : + From.Parsetree.module_binding -> To.Parsetree.module_binding = + fun { + From.Parsetree.pmb_name; + From.Parsetree.pmb_expr; + From.Parsetree.pmb_attributes; + From.Parsetree.pmb_loc; + } -> + { + To.Parsetree.pmb_name = copy_loc (fun x -> x) pmb_name; + To.Parsetree.pmb_expr = copy_module_expr pmb_expr; + To.Parsetree.pmb_attributes = copy_attributes pmb_attributes; + To.Parsetree.pmb_loc = copy_location pmb_loc; + } + +and copy_module_expr : From.Parsetree.module_expr -> To.Parsetree.module_expr = + fun { + From.Parsetree.pmod_desc; + From.Parsetree.pmod_loc; + From.Parsetree.pmod_attributes; + } -> + { + To.Parsetree.pmod_desc = copy_module_expr_desc pmod_desc; + To.Parsetree.pmod_loc = copy_location pmod_loc; + To.Parsetree.pmod_attributes = copy_attributes pmod_attributes; + } + +and copy_module_expr_desc : + From.Parsetree.module_expr_desc -> To.Parsetree.module_expr_desc = function + | From.Parsetree.Pmod_ident x0 -> + To.Parsetree.Pmod_ident (copy_loc copy_longident x0) + | From.Parsetree.Pmod_structure x0 -> + To.Parsetree.Pmod_structure (copy_structure x0) + | From.Parsetree.Pmod_functor (x0, x1, x2) -> + To.Parsetree.Pmod_functor + ( copy_loc (fun x -> x) x0, + copy_option copy_module_type x1, + copy_module_expr x2 ) + | From.Parsetree.Pmod_apply (x0, x1) -> + To.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) + | From.Parsetree.Pmod_constraint (x0, x1) -> + To.Parsetree.Pmod_constraint (copy_module_expr x0, copy_module_type x1) + | From.Parsetree.Pmod_unpack x0 -> + To.Parsetree.Pmod_unpack (copy_expression x0) + | From.Parsetree.Pmod_extension x0 -> + To.Parsetree.Pmod_extension (copy_extension x0) + +and copy_module_type : From.Parsetree.module_type -> To.Parsetree.module_type = + fun { + From.Parsetree.pmty_desc; + From.Parsetree.pmty_loc; + From.Parsetree.pmty_attributes; + } -> + { + To.Parsetree.pmty_desc = copy_module_type_desc pmty_desc; + To.Parsetree.pmty_loc = copy_location pmty_loc; + To.Parsetree.pmty_attributes = copy_attributes pmty_attributes; + } + +and copy_module_type_desc : + From.Parsetree.module_type_desc -> To.Parsetree.module_type_desc = function + | From.Parsetree.Pmty_ident x0 -> + To.Parsetree.Pmty_ident (copy_loc copy_longident x0) + | From.Parsetree.Pmty_signature x0 -> + To.Parsetree.Pmty_signature (copy_signature x0) + | From.Parsetree.Pmty_functor (x0, x1, x2) -> + To.Parsetree.Pmty_functor + ( copy_loc (fun x -> x) x0, + copy_option copy_module_type x1, + copy_module_type x2 ) + | From.Parsetree.Pmty_with (x0, x1) -> + To.Parsetree.Pmty_with + (copy_module_type x0, List.map copy_with_constraint x1) + | From.Parsetree.Pmty_typeof x0 -> + To.Parsetree.Pmty_typeof (copy_module_expr x0) + | From.Parsetree.Pmty_extension x0 -> + To.Parsetree.Pmty_extension (copy_extension x0) + | From.Parsetree.Pmty_alias x0 -> + To.Parsetree.Pmty_alias (copy_loc copy_longident x0) + +and copy_with_constraint : + From.Parsetree.with_constraint -> To.Parsetree.with_constraint = function + | From.Parsetree.Pwith_type (x0, x1) -> + To.Parsetree.Pwith_type + (copy_loc copy_longident x0, copy_type_declaration x1) + | From.Parsetree.Pwith_module (x0, x1) -> + To.Parsetree.Pwith_module + (copy_loc copy_longident x0, copy_loc copy_longident x1) + | From.Parsetree.Pwith_typesubst x0 -> + To.Parsetree.Pwith_typesubst (copy_type_declaration x0) + | From.Parsetree.Pwith_modsubst (x0, x1) -> + To.Parsetree.Pwith_modsubst + (copy_loc (fun x -> x) x0, copy_loc copy_longident x1) + +and copy_signature : From.Parsetree.signature -> To.Parsetree.signature = + fun x -> List.map copy_signature_item x + +and copy_signature_item : + From.Parsetree.signature_item -> To.Parsetree.signature_item = + fun { From.Parsetree.psig_desc; From.Parsetree.psig_loc } -> + { + To.Parsetree.psig_desc = copy_signature_item_desc psig_desc; + To.Parsetree.psig_loc = copy_location psig_loc; + } + +and copy_signature_item_desc : + From.Parsetree.signature_item_desc -> To.Parsetree.signature_item_desc = + function + | From.Parsetree.Psig_value x0 -> + To.Parsetree.Psig_value (copy_value_description x0) + | From.Parsetree.Psig_type (x0, x1) -> + To.Parsetree.Psig_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | From.Parsetree.Psig_typext x0 -> + To.Parsetree.Psig_typext (copy_type_extension x0) + | From.Parsetree.Psig_exception x0 -> + To.Parsetree.Psig_exception (copy_extension_constructor x0) + | From.Parsetree.Psig_module x0 -> + To.Parsetree.Psig_module (copy_module_declaration x0) + | From.Parsetree.Psig_recmodule x0 -> + To.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) + | From.Parsetree.Psig_modtype x0 -> + To.Parsetree.Psig_modtype (copy_module_type_declaration x0) + | From.Parsetree.Psig_open x0 -> + To.Parsetree.Psig_open (copy_open_description x0) + | From.Parsetree.Psig_include x0 -> + To.Parsetree.Psig_include (copy_include_description x0) + | From.Parsetree.Psig_class x0 -> + To.Parsetree.Psig_class (List.map copy_class_description x0) + | From.Parsetree.Psig_class_type x0 -> + To.Parsetree.Psig_class_type (List.map copy_class_type_declaration x0) + | From.Parsetree.Psig_attribute x0 -> + To.Parsetree.Psig_attribute (copy_attribute x0) + | From.Parsetree.Psig_extension (x0, x1) -> + To.Parsetree.Psig_extension (copy_extension x0, copy_attributes x1) + +and copy_class_type_declaration : + From.Parsetree.class_type_declaration -> To.Parsetree.class_type_declaration + = + fun x -> copy_class_infos copy_class_type x + +and copy_class_description : + From.Parsetree.class_description -> To.Parsetree.class_description = + fun x -> copy_class_infos copy_class_type x + +and copy_class_type : From.Parsetree.class_type -> To.Parsetree.class_type = + fun { + From.Parsetree.pcty_desc; + From.Parsetree.pcty_loc; + From.Parsetree.pcty_attributes; + } -> + { + To.Parsetree.pcty_desc = copy_class_type_desc pcty_desc; + To.Parsetree.pcty_loc = copy_location pcty_loc; + To.Parsetree.pcty_attributes = copy_attributes pcty_attributes; + } + +and copy_class_type_desc : + From.Parsetree.class_type_desc -> To.Parsetree.class_type_desc = function + | From.Parsetree.Pcty_constr (x0, x1) -> + To.Parsetree.Pcty_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Pcty_signature x0 -> + To.Parsetree.Pcty_signature (copy_class_signature x0) + | From.Parsetree.Pcty_arrow (x0, x1, x2) -> + To.Parsetree.Pcty_arrow + (copy_arg_label x0, copy_core_type x1, copy_class_type x2) + | From.Parsetree.Pcty_extension x0 -> + To.Parsetree.Pcty_extension (copy_extension x0) + +and copy_class_signature : + From.Parsetree.class_signature -> To.Parsetree.class_signature = + fun { From.Parsetree.pcsig_self; From.Parsetree.pcsig_fields } -> + { + To.Parsetree.pcsig_self = copy_core_type pcsig_self; + To.Parsetree.pcsig_fields = List.map copy_class_type_field pcsig_fields; + } + +and copy_class_type_field : + From.Parsetree.class_type_field -> To.Parsetree.class_type_field = + fun { + From.Parsetree.pctf_desc; + From.Parsetree.pctf_loc; + From.Parsetree.pctf_attributes; + } -> + { + To.Parsetree.pctf_desc = copy_class_type_field_desc pctf_desc; + To.Parsetree.pctf_loc = copy_location pctf_loc; + To.Parsetree.pctf_attributes = copy_attributes pctf_attributes; + } + +and copy_class_type_field_desc : + From.Parsetree.class_type_field_desc -> To.Parsetree.class_type_field_desc = + function + | From.Parsetree.Pctf_inherit x0 -> + To.Parsetree.Pctf_inherit (copy_class_type x0) + | From.Parsetree.Pctf_val x0 -> + To.Parsetree.Pctf_val + (let x0, x1, x2, x3 = x0 in + ( x0.From.Asttypes.txt, + copy_mutable_flag x1, + copy_virtual_flag x2, + copy_core_type x3 )) + | From.Parsetree.Pctf_method x0 -> + To.Parsetree.Pctf_method + (let x0, x1, x2, x3 = x0 in + ( x0.From.Asttypes.txt, + copy_private_flag x1, + copy_virtual_flag x2, + copy_core_type x3 )) + | From.Parsetree.Pctf_constraint x0 -> + To.Parsetree.Pctf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | From.Parsetree.Pctf_attribute x0 -> + To.Parsetree.Pctf_attribute (copy_attribute x0) + | From.Parsetree.Pctf_extension x0 -> + To.Parsetree.Pctf_extension (copy_extension x0) + +and copy_extension : From.Parsetree.extension -> To.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 From.Parsetree.class_infos -> + 'g0 To.Parsetree.class_infos = + fun f0 + { + From.Parsetree.pci_virt; + From.Parsetree.pci_params; + From.Parsetree.pci_name; + From.Parsetree.pci_expr; + From.Parsetree.pci_loc; + From.Parsetree.pci_attributes; + } -> + { + To.Parsetree.pci_virt = copy_virtual_flag pci_virt; + To.Parsetree.pci_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + pci_params; + To.Parsetree.pci_name = copy_loc (fun x -> x) pci_name; + To.Parsetree.pci_expr = f0 pci_expr; + To.Parsetree.pci_loc = copy_location pci_loc; + To.Parsetree.pci_attributes = copy_attributes pci_attributes; + } + +and copy_virtual_flag : From.Asttypes.virtual_flag -> To.Asttypes.virtual_flag = + function + | From.Asttypes.Virtual -> To.Asttypes.Virtual + | From.Asttypes.Concrete -> To.Asttypes.Concrete + +and copy_include_description : + From.Parsetree.include_description -> To.Parsetree.include_description = + fun x -> copy_include_infos copy_module_type x + +and copy_include_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 From.Parsetree.include_infos -> + 'g0 To.Parsetree.include_infos = + fun f0 + { + From.Parsetree.pincl_mod; + From.Parsetree.pincl_loc; + From.Parsetree.pincl_attributes; + } -> + { + To.Parsetree.pincl_mod = f0 pincl_mod; + To.Parsetree.pincl_loc = copy_location pincl_loc; + To.Parsetree.pincl_attributes = copy_attributes pincl_attributes; + } + +and copy_open_description : + From.Parsetree.open_description -> To.Parsetree.open_description = + fun { + From.Parsetree.popen_lid; + From.Parsetree.popen_override; + From.Parsetree.popen_loc; + From.Parsetree.popen_attributes; + } -> + { + To.Parsetree.popen_lid = copy_loc copy_longident popen_lid; + To.Parsetree.popen_override = copy_override_flag popen_override; + To.Parsetree.popen_loc = copy_location popen_loc; + To.Parsetree.popen_attributes = copy_attributes popen_attributes; + } + +and copy_override_flag : + From.Asttypes.override_flag -> To.Asttypes.override_flag = function + | From.Asttypes.Override -> To.Asttypes.Override + | From.Asttypes.Fresh -> To.Asttypes.Fresh + +and copy_module_type_declaration : + From.Parsetree.module_type_declaration -> + To.Parsetree.module_type_declaration = + fun { + From.Parsetree.pmtd_name; + From.Parsetree.pmtd_type; + From.Parsetree.pmtd_attributes; + From.Parsetree.pmtd_loc; + } -> + { + To.Parsetree.pmtd_name = copy_loc (fun x -> x) pmtd_name; + To.Parsetree.pmtd_type = copy_option copy_module_type pmtd_type; + To.Parsetree.pmtd_attributes = copy_attributes pmtd_attributes; + To.Parsetree.pmtd_loc = copy_location pmtd_loc; + } + +and copy_module_declaration : + From.Parsetree.module_declaration -> To.Parsetree.module_declaration = + fun { + From.Parsetree.pmd_name; + From.Parsetree.pmd_type; + From.Parsetree.pmd_attributes; + From.Parsetree.pmd_loc; + } -> + { + To.Parsetree.pmd_name = copy_loc (fun x -> x) pmd_name; + To.Parsetree.pmd_type = copy_module_type pmd_type; + To.Parsetree.pmd_attributes = copy_attributes pmd_attributes; + To.Parsetree.pmd_loc = copy_location pmd_loc; + } + +and copy_type_extension : + From.Parsetree.type_extension -> To.Parsetree.type_extension = + fun { + From.Parsetree.ptyext_path; + From.Parsetree.ptyext_params; + From.Parsetree.ptyext_constructors; + From.Parsetree.ptyext_private; + From.Parsetree.ptyext_attributes; + } -> + { + To.Parsetree.ptyext_path = copy_loc copy_longident ptyext_path; + To.Parsetree.ptyext_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptyext_params; + To.Parsetree.ptyext_constructors = + List.map copy_extension_constructor ptyext_constructors; + To.Parsetree.ptyext_private = copy_private_flag ptyext_private; + To.Parsetree.ptyext_attributes = copy_attributes ptyext_attributes; + } + +and copy_extension_constructor : + From.Parsetree.extension_constructor -> To.Parsetree.extension_constructor = + fun { + From.Parsetree.pext_name; + From.Parsetree.pext_kind; + From.Parsetree.pext_loc; + From.Parsetree.pext_attributes; + } -> + { + To.Parsetree.pext_name = copy_loc (fun x -> x) pext_name; + To.Parsetree.pext_kind = copy_extension_constructor_kind pext_kind; + To.Parsetree.pext_loc = copy_location pext_loc; + To.Parsetree.pext_attributes = copy_attributes pext_attributes; + } + +and copy_extension_constructor_kind : + From.Parsetree.extension_constructor_kind -> + To.Parsetree.extension_constructor_kind = function + | From.Parsetree.Pext_decl (x0, x1) -> + To.Parsetree.Pext_decl + (copy_constructor_arguments x0, copy_option copy_core_type x1) + | From.Parsetree.Pext_rebind x0 -> + To.Parsetree.Pext_rebind (copy_loc copy_longident x0) + +and copy_type_declaration : + From.Parsetree.type_declaration -> To.Parsetree.type_declaration = + fun { + From.Parsetree.ptype_name; + From.Parsetree.ptype_params; + From.Parsetree.ptype_cstrs; + From.Parsetree.ptype_kind; + From.Parsetree.ptype_private; + From.Parsetree.ptype_manifest; + From.Parsetree.ptype_attributes; + From.Parsetree.ptype_loc; + } -> + { + To.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name; + To.Parsetree.ptype_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptype_params; + To.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; + To.Parsetree.ptype_kind = copy_type_kind ptype_kind; + To.Parsetree.ptype_private = copy_private_flag ptype_private; + To.Parsetree.ptype_manifest = copy_option copy_core_type ptype_manifest; + To.Parsetree.ptype_attributes = copy_attributes ptype_attributes; + To.Parsetree.ptype_loc = copy_location ptype_loc; + } + +and copy_private_flag : From.Asttypes.private_flag -> To.Asttypes.private_flag = + function + | From.Asttypes.Private -> To.Asttypes.Private + | From.Asttypes.Public -> To.Asttypes.Public + +and copy_type_kind : From.Parsetree.type_kind -> To.Parsetree.type_kind = + function + | From.Parsetree.Ptype_abstract -> To.Parsetree.Ptype_abstract + | From.Parsetree.Ptype_variant x0 -> + To.Parsetree.Ptype_variant (List.map copy_constructor_declaration x0) + | From.Parsetree.Ptype_record x0 -> + To.Parsetree.Ptype_record (List.map copy_label_declaration x0) + | From.Parsetree.Ptype_open -> To.Parsetree.Ptype_open + +and copy_constructor_declaration : + From.Parsetree.constructor_declaration -> + To.Parsetree.constructor_declaration = + fun { + From.Parsetree.pcd_name; + From.Parsetree.pcd_args; + From.Parsetree.pcd_res; + From.Parsetree.pcd_loc; + From.Parsetree.pcd_attributes; + } -> + { + To.Parsetree.pcd_name = copy_loc (fun x -> x) pcd_name; + To.Parsetree.pcd_args = copy_constructor_arguments pcd_args; + To.Parsetree.pcd_res = copy_option copy_core_type pcd_res; + To.Parsetree.pcd_loc = copy_location pcd_loc; + To.Parsetree.pcd_attributes = copy_attributes pcd_attributes; + } + +and copy_constructor_arguments : + From.Parsetree.constructor_arguments -> To.Parsetree.constructor_arguments = + function + | From.Parsetree.Pcstr_tuple x0 -> + To.Parsetree.Pcstr_tuple (List.map copy_core_type x0) + | From.Parsetree.Pcstr_record x0 -> + To.Parsetree.Pcstr_record (List.map copy_label_declaration x0) + +and copy_label_declaration : + From.Parsetree.label_declaration -> To.Parsetree.label_declaration = + fun { + From.Parsetree.pld_name; + From.Parsetree.pld_mutable; + From.Parsetree.pld_type; + From.Parsetree.pld_loc; + From.Parsetree.pld_attributes; + } -> + { + To.Parsetree.pld_name = copy_loc (fun x -> x) pld_name; + To.Parsetree.pld_mutable = copy_mutable_flag pld_mutable; + To.Parsetree.pld_type = copy_core_type pld_type; + To.Parsetree.pld_loc = copy_location pld_loc; + To.Parsetree.pld_attributes = copy_attributes pld_attributes; + } + +and copy_mutable_flag : From.Asttypes.mutable_flag -> To.Asttypes.mutable_flag = + function + | From.Asttypes.Immutable -> To.Asttypes.Immutable + | From.Asttypes.Mutable -> To.Asttypes.Mutable + +and copy_variance : From.Asttypes.variance -> To.Asttypes.variance = function + | From.Asttypes.Covariant -> To.Asttypes.Covariant + | From.Asttypes.Contravariant -> To.Asttypes.Contravariant + | From.Asttypes.Invariant -> To.Asttypes.Invariant + +and copy_value_description : + From.Parsetree.value_description -> To.Parsetree.value_description = + fun { + From.Parsetree.pval_name; + From.Parsetree.pval_type; + From.Parsetree.pval_prim; + From.Parsetree.pval_attributes; + From.Parsetree.pval_loc; + } -> + { + To.Parsetree.pval_name = copy_loc (fun x -> x) pval_name; + To.Parsetree.pval_type = copy_core_type pval_type; + To.Parsetree.pval_prim = List.map (fun x -> x) pval_prim; + To.Parsetree.pval_attributes = copy_attributes pval_attributes; + To.Parsetree.pval_loc = copy_location pval_loc; + } + +and copy_arg_label : From.Asttypes.arg_label -> To.Asttypes.arg_label = function + | From.Asttypes.Nolabel -> To.Asttypes.Nolabel + | From.Asttypes.Labelled x0 -> To.Asttypes.Labelled x0 + | From.Asttypes.Optional x0 -> To.Asttypes.Optional x0 + +and copy_closed_flag : From.Asttypes.closed_flag -> To.Asttypes.closed_flag = + function + | From.Asttypes.Closed -> To.Asttypes.Closed + | From.Asttypes.Open -> To.Asttypes.Open + +and copy_label : From.Asttypes.label -> To.Asttypes.label = fun x -> x + +and copy_rec_flag : From.Asttypes.rec_flag -> To.Asttypes.rec_flag = function + | From.Asttypes.Nonrecursive -> To.Asttypes.Nonrecursive + | From.Asttypes.Recursive -> To.Asttypes.Recursive + +and copy_constant : From.Parsetree.constant -> To.Parsetree.constant = function + | From.Parsetree.Pconst_integer (x0, x1) -> + To.Parsetree.Pconst_integer (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pconst_char x0 -> To.Parsetree.Pconst_char x0 + | From.Parsetree.Pconst_string (x0, x1) -> + To.Parsetree.Pconst_string (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pconst_float (x0, x1) -> + To.Parsetree.Pconst_float (x0, copy_option (fun x -> x) x1) + +and copy_option : 'f0 'g0. ('f0 -> 'g0) -> 'f0 option -> 'g0 option = + fun f0 -> function None -> None | Some x0 -> Some (f0 x0) + +and copy_longident : Longident.t -> Longident.t = fun x -> x + +and copy_loc : + 'f0 'g0. ('f0 -> 'g0) -> 'f0 From.Asttypes.loc -> 'g0 To.Asttypes.loc = + fun f0 { From.Asttypes.txt; From.Asttypes.loc } -> + { To.Asttypes.txt = f0 txt; To.Asttypes.loc = copy_location loc } + +and copy_location : Location.t -> Location.t = fun x -> x + +and copy_bool : bool -> bool = function false -> false | true -> true + +let rec copy_toplevel_phrase : + From.Parsetree.toplevel_phrase -> To.Parsetree.toplevel_phrase = function + | From.Parsetree.Ptop_def x0 -> To.Parsetree.Ptop_def (copy_structure x0) + | From.Parsetree.Ptop_dir (x0, x1) -> + To.Parsetree.Ptop_dir (x0, copy_directive_argument x1) + +and copy_directive_argument : + From.Parsetree.directive_argument -> To.Parsetree.directive_argument = + function + | From.Parsetree.Pdir_none -> To.Parsetree.Pdir_none + | From.Parsetree.Pdir_string x0 -> To.Parsetree.Pdir_string x0 + | From.Parsetree.Pdir_int (x0, x1) -> + To.Parsetree.Pdir_int (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pdir_ident x0 -> To.Parsetree.Pdir_ident (copy_longident x0) + | From.Parsetree.Pdir_bool x0 -> To.Parsetree.Pdir_bool (copy_bool x0) + +let copy_cases x = List.map copy_case x + +let copy_pat = copy_pattern + +let copy_expr = copy_expression + +let copy_typ = copy_core_type diff -Nru ppxlib-0.15.0/astlib/migrate_405_406.ml ppxlib-0.24.0/astlib/migrate_405_406.ml --- ppxlib-0.15.0/astlib/migrate_405_406.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/migrate_405_406.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1017 @@ +(**************************************************************************) +(* *) +(* OCaml Migrate Parsetree *) +(* *) +(* Frédéric Bour *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2017 Institut National de Recherche en Informatique et *) +(* en Automatique (INRIA). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module From = Ast_405 +module To = Ast_406 + +let rec copy_expression : From.Parsetree.expression -> To.Parsetree.expression = + fun { + From.Parsetree.pexp_desc; + From.Parsetree.pexp_loc; + From.Parsetree.pexp_attributes; + } -> + { + To.Parsetree.pexp_desc = copy_expression_desc pexp_desc; + To.Parsetree.pexp_loc = copy_location pexp_loc; + To.Parsetree.pexp_attributes = copy_attributes pexp_attributes; + } + +and copy_expression_desc : + From.Parsetree.expression_desc -> To.Parsetree.expression_desc = function + | From.Parsetree.Pexp_ident x0 -> + To.Parsetree.Pexp_ident (copy_loc copy_longident x0) + | From.Parsetree.Pexp_constant x0 -> + To.Parsetree.Pexp_constant (copy_constant x0) + | From.Parsetree.Pexp_let (x0, x1, x2) -> + To.Parsetree.Pexp_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_expression x2) + | From.Parsetree.Pexp_function x0 -> + To.Parsetree.Pexp_function (List.map copy_case x0) + | From.Parsetree.Pexp_fun (x0, x1, x2, x3) -> + To.Parsetree.Pexp_fun + ( copy_arg_label x0, + copy_option copy_expression x1, + copy_pattern x2, + copy_expression x3 ) + | From.Parsetree.Pexp_apply (x0, x1) -> + To.Parsetree.Pexp_apply + ( copy_expression x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | From.Parsetree.Pexp_match (x0, x1) -> + To.Parsetree.Pexp_match (copy_expression x0, List.map copy_case x1) + | From.Parsetree.Pexp_try (x0, x1) -> + To.Parsetree.Pexp_try (copy_expression x0, List.map copy_case x1) + | From.Parsetree.Pexp_tuple x0 -> + To.Parsetree.Pexp_tuple (List.map copy_expression x0) + | From.Parsetree.Pexp_construct (x0, x1) -> + To.Parsetree.Pexp_construct + (copy_loc copy_longident x0, copy_option copy_expression x1) + | From.Parsetree.Pexp_variant (x0, x1) -> + To.Parsetree.Pexp_variant (copy_label x0, copy_option copy_expression x1) + | From.Parsetree.Pexp_record (x0, x1) -> + To.Parsetree.Pexp_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_expression x1)) + x0, + copy_option copy_expression x1 ) + | From.Parsetree.Pexp_field (x0, x1) -> + To.Parsetree.Pexp_field (copy_expression x0, copy_loc copy_longident x1) + | From.Parsetree.Pexp_setfield (x0, x1, x2) -> + To.Parsetree.Pexp_setfield + (copy_expression x0, copy_loc copy_longident x1, copy_expression x2) + | From.Parsetree.Pexp_array x0 -> + To.Parsetree.Pexp_array (List.map copy_expression x0) + | From.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> + To.Parsetree.Pexp_ifthenelse + (copy_expression x0, copy_expression x1, copy_option copy_expression x2) + | From.Parsetree.Pexp_sequence (x0, x1) -> + To.Parsetree.Pexp_sequence (copy_expression x0, copy_expression x1) + | From.Parsetree.Pexp_while (x0, x1) -> + To.Parsetree.Pexp_while (copy_expression x0, copy_expression x1) + | From.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> + To.Parsetree.Pexp_for + ( copy_pattern x0, + copy_expression x1, + copy_expression x2, + copy_direction_flag x3, + copy_expression x4 ) + | From.Parsetree.Pexp_constraint (x0, x1) -> + To.Parsetree.Pexp_constraint (copy_expression x0, copy_core_type x1) + | From.Parsetree.Pexp_coerce (x0, x1, x2) -> + To.Parsetree.Pexp_coerce + (copy_expression x0, copy_option copy_core_type x1, copy_core_type x2) + | From.Parsetree.Pexp_send (x0, x1) -> + To.Parsetree.Pexp_send (copy_expression x0, copy_loc (fun x -> x) x1) + | From.Parsetree.Pexp_new x0 -> + To.Parsetree.Pexp_new (copy_loc copy_longident x0) + | From.Parsetree.Pexp_setinstvar (x0, x1) -> + To.Parsetree.Pexp_setinstvar (copy_loc (fun x -> x) x0, copy_expression x1) + | From.Parsetree.Pexp_override x0 -> + To.Parsetree.Pexp_override + (List.map + (fun x -> + let x0, x1 = x in + (copy_loc (fun x -> x) x0, copy_expression x1)) + x0) + | From.Parsetree.Pexp_letmodule (x0, x1, x2) -> + To.Parsetree.Pexp_letmodule + (copy_loc (fun x -> x) x0, copy_module_expr x1, copy_expression x2) + | From.Parsetree.Pexp_letexception (x0, x1) -> + To.Parsetree.Pexp_letexception + (copy_extension_constructor x0, copy_expression x1) + | From.Parsetree.Pexp_assert x0 -> + To.Parsetree.Pexp_assert (copy_expression x0) + | From.Parsetree.Pexp_lazy x0 -> To.Parsetree.Pexp_lazy (copy_expression x0) + | From.Parsetree.Pexp_poly (x0, x1) -> + To.Parsetree.Pexp_poly (copy_expression x0, copy_option copy_core_type x1) + | From.Parsetree.Pexp_object x0 -> + To.Parsetree.Pexp_object (copy_class_structure x0) + | From.Parsetree.Pexp_newtype (x0, x1) -> + To.Parsetree.Pexp_newtype (copy_loc (fun x -> x) x0, copy_expression x1) + | From.Parsetree.Pexp_pack x0 -> To.Parsetree.Pexp_pack (copy_module_expr x0) + | From.Parsetree.Pexp_open (x0, x1, x2) -> + To.Parsetree.Pexp_open + (copy_override_flag x0, copy_loc copy_longident x1, copy_expression x2) + | From.Parsetree.Pexp_extension x0 -> + To.Parsetree.Pexp_extension (copy_extension x0) + | From.Parsetree.Pexp_unreachable -> To.Parsetree.Pexp_unreachable + +and copy_direction_flag : + From.Asttypes.direction_flag -> To.Asttypes.direction_flag = function + | From.Asttypes.Upto -> To.Asttypes.Upto + | From.Asttypes.Downto -> To.Asttypes.Downto + +and copy_case : From.Parsetree.case -> To.Parsetree.case = + fun { From.Parsetree.pc_lhs; From.Parsetree.pc_guard; From.Parsetree.pc_rhs } -> + { + To.Parsetree.pc_lhs = copy_pattern pc_lhs; + To.Parsetree.pc_guard = copy_option copy_expression pc_guard; + To.Parsetree.pc_rhs = copy_expression pc_rhs; + } + +and copy_value_binding : + From.Parsetree.value_binding -> To.Parsetree.value_binding = + fun { + From.Parsetree.pvb_pat; + From.Parsetree.pvb_expr; + From.Parsetree.pvb_attributes; + From.Parsetree.pvb_loc; + } -> + { + To.Parsetree.pvb_pat = copy_pattern pvb_pat; + To.Parsetree.pvb_expr = copy_expression pvb_expr; + To.Parsetree.pvb_attributes = copy_attributes pvb_attributes; + To.Parsetree.pvb_loc = copy_location pvb_loc; + } + +and copy_pattern : From.Parsetree.pattern -> To.Parsetree.pattern = + fun { + From.Parsetree.ppat_desc; + From.Parsetree.ppat_loc; + From.Parsetree.ppat_attributes; + } -> + { + To.Parsetree.ppat_desc = copy_pattern_desc ppat_desc; + To.Parsetree.ppat_loc = copy_location ppat_loc; + To.Parsetree.ppat_attributes = copy_attributes ppat_attributes; + } + +and copy_pattern_desc : From.Parsetree.pattern_desc -> To.Parsetree.pattern_desc + = function + | From.Parsetree.Ppat_any -> To.Parsetree.Ppat_any + | From.Parsetree.Ppat_var x0 -> + To.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) + | From.Parsetree.Ppat_alias (x0, x1) -> + To.Parsetree.Ppat_alias (copy_pattern x0, copy_loc (fun x -> x) x1) + | From.Parsetree.Ppat_constant x0 -> + To.Parsetree.Ppat_constant (copy_constant x0) + | From.Parsetree.Ppat_interval (x0, x1) -> + To.Parsetree.Ppat_interval (copy_constant x0, copy_constant x1) + | From.Parsetree.Ppat_tuple x0 -> + To.Parsetree.Ppat_tuple (List.map copy_pattern x0) + | From.Parsetree.Ppat_construct (x0, x1) -> + To.Parsetree.Ppat_construct + (copy_loc copy_longident x0, copy_option copy_pattern x1) + | From.Parsetree.Ppat_variant (x0, x1) -> + To.Parsetree.Ppat_variant (copy_label x0, copy_option copy_pattern x1) + | From.Parsetree.Ppat_record (x0, x1) -> + To.Parsetree.Ppat_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_pattern x1)) + x0, + copy_closed_flag x1 ) + | From.Parsetree.Ppat_array x0 -> + To.Parsetree.Ppat_array (List.map copy_pattern x0) + | From.Parsetree.Ppat_or (x0, x1) -> + To.Parsetree.Ppat_or (copy_pattern x0, copy_pattern x1) + | From.Parsetree.Ppat_constraint (x0, x1) -> + To.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1) + | From.Parsetree.Ppat_type x0 -> + To.Parsetree.Ppat_type (copy_loc copy_longident x0) + | From.Parsetree.Ppat_lazy x0 -> To.Parsetree.Ppat_lazy (copy_pattern x0) + | From.Parsetree.Ppat_unpack x0 -> + To.Parsetree.Ppat_unpack (copy_loc (fun x -> x) x0) + | From.Parsetree.Ppat_exception x0 -> + To.Parsetree.Ppat_exception (copy_pattern x0) + | From.Parsetree.Ppat_extension x0 -> + To.Parsetree.Ppat_extension (copy_extension x0) + | From.Parsetree.Ppat_open (x0, x1) -> + To.Parsetree.Ppat_open (copy_loc copy_longident x0, copy_pattern x1) + +and copy_core_type : From.Parsetree.core_type -> To.Parsetree.core_type = + fun { + From.Parsetree.ptyp_desc; + From.Parsetree.ptyp_loc; + From.Parsetree.ptyp_attributes; + } -> + { + To.Parsetree.ptyp_desc = copy_core_type_desc ptyp_desc; + To.Parsetree.ptyp_loc = copy_location ptyp_loc; + To.Parsetree.ptyp_attributes = copy_attributes ptyp_attributes; + } + +and copy_core_type_desc : + From.Parsetree.core_type_desc -> To.Parsetree.core_type_desc = function + | From.Parsetree.Ptyp_any -> To.Parsetree.Ptyp_any + | From.Parsetree.Ptyp_var x0 -> To.Parsetree.Ptyp_var x0 + | From.Parsetree.Ptyp_arrow (x0, x1, x2) -> + To.Parsetree.Ptyp_arrow + (copy_arg_label x0, copy_core_type x1, copy_core_type x2) + | From.Parsetree.Ptyp_tuple x0 -> + To.Parsetree.Ptyp_tuple (List.map copy_core_type x0) + | From.Parsetree.Ptyp_constr (x0, x1) -> + To.Parsetree.Ptyp_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Ptyp_object (x0, x1) -> + To.Parsetree.Ptyp_object + ( List.map + (fun x -> + let x0, x1, x2 = x in + To.Parsetree.Otag + (copy_loc (fun x -> x) x0, copy_attributes x1, copy_core_type x2)) + x0, + copy_closed_flag x1 ) + | From.Parsetree.Ptyp_class (x0, x1) -> + To.Parsetree.Ptyp_class + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Ptyp_alias (x0, x1) -> + To.Parsetree.Ptyp_alias (copy_core_type x0, x1) + | From.Parsetree.Ptyp_variant (x0, x1, x2) -> + To.Parsetree.Ptyp_variant + ( List.map copy_row_field x0, + copy_closed_flag x1, + copy_option (fun x -> List.map copy_label x) x2 ) + | From.Parsetree.Ptyp_poly (x0, x1) -> + To.Parsetree.Ptyp_poly + (List.map (fun x -> copy_loc (fun x -> x) x) x0, copy_core_type x1) + | From.Parsetree.Ptyp_package x0 -> + To.Parsetree.Ptyp_package (copy_package_type x0) + | From.Parsetree.Ptyp_extension x0 -> + To.Parsetree.Ptyp_extension (copy_extension x0) + +and copy_package_type : From.Parsetree.package_type -> To.Parsetree.package_type + = + fun x -> + let x0, x1 = x in + ( copy_loc copy_longident x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_core_type x1)) + x1 ) + +and copy_row_field : From.Parsetree.row_field -> To.Parsetree.row_field = + function + | From.Parsetree.Rtag (x0, x1, x2, x3) -> + To.Parsetree.Rtag + ( { txt = copy_label x0; loc = Location.none }, + copy_attributes x1, + copy_bool x2, + List.map copy_core_type x3 ) + | From.Parsetree.Rinherit x0 -> To.Parsetree.Rinherit (copy_core_type x0) + +and copy_attributes : From.Parsetree.attributes -> To.Parsetree.attributes = + fun x -> List.map copy_attribute x + +and copy_attribute : From.Parsetree.attribute -> To.Parsetree.attribute = + fun x -> + let x0, x1 = x in + (copy_loc (fun x -> x) x0, copy_payload x1) + +and copy_payload : From.Parsetree.payload -> To.Parsetree.payload = function + | From.Parsetree.PStr x0 -> To.Parsetree.PStr (copy_structure x0) + | From.Parsetree.PSig x0 -> To.Parsetree.PSig (copy_signature x0) + | From.Parsetree.PTyp x0 -> To.Parsetree.PTyp (copy_core_type x0) + | From.Parsetree.PPat (x0, x1) -> + To.Parsetree.PPat (copy_pattern x0, copy_option copy_expression x1) + +and copy_structure : From.Parsetree.structure -> To.Parsetree.structure = + fun x -> List.map copy_structure_item x + +and copy_structure_item : + From.Parsetree.structure_item -> To.Parsetree.structure_item = + fun { From.Parsetree.pstr_desc; From.Parsetree.pstr_loc } -> + { + To.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc; + To.Parsetree.pstr_loc = copy_location pstr_loc; + } + +and copy_structure_item_desc : + From.Parsetree.structure_item_desc -> To.Parsetree.structure_item_desc = + function + | From.Parsetree.Pstr_eval (x0, x1) -> + To.Parsetree.Pstr_eval (copy_expression x0, copy_attributes x1) + | From.Parsetree.Pstr_value (x0, x1) -> + To.Parsetree.Pstr_value (copy_rec_flag x0, List.map copy_value_binding x1) + | From.Parsetree.Pstr_primitive x0 -> + To.Parsetree.Pstr_primitive (copy_value_description x0) + | From.Parsetree.Pstr_type (x0, x1) -> + To.Parsetree.Pstr_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | From.Parsetree.Pstr_typext x0 -> + To.Parsetree.Pstr_typext (copy_type_extension x0) + | From.Parsetree.Pstr_exception x0 -> + To.Parsetree.Pstr_exception (copy_extension_constructor x0) + | From.Parsetree.Pstr_module x0 -> + To.Parsetree.Pstr_module (copy_module_binding x0) + | From.Parsetree.Pstr_recmodule x0 -> + To.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) + | From.Parsetree.Pstr_modtype x0 -> + To.Parsetree.Pstr_modtype (copy_module_type_declaration x0) + | From.Parsetree.Pstr_open x0 -> + To.Parsetree.Pstr_open (copy_open_description x0) + | From.Parsetree.Pstr_class x0 -> + To.Parsetree.Pstr_class (List.map copy_class_declaration x0) + | From.Parsetree.Pstr_class_type x0 -> + To.Parsetree.Pstr_class_type (List.map copy_class_type_declaration x0) + | From.Parsetree.Pstr_include x0 -> + To.Parsetree.Pstr_include (copy_include_declaration x0) + | From.Parsetree.Pstr_attribute x0 -> + To.Parsetree.Pstr_attribute (copy_attribute x0) + | From.Parsetree.Pstr_extension (x0, x1) -> + To.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1) + +and copy_include_declaration : + From.Parsetree.include_declaration -> To.Parsetree.include_declaration = + fun x -> copy_include_infos copy_module_expr x + +and copy_class_declaration : + From.Parsetree.class_declaration -> To.Parsetree.class_declaration = + fun x -> copy_class_infos copy_class_expr x + +and copy_class_expr : From.Parsetree.class_expr -> To.Parsetree.class_expr = + fun { + From.Parsetree.pcl_desc; + From.Parsetree.pcl_loc; + From.Parsetree.pcl_attributes; + } -> + { + To.Parsetree.pcl_desc = copy_class_expr_desc pcl_desc; + To.Parsetree.pcl_loc = copy_location pcl_loc; + To.Parsetree.pcl_attributes = copy_attributes pcl_attributes; + } + +and copy_class_expr_desc : + From.Parsetree.class_expr_desc -> To.Parsetree.class_expr_desc = function + | From.Parsetree.Pcl_constr (x0, x1) -> + To.Parsetree.Pcl_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Pcl_structure x0 -> + To.Parsetree.Pcl_structure (copy_class_structure x0) + | From.Parsetree.Pcl_fun (x0, x1, x2, x3) -> + To.Parsetree.Pcl_fun + ( copy_arg_label x0, + copy_option copy_expression x1, + copy_pattern x2, + copy_class_expr x3 ) + | From.Parsetree.Pcl_apply (x0, x1) -> + To.Parsetree.Pcl_apply + ( copy_class_expr x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | From.Parsetree.Pcl_let (x0, x1, x2) -> + To.Parsetree.Pcl_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_class_expr x2) + | From.Parsetree.Pcl_constraint (x0, x1) -> + To.Parsetree.Pcl_constraint (copy_class_expr x0, copy_class_type x1) + | From.Parsetree.Pcl_extension x0 -> + To.Parsetree.Pcl_extension (copy_extension x0) + +and copy_class_structure : + From.Parsetree.class_structure -> To.Parsetree.class_structure = + fun { From.Parsetree.pcstr_self; From.Parsetree.pcstr_fields } -> + { + To.Parsetree.pcstr_self = copy_pattern pcstr_self; + To.Parsetree.pcstr_fields = List.map copy_class_field pcstr_fields; + } + +and copy_class_field : From.Parsetree.class_field -> To.Parsetree.class_field = + fun { + From.Parsetree.pcf_desc; + From.Parsetree.pcf_loc; + From.Parsetree.pcf_attributes; + } -> + { + To.Parsetree.pcf_desc = copy_class_field_desc pcf_desc; + To.Parsetree.pcf_loc = copy_location pcf_loc; + To.Parsetree.pcf_attributes = copy_attributes pcf_attributes; + } + +and copy_class_field_desc : + From.Parsetree.class_field_desc -> To.Parsetree.class_field_desc = function + | From.Parsetree.Pcf_inherit (x0, x1, x2) -> + To.Parsetree.Pcf_inherit + ( copy_override_flag x0, + copy_class_expr x1, + copy_option (copy_loc (fun x -> x)) x2 ) + | From.Parsetree.Pcf_val x0 -> + To.Parsetree.Pcf_val + (let x0, x1, x2 = x0 in + ( copy_loc (fun x -> x) x0, + copy_mutable_flag x1, + copy_class_field_kind x2 )) + | From.Parsetree.Pcf_method x0 -> + To.Parsetree.Pcf_method + (let x0, x1, x2 = x0 in + ( copy_loc (fun x -> x) x0, + copy_private_flag x1, + copy_class_field_kind x2 )) + | From.Parsetree.Pcf_constraint x0 -> + To.Parsetree.Pcf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | From.Parsetree.Pcf_initializer x0 -> + To.Parsetree.Pcf_initializer (copy_expression x0) + | From.Parsetree.Pcf_attribute x0 -> + To.Parsetree.Pcf_attribute (copy_attribute x0) + | From.Parsetree.Pcf_extension x0 -> + To.Parsetree.Pcf_extension (copy_extension x0) + +and copy_class_field_kind : + From.Parsetree.class_field_kind -> To.Parsetree.class_field_kind = function + | From.Parsetree.Cfk_virtual x0 -> + To.Parsetree.Cfk_virtual (copy_core_type x0) + | From.Parsetree.Cfk_concrete (x0, x1) -> + To.Parsetree.Cfk_concrete (copy_override_flag x0, copy_expression x1) + +and copy_module_binding : + From.Parsetree.module_binding -> To.Parsetree.module_binding = + fun { + From.Parsetree.pmb_name; + From.Parsetree.pmb_expr; + From.Parsetree.pmb_attributes; + From.Parsetree.pmb_loc; + } -> + { + To.Parsetree.pmb_name = copy_loc (fun x -> x) pmb_name; + To.Parsetree.pmb_expr = copy_module_expr pmb_expr; + To.Parsetree.pmb_attributes = copy_attributes pmb_attributes; + To.Parsetree.pmb_loc = copy_location pmb_loc; + } + +and copy_module_expr : From.Parsetree.module_expr -> To.Parsetree.module_expr = + fun { + From.Parsetree.pmod_desc; + From.Parsetree.pmod_loc; + From.Parsetree.pmod_attributes; + } -> + { + To.Parsetree.pmod_desc = copy_module_expr_desc pmod_desc; + To.Parsetree.pmod_loc = copy_location pmod_loc; + To.Parsetree.pmod_attributes = copy_attributes pmod_attributes; + } + +and copy_module_expr_desc : + From.Parsetree.module_expr_desc -> To.Parsetree.module_expr_desc = function + | From.Parsetree.Pmod_ident x0 -> + To.Parsetree.Pmod_ident (copy_loc copy_longident x0) + | From.Parsetree.Pmod_structure x0 -> + To.Parsetree.Pmod_structure (copy_structure x0) + | From.Parsetree.Pmod_functor (x0, x1, x2) -> + To.Parsetree.Pmod_functor + ( copy_loc (fun x -> x) x0, + copy_option copy_module_type x1, + copy_module_expr x2 ) + | From.Parsetree.Pmod_apply (x0, x1) -> + To.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) + | From.Parsetree.Pmod_constraint (x0, x1) -> + To.Parsetree.Pmod_constraint (copy_module_expr x0, copy_module_type x1) + | From.Parsetree.Pmod_unpack x0 -> + To.Parsetree.Pmod_unpack (copy_expression x0) + | From.Parsetree.Pmod_extension x0 -> + To.Parsetree.Pmod_extension (copy_extension x0) + +and copy_module_type : From.Parsetree.module_type -> To.Parsetree.module_type = + fun { + From.Parsetree.pmty_desc; + From.Parsetree.pmty_loc; + From.Parsetree.pmty_attributes; + } -> + { + To.Parsetree.pmty_desc = copy_module_type_desc pmty_desc; + To.Parsetree.pmty_loc = copy_location pmty_loc; + To.Parsetree.pmty_attributes = copy_attributes pmty_attributes; + } + +and copy_module_type_desc : + From.Parsetree.module_type_desc -> To.Parsetree.module_type_desc = function + | From.Parsetree.Pmty_ident x0 -> + To.Parsetree.Pmty_ident (copy_loc copy_longident x0) + | From.Parsetree.Pmty_signature x0 -> + To.Parsetree.Pmty_signature (copy_signature x0) + | From.Parsetree.Pmty_functor (x0, x1, x2) -> + To.Parsetree.Pmty_functor + ( copy_loc (fun x -> x) x0, + copy_option copy_module_type x1, + copy_module_type x2 ) + | From.Parsetree.Pmty_with (x0, x1) -> + To.Parsetree.Pmty_with + (copy_module_type x0, List.map copy_with_constraint x1) + | From.Parsetree.Pmty_typeof x0 -> + To.Parsetree.Pmty_typeof (copy_module_expr x0) + | From.Parsetree.Pmty_extension x0 -> + To.Parsetree.Pmty_extension (copy_extension x0) + | From.Parsetree.Pmty_alias x0 -> + To.Parsetree.Pmty_alias (copy_loc copy_longident x0) + +and copy_with_constraint : + From.Parsetree.with_constraint -> To.Parsetree.with_constraint = function + | From.Parsetree.Pwith_type (x0, x1) -> + To.Parsetree.Pwith_type + (copy_loc copy_longident x0, copy_type_declaration x1) + | From.Parsetree.Pwith_module (x0, x1) -> + To.Parsetree.Pwith_module + (copy_loc copy_longident x0, copy_loc copy_longident x1) + | From.Parsetree.Pwith_typesubst x0 -> + To.Parsetree.Pwith_typesubst + ( copy_loc (fun x -> Longident.Lident x) x0.From.Parsetree.ptype_name, + copy_type_declaration x0 ) + | From.Parsetree.Pwith_modsubst (x0, x1) -> + To.Parsetree.Pwith_modsubst + (copy_loc (fun x -> Longident.Lident x) x0, copy_loc copy_longident x1) + +and copy_signature : From.Parsetree.signature -> To.Parsetree.signature = + fun x -> List.map copy_signature_item x + +and copy_signature_item : + From.Parsetree.signature_item -> To.Parsetree.signature_item = + fun { From.Parsetree.psig_desc; From.Parsetree.psig_loc } -> + { + To.Parsetree.psig_desc = copy_signature_item_desc psig_desc; + To.Parsetree.psig_loc = copy_location psig_loc; + } + +and copy_signature_item_desc : + From.Parsetree.signature_item_desc -> To.Parsetree.signature_item_desc = + function + | From.Parsetree.Psig_value x0 -> + To.Parsetree.Psig_value (copy_value_description x0) + | From.Parsetree.Psig_type (x0, x1) -> + To.Parsetree.Psig_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | From.Parsetree.Psig_typext x0 -> + To.Parsetree.Psig_typext (copy_type_extension x0) + | From.Parsetree.Psig_exception x0 -> + To.Parsetree.Psig_exception (copy_extension_constructor x0) + | From.Parsetree.Psig_module x0 -> + To.Parsetree.Psig_module (copy_module_declaration x0) + | From.Parsetree.Psig_recmodule x0 -> + To.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) + | From.Parsetree.Psig_modtype x0 -> + To.Parsetree.Psig_modtype (copy_module_type_declaration x0) + | From.Parsetree.Psig_open x0 -> + To.Parsetree.Psig_open (copy_open_description x0) + | From.Parsetree.Psig_include x0 -> + To.Parsetree.Psig_include (copy_include_description x0) + | From.Parsetree.Psig_class x0 -> + To.Parsetree.Psig_class (List.map copy_class_description x0) + | From.Parsetree.Psig_class_type x0 -> + To.Parsetree.Psig_class_type (List.map copy_class_type_declaration x0) + | From.Parsetree.Psig_attribute x0 -> + To.Parsetree.Psig_attribute (copy_attribute x0) + | From.Parsetree.Psig_extension (x0, x1) -> + To.Parsetree.Psig_extension (copy_extension x0, copy_attributes x1) + +and copy_class_type_declaration : + From.Parsetree.class_type_declaration -> To.Parsetree.class_type_declaration + = + fun x -> copy_class_infos copy_class_type x + +and copy_class_description : + From.Parsetree.class_description -> To.Parsetree.class_description = + fun x -> copy_class_infos copy_class_type x + +and copy_class_type : From.Parsetree.class_type -> To.Parsetree.class_type = + fun { + From.Parsetree.pcty_desc; + From.Parsetree.pcty_loc; + From.Parsetree.pcty_attributes; + } -> + { + To.Parsetree.pcty_desc = copy_class_type_desc pcty_desc; + To.Parsetree.pcty_loc = copy_location pcty_loc; + To.Parsetree.pcty_attributes = copy_attributes pcty_attributes; + } + +and copy_class_type_desc : + From.Parsetree.class_type_desc -> To.Parsetree.class_type_desc = function + | From.Parsetree.Pcty_constr (x0, x1) -> + To.Parsetree.Pcty_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Pcty_signature x0 -> + To.Parsetree.Pcty_signature (copy_class_signature x0) + | From.Parsetree.Pcty_arrow (x0, x1, x2) -> + To.Parsetree.Pcty_arrow + (copy_arg_label x0, copy_core_type x1, copy_class_type x2) + | From.Parsetree.Pcty_extension x0 -> + To.Parsetree.Pcty_extension (copy_extension x0) + +and copy_class_signature : + From.Parsetree.class_signature -> To.Parsetree.class_signature = + fun { From.Parsetree.pcsig_self; From.Parsetree.pcsig_fields } -> + { + To.Parsetree.pcsig_self = copy_core_type pcsig_self; + To.Parsetree.pcsig_fields = List.map copy_class_type_field pcsig_fields; + } + +and copy_class_type_field : + From.Parsetree.class_type_field -> To.Parsetree.class_type_field = + fun { + From.Parsetree.pctf_desc; + From.Parsetree.pctf_loc; + From.Parsetree.pctf_attributes; + } -> + { + To.Parsetree.pctf_desc = copy_class_type_field_desc pctf_desc; + To.Parsetree.pctf_loc = copy_location pctf_loc; + To.Parsetree.pctf_attributes = copy_attributes pctf_attributes; + } + +and copy_class_type_field_desc : + From.Parsetree.class_type_field_desc -> To.Parsetree.class_type_field_desc = + function + | From.Parsetree.Pctf_inherit x0 -> + To.Parsetree.Pctf_inherit (copy_class_type x0) + | From.Parsetree.Pctf_val x0 -> + To.Parsetree.Pctf_val + (let x0, x1, x2, x3 = x0 in + ( copy_loc (fun x -> x) x0, + copy_mutable_flag x1, + copy_virtual_flag x2, + copy_core_type x3 )) + | From.Parsetree.Pctf_method x0 -> + To.Parsetree.Pctf_method + (let x0, x1, x2, x3 = x0 in + ( copy_loc (fun x -> x) x0, + copy_private_flag x1, + copy_virtual_flag x2, + copy_core_type x3 )) + | From.Parsetree.Pctf_constraint x0 -> + To.Parsetree.Pctf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | From.Parsetree.Pctf_attribute x0 -> + To.Parsetree.Pctf_attribute (copy_attribute x0) + | From.Parsetree.Pctf_extension x0 -> + To.Parsetree.Pctf_extension (copy_extension x0) + +and copy_extension : From.Parsetree.extension -> To.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 From.Parsetree.class_infos -> + 'g0 To.Parsetree.class_infos = + fun f0 + { + From.Parsetree.pci_virt; + From.Parsetree.pci_params; + From.Parsetree.pci_name; + From.Parsetree.pci_expr; + From.Parsetree.pci_loc; + From.Parsetree.pci_attributes; + } -> + { + To.Parsetree.pci_virt = copy_virtual_flag pci_virt; + To.Parsetree.pci_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + pci_params; + To.Parsetree.pci_name = copy_loc (fun x -> x) pci_name; + To.Parsetree.pci_expr = f0 pci_expr; + To.Parsetree.pci_loc = copy_location pci_loc; + To.Parsetree.pci_attributes = copy_attributes pci_attributes; + } + +and copy_virtual_flag : From.Asttypes.virtual_flag -> To.Asttypes.virtual_flag = + function + | From.Asttypes.Virtual -> To.Asttypes.Virtual + | From.Asttypes.Concrete -> To.Asttypes.Concrete + +and copy_include_description : + From.Parsetree.include_description -> To.Parsetree.include_description = + fun x -> copy_include_infos copy_module_type x + +and copy_include_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 From.Parsetree.include_infos -> + 'g0 To.Parsetree.include_infos = + fun f0 + { + From.Parsetree.pincl_mod; + From.Parsetree.pincl_loc; + From.Parsetree.pincl_attributes; + } -> + { + To.Parsetree.pincl_mod = f0 pincl_mod; + To.Parsetree.pincl_loc = copy_location pincl_loc; + To.Parsetree.pincl_attributes = copy_attributes pincl_attributes; + } + +and copy_open_description : + From.Parsetree.open_description -> To.Parsetree.open_description = + fun { + From.Parsetree.popen_lid; + From.Parsetree.popen_override; + From.Parsetree.popen_loc; + From.Parsetree.popen_attributes; + } -> + { + To.Parsetree.popen_lid = copy_loc copy_longident popen_lid; + To.Parsetree.popen_override = copy_override_flag popen_override; + To.Parsetree.popen_loc = copy_location popen_loc; + To.Parsetree.popen_attributes = copy_attributes popen_attributes; + } + +and copy_override_flag : + From.Asttypes.override_flag -> To.Asttypes.override_flag = function + | From.Asttypes.Override -> To.Asttypes.Override + | From.Asttypes.Fresh -> To.Asttypes.Fresh + +and copy_module_type_declaration : + From.Parsetree.module_type_declaration -> + To.Parsetree.module_type_declaration = + fun { + From.Parsetree.pmtd_name; + From.Parsetree.pmtd_type; + From.Parsetree.pmtd_attributes; + From.Parsetree.pmtd_loc; + } -> + { + To.Parsetree.pmtd_name = copy_loc (fun x -> x) pmtd_name; + To.Parsetree.pmtd_type = copy_option copy_module_type pmtd_type; + To.Parsetree.pmtd_attributes = copy_attributes pmtd_attributes; + To.Parsetree.pmtd_loc = copy_location pmtd_loc; + } + +and copy_module_declaration : + From.Parsetree.module_declaration -> To.Parsetree.module_declaration = + fun { + From.Parsetree.pmd_name; + From.Parsetree.pmd_type; + From.Parsetree.pmd_attributes; + From.Parsetree.pmd_loc; + } -> + { + To.Parsetree.pmd_name = copy_loc (fun x -> x) pmd_name; + To.Parsetree.pmd_type = copy_module_type pmd_type; + To.Parsetree.pmd_attributes = copy_attributes pmd_attributes; + To.Parsetree.pmd_loc = copy_location pmd_loc; + } + +and copy_type_extension : + From.Parsetree.type_extension -> To.Parsetree.type_extension = + fun { + From.Parsetree.ptyext_path; + From.Parsetree.ptyext_params; + From.Parsetree.ptyext_constructors; + From.Parsetree.ptyext_private; + From.Parsetree.ptyext_attributes; + } -> + { + To.Parsetree.ptyext_path = copy_loc copy_longident ptyext_path; + To.Parsetree.ptyext_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptyext_params; + To.Parsetree.ptyext_constructors = + List.map copy_extension_constructor ptyext_constructors; + To.Parsetree.ptyext_private = copy_private_flag ptyext_private; + To.Parsetree.ptyext_attributes = copy_attributes ptyext_attributes; + } + +and copy_extension_constructor : + From.Parsetree.extension_constructor -> To.Parsetree.extension_constructor = + fun { + From.Parsetree.pext_name; + From.Parsetree.pext_kind; + From.Parsetree.pext_loc; + From.Parsetree.pext_attributes; + } -> + { + To.Parsetree.pext_name = copy_loc (fun x -> x) pext_name; + To.Parsetree.pext_kind = copy_extension_constructor_kind pext_kind; + To.Parsetree.pext_loc = copy_location pext_loc; + To.Parsetree.pext_attributes = copy_attributes pext_attributes; + } + +and copy_extension_constructor_kind : + From.Parsetree.extension_constructor_kind -> + To.Parsetree.extension_constructor_kind = function + | From.Parsetree.Pext_decl (x0, x1) -> + To.Parsetree.Pext_decl + (copy_constructor_arguments x0, copy_option copy_core_type x1) + | From.Parsetree.Pext_rebind x0 -> + To.Parsetree.Pext_rebind (copy_loc copy_longident x0) + +and copy_type_declaration : + From.Parsetree.type_declaration -> To.Parsetree.type_declaration = + fun { + From.Parsetree.ptype_name; + From.Parsetree.ptype_params; + From.Parsetree.ptype_cstrs; + From.Parsetree.ptype_kind; + From.Parsetree.ptype_private; + From.Parsetree.ptype_manifest; + From.Parsetree.ptype_attributes; + From.Parsetree.ptype_loc; + } -> + { + To.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name; + To.Parsetree.ptype_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptype_params; + To.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; + To.Parsetree.ptype_kind = copy_type_kind ptype_kind; + To.Parsetree.ptype_private = copy_private_flag ptype_private; + To.Parsetree.ptype_manifest = copy_option copy_core_type ptype_manifest; + To.Parsetree.ptype_attributes = copy_attributes ptype_attributes; + To.Parsetree.ptype_loc = copy_location ptype_loc; + } + +and copy_private_flag : From.Asttypes.private_flag -> To.Asttypes.private_flag = + function + | From.Asttypes.Private -> To.Asttypes.Private + | From.Asttypes.Public -> To.Asttypes.Public + +and copy_type_kind : From.Parsetree.type_kind -> To.Parsetree.type_kind = + function + | From.Parsetree.Ptype_abstract -> To.Parsetree.Ptype_abstract + | From.Parsetree.Ptype_variant x0 -> + To.Parsetree.Ptype_variant (List.map copy_constructor_declaration x0) + | From.Parsetree.Ptype_record x0 -> + To.Parsetree.Ptype_record (List.map copy_label_declaration x0) + | From.Parsetree.Ptype_open -> To.Parsetree.Ptype_open + +and copy_constructor_declaration : + From.Parsetree.constructor_declaration -> + To.Parsetree.constructor_declaration = + fun { + From.Parsetree.pcd_name; + From.Parsetree.pcd_args; + From.Parsetree.pcd_res; + From.Parsetree.pcd_loc; + From.Parsetree.pcd_attributes; + } -> + { + To.Parsetree.pcd_name = copy_loc (fun x -> x) pcd_name; + To.Parsetree.pcd_args = copy_constructor_arguments pcd_args; + To.Parsetree.pcd_res = copy_option copy_core_type pcd_res; + To.Parsetree.pcd_loc = copy_location pcd_loc; + To.Parsetree.pcd_attributes = copy_attributes pcd_attributes; + } + +and copy_constructor_arguments : + From.Parsetree.constructor_arguments -> To.Parsetree.constructor_arguments = + function + | From.Parsetree.Pcstr_tuple x0 -> + To.Parsetree.Pcstr_tuple (List.map copy_core_type x0) + | From.Parsetree.Pcstr_record x0 -> + To.Parsetree.Pcstr_record (List.map copy_label_declaration x0) + +and copy_label_declaration : + From.Parsetree.label_declaration -> To.Parsetree.label_declaration = + fun { + From.Parsetree.pld_name; + From.Parsetree.pld_mutable; + From.Parsetree.pld_type; + From.Parsetree.pld_loc; + From.Parsetree.pld_attributes; + } -> + { + To.Parsetree.pld_name = copy_loc (fun x -> x) pld_name; + To.Parsetree.pld_mutable = copy_mutable_flag pld_mutable; + To.Parsetree.pld_type = copy_core_type pld_type; + To.Parsetree.pld_loc = copy_location pld_loc; + To.Parsetree.pld_attributes = copy_attributes pld_attributes; + } + +and copy_mutable_flag : From.Asttypes.mutable_flag -> To.Asttypes.mutable_flag = + function + | From.Asttypes.Immutable -> To.Asttypes.Immutable + | From.Asttypes.Mutable -> To.Asttypes.Mutable + +and copy_variance : From.Asttypes.variance -> To.Asttypes.variance = function + | From.Asttypes.Covariant -> To.Asttypes.Covariant + | From.Asttypes.Contravariant -> To.Asttypes.Contravariant + | From.Asttypes.Invariant -> To.Asttypes.Invariant + +and copy_value_description : + From.Parsetree.value_description -> To.Parsetree.value_description = + fun { + From.Parsetree.pval_name; + From.Parsetree.pval_type; + From.Parsetree.pval_prim; + From.Parsetree.pval_attributes; + From.Parsetree.pval_loc; + } -> + { + To.Parsetree.pval_name = copy_loc (fun x -> x) pval_name; + To.Parsetree.pval_type = copy_core_type pval_type; + To.Parsetree.pval_prim = List.map (fun x -> x) pval_prim; + To.Parsetree.pval_attributes = copy_attributes pval_attributes; + To.Parsetree.pval_loc = copy_location pval_loc; + } + +and copy_arg_label : From.Asttypes.arg_label -> To.Asttypes.arg_label = function + | From.Asttypes.Nolabel -> To.Asttypes.Nolabel + | From.Asttypes.Labelled x0 -> To.Asttypes.Labelled x0 + | From.Asttypes.Optional x0 -> To.Asttypes.Optional x0 + +and copy_closed_flag : From.Asttypes.closed_flag -> To.Asttypes.closed_flag = + function + | From.Asttypes.Closed -> To.Asttypes.Closed + | From.Asttypes.Open -> To.Asttypes.Open + +and copy_label : From.Asttypes.label -> To.Asttypes.label = fun x -> x + +and copy_rec_flag : From.Asttypes.rec_flag -> To.Asttypes.rec_flag = function + | From.Asttypes.Nonrecursive -> To.Asttypes.Nonrecursive + | From.Asttypes.Recursive -> To.Asttypes.Recursive + +and copy_constant : From.Parsetree.constant -> To.Parsetree.constant = function + | From.Parsetree.Pconst_integer (x0, x1) -> + To.Parsetree.Pconst_integer (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pconst_char x0 -> To.Parsetree.Pconst_char x0 + | From.Parsetree.Pconst_string (x0, x1) -> + To.Parsetree.Pconst_string (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pconst_float (x0, x1) -> + To.Parsetree.Pconst_float (x0, copy_option (fun x -> x) x1) + +and copy_option : 'f0 'g0. ('f0 -> 'g0) -> 'f0 option -> 'g0 option = + fun f0 -> function None -> None | Some x0 -> Some (f0 x0) + +and copy_longident : Longident.t -> Longident.t = fun x -> x + +and copy_loc : + 'f0 'g0. ('f0 -> 'g0) -> 'f0 From.Asttypes.loc -> 'g0 To.Asttypes.loc = + fun f0 { From.Asttypes.txt; From.Asttypes.loc } -> + { To.Asttypes.txt = f0 txt; To.Asttypes.loc = copy_location loc } + +and copy_location : Location.t -> Location.t = fun x -> x + +and copy_bool : bool -> bool = function false -> false | true -> true + +let rec copy_toplevel_phrase : + From.Parsetree.toplevel_phrase -> To.Parsetree.toplevel_phrase = function + | From.Parsetree.Ptop_def x0 -> To.Parsetree.Ptop_def (copy_structure x0) + | From.Parsetree.Ptop_dir (x0, x1) -> + To.Parsetree.Ptop_dir (x0, copy_directive_argument x1) + +and copy_directive_argument : + From.Parsetree.directive_argument -> To.Parsetree.directive_argument = + function + | From.Parsetree.Pdir_none -> To.Parsetree.Pdir_none + | From.Parsetree.Pdir_string x0 -> To.Parsetree.Pdir_string x0 + | From.Parsetree.Pdir_int (x0, x1) -> + To.Parsetree.Pdir_int (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pdir_ident x0 -> To.Parsetree.Pdir_ident (copy_longident x0) + | From.Parsetree.Pdir_bool x0 -> To.Parsetree.Pdir_bool (copy_bool x0) + +let copy_cases x = List.map copy_case x + +let copy_pat = copy_pattern + +let copy_expr = copy_expression + +let copy_typ = copy_core_type diff -Nru ppxlib-0.15.0/astlib/migrate_406_405.ml ppxlib-0.24.0/astlib/migrate_406_405.ml --- ppxlib-0.15.0/astlib/migrate_406_405.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/migrate_406_405.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1029 @@ +(**************************************************************************) +(* *) +(* OCaml Migrate Parsetree *) +(* *) +(* Frédéric Bour *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2017 Institut National de Recherche en Informatique et *) +(* en Automatique (INRIA). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module From = Ast_406 +module To = Ast_405 + +let migration_error loc missing_feature = + Location.raise_errorf ~loc + "migration error: %s is not supported before OCaml 4.06" missing_feature + +let rec copy_expression : From.Parsetree.expression -> To.Parsetree.expression = + fun { + From.Parsetree.pexp_desc; + From.Parsetree.pexp_loc; + From.Parsetree.pexp_attributes; + } -> + { + To.Parsetree.pexp_desc = copy_expression_desc pexp_desc; + To.Parsetree.pexp_loc = copy_location pexp_loc; + To.Parsetree.pexp_attributes = copy_attributes pexp_attributes; + } + +and copy_expression_desc : + From.Parsetree.expression_desc -> To.Parsetree.expression_desc = function + | From.Parsetree.Pexp_ident x0 -> + To.Parsetree.Pexp_ident (copy_loc copy_longident x0) + | From.Parsetree.Pexp_constant x0 -> + To.Parsetree.Pexp_constant (copy_constant x0) + | From.Parsetree.Pexp_let (x0, x1, x2) -> + To.Parsetree.Pexp_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_expression x2) + | From.Parsetree.Pexp_function x0 -> + To.Parsetree.Pexp_function (List.map copy_case x0) + | From.Parsetree.Pexp_fun (x0, x1, x2, x3) -> + To.Parsetree.Pexp_fun + ( copy_arg_label x0, + copy_option copy_expression x1, + copy_pattern x2, + copy_expression x3 ) + | From.Parsetree.Pexp_apply (x0, x1) -> + To.Parsetree.Pexp_apply + ( copy_expression x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | From.Parsetree.Pexp_match (x0, x1) -> + To.Parsetree.Pexp_match (copy_expression x0, List.map copy_case x1) + | From.Parsetree.Pexp_try (x0, x1) -> + To.Parsetree.Pexp_try (copy_expression x0, List.map copy_case x1) + | From.Parsetree.Pexp_tuple x0 -> + To.Parsetree.Pexp_tuple (List.map copy_expression x0) + | From.Parsetree.Pexp_construct (x0, x1) -> + To.Parsetree.Pexp_construct + (copy_loc copy_longident x0, copy_option copy_expression x1) + | From.Parsetree.Pexp_variant (x0, x1) -> + To.Parsetree.Pexp_variant (copy_label x0, copy_option copy_expression x1) + | From.Parsetree.Pexp_record (x0, x1) -> + To.Parsetree.Pexp_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_expression x1)) + x0, + copy_option copy_expression x1 ) + | From.Parsetree.Pexp_field (x0, x1) -> + To.Parsetree.Pexp_field (copy_expression x0, copy_loc copy_longident x1) + | From.Parsetree.Pexp_setfield (x0, x1, x2) -> + To.Parsetree.Pexp_setfield + (copy_expression x0, copy_loc copy_longident x1, copy_expression x2) + | From.Parsetree.Pexp_array x0 -> + To.Parsetree.Pexp_array (List.map copy_expression x0) + | From.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> + To.Parsetree.Pexp_ifthenelse + (copy_expression x0, copy_expression x1, copy_option copy_expression x2) + | From.Parsetree.Pexp_sequence (x0, x1) -> + To.Parsetree.Pexp_sequence (copy_expression x0, copy_expression x1) + | From.Parsetree.Pexp_while (x0, x1) -> + To.Parsetree.Pexp_while (copy_expression x0, copy_expression x1) + | From.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> + To.Parsetree.Pexp_for + ( copy_pattern x0, + copy_expression x1, + copy_expression x2, + copy_direction_flag x3, + copy_expression x4 ) + | From.Parsetree.Pexp_constraint (x0, x1) -> + To.Parsetree.Pexp_constraint (copy_expression x0, copy_core_type x1) + | From.Parsetree.Pexp_coerce (x0, x1, x2) -> + To.Parsetree.Pexp_coerce + (copy_expression x0, copy_option copy_core_type x1, copy_core_type x2) + | From.Parsetree.Pexp_send (x0, x1) -> + To.Parsetree.Pexp_send (copy_expression x0, copy_loc (fun x -> x) x1) + | From.Parsetree.Pexp_new x0 -> + To.Parsetree.Pexp_new (copy_loc copy_longident x0) + | From.Parsetree.Pexp_setinstvar (x0, x1) -> + To.Parsetree.Pexp_setinstvar (copy_loc (fun x -> x) x0, copy_expression x1) + | From.Parsetree.Pexp_override x0 -> + To.Parsetree.Pexp_override + (List.map + (fun x -> + let x0, x1 = x in + (copy_loc (fun x -> x) x0, copy_expression x1)) + x0) + | From.Parsetree.Pexp_letmodule (x0, x1, x2) -> + To.Parsetree.Pexp_letmodule + (copy_loc (fun x -> x) x0, copy_module_expr x1, copy_expression x2) + | From.Parsetree.Pexp_letexception (x0, x1) -> + To.Parsetree.Pexp_letexception + (copy_extension_constructor x0, copy_expression x1) + | From.Parsetree.Pexp_assert x0 -> + To.Parsetree.Pexp_assert (copy_expression x0) + | From.Parsetree.Pexp_lazy x0 -> To.Parsetree.Pexp_lazy (copy_expression x0) + | From.Parsetree.Pexp_poly (x0, x1) -> + To.Parsetree.Pexp_poly (copy_expression x0, copy_option copy_core_type x1) + | From.Parsetree.Pexp_object x0 -> + To.Parsetree.Pexp_object (copy_class_structure x0) + | From.Parsetree.Pexp_newtype (x0, x1) -> + To.Parsetree.Pexp_newtype (copy_loc (fun x -> x) x0, copy_expression x1) + | From.Parsetree.Pexp_pack x0 -> To.Parsetree.Pexp_pack (copy_module_expr x0) + | From.Parsetree.Pexp_open (x0, x1, x2) -> + To.Parsetree.Pexp_open + (copy_override_flag x0, copy_loc copy_longident x1, copy_expression x2) + | From.Parsetree.Pexp_extension x0 -> + To.Parsetree.Pexp_extension (copy_extension x0) + | From.Parsetree.Pexp_unreachable -> To.Parsetree.Pexp_unreachable + +and copy_direction_flag : + From.Asttypes.direction_flag -> To.Asttypes.direction_flag = function + | From.Asttypes.Upto -> To.Asttypes.Upto + | From.Asttypes.Downto -> To.Asttypes.Downto + +and copy_case : From.Parsetree.case -> To.Parsetree.case = + fun { From.Parsetree.pc_lhs; From.Parsetree.pc_guard; From.Parsetree.pc_rhs } -> + { + To.Parsetree.pc_lhs = copy_pattern pc_lhs; + To.Parsetree.pc_guard = copy_option copy_expression pc_guard; + To.Parsetree.pc_rhs = copy_expression pc_rhs; + } + +and copy_value_binding : + From.Parsetree.value_binding -> To.Parsetree.value_binding = + fun { + From.Parsetree.pvb_pat; + From.Parsetree.pvb_expr; + From.Parsetree.pvb_attributes; + From.Parsetree.pvb_loc; + } -> + { + To.Parsetree.pvb_pat = copy_pattern pvb_pat; + To.Parsetree.pvb_expr = copy_expression pvb_expr; + To.Parsetree.pvb_attributes = copy_attributes pvb_attributes; + To.Parsetree.pvb_loc = copy_location pvb_loc; + } + +and copy_pattern : From.Parsetree.pattern -> To.Parsetree.pattern = + fun { + From.Parsetree.ppat_desc; + From.Parsetree.ppat_loc; + From.Parsetree.ppat_attributes; + } -> + { + To.Parsetree.ppat_desc = copy_pattern_desc ppat_desc; + To.Parsetree.ppat_loc = copy_location ppat_loc; + To.Parsetree.ppat_attributes = copy_attributes ppat_attributes; + } + +and copy_pattern_desc : From.Parsetree.pattern_desc -> To.Parsetree.pattern_desc + = function + | From.Parsetree.Ppat_any -> To.Parsetree.Ppat_any + | From.Parsetree.Ppat_var x0 -> + To.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) + | From.Parsetree.Ppat_alias (x0, x1) -> + To.Parsetree.Ppat_alias (copy_pattern x0, copy_loc (fun x -> x) x1) + | From.Parsetree.Ppat_constant x0 -> + To.Parsetree.Ppat_constant (copy_constant x0) + | From.Parsetree.Ppat_interval (x0, x1) -> + To.Parsetree.Ppat_interval (copy_constant x0, copy_constant x1) + | From.Parsetree.Ppat_tuple x0 -> + To.Parsetree.Ppat_tuple (List.map copy_pattern x0) + | From.Parsetree.Ppat_construct (x0, x1) -> + To.Parsetree.Ppat_construct + (copy_loc copy_longident x0, copy_option copy_pattern x1) + | From.Parsetree.Ppat_variant (x0, x1) -> + To.Parsetree.Ppat_variant (copy_label x0, copy_option copy_pattern x1) + | From.Parsetree.Ppat_record (x0, x1) -> + To.Parsetree.Ppat_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_pattern x1)) + x0, + copy_closed_flag x1 ) + | From.Parsetree.Ppat_array x0 -> + To.Parsetree.Ppat_array (List.map copy_pattern x0) + | From.Parsetree.Ppat_or (x0, x1) -> + To.Parsetree.Ppat_or (copy_pattern x0, copy_pattern x1) + | From.Parsetree.Ppat_constraint (x0, x1) -> + To.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1) + | From.Parsetree.Ppat_type x0 -> + To.Parsetree.Ppat_type (copy_loc copy_longident x0) + | From.Parsetree.Ppat_lazy x0 -> To.Parsetree.Ppat_lazy (copy_pattern x0) + | From.Parsetree.Ppat_unpack x0 -> + To.Parsetree.Ppat_unpack (copy_loc (fun x -> x) x0) + | From.Parsetree.Ppat_exception x0 -> + To.Parsetree.Ppat_exception (copy_pattern x0) + | From.Parsetree.Ppat_extension x0 -> + To.Parsetree.Ppat_extension (copy_extension x0) + | From.Parsetree.Ppat_open (x0, x1) -> + To.Parsetree.Ppat_open (copy_loc copy_longident x0, copy_pattern x1) + +and copy_core_type : From.Parsetree.core_type -> To.Parsetree.core_type = + fun { + From.Parsetree.ptyp_desc; + From.Parsetree.ptyp_loc; + From.Parsetree.ptyp_attributes; + } -> + { + To.Parsetree.ptyp_desc = copy_core_type_desc ptyp_desc; + To.Parsetree.ptyp_loc = copy_location ptyp_loc; + To.Parsetree.ptyp_attributes = copy_attributes ptyp_attributes; + } + +and copy_core_type_desc : + From.Parsetree.core_type_desc -> To.Parsetree.core_type_desc = function + | From.Parsetree.Ptyp_any -> To.Parsetree.Ptyp_any + | From.Parsetree.Ptyp_var x0 -> To.Parsetree.Ptyp_var x0 + | From.Parsetree.Ptyp_arrow (x0, x1, x2) -> + To.Parsetree.Ptyp_arrow + (copy_arg_label x0, copy_core_type x1, copy_core_type x2) + | From.Parsetree.Ptyp_tuple x0 -> + To.Parsetree.Ptyp_tuple (List.map copy_core_type x0) + | From.Parsetree.Ptyp_constr (x0, x1) -> + To.Parsetree.Ptyp_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Ptyp_object (x0, x1) -> + To.Parsetree.Ptyp_object + ( List.map + (function + | From.Parsetree.Otag (x0, x1, x2) -> + ( copy_loc (fun x -> x) x0, + copy_attributes x1, + copy_core_type x2 ) + | From.Parsetree.Oinherit _ -> + migration_error Location.none "inheritance in object type") + x0, + copy_closed_flag x1 ) + | From.Parsetree.Ptyp_class (x0, x1) -> + To.Parsetree.Ptyp_class + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Ptyp_alias (x0, x1) -> + To.Parsetree.Ptyp_alias (copy_core_type x0, x1) + | From.Parsetree.Ptyp_variant (x0, x1, x2) -> + To.Parsetree.Ptyp_variant + ( List.map copy_row_field x0, + copy_closed_flag x1, + copy_option (fun x -> List.map copy_label x) x2 ) + | From.Parsetree.Ptyp_poly (x0, x1) -> + To.Parsetree.Ptyp_poly + (List.map (fun x -> copy_loc (fun x -> x) x) x0, copy_core_type x1) + | From.Parsetree.Ptyp_package x0 -> + To.Parsetree.Ptyp_package (copy_package_type x0) + | From.Parsetree.Ptyp_extension x0 -> + To.Parsetree.Ptyp_extension (copy_extension x0) + +and copy_package_type : From.Parsetree.package_type -> To.Parsetree.package_type + = + fun x -> + let x0, x1 = x in + ( copy_loc copy_longident x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_core_type x1)) + x1 ) + +and copy_row_field : From.Parsetree.row_field -> To.Parsetree.row_field = + function + | From.Parsetree.Rtag (x0, x1, x2, x3) -> + To.Parsetree.Rtag + ( copy_label x0.txt, + copy_attributes x1, + copy_bool x2, + List.map copy_core_type x3 ) + | From.Parsetree.Rinherit x0 -> To.Parsetree.Rinherit (copy_core_type x0) + +and copy_attributes : From.Parsetree.attributes -> To.Parsetree.attributes = + fun x -> List.map copy_attribute x + +and copy_attribute : From.Parsetree.attribute -> To.Parsetree.attribute = + fun x -> + let x0, x1 = x in + (copy_loc (fun x -> x) x0, copy_payload x1) + +and copy_payload : From.Parsetree.payload -> To.Parsetree.payload = function + | From.Parsetree.PStr x0 -> To.Parsetree.PStr (copy_structure x0) + | From.Parsetree.PSig x0 -> To.Parsetree.PSig (copy_signature x0) + | From.Parsetree.PTyp x0 -> To.Parsetree.PTyp (copy_core_type x0) + | From.Parsetree.PPat (x0, x1) -> + To.Parsetree.PPat (copy_pattern x0, copy_option copy_expression x1) + +and copy_structure : From.Parsetree.structure -> To.Parsetree.structure = + fun x -> List.map copy_structure_item x + +and copy_structure_item : + From.Parsetree.structure_item -> To.Parsetree.structure_item = + fun { From.Parsetree.pstr_desc; From.Parsetree.pstr_loc } -> + { + To.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc; + To.Parsetree.pstr_loc = copy_location pstr_loc; + } + +and copy_structure_item_desc : + From.Parsetree.structure_item_desc -> To.Parsetree.structure_item_desc = + function + | From.Parsetree.Pstr_eval (x0, x1) -> + To.Parsetree.Pstr_eval (copy_expression x0, copy_attributes x1) + | From.Parsetree.Pstr_value (x0, x1) -> + To.Parsetree.Pstr_value (copy_rec_flag x0, List.map copy_value_binding x1) + | From.Parsetree.Pstr_primitive x0 -> + To.Parsetree.Pstr_primitive (copy_value_description x0) + | From.Parsetree.Pstr_type (x0, x1) -> + To.Parsetree.Pstr_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | From.Parsetree.Pstr_typext x0 -> + To.Parsetree.Pstr_typext (copy_type_extension x0) + | From.Parsetree.Pstr_exception x0 -> + To.Parsetree.Pstr_exception (copy_extension_constructor x0) + | From.Parsetree.Pstr_module x0 -> + To.Parsetree.Pstr_module (copy_module_binding x0) + | From.Parsetree.Pstr_recmodule x0 -> + To.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) + | From.Parsetree.Pstr_modtype x0 -> + To.Parsetree.Pstr_modtype (copy_module_type_declaration x0) + | From.Parsetree.Pstr_open x0 -> + To.Parsetree.Pstr_open (copy_open_description x0) + | From.Parsetree.Pstr_class x0 -> + To.Parsetree.Pstr_class (List.map copy_class_declaration x0) + | From.Parsetree.Pstr_class_type x0 -> + To.Parsetree.Pstr_class_type (List.map copy_class_type_declaration x0) + | From.Parsetree.Pstr_include x0 -> + To.Parsetree.Pstr_include (copy_include_declaration x0) + | From.Parsetree.Pstr_attribute x0 -> + To.Parsetree.Pstr_attribute (copy_attribute x0) + | From.Parsetree.Pstr_extension (x0, x1) -> + To.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1) + +and copy_include_declaration : + From.Parsetree.include_declaration -> To.Parsetree.include_declaration = + fun x -> copy_include_infos copy_module_expr x + +and copy_class_declaration : + From.Parsetree.class_declaration -> To.Parsetree.class_declaration = + fun x -> copy_class_infos copy_class_expr x + +and copy_class_expr : From.Parsetree.class_expr -> To.Parsetree.class_expr = + fun { + From.Parsetree.pcl_desc; + From.Parsetree.pcl_loc; + From.Parsetree.pcl_attributes; + } -> + { + To.Parsetree.pcl_desc = copy_class_expr_desc pcl_desc; + To.Parsetree.pcl_loc = copy_location pcl_loc; + To.Parsetree.pcl_attributes = copy_attributes pcl_attributes; + } + +and copy_class_expr_desc : + From.Parsetree.class_expr_desc -> To.Parsetree.class_expr_desc = function + | From.Parsetree.Pcl_constr (x0, x1) -> + To.Parsetree.Pcl_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Pcl_structure x0 -> + To.Parsetree.Pcl_structure (copy_class_structure x0) + | From.Parsetree.Pcl_fun (x0, x1, x2, x3) -> + To.Parsetree.Pcl_fun + ( copy_arg_label x0, + copy_option copy_expression x1, + copy_pattern x2, + copy_class_expr x3 ) + | From.Parsetree.Pcl_apply (x0, x1) -> + To.Parsetree.Pcl_apply + ( copy_class_expr x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | From.Parsetree.Pcl_let (x0, x1, x2) -> + To.Parsetree.Pcl_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_class_expr x2) + | From.Parsetree.Pcl_constraint (x0, x1) -> + To.Parsetree.Pcl_constraint (copy_class_expr x0, copy_class_type x1) + | From.Parsetree.Pcl_extension x0 -> + To.Parsetree.Pcl_extension (copy_extension x0) + | From.Parsetree.Pcl_open (_, loc, _) -> + migration_error loc.Location.loc "module open in class expression" + +and copy_class_structure : + From.Parsetree.class_structure -> To.Parsetree.class_structure = + fun { From.Parsetree.pcstr_self; From.Parsetree.pcstr_fields } -> + { + To.Parsetree.pcstr_self = copy_pattern pcstr_self; + To.Parsetree.pcstr_fields = List.map copy_class_field pcstr_fields; + } + +and copy_class_field : From.Parsetree.class_field -> To.Parsetree.class_field = + fun { + From.Parsetree.pcf_desc; + From.Parsetree.pcf_loc; + From.Parsetree.pcf_attributes; + } -> + { + To.Parsetree.pcf_desc = copy_class_field_desc pcf_desc; + To.Parsetree.pcf_loc = copy_location pcf_loc; + To.Parsetree.pcf_attributes = copy_attributes pcf_attributes; + } + +and copy_class_field_desc : + From.Parsetree.class_field_desc -> To.Parsetree.class_field_desc = function + | From.Parsetree.Pcf_inherit (x0, x1, x2) -> + To.Parsetree.Pcf_inherit + ( copy_override_flag x0, + copy_class_expr x1, + copy_option (copy_loc (fun x -> x)) x2 ) + | From.Parsetree.Pcf_val x0 -> + To.Parsetree.Pcf_val + (let x0, x1, x2 = x0 in + ( copy_loc (fun x -> x) x0, + copy_mutable_flag x1, + copy_class_field_kind x2 )) + | From.Parsetree.Pcf_method x0 -> + To.Parsetree.Pcf_method + (let x0, x1, x2 = x0 in + ( copy_loc (fun x -> x) x0, + copy_private_flag x1, + copy_class_field_kind x2 )) + | From.Parsetree.Pcf_constraint x0 -> + To.Parsetree.Pcf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | From.Parsetree.Pcf_initializer x0 -> + To.Parsetree.Pcf_initializer (copy_expression x0) + | From.Parsetree.Pcf_attribute x0 -> + To.Parsetree.Pcf_attribute (copy_attribute x0) + | From.Parsetree.Pcf_extension x0 -> + To.Parsetree.Pcf_extension (copy_extension x0) + +and copy_class_field_kind : + From.Parsetree.class_field_kind -> To.Parsetree.class_field_kind = function + | From.Parsetree.Cfk_virtual x0 -> + To.Parsetree.Cfk_virtual (copy_core_type x0) + | From.Parsetree.Cfk_concrete (x0, x1) -> + To.Parsetree.Cfk_concrete (copy_override_flag x0, copy_expression x1) + +and copy_module_binding : + From.Parsetree.module_binding -> To.Parsetree.module_binding = + fun { + From.Parsetree.pmb_name; + From.Parsetree.pmb_expr; + From.Parsetree.pmb_attributes; + From.Parsetree.pmb_loc; + } -> + { + To.Parsetree.pmb_name = copy_loc (fun x -> x) pmb_name; + To.Parsetree.pmb_expr = copy_module_expr pmb_expr; + To.Parsetree.pmb_attributes = copy_attributes pmb_attributes; + To.Parsetree.pmb_loc = copy_location pmb_loc; + } + +and copy_module_expr : From.Parsetree.module_expr -> To.Parsetree.module_expr = + fun { + From.Parsetree.pmod_desc; + From.Parsetree.pmod_loc; + From.Parsetree.pmod_attributes; + } -> + { + To.Parsetree.pmod_desc = copy_module_expr_desc pmod_desc; + To.Parsetree.pmod_loc = copy_location pmod_loc; + To.Parsetree.pmod_attributes = copy_attributes pmod_attributes; + } + +and copy_module_expr_desc : + From.Parsetree.module_expr_desc -> To.Parsetree.module_expr_desc = function + | From.Parsetree.Pmod_ident x0 -> + To.Parsetree.Pmod_ident (copy_loc copy_longident x0) + | From.Parsetree.Pmod_structure x0 -> + To.Parsetree.Pmod_structure (copy_structure x0) + | From.Parsetree.Pmod_functor (x0, x1, x2) -> + To.Parsetree.Pmod_functor + ( copy_loc (fun x -> x) x0, + copy_option copy_module_type x1, + copy_module_expr x2 ) + | From.Parsetree.Pmod_apply (x0, x1) -> + To.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) + | From.Parsetree.Pmod_constraint (x0, x1) -> + To.Parsetree.Pmod_constraint (copy_module_expr x0, copy_module_type x1) + | From.Parsetree.Pmod_unpack x0 -> + To.Parsetree.Pmod_unpack (copy_expression x0) + | From.Parsetree.Pmod_extension x0 -> + To.Parsetree.Pmod_extension (copy_extension x0) + +and copy_module_type : From.Parsetree.module_type -> To.Parsetree.module_type = + fun { + From.Parsetree.pmty_desc; + From.Parsetree.pmty_loc; + From.Parsetree.pmty_attributes; + } -> + { + To.Parsetree.pmty_desc = copy_module_type_desc pmty_desc; + To.Parsetree.pmty_loc = copy_location pmty_loc; + To.Parsetree.pmty_attributes = copy_attributes pmty_attributes; + } + +and copy_module_type_desc : + From.Parsetree.module_type_desc -> To.Parsetree.module_type_desc = function + | From.Parsetree.Pmty_ident x0 -> + To.Parsetree.Pmty_ident (copy_loc copy_longident x0) + | From.Parsetree.Pmty_signature x0 -> + To.Parsetree.Pmty_signature (copy_signature x0) + | From.Parsetree.Pmty_functor (x0, x1, x2) -> + To.Parsetree.Pmty_functor + ( copy_loc (fun x -> x) x0, + copy_option copy_module_type x1, + copy_module_type x2 ) + | From.Parsetree.Pmty_with (x0, x1) -> + To.Parsetree.Pmty_with + (copy_module_type x0, List.map copy_with_constraint x1) + | From.Parsetree.Pmty_typeof x0 -> + To.Parsetree.Pmty_typeof (copy_module_expr x0) + | From.Parsetree.Pmty_extension x0 -> + To.Parsetree.Pmty_extension (copy_extension x0) + | From.Parsetree.Pmty_alias x0 -> + To.Parsetree.Pmty_alias (copy_loc copy_longident x0) + +and copy_with_constraint : + From.Parsetree.with_constraint -> To.Parsetree.with_constraint = function + | From.Parsetree.Pwith_type (x0, x1) -> + To.Parsetree.Pwith_type + (copy_loc copy_longident x0, copy_type_declaration x1) + | From.Parsetree.Pwith_module (x0, x1) -> + To.Parsetree.Pwith_module + (copy_loc copy_longident x0, copy_loc copy_longident x1) + | From.Parsetree.Pwith_typesubst ({ txt = Longident.Lident _; _ }, x0) -> + To.Parsetree.Pwith_typesubst (copy_type_declaration x0) + | From.Parsetree.Pwith_modsubst ({ txt = Longident.Lident x0; loc }, x1) -> + To.Parsetree.Pwith_modsubst ({ txt = x0; loc }, copy_loc copy_longident x1) + | From.Parsetree.Pwith_typesubst ({ loc; _ }, _x0) -> + migration_error loc "type substitution inside a submodule" + | From.Parsetree.Pwith_modsubst ({ loc; _ }, _x1) -> + migration_error loc "module substitution inside a submodule" + +and copy_signature : From.Parsetree.signature -> To.Parsetree.signature = + fun x -> List.map copy_signature_item x + +and copy_signature_item : + From.Parsetree.signature_item -> To.Parsetree.signature_item = + fun { From.Parsetree.psig_desc; From.Parsetree.psig_loc } -> + { + To.Parsetree.psig_desc = copy_signature_item_desc psig_desc; + To.Parsetree.psig_loc = copy_location psig_loc; + } + +and copy_signature_item_desc : + From.Parsetree.signature_item_desc -> To.Parsetree.signature_item_desc = + function + | From.Parsetree.Psig_value x0 -> + To.Parsetree.Psig_value (copy_value_description x0) + | From.Parsetree.Psig_type (x0, x1) -> + To.Parsetree.Psig_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | From.Parsetree.Psig_typext x0 -> + To.Parsetree.Psig_typext (copy_type_extension x0) + | From.Parsetree.Psig_exception x0 -> + To.Parsetree.Psig_exception (copy_extension_constructor x0) + | From.Parsetree.Psig_module x0 -> + To.Parsetree.Psig_module (copy_module_declaration x0) + | From.Parsetree.Psig_recmodule x0 -> + To.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) + | From.Parsetree.Psig_modtype x0 -> + To.Parsetree.Psig_modtype (copy_module_type_declaration x0) + | From.Parsetree.Psig_open x0 -> + To.Parsetree.Psig_open (copy_open_description x0) + | From.Parsetree.Psig_include x0 -> + To.Parsetree.Psig_include (copy_include_description x0) + | From.Parsetree.Psig_class x0 -> + To.Parsetree.Psig_class (List.map copy_class_description x0) + | From.Parsetree.Psig_class_type x0 -> + To.Parsetree.Psig_class_type (List.map copy_class_type_declaration x0) + | From.Parsetree.Psig_attribute x0 -> + To.Parsetree.Psig_attribute (copy_attribute x0) + | From.Parsetree.Psig_extension (x0, x1) -> + To.Parsetree.Psig_extension (copy_extension x0, copy_attributes x1) + +and copy_class_type_declaration : + From.Parsetree.class_type_declaration -> To.Parsetree.class_type_declaration + = + fun x -> copy_class_infos copy_class_type x + +and copy_class_description : + From.Parsetree.class_description -> To.Parsetree.class_description = + fun x -> copy_class_infos copy_class_type x + +and copy_class_type : From.Parsetree.class_type -> To.Parsetree.class_type = + fun { + From.Parsetree.pcty_desc; + From.Parsetree.pcty_loc; + From.Parsetree.pcty_attributes; + } -> + { + To.Parsetree.pcty_desc = copy_class_type_desc pcty_desc; + To.Parsetree.pcty_loc = copy_location pcty_loc; + To.Parsetree.pcty_attributes = copy_attributes pcty_attributes; + } + +and copy_class_type_desc : + From.Parsetree.class_type_desc -> To.Parsetree.class_type_desc = function + | From.Parsetree.Pcty_constr (x0, x1) -> + To.Parsetree.Pcty_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Pcty_signature x0 -> + To.Parsetree.Pcty_signature (copy_class_signature x0) + | From.Parsetree.Pcty_arrow (x0, x1, x2) -> + To.Parsetree.Pcty_arrow + (copy_arg_label x0, copy_core_type x1, copy_class_type x2) + | From.Parsetree.Pcty_extension x0 -> + To.Parsetree.Pcty_extension (copy_extension x0) + | From.Parsetree.Pcty_open (_, loc, _) -> + migration_error loc.Location.loc "module open in class type" + +and copy_class_signature : + From.Parsetree.class_signature -> To.Parsetree.class_signature = + fun { From.Parsetree.pcsig_self; From.Parsetree.pcsig_fields } -> + { + To.Parsetree.pcsig_self = copy_core_type pcsig_self; + To.Parsetree.pcsig_fields = List.map copy_class_type_field pcsig_fields; + } + +and copy_class_type_field : + From.Parsetree.class_type_field -> To.Parsetree.class_type_field = + fun { + From.Parsetree.pctf_desc; + From.Parsetree.pctf_loc; + From.Parsetree.pctf_attributes; + } -> + { + To.Parsetree.pctf_desc = copy_class_type_field_desc pctf_desc; + To.Parsetree.pctf_loc = copy_location pctf_loc; + To.Parsetree.pctf_attributes = copy_attributes pctf_attributes; + } + +and copy_class_type_field_desc : + From.Parsetree.class_type_field_desc -> To.Parsetree.class_type_field_desc = + function + | From.Parsetree.Pctf_inherit x0 -> + To.Parsetree.Pctf_inherit (copy_class_type x0) + | From.Parsetree.Pctf_val x0 -> + To.Parsetree.Pctf_val + (let x0, x1, x2, x3 = x0 in + ( copy_loc (fun x -> x) x0, + copy_mutable_flag x1, + copy_virtual_flag x2, + copy_core_type x3 )) + | From.Parsetree.Pctf_method x0 -> + To.Parsetree.Pctf_method + (let x0, x1, x2, x3 = x0 in + ( copy_loc (fun x -> x) x0, + copy_private_flag x1, + copy_virtual_flag x2, + copy_core_type x3 )) + | From.Parsetree.Pctf_constraint x0 -> + To.Parsetree.Pctf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | From.Parsetree.Pctf_attribute x0 -> + To.Parsetree.Pctf_attribute (copy_attribute x0) + | From.Parsetree.Pctf_extension x0 -> + To.Parsetree.Pctf_extension (copy_extension x0) + +and copy_extension : From.Parsetree.extension -> To.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 From.Parsetree.class_infos -> + 'g0 To.Parsetree.class_infos = + fun f0 + { + From.Parsetree.pci_virt; + From.Parsetree.pci_params; + From.Parsetree.pci_name; + From.Parsetree.pci_expr; + From.Parsetree.pci_loc; + From.Parsetree.pci_attributes; + } -> + { + To.Parsetree.pci_virt = copy_virtual_flag pci_virt; + To.Parsetree.pci_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + pci_params; + To.Parsetree.pci_name = copy_loc (fun x -> x) pci_name; + To.Parsetree.pci_expr = f0 pci_expr; + To.Parsetree.pci_loc = copy_location pci_loc; + To.Parsetree.pci_attributes = copy_attributes pci_attributes; + } + +and copy_virtual_flag : From.Asttypes.virtual_flag -> To.Asttypes.virtual_flag = + function + | From.Asttypes.Virtual -> To.Asttypes.Virtual + | From.Asttypes.Concrete -> To.Asttypes.Concrete + +and copy_include_description : + From.Parsetree.include_description -> To.Parsetree.include_description = + fun x -> copy_include_infos copy_module_type x + +and copy_include_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 From.Parsetree.include_infos -> + 'g0 To.Parsetree.include_infos = + fun f0 + { + From.Parsetree.pincl_mod; + From.Parsetree.pincl_loc; + From.Parsetree.pincl_attributes; + } -> + { + To.Parsetree.pincl_mod = f0 pincl_mod; + To.Parsetree.pincl_loc = copy_location pincl_loc; + To.Parsetree.pincl_attributes = copy_attributes pincl_attributes; + } + +and copy_open_description : + From.Parsetree.open_description -> To.Parsetree.open_description = + fun { + From.Parsetree.popen_lid; + From.Parsetree.popen_override; + From.Parsetree.popen_loc; + From.Parsetree.popen_attributes; + } -> + { + To.Parsetree.popen_lid = copy_loc copy_longident popen_lid; + To.Parsetree.popen_override = copy_override_flag popen_override; + To.Parsetree.popen_loc = copy_location popen_loc; + To.Parsetree.popen_attributes = copy_attributes popen_attributes; + } + +and copy_override_flag : + From.Asttypes.override_flag -> To.Asttypes.override_flag = function + | From.Asttypes.Override -> To.Asttypes.Override + | From.Asttypes.Fresh -> To.Asttypes.Fresh + +and copy_module_type_declaration : + From.Parsetree.module_type_declaration -> + To.Parsetree.module_type_declaration = + fun { + From.Parsetree.pmtd_name; + From.Parsetree.pmtd_type; + From.Parsetree.pmtd_attributes; + From.Parsetree.pmtd_loc; + } -> + { + To.Parsetree.pmtd_name = copy_loc (fun x -> x) pmtd_name; + To.Parsetree.pmtd_type = copy_option copy_module_type pmtd_type; + To.Parsetree.pmtd_attributes = copy_attributes pmtd_attributes; + To.Parsetree.pmtd_loc = copy_location pmtd_loc; + } + +and copy_module_declaration : + From.Parsetree.module_declaration -> To.Parsetree.module_declaration = + fun { + From.Parsetree.pmd_name; + From.Parsetree.pmd_type; + From.Parsetree.pmd_attributes; + From.Parsetree.pmd_loc; + } -> + { + To.Parsetree.pmd_name = copy_loc (fun x -> x) pmd_name; + To.Parsetree.pmd_type = copy_module_type pmd_type; + To.Parsetree.pmd_attributes = copy_attributes pmd_attributes; + To.Parsetree.pmd_loc = copy_location pmd_loc; + } + +and copy_type_extension : + From.Parsetree.type_extension -> To.Parsetree.type_extension = + fun { + From.Parsetree.ptyext_path; + From.Parsetree.ptyext_params; + From.Parsetree.ptyext_constructors; + From.Parsetree.ptyext_private; + From.Parsetree.ptyext_attributes; + } -> + { + To.Parsetree.ptyext_path = copy_loc copy_longident ptyext_path; + To.Parsetree.ptyext_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptyext_params; + To.Parsetree.ptyext_constructors = + List.map copy_extension_constructor ptyext_constructors; + To.Parsetree.ptyext_private = copy_private_flag ptyext_private; + To.Parsetree.ptyext_attributes = copy_attributes ptyext_attributes; + } + +and copy_extension_constructor : + From.Parsetree.extension_constructor -> To.Parsetree.extension_constructor = + fun { + From.Parsetree.pext_name; + From.Parsetree.pext_kind; + From.Parsetree.pext_loc; + From.Parsetree.pext_attributes; + } -> + { + To.Parsetree.pext_name = copy_loc (fun x -> x) pext_name; + To.Parsetree.pext_kind = copy_extension_constructor_kind pext_kind; + To.Parsetree.pext_loc = copy_location pext_loc; + To.Parsetree.pext_attributes = copy_attributes pext_attributes; + } + +and copy_extension_constructor_kind : + From.Parsetree.extension_constructor_kind -> + To.Parsetree.extension_constructor_kind = function + | From.Parsetree.Pext_decl (x0, x1) -> + To.Parsetree.Pext_decl + (copy_constructor_arguments x0, copy_option copy_core_type x1) + | From.Parsetree.Pext_rebind x0 -> + To.Parsetree.Pext_rebind (copy_loc copy_longident x0) + +and copy_type_declaration : + From.Parsetree.type_declaration -> To.Parsetree.type_declaration = + fun { + From.Parsetree.ptype_name; + From.Parsetree.ptype_params; + From.Parsetree.ptype_cstrs; + From.Parsetree.ptype_kind; + From.Parsetree.ptype_private; + From.Parsetree.ptype_manifest; + From.Parsetree.ptype_attributes; + From.Parsetree.ptype_loc; + } -> + { + To.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name; + To.Parsetree.ptype_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptype_params; + To.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; + To.Parsetree.ptype_kind = copy_type_kind ptype_kind; + To.Parsetree.ptype_private = copy_private_flag ptype_private; + To.Parsetree.ptype_manifest = copy_option copy_core_type ptype_manifest; + To.Parsetree.ptype_attributes = copy_attributes ptype_attributes; + To.Parsetree.ptype_loc = copy_location ptype_loc; + } + +and copy_private_flag : From.Asttypes.private_flag -> To.Asttypes.private_flag = + function + | From.Asttypes.Private -> To.Asttypes.Private + | From.Asttypes.Public -> To.Asttypes.Public + +and copy_type_kind : From.Parsetree.type_kind -> To.Parsetree.type_kind = + function + | From.Parsetree.Ptype_abstract -> To.Parsetree.Ptype_abstract + | From.Parsetree.Ptype_variant x0 -> + To.Parsetree.Ptype_variant (List.map copy_constructor_declaration x0) + | From.Parsetree.Ptype_record x0 -> + To.Parsetree.Ptype_record (List.map copy_label_declaration x0) + | From.Parsetree.Ptype_open -> To.Parsetree.Ptype_open + +and copy_constructor_declaration : + From.Parsetree.constructor_declaration -> + To.Parsetree.constructor_declaration = + fun { + From.Parsetree.pcd_name; + From.Parsetree.pcd_args; + From.Parsetree.pcd_res; + From.Parsetree.pcd_loc; + From.Parsetree.pcd_attributes; + } -> + { + To.Parsetree.pcd_name = copy_loc (fun x -> x) pcd_name; + To.Parsetree.pcd_args = copy_constructor_arguments pcd_args; + To.Parsetree.pcd_res = copy_option copy_core_type pcd_res; + To.Parsetree.pcd_loc = copy_location pcd_loc; + To.Parsetree.pcd_attributes = copy_attributes pcd_attributes; + } + +and copy_constructor_arguments : + From.Parsetree.constructor_arguments -> To.Parsetree.constructor_arguments = + function + | From.Parsetree.Pcstr_tuple x0 -> + To.Parsetree.Pcstr_tuple (List.map copy_core_type x0) + | From.Parsetree.Pcstr_record x0 -> + To.Parsetree.Pcstr_record (List.map copy_label_declaration x0) + +and copy_label_declaration : + From.Parsetree.label_declaration -> To.Parsetree.label_declaration = + fun { + From.Parsetree.pld_name; + From.Parsetree.pld_mutable; + From.Parsetree.pld_type; + From.Parsetree.pld_loc; + From.Parsetree.pld_attributes; + } -> + { + To.Parsetree.pld_name = copy_loc (fun x -> x) pld_name; + To.Parsetree.pld_mutable = copy_mutable_flag pld_mutable; + To.Parsetree.pld_type = copy_core_type pld_type; + To.Parsetree.pld_loc = copy_location pld_loc; + To.Parsetree.pld_attributes = copy_attributes pld_attributes; + } + +and copy_mutable_flag : From.Asttypes.mutable_flag -> To.Asttypes.mutable_flag = + function + | From.Asttypes.Immutable -> To.Asttypes.Immutable + | From.Asttypes.Mutable -> To.Asttypes.Mutable + +and copy_variance : From.Asttypes.variance -> To.Asttypes.variance = function + | From.Asttypes.Covariant -> To.Asttypes.Covariant + | From.Asttypes.Contravariant -> To.Asttypes.Contravariant + | From.Asttypes.Invariant -> To.Asttypes.Invariant + +and copy_value_description : + From.Parsetree.value_description -> To.Parsetree.value_description = + fun { + From.Parsetree.pval_name; + From.Parsetree.pval_type; + From.Parsetree.pval_prim; + From.Parsetree.pval_attributes; + From.Parsetree.pval_loc; + } -> + { + To.Parsetree.pval_name = copy_loc (fun x -> x) pval_name; + To.Parsetree.pval_type = copy_core_type pval_type; + To.Parsetree.pval_prim = List.map (fun x -> x) pval_prim; + To.Parsetree.pval_attributes = copy_attributes pval_attributes; + To.Parsetree.pval_loc = copy_location pval_loc; + } + +and copy_arg_label : From.Asttypes.arg_label -> To.Asttypes.arg_label = function + | From.Asttypes.Nolabel -> To.Asttypes.Nolabel + | From.Asttypes.Labelled x0 -> To.Asttypes.Labelled x0 + | From.Asttypes.Optional x0 -> To.Asttypes.Optional x0 + +and copy_closed_flag : From.Asttypes.closed_flag -> To.Asttypes.closed_flag = + function + | From.Asttypes.Closed -> To.Asttypes.Closed + | From.Asttypes.Open -> To.Asttypes.Open + +and copy_label : From.Asttypes.label -> To.Asttypes.label = fun x -> x + +and copy_rec_flag : From.Asttypes.rec_flag -> To.Asttypes.rec_flag = function + | From.Asttypes.Nonrecursive -> To.Asttypes.Nonrecursive + | From.Asttypes.Recursive -> To.Asttypes.Recursive + +and copy_constant : From.Parsetree.constant -> To.Parsetree.constant = function + | From.Parsetree.Pconst_integer (x0, x1) -> + To.Parsetree.Pconst_integer (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pconst_char x0 -> To.Parsetree.Pconst_char x0 + | From.Parsetree.Pconst_string (x0, x1) -> + To.Parsetree.Pconst_string (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pconst_float (x0, x1) -> + To.Parsetree.Pconst_float (x0, copy_option (fun x -> x) x1) + +and copy_option : 'f0 'g0. ('f0 -> 'g0) -> 'f0 option -> 'g0 option = + fun f0 -> function None -> None | Some x0 -> Some (f0 x0) + +and copy_longident : Longident.t -> Longident.t = fun x -> x + +and copy_loc : + 'f0 'g0. ('f0 -> 'g0) -> 'f0 From.Asttypes.loc -> 'g0 To.Asttypes.loc = + fun f0 { From.Asttypes.txt; From.Asttypes.loc } -> + { To.Asttypes.txt = f0 txt; To.Asttypes.loc = copy_location loc } + +and copy_location : Location.t -> Location.t = fun x -> x + +and copy_bool : bool -> bool = function false -> false | true -> true + +let rec copy_toplevel_phrase : + From.Parsetree.toplevel_phrase -> To.Parsetree.toplevel_phrase = function + | From.Parsetree.Ptop_def x0 -> To.Parsetree.Ptop_def (copy_structure x0) + | From.Parsetree.Ptop_dir (x0, x1) -> + To.Parsetree.Ptop_dir (x0, copy_directive_argument x1) + +and copy_directive_argument : + From.Parsetree.directive_argument -> To.Parsetree.directive_argument = + function + | From.Parsetree.Pdir_none -> To.Parsetree.Pdir_none + | From.Parsetree.Pdir_string x0 -> To.Parsetree.Pdir_string x0 + | From.Parsetree.Pdir_int (x0, x1) -> + To.Parsetree.Pdir_int (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pdir_ident x0 -> To.Parsetree.Pdir_ident (copy_longident x0) + | From.Parsetree.Pdir_bool x0 -> To.Parsetree.Pdir_bool (copy_bool x0) + +let copy_cases x = List.map copy_case x + +let copy_pat = copy_pattern + +let copy_expr = copy_expression + +let copy_typ = copy_core_type diff -Nru ppxlib-0.15.0/astlib/migrate_406_407.ml ppxlib-0.24.0/astlib/migrate_406_407.ml --- ppxlib-0.15.0/astlib/migrate_406_407.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/migrate_406_407.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1025 @@ +(**************************************************************************) +(* *) +(* OCaml Migrate Parsetree *) +(* *) +(* Frédéric Bour *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2017 Institut National de Recherche en Informatique et *) +(* en Automatique (INRIA). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module From = Ast_406 +module To = Ast_407 + +let rec copy_expression : From.Parsetree.expression -> To.Parsetree.expression = + fun { + From.Parsetree.pexp_desc; + From.Parsetree.pexp_loc; + From.Parsetree.pexp_attributes; + } -> + { + To.Parsetree.pexp_desc = copy_expression_desc pexp_desc; + To.Parsetree.pexp_loc = copy_location pexp_loc; + To.Parsetree.pexp_attributes = copy_attributes pexp_attributes; + } + +and copy_expression_desc : + From.Parsetree.expression_desc -> To.Parsetree.expression_desc = function + | From.Parsetree.Pexp_ident x0 -> + To.Parsetree.Pexp_ident (copy_loc copy_longident x0) + | From.Parsetree.Pexp_constant x0 -> + To.Parsetree.Pexp_constant (copy_constant x0) + | From.Parsetree.Pexp_let (x0, x1, x2) -> + To.Parsetree.Pexp_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_expression x2) + | From.Parsetree.Pexp_function x0 -> + To.Parsetree.Pexp_function (List.map copy_case x0) + | From.Parsetree.Pexp_fun (x0, x1, x2, x3) -> + To.Parsetree.Pexp_fun + ( copy_arg_label x0, + copy_option copy_expression x1, + copy_pattern x2, + copy_expression x3 ) + | From.Parsetree.Pexp_apply (x0, x1) -> + To.Parsetree.Pexp_apply + ( copy_expression x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | From.Parsetree.Pexp_match (x0, x1) -> + To.Parsetree.Pexp_match (copy_expression x0, List.map copy_case x1) + | From.Parsetree.Pexp_try (x0, x1) -> + To.Parsetree.Pexp_try (copy_expression x0, List.map copy_case x1) + | From.Parsetree.Pexp_tuple x0 -> + To.Parsetree.Pexp_tuple (List.map copy_expression x0) + | From.Parsetree.Pexp_construct (x0, x1) -> + To.Parsetree.Pexp_construct + (copy_loc copy_longident x0, copy_option copy_expression x1) + | From.Parsetree.Pexp_variant (x0, x1) -> + To.Parsetree.Pexp_variant (copy_label x0, copy_option copy_expression x1) + | From.Parsetree.Pexp_record (x0, x1) -> + To.Parsetree.Pexp_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_expression x1)) + x0, + copy_option copy_expression x1 ) + | From.Parsetree.Pexp_field (x0, x1) -> + To.Parsetree.Pexp_field (copy_expression x0, copy_loc copy_longident x1) + | From.Parsetree.Pexp_setfield (x0, x1, x2) -> + To.Parsetree.Pexp_setfield + (copy_expression x0, copy_loc copy_longident x1, copy_expression x2) + | From.Parsetree.Pexp_array x0 -> + To.Parsetree.Pexp_array (List.map copy_expression x0) + | From.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> + To.Parsetree.Pexp_ifthenelse + (copy_expression x0, copy_expression x1, copy_option copy_expression x2) + | From.Parsetree.Pexp_sequence (x0, x1) -> + To.Parsetree.Pexp_sequence (copy_expression x0, copy_expression x1) + | From.Parsetree.Pexp_while (x0, x1) -> + To.Parsetree.Pexp_while (copy_expression x0, copy_expression x1) + | From.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> + To.Parsetree.Pexp_for + ( copy_pattern x0, + copy_expression x1, + copy_expression x2, + copy_direction_flag x3, + copy_expression x4 ) + | From.Parsetree.Pexp_constraint (x0, x1) -> + To.Parsetree.Pexp_constraint (copy_expression x0, copy_core_type x1) + | From.Parsetree.Pexp_coerce (x0, x1, x2) -> + To.Parsetree.Pexp_coerce + (copy_expression x0, copy_option copy_core_type x1, copy_core_type x2) + | From.Parsetree.Pexp_send (x0, x1) -> + To.Parsetree.Pexp_send (copy_expression x0, copy_loc (fun x -> x) x1) + | From.Parsetree.Pexp_new x0 -> + To.Parsetree.Pexp_new (copy_loc copy_longident x0) + | From.Parsetree.Pexp_setinstvar (x0, x1) -> + To.Parsetree.Pexp_setinstvar (copy_loc (fun x -> x) x0, copy_expression x1) + | From.Parsetree.Pexp_override x0 -> + To.Parsetree.Pexp_override + (List.map + (fun x -> + let x0, x1 = x in + (copy_loc (fun x -> x) x0, copy_expression x1)) + x0) + | From.Parsetree.Pexp_letmodule (x0, x1, x2) -> + To.Parsetree.Pexp_letmodule + (copy_loc (fun x -> x) x0, copy_module_expr x1, copy_expression x2) + | From.Parsetree.Pexp_letexception (x0, x1) -> + To.Parsetree.Pexp_letexception + (copy_extension_constructor x0, copy_expression x1) + | From.Parsetree.Pexp_assert x0 -> + To.Parsetree.Pexp_assert (copy_expression x0) + | From.Parsetree.Pexp_lazy x0 -> To.Parsetree.Pexp_lazy (copy_expression x0) + | From.Parsetree.Pexp_poly (x0, x1) -> + To.Parsetree.Pexp_poly (copy_expression x0, copy_option copy_core_type x1) + | From.Parsetree.Pexp_object x0 -> + To.Parsetree.Pexp_object (copy_class_structure x0) + | From.Parsetree.Pexp_newtype (x0, x1) -> + To.Parsetree.Pexp_newtype (copy_loc (fun x -> x) x0, copy_expression x1) + | From.Parsetree.Pexp_pack x0 -> To.Parsetree.Pexp_pack (copy_module_expr x0) + | From.Parsetree.Pexp_open (x0, x1, x2) -> + To.Parsetree.Pexp_open + (copy_override_flag x0, copy_loc copy_longident x1, copy_expression x2) + | From.Parsetree.Pexp_extension x0 -> + To.Parsetree.Pexp_extension (copy_extension x0) + | From.Parsetree.Pexp_unreachable -> To.Parsetree.Pexp_unreachable + +and copy_direction_flag : + From.Asttypes.direction_flag -> To.Asttypes.direction_flag = function + | From.Asttypes.Upto -> To.Asttypes.Upto + | From.Asttypes.Downto -> To.Asttypes.Downto + +and copy_case : From.Parsetree.case -> To.Parsetree.case = + fun { From.Parsetree.pc_lhs; From.Parsetree.pc_guard; From.Parsetree.pc_rhs } -> + { + To.Parsetree.pc_lhs = copy_pattern pc_lhs; + To.Parsetree.pc_guard = copy_option copy_expression pc_guard; + To.Parsetree.pc_rhs = copy_expression pc_rhs; + } + +and copy_value_binding : + From.Parsetree.value_binding -> To.Parsetree.value_binding = + fun { + From.Parsetree.pvb_pat; + From.Parsetree.pvb_expr; + From.Parsetree.pvb_attributes; + From.Parsetree.pvb_loc; + } -> + { + To.Parsetree.pvb_pat = copy_pattern pvb_pat; + To.Parsetree.pvb_expr = copy_expression pvb_expr; + To.Parsetree.pvb_attributes = copy_attributes pvb_attributes; + To.Parsetree.pvb_loc = copy_location pvb_loc; + } + +and copy_pattern : From.Parsetree.pattern -> To.Parsetree.pattern = + fun { + From.Parsetree.ppat_desc; + From.Parsetree.ppat_loc; + From.Parsetree.ppat_attributes; + } -> + { + To.Parsetree.ppat_desc = copy_pattern_desc ppat_desc; + To.Parsetree.ppat_loc = copy_location ppat_loc; + To.Parsetree.ppat_attributes = copy_attributes ppat_attributes; + } + +and copy_pattern_desc : From.Parsetree.pattern_desc -> To.Parsetree.pattern_desc + = function + | From.Parsetree.Ppat_any -> To.Parsetree.Ppat_any + | From.Parsetree.Ppat_var x0 -> + To.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) + | From.Parsetree.Ppat_alias (x0, x1) -> + To.Parsetree.Ppat_alias (copy_pattern x0, copy_loc (fun x -> x) x1) + | From.Parsetree.Ppat_constant x0 -> + To.Parsetree.Ppat_constant (copy_constant x0) + | From.Parsetree.Ppat_interval (x0, x1) -> + To.Parsetree.Ppat_interval (copy_constant x0, copy_constant x1) + | From.Parsetree.Ppat_tuple x0 -> + To.Parsetree.Ppat_tuple (List.map copy_pattern x0) + | From.Parsetree.Ppat_construct (x0, x1) -> + To.Parsetree.Ppat_construct + (copy_loc copy_longident x0, copy_option copy_pattern x1) + | From.Parsetree.Ppat_variant (x0, x1) -> + To.Parsetree.Ppat_variant (copy_label x0, copy_option copy_pattern x1) + | From.Parsetree.Ppat_record (x0, x1) -> + To.Parsetree.Ppat_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_pattern x1)) + x0, + copy_closed_flag x1 ) + | From.Parsetree.Ppat_array x0 -> + To.Parsetree.Ppat_array (List.map copy_pattern x0) + | From.Parsetree.Ppat_or (x0, x1) -> + To.Parsetree.Ppat_or (copy_pattern x0, copy_pattern x1) + | From.Parsetree.Ppat_constraint (x0, x1) -> + To.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1) + | From.Parsetree.Ppat_type x0 -> + To.Parsetree.Ppat_type (copy_loc copy_longident x0) + | From.Parsetree.Ppat_lazy x0 -> To.Parsetree.Ppat_lazy (copy_pattern x0) + | From.Parsetree.Ppat_unpack x0 -> + To.Parsetree.Ppat_unpack (copy_loc (fun x -> x) x0) + | From.Parsetree.Ppat_exception x0 -> + To.Parsetree.Ppat_exception (copy_pattern x0) + | From.Parsetree.Ppat_extension x0 -> + To.Parsetree.Ppat_extension (copy_extension x0) + | From.Parsetree.Ppat_open (x0, x1) -> + To.Parsetree.Ppat_open (copy_loc copy_longident x0, copy_pattern x1) + +and copy_core_type : From.Parsetree.core_type -> To.Parsetree.core_type = + fun { + From.Parsetree.ptyp_desc; + From.Parsetree.ptyp_loc; + From.Parsetree.ptyp_attributes; + } -> + { + To.Parsetree.ptyp_desc = copy_core_type_desc ptyp_desc; + To.Parsetree.ptyp_loc = copy_location ptyp_loc; + To.Parsetree.ptyp_attributes = copy_attributes ptyp_attributes; + } + +and copy_core_type_desc : + From.Parsetree.core_type_desc -> To.Parsetree.core_type_desc = function + | From.Parsetree.Ptyp_any -> To.Parsetree.Ptyp_any + | From.Parsetree.Ptyp_var x0 -> To.Parsetree.Ptyp_var x0 + | From.Parsetree.Ptyp_arrow (x0, x1, x2) -> + To.Parsetree.Ptyp_arrow + (copy_arg_label x0, copy_core_type x1, copy_core_type x2) + | From.Parsetree.Ptyp_tuple x0 -> + To.Parsetree.Ptyp_tuple (List.map copy_core_type x0) + | From.Parsetree.Ptyp_constr (x0, x1) -> + To.Parsetree.Ptyp_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Ptyp_object (x0, x1) -> + To.Parsetree.Ptyp_object + (List.map copy_object_field x0, copy_closed_flag x1) + | From.Parsetree.Ptyp_class (x0, x1) -> + To.Parsetree.Ptyp_class + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Ptyp_alias (x0, x1) -> + To.Parsetree.Ptyp_alias (copy_core_type x0, x1) + | From.Parsetree.Ptyp_variant (x0, x1, x2) -> + To.Parsetree.Ptyp_variant + ( List.map copy_row_field x0, + copy_closed_flag x1, + copy_option (fun x -> List.map copy_label x) x2 ) + | From.Parsetree.Ptyp_poly (x0, x1) -> + To.Parsetree.Ptyp_poly + (List.map (fun x -> copy_loc (fun x -> x) x) x0, copy_core_type x1) + | From.Parsetree.Ptyp_package x0 -> + To.Parsetree.Ptyp_package (copy_package_type x0) + | From.Parsetree.Ptyp_extension x0 -> + To.Parsetree.Ptyp_extension (copy_extension x0) + +and copy_package_type : From.Parsetree.package_type -> To.Parsetree.package_type + = + fun x -> + let x0, x1 = x in + ( copy_loc copy_longident x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_core_type x1)) + x1 ) + +and copy_row_field : From.Parsetree.row_field -> To.Parsetree.row_field = + function + | From.Parsetree.Rtag (x0, x1, x2, x3) -> + To.Parsetree.Rtag + ( copy_loc copy_label x0, + copy_attributes x1, + copy_bool x2, + List.map copy_core_type x3 ) + | From.Parsetree.Rinherit x0 -> To.Parsetree.Rinherit (copy_core_type x0) + +and copy_object_field : From.Parsetree.object_field -> To.Parsetree.object_field + = function + | From.Parsetree.Otag (x0, x1, x2) -> + To.Parsetree.Otag + (copy_loc (fun x -> x) x0, copy_attributes x1, copy_core_type x2) + | From.Parsetree.Oinherit x -> To.Parsetree.Oinherit (copy_core_type x) + +and copy_attributes : From.Parsetree.attributes -> To.Parsetree.attributes = + fun x -> List.map copy_attribute x + +and copy_attribute : From.Parsetree.attribute -> To.Parsetree.attribute = + fun x -> + let x0, x1 = x in + (copy_loc (fun x -> x) x0, copy_payload x1) + +and copy_payload : From.Parsetree.payload -> To.Parsetree.payload = function + | From.Parsetree.PStr x0 -> To.Parsetree.PStr (copy_structure x0) + | From.Parsetree.PSig x0 -> To.Parsetree.PSig (copy_signature x0) + | From.Parsetree.PTyp x0 -> To.Parsetree.PTyp (copy_core_type x0) + | From.Parsetree.PPat (x0, x1) -> + To.Parsetree.PPat (copy_pattern x0, copy_option copy_expression x1) + +and copy_structure : From.Parsetree.structure -> To.Parsetree.structure = + fun x -> List.map copy_structure_item x + +and copy_structure_item : + From.Parsetree.structure_item -> To.Parsetree.structure_item = + fun { From.Parsetree.pstr_desc; From.Parsetree.pstr_loc } -> + { + To.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc; + To.Parsetree.pstr_loc = copy_location pstr_loc; + } + +and copy_structure_item_desc : + From.Parsetree.structure_item_desc -> To.Parsetree.structure_item_desc = + function + | From.Parsetree.Pstr_eval (x0, x1) -> + To.Parsetree.Pstr_eval (copy_expression x0, copy_attributes x1) + | From.Parsetree.Pstr_value (x0, x1) -> + To.Parsetree.Pstr_value (copy_rec_flag x0, List.map copy_value_binding x1) + | From.Parsetree.Pstr_primitive x0 -> + To.Parsetree.Pstr_primitive (copy_value_description x0) + | From.Parsetree.Pstr_type (x0, x1) -> + To.Parsetree.Pstr_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | From.Parsetree.Pstr_typext x0 -> + To.Parsetree.Pstr_typext (copy_type_extension x0) + | From.Parsetree.Pstr_exception x0 -> + To.Parsetree.Pstr_exception (copy_extension_constructor x0) + | From.Parsetree.Pstr_module x0 -> + To.Parsetree.Pstr_module (copy_module_binding x0) + | From.Parsetree.Pstr_recmodule x0 -> + To.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) + | From.Parsetree.Pstr_modtype x0 -> + To.Parsetree.Pstr_modtype (copy_module_type_declaration x0) + | From.Parsetree.Pstr_open x0 -> + To.Parsetree.Pstr_open (copy_open_description x0) + | From.Parsetree.Pstr_class x0 -> + To.Parsetree.Pstr_class (List.map copy_class_declaration x0) + | From.Parsetree.Pstr_class_type x0 -> + To.Parsetree.Pstr_class_type (List.map copy_class_type_declaration x0) + | From.Parsetree.Pstr_include x0 -> + To.Parsetree.Pstr_include (copy_include_declaration x0) + | From.Parsetree.Pstr_attribute x0 -> + To.Parsetree.Pstr_attribute (copy_attribute x0) + | From.Parsetree.Pstr_extension (x0, x1) -> + To.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1) + +and copy_include_declaration : + From.Parsetree.include_declaration -> To.Parsetree.include_declaration = + fun x -> copy_include_infos copy_module_expr x + +and copy_class_declaration : + From.Parsetree.class_declaration -> To.Parsetree.class_declaration = + fun x -> copy_class_infos copy_class_expr x + +and copy_class_expr : From.Parsetree.class_expr -> To.Parsetree.class_expr = + fun { + From.Parsetree.pcl_desc; + From.Parsetree.pcl_loc; + From.Parsetree.pcl_attributes; + } -> + { + To.Parsetree.pcl_desc = copy_class_expr_desc pcl_desc; + To.Parsetree.pcl_loc = copy_location pcl_loc; + To.Parsetree.pcl_attributes = copy_attributes pcl_attributes; + } + +and copy_class_expr_desc : + From.Parsetree.class_expr_desc -> To.Parsetree.class_expr_desc = function + | From.Parsetree.Pcl_constr (x0, x1) -> + To.Parsetree.Pcl_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Pcl_structure x0 -> + To.Parsetree.Pcl_structure (copy_class_structure x0) + | From.Parsetree.Pcl_fun (x0, x1, x2, x3) -> + To.Parsetree.Pcl_fun + ( copy_arg_label x0, + copy_option copy_expression x1, + copy_pattern x2, + copy_class_expr x3 ) + | From.Parsetree.Pcl_apply (x0, x1) -> + To.Parsetree.Pcl_apply + ( copy_class_expr x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | From.Parsetree.Pcl_let (x0, x1, x2) -> + To.Parsetree.Pcl_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_class_expr x2) + | From.Parsetree.Pcl_constraint (x0, x1) -> + To.Parsetree.Pcl_constraint (copy_class_expr x0, copy_class_type x1) + | From.Parsetree.Pcl_extension x0 -> + To.Parsetree.Pcl_extension (copy_extension x0) + | From.Parsetree.Pcl_open (ovf, loc, ce) -> + To.Parsetree.Pcl_open + (copy_override_flag ovf, copy_loc copy_longident loc, copy_class_expr ce) + +and copy_class_structure : + From.Parsetree.class_structure -> To.Parsetree.class_structure = + fun { From.Parsetree.pcstr_self; From.Parsetree.pcstr_fields } -> + { + To.Parsetree.pcstr_self = copy_pattern pcstr_self; + To.Parsetree.pcstr_fields = List.map copy_class_field pcstr_fields; + } + +and copy_class_field : From.Parsetree.class_field -> To.Parsetree.class_field = + fun { + From.Parsetree.pcf_desc; + From.Parsetree.pcf_loc; + From.Parsetree.pcf_attributes; + } -> + { + To.Parsetree.pcf_desc = copy_class_field_desc pcf_desc; + To.Parsetree.pcf_loc = copy_location pcf_loc; + To.Parsetree.pcf_attributes = copy_attributes pcf_attributes; + } + +and copy_class_field_desc : + From.Parsetree.class_field_desc -> To.Parsetree.class_field_desc = function + | From.Parsetree.Pcf_inherit (x0, x1, x2) -> + To.Parsetree.Pcf_inherit + ( copy_override_flag x0, + copy_class_expr x1, + copy_option (copy_loc (fun x -> x)) x2 ) + | From.Parsetree.Pcf_val x0 -> + To.Parsetree.Pcf_val + (let x0, x1, x2 = x0 in + ( copy_loc (fun x -> x) x0, + copy_mutable_flag x1, + copy_class_field_kind x2 )) + | From.Parsetree.Pcf_method x0 -> + To.Parsetree.Pcf_method + (let x0, x1, x2 = x0 in + ( copy_loc (fun x -> x) x0, + copy_private_flag x1, + copy_class_field_kind x2 )) + | From.Parsetree.Pcf_constraint x0 -> + To.Parsetree.Pcf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | From.Parsetree.Pcf_initializer x0 -> + To.Parsetree.Pcf_initializer (copy_expression x0) + | From.Parsetree.Pcf_attribute x0 -> + To.Parsetree.Pcf_attribute (copy_attribute x0) + | From.Parsetree.Pcf_extension x0 -> + To.Parsetree.Pcf_extension (copy_extension x0) + +and copy_class_field_kind : + From.Parsetree.class_field_kind -> To.Parsetree.class_field_kind = function + | From.Parsetree.Cfk_virtual x0 -> + To.Parsetree.Cfk_virtual (copy_core_type x0) + | From.Parsetree.Cfk_concrete (x0, x1) -> + To.Parsetree.Cfk_concrete (copy_override_flag x0, copy_expression x1) + +and copy_module_binding : + From.Parsetree.module_binding -> To.Parsetree.module_binding = + fun { + From.Parsetree.pmb_name; + From.Parsetree.pmb_expr; + From.Parsetree.pmb_attributes; + From.Parsetree.pmb_loc; + } -> + { + To.Parsetree.pmb_name = copy_loc (fun x -> x) pmb_name; + To.Parsetree.pmb_expr = copy_module_expr pmb_expr; + To.Parsetree.pmb_attributes = copy_attributes pmb_attributes; + To.Parsetree.pmb_loc = copy_location pmb_loc; + } + +and copy_module_expr : From.Parsetree.module_expr -> To.Parsetree.module_expr = + fun { + From.Parsetree.pmod_desc; + From.Parsetree.pmod_loc; + From.Parsetree.pmod_attributes; + } -> + { + To.Parsetree.pmod_desc = copy_module_expr_desc pmod_desc; + To.Parsetree.pmod_loc = copy_location pmod_loc; + To.Parsetree.pmod_attributes = copy_attributes pmod_attributes; + } + +and copy_module_expr_desc : + From.Parsetree.module_expr_desc -> To.Parsetree.module_expr_desc = function + | From.Parsetree.Pmod_ident x0 -> + To.Parsetree.Pmod_ident (copy_loc copy_longident x0) + | From.Parsetree.Pmod_structure x0 -> + To.Parsetree.Pmod_structure (copy_structure x0) + | From.Parsetree.Pmod_functor (x0, x1, x2) -> + To.Parsetree.Pmod_functor + ( copy_loc (fun x -> x) x0, + copy_option copy_module_type x1, + copy_module_expr x2 ) + | From.Parsetree.Pmod_apply (x0, x1) -> + To.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) + | From.Parsetree.Pmod_constraint (x0, x1) -> + To.Parsetree.Pmod_constraint (copy_module_expr x0, copy_module_type x1) + | From.Parsetree.Pmod_unpack x0 -> + To.Parsetree.Pmod_unpack (copy_expression x0) + | From.Parsetree.Pmod_extension x0 -> + To.Parsetree.Pmod_extension (copy_extension x0) + +and copy_module_type : From.Parsetree.module_type -> To.Parsetree.module_type = + fun { + From.Parsetree.pmty_desc; + From.Parsetree.pmty_loc; + From.Parsetree.pmty_attributes; + } -> + { + To.Parsetree.pmty_desc = copy_module_type_desc pmty_desc; + To.Parsetree.pmty_loc = copy_location pmty_loc; + To.Parsetree.pmty_attributes = copy_attributes pmty_attributes; + } + +and copy_module_type_desc : + From.Parsetree.module_type_desc -> To.Parsetree.module_type_desc = function + | From.Parsetree.Pmty_ident x0 -> + To.Parsetree.Pmty_ident (copy_loc copy_longident x0) + | From.Parsetree.Pmty_signature x0 -> + To.Parsetree.Pmty_signature (copy_signature x0) + | From.Parsetree.Pmty_functor (x0, x1, x2) -> + To.Parsetree.Pmty_functor + ( copy_loc (fun x -> x) x0, + copy_option copy_module_type x1, + copy_module_type x2 ) + | From.Parsetree.Pmty_with (x0, x1) -> + To.Parsetree.Pmty_with + (copy_module_type x0, List.map copy_with_constraint x1) + | From.Parsetree.Pmty_typeof x0 -> + To.Parsetree.Pmty_typeof (copy_module_expr x0) + | From.Parsetree.Pmty_extension x0 -> + To.Parsetree.Pmty_extension (copy_extension x0) + | From.Parsetree.Pmty_alias x0 -> + To.Parsetree.Pmty_alias (copy_loc copy_longident x0) + +and copy_with_constraint : + From.Parsetree.with_constraint -> To.Parsetree.with_constraint = function + | From.Parsetree.Pwith_type (x0, x1) -> + To.Parsetree.Pwith_type + (copy_loc copy_longident x0, copy_type_declaration x1) + | From.Parsetree.Pwith_module (x0, x1) -> + To.Parsetree.Pwith_module + (copy_loc copy_longident x0, copy_loc copy_longident x1) + | From.Parsetree.Pwith_typesubst (x0, x1) -> + To.Parsetree.Pwith_typesubst + (copy_loc copy_longident x0, copy_type_declaration x1) + | From.Parsetree.Pwith_modsubst (x0, x1) -> + To.Parsetree.Pwith_modsubst + (copy_loc copy_longident x0, copy_loc copy_longident x1) + +and copy_signature : From.Parsetree.signature -> To.Parsetree.signature = + fun x -> List.map copy_signature_item x + +and copy_signature_item : + From.Parsetree.signature_item -> To.Parsetree.signature_item = + fun { From.Parsetree.psig_desc; From.Parsetree.psig_loc } -> + { + To.Parsetree.psig_desc = copy_signature_item_desc psig_desc; + To.Parsetree.psig_loc = copy_location psig_loc; + } + +and copy_signature_item_desc : + From.Parsetree.signature_item_desc -> To.Parsetree.signature_item_desc = + function + | From.Parsetree.Psig_value x0 -> + To.Parsetree.Psig_value (copy_value_description x0) + | From.Parsetree.Psig_type (x0, x1) -> + To.Parsetree.Psig_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | From.Parsetree.Psig_typext x0 -> + To.Parsetree.Psig_typext (copy_type_extension x0) + | From.Parsetree.Psig_exception x0 -> + To.Parsetree.Psig_exception (copy_extension_constructor x0) + | From.Parsetree.Psig_module x0 -> + To.Parsetree.Psig_module (copy_module_declaration x0) + | From.Parsetree.Psig_recmodule x0 -> + To.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) + | From.Parsetree.Psig_modtype x0 -> + To.Parsetree.Psig_modtype (copy_module_type_declaration x0) + | From.Parsetree.Psig_open x0 -> + To.Parsetree.Psig_open (copy_open_description x0) + | From.Parsetree.Psig_include x0 -> + To.Parsetree.Psig_include (copy_include_description x0) + | From.Parsetree.Psig_class x0 -> + To.Parsetree.Psig_class (List.map copy_class_description x0) + | From.Parsetree.Psig_class_type x0 -> + To.Parsetree.Psig_class_type (List.map copy_class_type_declaration x0) + | From.Parsetree.Psig_attribute x0 -> + To.Parsetree.Psig_attribute (copy_attribute x0) + | From.Parsetree.Psig_extension (x0, x1) -> + To.Parsetree.Psig_extension (copy_extension x0, copy_attributes x1) + +and copy_class_type_declaration : + From.Parsetree.class_type_declaration -> To.Parsetree.class_type_declaration + = + fun x -> copy_class_infos copy_class_type x + +and copy_class_description : + From.Parsetree.class_description -> To.Parsetree.class_description = + fun x -> copy_class_infos copy_class_type x + +and copy_class_type : From.Parsetree.class_type -> To.Parsetree.class_type = + fun { + From.Parsetree.pcty_desc; + From.Parsetree.pcty_loc; + From.Parsetree.pcty_attributes; + } -> + { + To.Parsetree.pcty_desc = copy_class_type_desc pcty_desc; + To.Parsetree.pcty_loc = copy_location pcty_loc; + To.Parsetree.pcty_attributes = copy_attributes pcty_attributes; + } + +and copy_class_type_desc : + From.Parsetree.class_type_desc -> To.Parsetree.class_type_desc = function + | From.Parsetree.Pcty_constr (x0, x1) -> + To.Parsetree.Pcty_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Pcty_signature x0 -> + To.Parsetree.Pcty_signature (copy_class_signature x0) + | From.Parsetree.Pcty_arrow (x0, x1, x2) -> + To.Parsetree.Pcty_arrow + (copy_arg_label x0, copy_core_type x1, copy_class_type x2) + | From.Parsetree.Pcty_extension x0 -> + To.Parsetree.Pcty_extension (copy_extension x0) + | From.Parsetree.Pcty_open (ovf, loc, cty) -> + To.Parsetree.Pcty_open + ( copy_override_flag ovf, + copy_loc copy_longident loc, + copy_class_type cty ) + +and copy_class_signature : + From.Parsetree.class_signature -> To.Parsetree.class_signature = + fun { From.Parsetree.pcsig_self; From.Parsetree.pcsig_fields } -> + { + To.Parsetree.pcsig_self = copy_core_type pcsig_self; + To.Parsetree.pcsig_fields = List.map copy_class_type_field pcsig_fields; + } + +and copy_class_type_field : + From.Parsetree.class_type_field -> To.Parsetree.class_type_field = + fun { + From.Parsetree.pctf_desc; + From.Parsetree.pctf_loc; + From.Parsetree.pctf_attributes; + } -> + { + To.Parsetree.pctf_desc = copy_class_type_field_desc pctf_desc; + To.Parsetree.pctf_loc = copy_location pctf_loc; + To.Parsetree.pctf_attributes = copy_attributes pctf_attributes; + } + +and copy_class_type_field_desc : + From.Parsetree.class_type_field_desc -> To.Parsetree.class_type_field_desc = + function + | From.Parsetree.Pctf_inherit x0 -> + To.Parsetree.Pctf_inherit (copy_class_type x0) + | From.Parsetree.Pctf_val x0 -> + To.Parsetree.Pctf_val + (let x0, x1, x2, x3 = x0 in + ( copy_loc (fun x -> x) x0, + copy_mutable_flag x1, + copy_virtual_flag x2, + copy_core_type x3 )) + | From.Parsetree.Pctf_method x0 -> + To.Parsetree.Pctf_method + (let x0, x1, x2, x3 = x0 in + ( copy_loc (fun x -> x) x0, + copy_private_flag x1, + copy_virtual_flag x2, + copy_core_type x3 )) + | From.Parsetree.Pctf_constraint x0 -> + To.Parsetree.Pctf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | From.Parsetree.Pctf_attribute x0 -> + To.Parsetree.Pctf_attribute (copy_attribute x0) + | From.Parsetree.Pctf_extension x0 -> + To.Parsetree.Pctf_extension (copy_extension x0) + +and copy_extension : From.Parsetree.extension -> To.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 From.Parsetree.class_infos -> + 'g0 To.Parsetree.class_infos = + fun f0 + { + From.Parsetree.pci_virt; + From.Parsetree.pci_params; + From.Parsetree.pci_name; + From.Parsetree.pci_expr; + From.Parsetree.pci_loc; + From.Parsetree.pci_attributes; + } -> + { + To.Parsetree.pci_virt = copy_virtual_flag pci_virt; + To.Parsetree.pci_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + pci_params; + To.Parsetree.pci_name = copy_loc (fun x -> x) pci_name; + To.Parsetree.pci_expr = f0 pci_expr; + To.Parsetree.pci_loc = copy_location pci_loc; + To.Parsetree.pci_attributes = copy_attributes pci_attributes; + } + +and copy_virtual_flag : From.Asttypes.virtual_flag -> To.Asttypes.virtual_flag = + function + | From.Asttypes.Virtual -> To.Asttypes.Virtual + | From.Asttypes.Concrete -> To.Asttypes.Concrete + +and copy_include_description : + From.Parsetree.include_description -> To.Parsetree.include_description = + fun x -> copy_include_infos copy_module_type x + +and copy_include_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 From.Parsetree.include_infos -> + 'g0 To.Parsetree.include_infos = + fun f0 + { + From.Parsetree.pincl_mod; + From.Parsetree.pincl_loc; + From.Parsetree.pincl_attributes; + } -> + { + To.Parsetree.pincl_mod = f0 pincl_mod; + To.Parsetree.pincl_loc = copy_location pincl_loc; + To.Parsetree.pincl_attributes = copy_attributes pincl_attributes; + } + +and copy_open_description : + From.Parsetree.open_description -> To.Parsetree.open_description = + fun { + From.Parsetree.popen_lid; + From.Parsetree.popen_override; + From.Parsetree.popen_loc; + From.Parsetree.popen_attributes; + } -> + { + To.Parsetree.popen_lid = copy_loc copy_longident popen_lid; + To.Parsetree.popen_override = copy_override_flag popen_override; + To.Parsetree.popen_loc = copy_location popen_loc; + To.Parsetree.popen_attributes = copy_attributes popen_attributes; + } + +and copy_override_flag : + From.Asttypes.override_flag -> To.Asttypes.override_flag = function + | From.Asttypes.Override -> To.Asttypes.Override + | From.Asttypes.Fresh -> To.Asttypes.Fresh + +and copy_module_type_declaration : + From.Parsetree.module_type_declaration -> + To.Parsetree.module_type_declaration = + fun { + From.Parsetree.pmtd_name; + From.Parsetree.pmtd_type; + From.Parsetree.pmtd_attributes; + From.Parsetree.pmtd_loc; + } -> + { + To.Parsetree.pmtd_name = copy_loc (fun x -> x) pmtd_name; + To.Parsetree.pmtd_type = copy_option copy_module_type pmtd_type; + To.Parsetree.pmtd_attributes = copy_attributes pmtd_attributes; + To.Parsetree.pmtd_loc = copy_location pmtd_loc; + } + +and copy_module_declaration : + From.Parsetree.module_declaration -> To.Parsetree.module_declaration = + fun { + From.Parsetree.pmd_name; + From.Parsetree.pmd_type; + From.Parsetree.pmd_attributes; + From.Parsetree.pmd_loc; + } -> + { + To.Parsetree.pmd_name = copy_loc (fun x -> x) pmd_name; + To.Parsetree.pmd_type = copy_module_type pmd_type; + To.Parsetree.pmd_attributes = copy_attributes pmd_attributes; + To.Parsetree.pmd_loc = copy_location pmd_loc; + } + +and copy_type_extension : + From.Parsetree.type_extension -> To.Parsetree.type_extension = + fun { + From.Parsetree.ptyext_path; + From.Parsetree.ptyext_params; + From.Parsetree.ptyext_constructors; + From.Parsetree.ptyext_private; + From.Parsetree.ptyext_attributes; + } -> + { + To.Parsetree.ptyext_path = copy_loc copy_longident ptyext_path; + To.Parsetree.ptyext_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptyext_params; + To.Parsetree.ptyext_constructors = + List.map copy_extension_constructor ptyext_constructors; + To.Parsetree.ptyext_private = copy_private_flag ptyext_private; + To.Parsetree.ptyext_attributes = copy_attributes ptyext_attributes; + } + +and copy_extension_constructor : + From.Parsetree.extension_constructor -> To.Parsetree.extension_constructor = + fun { + From.Parsetree.pext_name; + From.Parsetree.pext_kind; + From.Parsetree.pext_loc; + From.Parsetree.pext_attributes; + } -> + { + To.Parsetree.pext_name = copy_loc (fun x -> x) pext_name; + To.Parsetree.pext_kind = copy_extension_constructor_kind pext_kind; + To.Parsetree.pext_loc = copy_location pext_loc; + To.Parsetree.pext_attributes = copy_attributes pext_attributes; + } + +and copy_extension_constructor_kind : + From.Parsetree.extension_constructor_kind -> + To.Parsetree.extension_constructor_kind = function + | From.Parsetree.Pext_decl (x0, x1) -> + To.Parsetree.Pext_decl + (copy_constructor_arguments x0, copy_option copy_core_type x1) + | From.Parsetree.Pext_rebind x0 -> + To.Parsetree.Pext_rebind (copy_loc copy_longident x0) + +and copy_type_declaration : + From.Parsetree.type_declaration -> To.Parsetree.type_declaration = + fun { + From.Parsetree.ptype_name; + From.Parsetree.ptype_params; + From.Parsetree.ptype_cstrs; + From.Parsetree.ptype_kind; + From.Parsetree.ptype_private; + From.Parsetree.ptype_manifest; + From.Parsetree.ptype_attributes; + From.Parsetree.ptype_loc; + } -> + { + To.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name; + To.Parsetree.ptype_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptype_params; + To.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; + To.Parsetree.ptype_kind = copy_type_kind ptype_kind; + To.Parsetree.ptype_private = copy_private_flag ptype_private; + To.Parsetree.ptype_manifest = copy_option copy_core_type ptype_manifest; + To.Parsetree.ptype_attributes = copy_attributes ptype_attributes; + To.Parsetree.ptype_loc = copy_location ptype_loc; + } + +and copy_private_flag : From.Asttypes.private_flag -> To.Asttypes.private_flag = + function + | From.Asttypes.Private -> To.Asttypes.Private + | From.Asttypes.Public -> To.Asttypes.Public + +and copy_type_kind : From.Parsetree.type_kind -> To.Parsetree.type_kind = + function + | From.Parsetree.Ptype_abstract -> To.Parsetree.Ptype_abstract + | From.Parsetree.Ptype_variant x0 -> + To.Parsetree.Ptype_variant (List.map copy_constructor_declaration x0) + | From.Parsetree.Ptype_record x0 -> + To.Parsetree.Ptype_record (List.map copy_label_declaration x0) + | From.Parsetree.Ptype_open -> To.Parsetree.Ptype_open + +and copy_constructor_declaration : + From.Parsetree.constructor_declaration -> + To.Parsetree.constructor_declaration = + fun { + From.Parsetree.pcd_name; + From.Parsetree.pcd_args; + From.Parsetree.pcd_res; + From.Parsetree.pcd_loc; + From.Parsetree.pcd_attributes; + } -> + { + To.Parsetree.pcd_name = copy_loc (fun x -> x) pcd_name; + To.Parsetree.pcd_args = copy_constructor_arguments pcd_args; + To.Parsetree.pcd_res = copy_option copy_core_type pcd_res; + To.Parsetree.pcd_loc = copy_location pcd_loc; + To.Parsetree.pcd_attributes = copy_attributes pcd_attributes; + } + +and copy_constructor_arguments : + From.Parsetree.constructor_arguments -> To.Parsetree.constructor_arguments = + function + | From.Parsetree.Pcstr_tuple x0 -> + To.Parsetree.Pcstr_tuple (List.map copy_core_type x0) + | From.Parsetree.Pcstr_record x0 -> + To.Parsetree.Pcstr_record (List.map copy_label_declaration x0) + +and copy_label_declaration : + From.Parsetree.label_declaration -> To.Parsetree.label_declaration = + fun { + From.Parsetree.pld_name; + From.Parsetree.pld_mutable; + From.Parsetree.pld_type; + From.Parsetree.pld_loc; + From.Parsetree.pld_attributes; + } -> + { + To.Parsetree.pld_name = copy_loc (fun x -> x) pld_name; + To.Parsetree.pld_mutable = copy_mutable_flag pld_mutable; + To.Parsetree.pld_type = copy_core_type pld_type; + To.Parsetree.pld_loc = copy_location pld_loc; + To.Parsetree.pld_attributes = copy_attributes pld_attributes; + } + +and copy_mutable_flag : From.Asttypes.mutable_flag -> To.Asttypes.mutable_flag = + function + | From.Asttypes.Immutable -> To.Asttypes.Immutable + | From.Asttypes.Mutable -> To.Asttypes.Mutable + +and copy_variance : From.Asttypes.variance -> To.Asttypes.variance = function + | From.Asttypes.Covariant -> To.Asttypes.Covariant + | From.Asttypes.Contravariant -> To.Asttypes.Contravariant + | From.Asttypes.Invariant -> To.Asttypes.Invariant + +and copy_value_description : + From.Parsetree.value_description -> To.Parsetree.value_description = + fun { + From.Parsetree.pval_name; + From.Parsetree.pval_type; + From.Parsetree.pval_prim; + From.Parsetree.pval_attributes; + From.Parsetree.pval_loc; + } -> + { + To.Parsetree.pval_name = copy_loc (fun x -> x) pval_name; + To.Parsetree.pval_type = copy_core_type pval_type; + To.Parsetree.pval_prim = List.map (fun x -> x) pval_prim; + To.Parsetree.pval_attributes = copy_attributes pval_attributes; + To.Parsetree.pval_loc = copy_location pval_loc; + } + +and copy_arg_label : From.Asttypes.arg_label -> To.Asttypes.arg_label = function + | From.Asttypes.Nolabel -> To.Asttypes.Nolabel + | From.Asttypes.Labelled x0 -> To.Asttypes.Labelled x0 + | From.Asttypes.Optional x0 -> To.Asttypes.Optional x0 + +and copy_closed_flag : From.Asttypes.closed_flag -> To.Asttypes.closed_flag = + function + | From.Asttypes.Closed -> To.Asttypes.Closed + | From.Asttypes.Open -> To.Asttypes.Open + +and copy_label : From.Asttypes.label -> To.Asttypes.label = fun x -> x + +and copy_rec_flag : From.Asttypes.rec_flag -> To.Asttypes.rec_flag = function + | From.Asttypes.Nonrecursive -> To.Asttypes.Nonrecursive + | From.Asttypes.Recursive -> To.Asttypes.Recursive + +and copy_constant : From.Parsetree.constant -> To.Parsetree.constant = function + | From.Parsetree.Pconst_integer (x0, x1) -> + To.Parsetree.Pconst_integer (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pconst_char x0 -> To.Parsetree.Pconst_char x0 + | From.Parsetree.Pconst_string (x0, x1) -> + To.Parsetree.Pconst_string (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pconst_float (x0, x1) -> + To.Parsetree.Pconst_float (x0, copy_option (fun x -> x) x1) + +and copy_option : 'f0 'g0. ('f0 -> 'g0) -> 'f0 option -> 'g0 option = + fun f0 -> function None -> None | Some x0 -> Some (f0 x0) + +and copy_longident : Longident.t -> Longident.t = fun x -> x + +and copy_loc : + 'f0 'g0. ('f0 -> 'g0) -> 'f0 From.Asttypes.loc -> 'g0 To.Asttypes.loc = + fun f0 { From.Asttypes.txt; From.Asttypes.loc } -> + { To.Asttypes.txt = f0 txt; To.Asttypes.loc = copy_location loc } + +and copy_location : Location.t -> Location.t = fun x -> x + +and copy_bool : bool -> bool = function false -> false | true -> true + +let rec copy_toplevel_phrase : + From.Parsetree.toplevel_phrase -> To.Parsetree.toplevel_phrase = function + | From.Parsetree.Ptop_def x0 -> To.Parsetree.Ptop_def (copy_structure x0) + | From.Parsetree.Ptop_dir (x0, x1) -> + To.Parsetree.Ptop_dir (x0, copy_directive_argument x1) + +and copy_directive_argument : + From.Parsetree.directive_argument -> To.Parsetree.directive_argument = + function + | From.Parsetree.Pdir_none -> To.Parsetree.Pdir_none + | From.Parsetree.Pdir_string x0 -> To.Parsetree.Pdir_string x0 + | From.Parsetree.Pdir_int (x0, x1) -> + To.Parsetree.Pdir_int (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pdir_ident x0 -> To.Parsetree.Pdir_ident (copy_longident x0) + | From.Parsetree.Pdir_bool x0 -> To.Parsetree.Pdir_bool (copy_bool x0) + +let copy_cases x = List.map copy_case x + +let copy_pat = copy_pattern + +let copy_expr = copy_expression + +let copy_typ = copy_core_type diff -Nru ppxlib-0.15.0/astlib/migrate_407_406.ml ppxlib-0.24.0/astlib/migrate_407_406.ml --- ppxlib-0.15.0/astlib/migrate_407_406.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/migrate_407_406.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1025 @@ +(**************************************************************************) +(* *) +(* OCaml Migrate Parsetree *) +(* *) +(* Frédéric Bour *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2017 Institut National de Recherche en Informatique et *) +(* en Automatique (INRIA). *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module From = Ast_407 +module To = Ast_406 + +let rec copy_expression : From.Parsetree.expression -> To.Parsetree.expression = + fun { + From.Parsetree.pexp_desc; + From.Parsetree.pexp_loc; + From.Parsetree.pexp_attributes; + } -> + { + To.Parsetree.pexp_desc = copy_expression_desc pexp_desc; + To.Parsetree.pexp_loc = copy_location pexp_loc; + To.Parsetree.pexp_attributes = copy_attributes pexp_attributes; + } + +and copy_expression_desc : + From.Parsetree.expression_desc -> To.Parsetree.expression_desc = function + | From.Parsetree.Pexp_ident x0 -> + To.Parsetree.Pexp_ident (copy_loc copy_longident x0) + | From.Parsetree.Pexp_constant x0 -> + To.Parsetree.Pexp_constant (copy_constant x0) + | From.Parsetree.Pexp_let (x0, x1, x2) -> + To.Parsetree.Pexp_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_expression x2) + | From.Parsetree.Pexp_function x0 -> + To.Parsetree.Pexp_function (List.map copy_case x0) + | From.Parsetree.Pexp_fun (x0, x1, x2, x3) -> + To.Parsetree.Pexp_fun + ( copy_arg_label x0, + copy_option copy_expression x1, + copy_pattern x2, + copy_expression x3 ) + | From.Parsetree.Pexp_apply (x0, x1) -> + To.Parsetree.Pexp_apply + ( copy_expression x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | From.Parsetree.Pexp_match (x0, x1) -> + To.Parsetree.Pexp_match (copy_expression x0, List.map copy_case x1) + | From.Parsetree.Pexp_try (x0, x1) -> + To.Parsetree.Pexp_try (copy_expression x0, List.map copy_case x1) + | From.Parsetree.Pexp_tuple x0 -> + To.Parsetree.Pexp_tuple (List.map copy_expression x0) + | From.Parsetree.Pexp_construct (x0, x1) -> + To.Parsetree.Pexp_construct + (copy_loc copy_longident x0, copy_option copy_expression x1) + | From.Parsetree.Pexp_variant (x0, x1) -> + To.Parsetree.Pexp_variant (copy_label x0, copy_option copy_expression x1) + | From.Parsetree.Pexp_record (x0, x1) -> + To.Parsetree.Pexp_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_expression x1)) + x0, + copy_option copy_expression x1 ) + | From.Parsetree.Pexp_field (x0, x1) -> + To.Parsetree.Pexp_field (copy_expression x0, copy_loc copy_longident x1) + | From.Parsetree.Pexp_setfield (x0, x1, x2) -> + To.Parsetree.Pexp_setfield + (copy_expression x0, copy_loc copy_longident x1, copy_expression x2) + | From.Parsetree.Pexp_array x0 -> + To.Parsetree.Pexp_array (List.map copy_expression x0) + | From.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> + To.Parsetree.Pexp_ifthenelse + (copy_expression x0, copy_expression x1, copy_option copy_expression x2) + | From.Parsetree.Pexp_sequence (x0, x1) -> + To.Parsetree.Pexp_sequence (copy_expression x0, copy_expression x1) + | From.Parsetree.Pexp_while (x0, x1) -> + To.Parsetree.Pexp_while (copy_expression x0, copy_expression x1) + | From.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> + To.Parsetree.Pexp_for + ( copy_pattern x0, + copy_expression x1, + copy_expression x2, + copy_direction_flag x3, + copy_expression x4 ) + | From.Parsetree.Pexp_constraint (x0, x1) -> + To.Parsetree.Pexp_constraint (copy_expression x0, copy_core_type x1) + | From.Parsetree.Pexp_coerce (x0, x1, x2) -> + To.Parsetree.Pexp_coerce + (copy_expression x0, copy_option copy_core_type x1, copy_core_type x2) + | From.Parsetree.Pexp_send (x0, x1) -> + To.Parsetree.Pexp_send (copy_expression x0, copy_loc (fun x -> x) x1) + | From.Parsetree.Pexp_new x0 -> + To.Parsetree.Pexp_new (copy_loc copy_longident x0) + | From.Parsetree.Pexp_setinstvar (x0, x1) -> + To.Parsetree.Pexp_setinstvar (copy_loc (fun x -> x) x0, copy_expression x1) + | From.Parsetree.Pexp_override x0 -> + To.Parsetree.Pexp_override + (List.map + (fun x -> + let x0, x1 = x in + (copy_loc (fun x -> x) x0, copy_expression x1)) + x0) + | From.Parsetree.Pexp_letmodule (x0, x1, x2) -> + To.Parsetree.Pexp_letmodule + (copy_loc (fun x -> x) x0, copy_module_expr x1, copy_expression x2) + | From.Parsetree.Pexp_letexception (x0, x1) -> + To.Parsetree.Pexp_letexception + (copy_extension_constructor x0, copy_expression x1) + | From.Parsetree.Pexp_assert x0 -> + To.Parsetree.Pexp_assert (copy_expression x0) + | From.Parsetree.Pexp_lazy x0 -> To.Parsetree.Pexp_lazy (copy_expression x0) + | From.Parsetree.Pexp_poly (x0, x1) -> + To.Parsetree.Pexp_poly (copy_expression x0, copy_option copy_core_type x1) + | From.Parsetree.Pexp_object x0 -> + To.Parsetree.Pexp_object (copy_class_structure x0) + | From.Parsetree.Pexp_newtype (x0, x1) -> + To.Parsetree.Pexp_newtype (copy_loc (fun x -> x) x0, copy_expression x1) + | From.Parsetree.Pexp_pack x0 -> To.Parsetree.Pexp_pack (copy_module_expr x0) + | From.Parsetree.Pexp_open (x0, x1, x2) -> + To.Parsetree.Pexp_open + (copy_override_flag x0, copy_loc copy_longident x1, copy_expression x2) + | From.Parsetree.Pexp_extension x0 -> + To.Parsetree.Pexp_extension (copy_extension x0) + | From.Parsetree.Pexp_unreachable -> To.Parsetree.Pexp_unreachable + +and copy_direction_flag : + From.Asttypes.direction_flag -> To.Asttypes.direction_flag = function + | From.Asttypes.Upto -> To.Asttypes.Upto + | From.Asttypes.Downto -> To.Asttypes.Downto + +and copy_case : From.Parsetree.case -> To.Parsetree.case = + fun { From.Parsetree.pc_lhs; From.Parsetree.pc_guard; From.Parsetree.pc_rhs } -> + { + To.Parsetree.pc_lhs = copy_pattern pc_lhs; + To.Parsetree.pc_guard = copy_option copy_expression pc_guard; + To.Parsetree.pc_rhs = copy_expression pc_rhs; + } + +and copy_value_binding : + From.Parsetree.value_binding -> To.Parsetree.value_binding = + fun { + From.Parsetree.pvb_pat; + From.Parsetree.pvb_expr; + From.Parsetree.pvb_attributes; + From.Parsetree.pvb_loc; + } -> + { + To.Parsetree.pvb_pat = copy_pattern pvb_pat; + To.Parsetree.pvb_expr = copy_expression pvb_expr; + To.Parsetree.pvb_attributes = copy_attributes pvb_attributes; + To.Parsetree.pvb_loc = copy_location pvb_loc; + } + +and copy_pattern : From.Parsetree.pattern -> To.Parsetree.pattern = + fun { + From.Parsetree.ppat_desc; + From.Parsetree.ppat_loc; + From.Parsetree.ppat_attributes; + } -> + { + To.Parsetree.ppat_desc = copy_pattern_desc ppat_desc; + To.Parsetree.ppat_loc = copy_location ppat_loc; + To.Parsetree.ppat_attributes = copy_attributes ppat_attributes; + } + +and copy_pattern_desc : From.Parsetree.pattern_desc -> To.Parsetree.pattern_desc + = function + | From.Parsetree.Ppat_any -> To.Parsetree.Ppat_any + | From.Parsetree.Ppat_var x0 -> + To.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) + | From.Parsetree.Ppat_alias (x0, x1) -> + To.Parsetree.Ppat_alias (copy_pattern x0, copy_loc (fun x -> x) x1) + | From.Parsetree.Ppat_constant x0 -> + To.Parsetree.Ppat_constant (copy_constant x0) + | From.Parsetree.Ppat_interval (x0, x1) -> + To.Parsetree.Ppat_interval (copy_constant x0, copy_constant x1) + | From.Parsetree.Ppat_tuple x0 -> + To.Parsetree.Ppat_tuple (List.map copy_pattern x0) + | From.Parsetree.Ppat_construct (x0, x1) -> + To.Parsetree.Ppat_construct + (copy_loc copy_longident x0, copy_option copy_pattern x1) + | From.Parsetree.Ppat_variant (x0, x1) -> + To.Parsetree.Ppat_variant (copy_label x0, copy_option copy_pattern x1) + | From.Parsetree.Ppat_record (x0, x1) -> + To.Parsetree.Ppat_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_pattern x1)) + x0, + copy_closed_flag x1 ) + | From.Parsetree.Ppat_array x0 -> + To.Parsetree.Ppat_array (List.map copy_pattern x0) + | From.Parsetree.Ppat_or (x0, x1) -> + To.Parsetree.Ppat_or (copy_pattern x0, copy_pattern x1) + | From.Parsetree.Ppat_constraint (x0, x1) -> + To.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1) + | From.Parsetree.Ppat_type x0 -> + To.Parsetree.Ppat_type (copy_loc copy_longident x0) + | From.Parsetree.Ppat_lazy x0 -> To.Parsetree.Ppat_lazy (copy_pattern x0) + | From.Parsetree.Ppat_unpack x0 -> + To.Parsetree.Ppat_unpack (copy_loc (fun x -> x) x0) + | From.Parsetree.Ppat_exception x0 -> + To.Parsetree.Ppat_exception (copy_pattern x0) + | From.Parsetree.Ppat_extension x0 -> + To.Parsetree.Ppat_extension (copy_extension x0) + | From.Parsetree.Ppat_open (x0, x1) -> + To.Parsetree.Ppat_open (copy_loc copy_longident x0, copy_pattern x1) + +and copy_core_type : From.Parsetree.core_type -> To.Parsetree.core_type = + fun { + From.Parsetree.ptyp_desc; + From.Parsetree.ptyp_loc; + From.Parsetree.ptyp_attributes; + } -> + { + To.Parsetree.ptyp_desc = copy_core_type_desc ptyp_desc; + To.Parsetree.ptyp_loc = copy_location ptyp_loc; + To.Parsetree.ptyp_attributes = copy_attributes ptyp_attributes; + } + +and copy_core_type_desc : + From.Parsetree.core_type_desc -> To.Parsetree.core_type_desc = function + | From.Parsetree.Ptyp_any -> To.Parsetree.Ptyp_any + | From.Parsetree.Ptyp_var x0 -> To.Parsetree.Ptyp_var x0 + | From.Parsetree.Ptyp_arrow (x0, x1, x2) -> + To.Parsetree.Ptyp_arrow + (copy_arg_label x0, copy_core_type x1, copy_core_type x2) + | From.Parsetree.Ptyp_tuple x0 -> + To.Parsetree.Ptyp_tuple (List.map copy_core_type x0) + | From.Parsetree.Ptyp_constr (x0, x1) -> + To.Parsetree.Ptyp_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Ptyp_object (x0, x1) -> + To.Parsetree.Ptyp_object + (List.map copy_object_field x0, copy_closed_flag x1) + | From.Parsetree.Ptyp_class (x0, x1) -> + To.Parsetree.Ptyp_class + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Ptyp_alias (x0, x1) -> + To.Parsetree.Ptyp_alias (copy_core_type x0, x1) + | From.Parsetree.Ptyp_variant (x0, x1, x2) -> + To.Parsetree.Ptyp_variant + ( List.map copy_row_field x0, + copy_closed_flag x1, + copy_option (fun x -> List.map copy_label x) x2 ) + | From.Parsetree.Ptyp_poly (x0, x1) -> + To.Parsetree.Ptyp_poly + (List.map (fun x -> copy_loc (fun x -> x) x) x0, copy_core_type x1) + | From.Parsetree.Ptyp_package x0 -> + To.Parsetree.Ptyp_package (copy_package_type x0) + | From.Parsetree.Ptyp_extension x0 -> + To.Parsetree.Ptyp_extension (copy_extension x0) + +and copy_package_type : From.Parsetree.package_type -> To.Parsetree.package_type + = + fun x -> + let x0, x1 = x in + ( copy_loc copy_longident x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_core_type x1)) + x1 ) + +and copy_row_field : From.Parsetree.row_field -> To.Parsetree.row_field = + function + | From.Parsetree.Rtag (x0, x1, x2, x3) -> + To.Parsetree.Rtag + ( copy_loc copy_label x0, + copy_attributes x1, + copy_bool x2, + List.map copy_core_type x3 ) + | From.Parsetree.Rinherit x0 -> To.Parsetree.Rinherit (copy_core_type x0) + +and copy_object_field : From.Parsetree.object_field -> To.Parsetree.object_field + = function + | From.Parsetree.Otag (x0, x1, x2) -> + To.Parsetree.Otag + (copy_loc (fun x -> x) x0, copy_attributes x1, copy_core_type x2) + | From.Parsetree.Oinherit x -> To.Parsetree.Oinherit (copy_core_type x) + +and copy_attributes : From.Parsetree.attributes -> To.Parsetree.attributes = + fun x -> List.map copy_attribute x + +and copy_attribute : From.Parsetree.attribute -> To.Parsetree.attribute = + fun x -> + let x0, x1 = x in + (copy_loc (fun x -> x) x0, copy_payload x1) + +and copy_payload : From.Parsetree.payload -> To.Parsetree.payload = function + | From.Parsetree.PStr x0 -> To.Parsetree.PStr (copy_structure x0) + | From.Parsetree.PSig x0 -> To.Parsetree.PSig (copy_signature x0) + | From.Parsetree.PTyp x0 -> To.Parsetree.PTyp (copy_core_type x0) + | From.Parsetree.PPat (x0, x1) -> + To.Parsetree.PPat (copy_pattern x0, copy_option copy_expression x1) + +and copy_structure : From.Parsetree.structure -> To.Parsetree.structure = + fun x -> List.map copy_structure_item x + +and copy_structure_item : + From.Parsetree.structure_item -> To.Parsetree.structure_item = + fun { From.Parsetree.pstr_desc; From.Parsetree.pstr_loc } -> + { + To.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc; + To.Parsetree.pstr_loc = copy_location pstr_loc; + } + +and copy_structure_item_desc : + From.Parsetree.structure_item_desc -> To.Parsetree.structure_item_desc = + function + | From.Parsetree.Pstr_eval (x0, x1) -> + To.Parsetree.Pstr_eval (copy_expression x0, copy_attributes x1) + | From.Parsetree.Pstr_value (x0, x1) -> + To.Parsetree.Pstr_value (copy_rec_flag x0, List.map copy_value_binding x1) + | From.Parsetree.Pstr_primitive x0 -> + To.Parsetree.Pstr_primitive (copy_value_description x0) + | From.Parsetree.Pstr_type (x0, x1) -> + To.Parsetree.Pstr_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | From.Parsetree.Pstr_typext x0 -> + To.Parsetree.Pstr_typext (copy_type_extension x0) + | From.Parsetree.Pstr_exception x0 -> + To.Parsetree.Pstr_exception (copy_extension_constructor x0) + | From.Parsetree.Pstr_module x0 -> + To.Parsetree.Pstr_module (copy_module_binding x0) + | From.Parsetree.Pstr_recmodule x0 -> + To.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) + | From.Parsetree.Pstr_modtype x0 -> + To.Parsetree.Pstr_modtype (copy_module_type_declaration x0) + | From.Parsetree.Pstr_open x0 -> + To.Parsetree.Pstr_open (copy_open_description x0) + | From.Parsetree.Pstr_class x0 -> + To.Parsetree.Pstr_class (List.map copy_class_declaration x0) + | From.Parsetree.Pstr_class_type x0 -> + To.Parsetree.Pstr_class_type (List.map copy_class_type_declaration x0) + | From.Parsetree.Pstr_include x0 -> + To.Parsetree.Pstr_include (copy_include_declaration x0) + | From.Parsetree.Pstr_attribute x0 -> + To.Parsetree.Pstr_attribute (copy_attribute x0) + | From.Parsetree.Pstr_extension (x0, x1) -> + To.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1) + +and copy_include_declaration : + From.Parsetree.include_declaration -> To.Parsetree.include_declaration = + fun x -> copy_include_infos copy_module_expr x + +and copy_class_declaration : + From.Parsetree.class_declaration -> To.Parsetree.class_declaration = + fun x -> copy_class_infos copy_class_expr x + +and copy_class_expr : From.Parsetree.class_expr -> To.Parsetree.class_expr = + fun { + From.Parsetree.pcl_desc; + From.Parsetree.pcl_loc; + From.Parsetree.pcl_attributes; + } -> + { + To.Parsetree.pcl_desc = copy_class_expr_desc pcl_desc; + To.Parsetree.pcl_loc = copy_location pcl_loc; + To.Parsetree.pcl_attributes = copy_attributes pcl_attributes; + } + +and copy_class_expr_desc : + From.Parsetree.class_expr_desc -> To.Parsetree.class_expr_desc = function + | From.Parsetree.Pcl_constr (x0, x1) -> + To.Parsetree.Pcl_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Pcl_structure x0 -> + To.Parsetree.Pcl_structure (copy_class_structure x0) + | From.Parsetree.Pcl_fun (x0, x1, x2, x3) -> + To.Parsetree.Pcl_fun + ( copy_arg_label x0, + copy_option copy_expression x1, + copy_pattern x2, + copy_class_expr x3 ) + | From.Parsetree.Pcl_apply (x0, x1) -> + To.Parsetree.Pcl_apply + ( copy_class_expr x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | From.Parsetree.Pcl_let (x0, x1, x2) -> + To.Parsetree.Pcl_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_class_expr x2) + | From.Parsetree.Pcl_constraint (x0, x1) -> + To.Parsetree.Pcl_constraint (copy_class_expr x0, copy_class_type x1) + | From.Parsetree.Pcl_extension x0 -> + To.Parsetree.Pcl_extension (copy_extension x0) + | From.Parsetree.Pcl_open (ovf, loc, ce) -> + To.Parsetree.Pcl_open + (copy_override_flag ovf, copy_loc copy_longident loc, copy_class_expr ce) + +and copy_class_structure : + From.Parsetree.class_structure -> To.Parsetree.class_structure = + fun { From.Parsetree.pcstr_self; From.Parsetree.pcstr_fields } -> + { + To.Parsetree.pcstr_self = copy_pattern pcstr_self; + To.Parsetree.pcstr_fields = List.map copy_class_field pcstr_fields; + } + +and copy_class_field : From.Parsetree.class_field -> To.Parsetree.class_field = + fun { + From.Parsetree.pcf_desc; + From.Parsetree.pcf_loc; + From.Parsetree.pcf_attributes; + } -> + { + To.Parsetree.pcf_desc = copy_class_field_desc pcf_desc; + To.Parsetree.pcf_loc = copy_location pcf_loc; + To.Parsetree.pcf_attributes = copy_attributes pcf_attributes; + } + +and copy_class_field_desc : + From.Parsetree.class_field_desc -> To.Parsetree.class_field_desc = function + | From.Parsetree.Pcf_inherit (x0, x1, x2) -> + To.Parsetree.Pcf_inherit + ( copy_override_flag x0, + copy_class_expr x1, + copy_option (copy_loc (fun x -> x)) x2 ) + | From.Parsetree.Pcf_val x0 -> + To.Parsetree.Pcf_val + (let x0, x1, x2 = x0 in + ( copy_loc (fun x -> x) x0, + copy_mutable_flag x1, + copy_class_field_kind x2 )) + | From.Parsetree.Pcf_method x0 -> + To.Parsetree.Pcf_method + (let x0, x1, x2 = x0 in + ( copy_loc (fun x -> x) x0, + copy_private_flag x1, + copy_class_field_kind x2 )) + | From.Parsetree.Pcf_constraint x0 -> + To.Parsetree.Pcf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | From.Parsetree.Pcf_initializer x0 -> + To.Parsetree.Pcf_initializer (copy_expression x0) + | From.Parsetree.Pcf_attribute x0 -> + To.Parsetree.Pcf_attribute (copy_attribute x0) + | From.Parsetree.Pcf_extension x0 -> + To.Parsetree.Pcf_extension (copy_extension x0) + +and copy_class_field_kind : + From.Parsetree.class_field_kind -> To.Parsetree.class_field_kind = function + | From.Parsetree.Cfk_virtual x0 -> + To.Parsetree.Cfk_virtual (copy_core_type x0) + | From.Parsetree.Cfk_concrete (x0, x1) -> + To.Parsetree.Cfk_concrete (copy_override_flag x0, copy_expression x1) + +and copy_module_binding : + From.Parsetree.module_binding -> To.Parsetree.module_binding = + fun { + From.Parsetree.pmb_name; + From.Parsetree.pmb_expr; + From.Parsetree.pmb_attributes; + From.Parsetree.pmb_loc; + } -> + { + To.Parsetree.pmb_name = copy_loc (fun x -> x) pmb_name; + To.Parsetree.pmb_expr = copy_module_expr pmb_expr; + To.Parsetree.pmb_attributes = copy_attributes pmb_attributes; + To.Parsetree.pmb_loc = copy_location pmb_loc; + } + +and copy_module_expr : From.Parsetree.module_expr -> To.Parsetree.module_expr = + fun { + From.Parsetree.pmod_desc; + From.Parsetree.pmod_loc; + From.Parsetree.pmod_attributes; + } -> + { + To.Parsetree.pmod_desc = copy_module_expr_desc pmod_desc; + To.Parsetree.pmod_loc = copy_location pmod_loc; + To.Parsetree.pmod_attributes = copy_attributes pmod_attributes; + } + +and copy_module_expr_desc : + From.Parsetree.module_expr_desc -> To.Parsetree.module_expr_desc = function + | From.Parsetree.Pmod_ident x0 -> + To.Parsetree.Pmod_ident (copy_loc copy_longident x0) + | From.Parsetree.Pmod_structure x0 -> + To.Parsetree.Pmod_structure (copy_structure x0) + | From.Parsetree.Pmod_functor (x0, x1, x2) -> + To.Parsetree.Pmod_functor + ( copy_loc (fun x -> x) x0, + copy_option copy_module_type x1, + copy_module_expr x2 ) + | From.Parsetree.Pmod_apply (x0, x1) -> + To.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) + | From.Parsetree.Pmod_constraint (x0, x1) -> + To.Parsetree.Pmod_constraint (copy_module_expr x0, copy_module_type x1) + | From.Parsetree.Pmod_unpack x0 -> + To.Parsetree.Pmod_unpack (copy_expression x0) + | From.Parsetree.Pmod_extension x0 -> + To.Parsetree.Pmod_extension (copy_extension x0) + +and copy_module_type : From.Parsetree.module_type -> To.Parsetree.module_type = + fun { + From.Parsetree.pmty_desc; + From.Parsetree.pmty_loc; + From.Parsetree.pmty_attributes; + } -> + { + To.Parsetree.pmty_desc = copy_module_type_desc pmty_desc; + To.Parsetree.pmty_loc = copy_location pmty_loc; + To.Parsetree.pmty_attributes = copy_attributes pmty_attributes; + } + +and copy_module_type_desc : + From.Parsetree.module_type_desc -> To.Parsetree.module_type_desc = function + | From.Parsetree.Pmty_ident x0 -> + To.Parsetree.Pmty_ident (copy_loc copy_longident x0) + | From.Parsetree.Pmty_signature x0 -> + To.Parsetree.Pmty_signature (copy_signature x0) + | From.Parsetree.Pmty_functor (x0, x1, x2) -> + To.Parsetree.Pmty_functor + ( copy_loc (fun x -> x) x0, + copy_option copy_module_type x1, + copy_module_type x2 ) + | From.Parsetree.Pmty_with (x0, x1) -> + To.Parsetree.Pmty_with + (copy_module_type x0, List.map copy_with_constraint x1) + | From.Parsetree.Pmty_typeof x0 -> + To.Parsetree.Pmty_typeof (copy_module_expr x0) + | From.Parsetree.Pmty_extension x0 -> + To.Parsetree.Pmty_extension (copy_extension x0) + | From.Parsetree.Pmty_alias x0 -> + To.Parsetree.Pmty_alias (copy_loc copy_longident x0) + +and copy_with_constraint : + From.Parsetree.with_constraint -> To.Parsetree.with_constraint = function + | From.Parsetree.Pwith_type (x0, x1) -> + To.Parsetree.Pwith_type + (copy_loc copy_longident x0, copy_type_declaration x1) + | From.Parsetree.Pwith_module (x0, x1) -> + To.Parsetree.Pwith_module + (copy_loc copy_longident x0, copy_loc copy_longident x1) + | From.Parsetree.Pwith_typesubst (x0, x1) -> + To.Parsetree.Pwith_typesubst + (copy_loc copy_longident x0, copy_type_declaration x1) + | From.Parsetree.Pwith_modsubst (x0, x1) -> + To.Parsetree.Pwith_modsubst + (copy_loc copy_longident x0, copy_loc copy_longident x1) + +and copy_signature : From.Parsetree.signature -> To.Parsetree.signature = + fun x -> List.map copy_signature_item x + +and copy_signature_item : + From.Parsetree.signature_item -> To.Parsetree.signature_item = + fun { From.Parsetree.psig_desc; From.Parsetree.psig_loc } -> + { + To.Parsetree.psig_desc = copy_signature_item_desc psig_desc; + To.Parsetree.psig_loc = copy_location psig_loc; + } + +and copy_signature_item_desc : + From.Parsetree.signature_item_desc -> To.Parsetree.signature_item_desc = + function + | From.Parsetree.Psig_value x0 -> + To.Parsetree.Psig_value (copy_value_description x0) + | From.Parsetree.Psig_type (x0, x1) -> + To.Parsetree.Psig_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | From.Parsetree.Psig_typext x0 -> + To.Parsetree.Psig_typext (copy_type_extension x0) + | From.Parsetree.Psig_exception x0 -> + To.Parsetree.Psig_exception (copy_extension_constructor x0) + | From.Parsetree.Psig_module x0 -> + To.Parsetree.Psig_module (copy_module_declaration x0) + | From.Parsetree.Psig_recmodule x0 -> + To.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) + | From.Parsetree.Psig_modtype x0 -> + To.Parsetree.Psig_modtype (copy_module_type_declaration x0) + | From.Parsetree.Psig_open x0 -> + To.Parsetree.Psig_open (copy_open_description x0) + | From.Parsetree.Psig_include x0 -> + To.Parsetree.Psig_include (copy_include_description x0) + | From.Parsetree.Psig_class x0 -> + To.Parsetree.Psig_class (List.map copy_class_description x0) + | From.Parsetree.Psig_class_type x0 -> + To.Parsetree.Psig_class_type (List.map copy_class_type_declaration x0) + | From.Parsetree.Psig_attribute x0 -> + To.Parsetree.Psig_attribute (copy_attribute x0) + | From.Parsetree.Psig_extension (x0, x1) -> + To.Parsetree.Psig_extension (copy_extension x0, copy_attributes x1) + +and copy_class_type_declaration : + From.Parsetree.class_type_declaration -> To.Parsetree.class_type_declaration + = + fun x -> copy_class_infos copy_class_type x + +and copy_class_description : + From.Parsetree.class_description -> To.Parsetree.class_description = + fun x -> copy_class_infos copy_class_type x + +and copy_class_type : From.Parsetree.class_type -> To.Parsetree.class_type = + fun { + From.Parsetree.pcty_desc; + From.Parsetree.pcty_loc; + From.Parsetree.pcty_attributes; + } -> + { + To.Parsetree.pcty_desc = copy_class_type_desc pcty_desc; + To.Parsetree.pcty_loc = copy_location pcty_loc; + To.Parsetree.pcty_attributes = copy_attributes pcty_attributes; + } + +and copy_class_type_desc : + From.Parsetree.class_type_desc -> To.Parsetree.class_type_desc = function + | From.Parsetree.Pcty_constr (x0, x1) -> + To.Parsetree.Pcty_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Pcty_signature x0 -> + To.Parsetree.Pcty_signature (copy_class_signature x0) + | From.Parsetree.Pcty_arrow (x0, x1, x2) -> + To.Parsetree.Pcty_arrow + (copy_arg_label x0, copy_core_type x1, copy_class_type x2) + | From.Parsetree.Pcty_extension x0 -> + To.Parsetree.Pcty_extension (copy_extension x0) + | From.Parsetree.Pcty_open (ovf, loc, cty) -> + To.Parsetree.Pcty_open + ( copy_override_flag ovf, + copy_loc copy_longident loc, + copy_class_type cty ) + +and copy_class_signature : + From.Parsetree.class_signature -> To.Parsetree.class_signature = + fun { From.Parsetree.pcsig_self; From.Parsetree.pcsig_fields } -> + { + To.Parsetree.pcsig_self = copy_core_type pcsig_self; + To.Parsetree.pcsig_fields = List.map copy_class_type_field pcsig_fields; + } + +and copy_class_type_field : + From.Parsetree.class_type_field -> To.Parsetree.class_type_field = + fun { + From.Parsetree.pctf_desc; + From.Parsetree.pctf_loc; + From.Parsetree.pctf_attributes; + } -> + { + To.Parsetree.pctf_desc = copy_class_type_field_desc pctf_desc; + To.Parsetree.pctf_loc = copy_location pctf_loc; + To.Parsetree.pctf_attributes = copy_attributes pctf_attributes; + } + +and copy_class_type_field_desc : + From.Parsetree.class_type_field_desc -> To.Parsetree.class_type_field_desc = + function + | From.Parsetree.Pctf_inherit x0 -> + To.Parsetree.Pctf_inherit (copy_class_type x0) + | From.Parsetree.Pctf_val x0 -> + To.Parsetree.Pctf_val + (let x0, x1, x2, x3 = x0 in + ( copy_loc (fun x -> x) x0, + copy_mutable_flag x1, + copy_virtual_flag x2, + copy_core_type x3 )) + | From.Parsetree.Pctf_method x0 -> + To.Parsetree.Pctf_method + (let x0, x1, x2, x3 = x0 in + ( copy_loc (fun x -> x) x0, + copy_private_flag x1, + copy_virtual_flag x2, + copy_core_type x3 )) + | From.Parsetree.Pctf_constraint x0 -> + To.Parsetree.Pctf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | From.Parsetree.Pctf_attribute x0 -> + To.Parsetree.Pctf_attribute (copy_attribute x0) + | From.Parsetree.Pctf_extension x0 -> + To.Parsetree.Pctf_extension (copy_extension x0) + +and copy_extension : From.Parsetree.extension -> To.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 From.Parsetree.class_infos -> + 'g0 To.Parsetree.class_infos = + fun f0 + { + From.Parsetree.pci_virt; + From.Parsetree.pci_params; + From.Parsetree.pci_name; + From.Parsetree.pci_expr; + From.Parsetree.pci_loc; + From.Parsetree.pci_attributes; + } -> + { + To.Parsetree.pci_virt = copy_virtual_flag pci_virt; + To.Parsetree.pci_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + pci_params; + To.Parsetree.pci_name = copy_loc (fun x -> x) pci_name; + To.Parsetree.pci_expr = f0 pci_expr; + To.Parsetree.pci_loc = copy_location pci_loc; + To.Parsetree.pci_attributes = copy_attributes pci_attributes; + } + +and copy_virtual_flag : From.Asttypes.virtual_flag -> To.Asttypes.virtual_flag = + function + | From.Asttypes.Virtual -> To.Asttypes.Virtual + | From.Asttypes.Concrete -> To.Asttypes.Concrete + +and copy_include_description : + From.Parsetree.include_description -> To.Parsetree.include_description = + fun x -> copy_include_infos copy_module_type x + +and copy_include_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 From.Parsetree.include_infos -> + 'g0 To.Parsetree.include_infos = + fun f0 + { + From.Parsetree.pincl_mod; + From.Parsetree.pincl_loc; + From.Parsetree.pincl_attributes; + } -> + { + To.Parsetree.pincl_mod = f0 pincl_mod; + To.Parsetree.pincl_loc = copy_location pincl_loc; + To.Parsetree.pincl_attributes = copy_attributes pincl_attributes; + } + +and copy_open_description : + From.Parsetree.open_description -> To.Parsetree.open_description = + fun { + From.Parsetree.popen_lid; + From.Parsetree.popen_override; + From.Parsetree.popen_loc; + From.Parsetree.popen_attributes; + } -> + { + To.Parsetree.popen_lid = copy_loc copy_longident popen_lid; + To.Parsetree.popen_override = copy_override_flag popen_override; + To.Parsetree.popen_loc = copy_location popen_loc; + To.Parsetree.popen_attributes = copy_attributes popen_attributes; + } + +and copy_override_flag : + From.Asttypes.override_flag -> To.Asttypes.override_flag = function + | From.Asttypes.Override -> To.Asttypes.Override + | From.Asttypes.Fresh -> To.Asttypes.Fresh + +and copy_module_type_declaration : + From.Parsetree.module_type_declaration -> + To.Parsetree.module_type_declaration = + fun { + From.Parsetree.pmtd_name; + From.Parsetree.pmtd_type; + From.Parsetree.pmtd_attributes; + From.Parsetree.pmtd_loc; + } -> + { + To.Parsetree.pmtd_name = copy_loc (fun x -> x) pmtd_name; + To.Parsetree.pmtd_type = copy_option copy_module_type pmtd_type; + To.Parsetree.pmtd_attributes = copy_attributes pmtd_attributes; + To.Parsetree.pmtd_loc = copy_location pmtd_loc; + } + +and copy_module_declaration : + From.Parsetree.module_declaration -> To.Parsetree.module_declaration = + fun { + From.Parsetree.pmd_name; + From.Parsetree.pmd_type; + From.Parsetree.pmd_attributes; + From.Parsetree.pmd_loc; + } -> + { + To.Parsetree.pmd_name = copy_loc (fun x -> x) pmd_name; + To.Parsetree.pmd_type = copy_module_type pmd_type; + To.Parsetree.pmd_attributes = copy_attributes pmd_attributes; + To.Parsetree.pmd_loc = copy_location pmd_loc; + } + +and copy_type_extension : + From.Parsetree.type_extension -> To.Parsetree.type_extension = + fun { + From.Parsetree.ptyext_path; + From.Parsetree.ptyext_params; + From.Parsetree.ptyext_constructors; + From.Parsetree.ptyext_private; + From.Parsetree.ptyext_attributes; + } -> + { + To.Parsetree.ptyext_path = copy_loc copy_longident ptyext_path; + To.Parsetree.ptyext_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptyext_params; + To.Parsetree.ptyext_constructors = + List.map copy_extension_constructor ptyext_constructors; + To.Parsetree.ptyext_private = copy_private_flag ptyext_private; + To.Parsetree.ptyext_attributes = copy_attributes ptyext_attributes; + } + +and copy_extension_constructor : + From.Parsetree.extension_constructor -> To.Parsetree.extension_constructor = + fun { + From.Parsetree.pext_name; + From.Parsetree.pext_kind; + From.Parsetree.pext_loc; + From.Parsetree.pext_attributes; + } -> + { + To.Parsetree.pext_name = copy_loc (fun x -> x) pext_name; + To.Parsetree.pext_kind = copy_extension_constructor_kind pext_kind; + To.Parsetree.pext_loc = copy_location pext_loc; + To.Parsetree.pext_attributes = copy_attributes pext_attributes; + } + +and copy_extension_constructor_kind : + From.Parsetree.extension_constructor_kind -> + To.Parsetree.extension_constructor_kind = function + | From.Parsetree.Pext_decl (x0, x1) -> + To.Parsetree.Pext_decl + (copy_constructor_arguments x0, copy_option copy_core_type x1) + | From.Parsetree.Pext_rebind x0 -> + To.Parsetree.Pext_rebind (copy_loc copy_longident x0) + +and copy_type_declaration : + From.Parsetree.type_declaration -> To.Parsetree.type_declaration = + fun { + From.Parsetree.ptype_name; + From.Parsetree.ptype_params; + From.Parsetree.ptype_cstrs; + From.Parsetree.ptype_kind; + From.Parsetree.ptype_private; + From.Parsetree.ptype_manifest; + From.Parsetree.ptype_attributes; + From.Parsetree.ptype_loc; + } -> + { + To.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name; + To.Parsetree.ptype_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptype_params; + To.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; + To.Parsetree.ptype_kind = copy_type_kind ptype_kind; + To.Parsetree.ptype_private = copy_private_flag ptype_private; + To.Parsetree.ptype_manifest = copy_option copy_core_type ptype_manifest; + To.Parsetree.ptype_attributes = copy_attributes ptype_attributes; + To.Parsetree.ptype_loc = copy_location ptype_loc; + } + +and copy_private_flag : From.Asttypes.private_flag -> To.Asttypes.private_flag = + function + | From.Asttypes.Private -> To.Asttypes.Private + | From.Asttypes.Public -> To.Asttypes.Public + +and copy_type_kind : From.Parsetree.type_kind -> To.Parsetree.type_kind = + function + | From.Parsetree.Ptype_abstract -> To.Parsetree.Ptype_abstract + | From.Parsetree.Ptype_variant x0 -> + To.Parsetree.Ptype_variant (List.map copy_constructor_declaration x0) + | From.Parsetree.Ptype_record x0 -> + To.Parsetree.Ptype_record (List.map copy_label_declaration x0) + | From.Parsetree.Ptype_open -> To.Parsetree.Ptype_open + +and copy_constructor_declaration : + From.Parsetree.constructor_declaration -> + To.Parsetree.constructor_declaration = + fun { + From.Parsetree.pcd_name; + From.Parsetree.pcd_args; + From.Parsetree.pcd_res; + From.Parsetree.pcd_loc; + From.Parsetree.pcd_attributes; + } -> + { + To.Parsetree.pcd_name = copy_loc (fun x -> x) pcd_name; + To.Parsetree.pcd_args = copy_constructor_arguments pcd_args; + To.Parsetree.pcd_res = copy_option copy_core_type pcd_res; + To.Parsetree.pcd_loc = copy_location pcd_loc; + To.Parsetree.pcd_attributes = copy_attributes pcd_attributes; + } + +and copy_constructor_arguments : + From.Parsetree.constructor_arguments -> To.Parsetree.constructor_arguments = + function + | From.Parsetree.Pcstr_tuple x0 -> + To.Parsetree.Pcstr_tuple (List.map copy_core_type x0) + | From.Parsetree.Pcstr_record x0 -> + To.Parsetree.Pcstr_record (List.map copy_label_declaration x0) + +and copy_label_declaration : + From.Parsetree.label_declaration -> To.Parsetree.label_declaration = + fun { + From.Parsetree.pld_name; + From.Parsetree.pld_mutable; + From.Parsetree.pld_type; + From.Parsetree.pld_loc; + From.Parsetree.pld_attributes; + } -> + { + To.Parsetree.pld_name = copy_loc (fun x -> x) pld_name; + To.Parsetree.pld_mutable = copy_mutable_flag pld_mutable; + To.Parsetree.pld_type = copy_core_type pld_type; + To.Parsetree.pld_loc = copy_location pld_loc; + To.Parsetree.pld_attributes = copy_attributes pld_attributes; + } + +and copy_mutable_flag : From.Asttypes.mutable_flag -> To.Asttypes.mutable_flag = + function + | From.Asttypes.Immutable -> To.Asttypes.Immutable + | From.Asttypes.Mutable -> To.Asttypes.Mutable + +and copy_variance : From.Asttypes.variance -> To.Asttypes.variance = function + | From.Asttypes.Covariant -> To.Asttypes.Covariant + | From.Asttypes.Contravariant -> To.Asttypes.Contravariant + | From.Asttypes.Invariant -> To.Asttypes.Invariant + +and copy_value_description : + From.Parsetree.value_description -> To.Parsetree.value_description = + fun { + From.Parsetree.pval_name; + From.Parsetree.pval_type; + From.Parsetree.pval_prim; + From.Parsetree.pval_attributes; + From.Parsetree.pval_loc; + } -> + { + To.Parsetree.pval_name = copy_loc (fun x -> x) pval_name; + To.Parsetree.pval_type = copy_core_type pval_type; + To.Parsetree.pval_prim = List.map (fun x -> x) pval_prim; + To.Parsetree.pval_attributes = copy_attributes pval_attributes; + To.Parsetree.pval_loc = copy_location pval_loc; + } + +and copy_arg_label : From.Asttypes.arg_label -> To.Asttypes.arg_label = function + | From.Asttypes.Nolabel -> To.Asttypes.Nolabel + | From.Asttypes.Labelled x0 -> To.Asttypes.Labelled x0 + | From.Asttypes.Optional x0 -> To.Asttypes.Optional x0 + +and copy_closed_flag : From.Asttypes.closed_flag -> To.Asttypes.closed_flag = + function + | From.Asttypes.Closed -> To.Asttypes.Closed + | From.Asttypes.Open -> To.Asttypes.Open + +and copy_label : From.Asttypes.label -> To.Asttypes.label = fun x -> x + +and copy_rec_flag : From.Asttypes.rec_flag -> To.Asttypes.rec_flag = function + | From.Asttypes.Nonrecursive -> To.Asttypes.Nonrecursive + | From.Asttypes.Recursive -> To.Asttypes.Recursive + +and copy_constant : From.Parsetree.constant -> To.Parsetree.constant = function + | From.Parsetree.Pconst_integer (x0, x1) -> + To.Parsetree.Pconst_integer (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pconst_char x0 -> To.Parsetree.Pconst_char x0 + | From.Parsetree.Pconst_string (x0, x1) -> + To.Parsetree.Pconst_string (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pconst_float (x0, x1) -> + To.Parsetree.Pconst_float (x0, copy_option (fun x -> x) x1) + +and copy_option : 'f0 'g0. ('f0 -> 'g0) -> 'f0 option -> 'g0 option = + fun f0 -> function None -> None | Some x0 -> Some (f0 x0) + +and copy_longident : Longident.t -> Longident.t = fun x -> x + +and copy_loc : + 'f0 'g0. ('f0 -> 'g0) -> 'f0 From.Asttypes.loc -> 'g0 To.Asttypes.loc = + fun f0 { From.Asttypes.txt; From.Asttypes.loc } -> + { To.Asttypes.txt = f0 txt; To.Asttypes.loc = copy_location loc } + +and copy_location : Location.t -> Location.t = fun x -> x + +and copy_bool : bool -> bool = function false -> false | true -> true + +let rec copy_toplevel_phrase : + From.Parsetree.toplevel_phrase -> To.Parsetree.toplevel_phrase = function + | From.Parsetree.Ptop_def x0 -> To.Parsetree.Ptop_def (copy_structure x0) + | From.Parsetree.Ptop_dir (x0, x1) -> + To.Parsetree.Ptop_dir (x0, copy_directive_argument x1) + +and copy_directive_argument : + From.Parsetree.directive_argument -> To.Parsetree.directive_argument = + function + | From.Parsetree.Pdir_none -> To.Parsetree.Pdir_none + | From.Parsetree.Pdir_string x0 -> To.Parsetree.Pdir_string x0 + | From.Parsetree.Pdir_int (x0, x1) -> + To.Parsetree.Pdir_int (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pdir_ident x0 -> To.Parsetree.Pdir_ident (copy_longident x0) + | From.Parsetree.Pdir_bool x0 -> To.Parsetree.Pdir_bool (copy_bool x0) + +let copy_cases x = List.map copy_case x + +let copy_pat = copy_pattern + +let copy_expr = copy_expression + +let copy_typ = copy_core_type diff -Nru ppxlib-0.15.0/astlib/migrate_407_408.ml ppxlib-0.24.0/astlib/migrate_407_408.ml --- ppxlib-0.15.0/astlib/migrate_407_408.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/migrate_407_408.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1131 @@ +module From = Ast_407 +module To = Ast_408 + +let rec copy_toplevel_phrase : + From.Parsetree.toplevel_phrase -> To.Parsetree.toplevel_phrase = function + | From.Parsetree.Ptop_def x0 -> To.Parsetree.Ptop_def (copy_structure x0) + | From.Parsetree.Ptop_dir (x0, x1) -> + To.Parsetree.Ptop_dir + { + To.Parsetree.pdir_name = + { Location.txt = x0; Location.loc = Location.none }; + To.Parsetree.pdir_arg = copy_directive_argument x1; + To.Parsetree.pdir_loc = Location.none; + } + +and copy_directive_argument : + From.Parsetree.directive_argument -> To.Parsetree.directive_argument option + = + let wrap pdira_desc = + Some { To.Parsetree.pdira_desc; To.Parsetree.pdira_loc = Location.none } + in + function + | From.Parsetree.Pdir_none -> None + | From.Parsetree.Pdir_string x0 -> To.Parsetree.Pdir_string x0 |> wrap + | From.Parsetree.Pdir_int (x0, x1) -> + To.Parsetree.Pdir_int (x0, copy_option (fun x -> x) x1) |> wrap + | From.Parsetree.Pdir_ident x0 -> + To.Parsetree.Pdir_ident (copy_longident x0) |> wrap + | From.Parsetree.Pdir_bool x0 -> To.Parsetree.Pdir_bool (copy_bool x0) |> wrap + +and copy_expression : From.Parsetree.expression -> To.Parsetree.expression = + fun { + From.Parsetree.pexp_desc; + From.Parsetree.pexp_loc; + From.Parsetree.pexp_attributes; + } -> + { + To.Parsetree.pexp_desc = copy_expression_desc pexp_desc; + To.Parsetree.pexp_loc = copy_location pexp_loc; + To.Parsetree.pexp_loc_stack = []; + To.Parsetree.pexp_attributes = copy_attributes pexp_attributes; + } + +and copy_expression_desc : + From.Parsetree.expression_desc -> To.Parsetree.expression_desc = function + | From.Parsetree.Pexp_ident x0 -> + To.Parsetree.Pexp_ident (copy_loc copy_longident x0) + | From.Parsetree.Pexp_constant x0 -> + To.Parsetree.Pexp_constant (copy_constant x0) + | From.Parsetree.Pexp_let (x0, x1, x2) -> + To.Parsetree.Pexp_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_expression x2) + | From.Parsetree.Pexp_function x0 -> + To.Parsetree.Pexp_function (List.map copy_case x0) + | From.Parsetree.Pexp_fun (x0, x1, x2, x3) -> + To.Parsetree.Pexp_fun + ( copy_arg_label x0, + copy_option copy_expression x1, + copy_pattern x2, + copy_expression x3 ) + | From.Parsetree.Pexp_apply (x0, x1) -> + To.Parsetree.Pexp_apply + ( copy_expression x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | From.Parsetree.Pexp_match (x0, x1) -> + To.Parsetree.Pexp_match (copy_expression x0, List.map copy_case x1) + | From.Parsetree.Pexp_try (x0, x1) -> + To.Parsetree.Pexp_try (copy_expression x0, List.map copy_case x1) + | From.Parsetree.Pexp_tuple x0 -> + To.Parsetree.Pexp_tuple (List.map copy_expression x0) + | From.Parsetree.Pexp_construct (x0, x1) -> + To.Parsetree.Pexp_construct + (copy_loc copy_longident x0, copy_option copy_expression x1) + | From.Parsetree.Pexp_variant (x0, x1) -> + To.Parsetree.Pexp_variant (copy_label x0, copy_option copy_expression x1) + | From.Parsetree.Pexp_record (x0, x1) -> + To.Parsetree.Pexp_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_expression x1)) + x0, + copy_option copy_expression x1 ) + | From.Parsetree.Pexp_field (x0, x1) -> + To.Parsetree.Pexp_field (copy_expression x0, copy_loc copy_longident x1) + | From.Parsetree.Pexp_setfield (x0, x1, x2) -> + To.Parsetree.Pexp_setfield + (copy_expression x0, copy_loc copy_longident x1, copy_expression x2) + | From.Parsetree.Pexp_array x0 -> + To.Parsetree.Pexp_array (List.map copy_expression x0) + | From.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> + To.Parsetree.Pexp_ifthenelse + (copy_expression x0, copy_expression x1, copy_option copy_expression x2) + | From.Parsetree.Pexp_sequence (x0, x1) -> + To.Parsetree.Pexp_sequence (copy_expression x0, copy_expression x1) + | From.Parsetree.Pexp_while (x0, x1) -> + To.Parsetree.Pexp_while (copy_expression x0, copy_expression x1) + | From.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> + To.Parsetree.Pexp_for + ( copy_pattern x0, + copy_expression x1, + copy_expression x2, + copy_direction_flag x3, + copy_expression x4 ) + | From.Parsetree.Pexp_constraint (x0, x1) -> + To.Parsetree.Pexp_constraint (copy_expression x0, copy_core_type x1) + | From.Parsetree.Pexp_coerce (x0, x1, x2) -> + To.Parsetree.Pexp_coerce + (copy_expression x0, copy_option copy_core_type x1, copy_core_type x2) + | From.Parsetree.Pexp_send (x0, x1) -> + To.Parsetree.Pexp_send (copy_expression x0, copy_loc copy_label x1) + | From.Parsetree.Pexp_new x0 -> + To.Parsetree.Pexp_new (copy_loc copy_longident x0) + | From.Parsetree.Pexp_setinstvar (x0, x1) -> + To.Parsetree.Pexp_setinstvar (copy_loc copy_label x0, copy_expression x1) + | From.Parsetree.Pexp_override x0 -> + To.Parsetree.Pexp_override + (List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_label x0, copy_expression x1)) + x0) + | From.Parsetree.Pexp_letmodule (x0, x1, x2) -> + To.Parsetree.Pexp_letmodule + (copy_loc (fun x -> x) x0, copy_module_expr x1, copy_expression x2) + | From.Parsetree.Pexp_letexception (x0, x1) -> + To.Parsetree.Pexp_letexception + (copy_extension_constructor x0, copy_expression x1) + | From.Parsetree.Pexp_assert x0 -> + To.Parsetree.Pexp_assert (copy_expression x0) + | From.Parsetree.Pexp_lazy x0 -> To.Parsetree.Pexp_lazy (copy_expression x0) + | From.Parsetree.Pexp_poly (x0, x1) -> + To.Parsetree.Pexp_poly (copy_expression x0, copy_option copy_core_type x1) + | From.Parsetree.Pexp_object x0 -> + To.Parsetree.Pexp_object (copy_class_structure x0) + | From.Parsetree.Pexp_newtype (x0, x1) -> + To.Parsetree.Pexp_newtype (copy_loc (fun x -> x) x0, copy_expression x1) + | From.Parsetree.Pexp_pack x0 -> To.Parsetree.Pexp_pack (copy_module_expr x0) + | From.Parsetree.Pexp_open (x0, x1, x2) -> + To.Parsetree.Pexp_open + ( { + To.Parsetree.popen_expr = + { + To.Parsetree.pmod_desc = + To.Parsetree.Pmod_ident (copy_loc copy_longident x1); + To.Parsetree.pmod_loc = x1.Location.loc; + To.Parsetree.pmod_attributes = []; + }; + To.Parsetree.popen_override = copy_override_flag x0; + To.Parsetree.popen_loc = x1.Location.loc; + To.Parsetree.popen_attributes = []; + }, + copy_expression x2 ) + | From.Parsetree.Pexp_extension x0 -> + To.Parsetree.Pexp_extension (copy_extension x0) + | From.Parsetree.Pexp_unreachable -> To.Parsetree.Pexp_unreachable + +and copy_direction_flag : + From.Asttypes.direction_flag -> To.Asttypes.direction_flag = function + | From.Asttypes.Upto -> To.Asttypes.Upto + | From.Asttypes.Downto -> To.Asttypes.Downto + +and copy_case : From.Parsetree.case -> To.Parsetree.case = + fun { From.Parsetree.pc_lhs; From.Parsetree.pc_guard; From.Parsetree.pc_rhs } -> + { + To.Parsetree.pc_lhs = copy_pattern pc_lhs; + To.Parsetree.pc_guard = copy_option copy_expression pc_guard; + To.Parsetree.pc_rhs = copy_expression pc_rhs; + } + +and copy_value_binding : + From.Parsetree.value_binding -> To.Parsetree.value_binding = + fun { + From.Parsetree.pvb_pat; + From.Parsetree.pvb_expr; + From.Parsetree.pvb_attributes; + From.Parsetree.pvb_loc; + } -> + { + To.Parsetree.pvb_pat = copy_pattern pvb_pat; + To.Parsetree.pvb_expr = copy_expression pvb_expr; + To.Parsetree.pvb_attributes = copy_attributes pvb_attributes; + To.Parsetree.pvb_loc = copy_location pvb_loc; + } + +and copy_pattern : From.Parsetree.pattern -> To.Parsetree.pattern = + fun { + From.Parsetree.ppat_desc; + From.Parsetree.ppat_loc; + From.Parsetree.ppat_attributes; + } -> + { + To.Parsetree.ppat_desc = copy_pattern_desc ppat_desc; + To.Parsetree.ppat_loc = copy_location ppat_loc; + To.Parsetree.ppat_loc_stack = []; + To.Parsetree.ppat_attributes = copy_attributes ppat_attributes; + } + +and copy_pattern_desc : From.Parsetree.pattern_desc -> To.Parsetree.pattern_desc + = function + | From.Parsetree.Ppat_any -> To.Parsetree.Ppat_any + | From.Parsetree.Ppat_var x0 -> + To.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) + | From.Parsetree.Ppat_alias (x0, x1) -> + To.Parsetree.Ppat_alias (copy_pattern x0, copy_loc (fun x -> x) x1) + | From.Parsetree.Ppat_constant x0 -> + To.Parsetree.Ppat_constant (copy_constant x0) + | From.Parsetree.Ppat_interval (x0, x1) -> + To.Parsetree.Ppat_interval (copy_constant x0, copy_constant x1) + | From.Parsetree.Ppat_tuple x0 -> + To.Parsetree.Ppat_tuple (List.map copy_pattern x0) + | From.Parsetree.Ppat_construct (x0, x1) -> + To.Parsetree.Ppat_construct + (copy_loc copy_longident x0, copy_option copy_pattern x1) + | From.Parsetree.Ppat_variant (x0, x1) -> + To.Parsetree.Ppat_variant (copy_label x0, copy_option copy_pattern x1) + | From.Parsetree.Ppat_record (x0, x1) -> + To.Parsetree.Ppat_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_pattern x1)) + x0, + copy_closed_flag x1 ) + | From.Parsetree.Ppat_array x0 -> + To.Parsetree.Ppat_array (List.map copy_pattern x0) + | From.Parsetree.Ppat_or (x0, x1) -> + To.Parsetree.Ppat_or (copy_pattern x0, copy_pattern x1) + | From.Parsetree.Ppat_constraint (x0, x1) -> + To.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1) + | From.Parsetree.Ppat_type x0 -> + To.Parsetree.Ppat_type (copy_loc copy_longident x0) + | From.Parsetree.Ppat_lazy x0 -> To.Parsetree.Ppat_lazy (copy_pattern x0) + | From.Parsetree.Ppat_unpack x0 -> + To.Parsetree.Ppat_unpack (copy_loc (fun x -> x) x0) + | From.Parsetree.Ppat_exception x0 -> + To.Parsetree.Ppat_exception (copy_pattern x0) + | From.Parsetree.Ppat_extension x0 -> + To.Parsetree.Ppat_extension (copy_extension x0) + | From.Parsetree.Ppat_open (x0, x1) -> + To.Parsetree.Ppat_open (copy_loc copy_longident x0, copy_pattern x1) + +and copy_core_type : From.Parsetree.core_type -> To.Parsetree.core_type = + fun { + From.Parsetree.ptyp_desc; + From.Parsetree.ptyp_loc; + From.Parsetree.ptyp_attributes; + } -> + { + To.Parsetree.ptyp_desc = copy_core_type_desc ptyp_desc; + To.Parsetree.ptyp_loc = copy_location ptyp_loc; + To.Parsetree.ptyp_loc_stack = []; + To.Parsetree.ptyp_attributes = copy_attributes ptyp_attributes; + } + +and copy_core_type_desc : + From.Parsetree.core_type_desc -> To.Parsetree.core_type_desc = function + | From.Parsetree.Ptyp_any -> To.Parsetree.Ptyp_any + | From.Parsetree.Ptyp_var x0 -> To.Parsetree.Ptyp_var x0 + | From.Parsetree.Ptyp_arrow (x0, x1, x2) -> + To.Parsetree.Ptyp_arrow + (copy_arg_label x0, copy_core_type x1, copy_core_type x2) + | From.Parsetree.Ptyp_tuple x0 -> + To.Parsetree.Ptyp_tuple (List.map copy_core_type x0) + | From.Parsetree.Ptyp_constr (x0, x1) -> + To.Parsetree.Ptyp_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Ptyp_object (x0, x1) -> + To.Parsetree.Ptyp_object + (List.map copy_object_field x0, copy_closed_flag x1) + | From.Parsetree.Ptyp_class (x0, x1) -> + To.Parsetree.Ptyp_class + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Ptyp_alias (x0, x1) -> + To.Parsetree.Ptyp_alias (copy_core_type x0, x1) + | From.Parsetree.Ptyp_variant (x0, x1, x2) -> + To.Parsetree.Ptyp_variant + ( List.map copy_row_field x0, + copy_closed_flag x1, + copy_option (fun x -> List.map copy_label x) x2 ) + | From.Parsetree.Ptyp_poly (x0, x1) -> + To.Parsetree.Ptyp_poly + (List.map (fun x -> copy_loc (fun x -> x) x) x0, copy_core_type x1) + | From.Parsetree.Ptyp_package x0 -> + To.Parsetree.Ptyp_package (copy_package_type x0) + | From.Parsetree.Ptyp_extension x0 -> + To.Parsetree.Ptyp_extension (copy_extension x0) + +and copy_package_type : From.Parsetree.package_type -> To.Parsetree.package_type + = + fun x -> + let x0, x1 = x in + ( copy_loc copy_longident x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_core_type x1)) + x1 ) + +and copy_row_field : From.Parsetree.row_field -> To.Parsetree.row_field = + function + | From.Parsetree.Rtag (x0, x1, x2, x3) -> + { + To.Parsetree.prf_desc = + To.Parsetree.Rtag + (copy_loc copy_label x0, copy_bool x2, List.map copy_core_type x3); + To.Parsetree.prf_loc = x0.Location.loc; + To.Parsetree.prf_attributes = copy_attributes x1; + } + | From.Parsetree.Rinherit x0 -> + { + To.Parsetree.prf_desc = To.Parsetree.Rinherit (copy_core_type x0); + To.Parsetree.prf_loc = x0.From.Parsetree.ptyp_loc; + To.Parsetree.prf_attributes = []; + } + +and copy_object_field : From.Parsetree.object_field -> To.Parsetree.object_field + = function + | From.Parsetree.Otag (x0, x1, x2) -> + { + To.Parsetree.pof_desc = + To.Parsetree.Otag (copy_loc copy_label x0, copy_core_type x2); + To.Parsetree.pof_loc = x0.Location.loc; + To.Parsetree.pof_attributes = copy_attributes x1; + } + | From.Parsetree.Oinherit x0 -> + { + To.Parsetree.pof_desc = To.Parsetree.Oinherit (copy_core_type x0); + To.Parsetree.pof_loc = x0.From.Parsetree.ptyp_loc; + To.Parsetree.pof_attributes = []; + } + +and copy_attributes : From.Parsetree.attributes -> To.Parsetree.attributes = + fun x -> List.map copy_attribute x + +and copy_attribute : From.Parsetree.attribute -> To.Parsetree.attribute = + fun x -> + let x0, x1 = x in + { + To.Parsetree.attr_name = copy_loc (fun x -> x) x0; + To.Parsetree.attr_payload = copy_payload x1; + To.Parsetree.attr_loc = x0.Location.loc; + } + +and copy_payload : From.Parsetree.payload -> To.Parsetree.payload = function + | From.Parsetree.PStr x0 -> To.Parsetree.PStr (copy_structure x0) + | From.Parsetree.PSig x0 -> To.Parsetree.PSig (copy_signature x0) + | From.Parsetree.PTyp x0 -> To.Parsetree.PTyp (copy_core_type x0) + | From.Parsetree.PPat (x0, x1) -> + To.Parsetree.PPat (copy_pattern x0, copy_option copy_expression x1) + +and copy_structure : From.Parsetree.structure -> To.Parsetree.structure = + fun x -> List.map copy_structure_item x + +and copy_structure_item : + From.Parsetree.structure_item -> To.Parsetree.structure_item = + fun { From.Parsetree.pstr_desc; From.Parsetree.pstr_loc } -> + { + To.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc; + To.Parsetree.pstr_loc = copy_location pstr_loc; + } + +and copy_structure_item_desc : + From.Parsetree.structure_item_desc -> To.Parsetree.structure_item_desc = + function + | From.Parsetree.Pstr_eval (x0, x1) -> + To.Parsetree.Pstr_eval (copy_expression x0, copy_attributes x1) + | From.Parsetree.Pstr_value (x0, x1) -> + To.Parsetree.Pstr_value (copy_rec_flag x0, List.map copy_value_binding x1) + | From.Parsetree.Pstr_primitive x0 -> + To.Parsetree.Pstr_primitive (copy_value_description x0) + | From.Parsetree.Pstr_type (x0, x1) -> + To.Parsetree.Pstr_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | From.Parsetree.Pstr_typext x0 -> + To.Parsetree.Pstr_typext (copy_type_extension x0) + | From.Parsetree.Pstr_exception x0 -> + let atat, at = + List.partition + (function + | { Location.txt = "ocaml.deprecated" | "deprecated"; _ }, _ -> + false + | _ -> true) + x0.pext_attributes + in + let x0 = { x0 with pext_attributes = at } in + To.Parsetree.Pstr_exception + { + To.Parsetree.ptyexn_constructor = copy_extension_constructor x0; + To.Parsetree.ptyexn_loc = x0.From.Parsetree.pext_loc; + To.Parsetree.ptyexn_attributes = copy_attributes atat; + } + | From.Parsetree.Pstr_module x0 -> + To.Parsetree.Pstr_module (copy_module_binding x0) + | From.Parsetree.Pstr_recmodule x0 -> + To.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) + | From.Parsetree.Pstr_modtype x0 -> + To.Parsetree.Pstr_modtype (copy_module_type_declaration x0) + | From.Parsetree.Pstr_open + { + From.Parsetree.popen_lid; + From.Parsetree.popen_override; + From.Parsetree.popen_loc; + From.Parsetree.popen_attributes; + } -> + To.Parsetree.Pstr_open + { + To.Parsetree.popen_expr = + { + To.Parsetree.pmod_desc = + To.Parsetree.Pmod_ident (copy_loc copy_longident popen_lid); + To.Parsetree.pmod_loc = popen_loc; + To.Parsetree.pmod_attributes = []; + }; + To.Parsetree.popen_override = copy_override_flag popen_override; + To.Parsetree.popen_loc = copy_location popen_loc; + To.Parsetree.popen_attributes = copy_attributes popen_attributes; + } + | From.Parsetree.Pstr_class x0 -> + To.Parsetree.Pstr_class (List.map copy_class_declaration x0) + | From.Parsetree.Pstr_class_type x0 -> + To.Parsetree.Pstr_class_type (List.map copy_class_type_declaration x0) + | From.Parsetree.Pstr_include x0 -> + To.Parsetree.Pstr_include (copy_include_declaration x0) + | From.Parsetree.Pstr_attribute x0 -> + To.Parsetree.Pstr_attribute (copy_attribute x0) + | From.Parsetree.Pstr_extension (x0, x1) -> + To.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1) + +and copy_include_declaration : + From.Parsetree.include_declaration -> To.Parsetree.include_declaration = + fun x -> copy_include_infos copy_module_expr x + +and copy_class_declaration : + From.Parsetree.class_declaration -> To.Parsetree.class_declaration = + fun x -> copy_class_infos copy_class_expr x + +and copy_class_expr : From.Parsetree.class_expr -> To.Parsetree.class_expr = + fun { + From.Parsetree.pcl_desc; + From.Parsetree.pcl_loc; + From.Parsetree.pcl_attributes; + } -> + { + To.Parsetree.pcl_desc = copy_class_expr_desc pcl_desc; + To.Parsetree.pcl_loc = copy_location pcl_loc; + To.Parsetree.pcl_attributes = copy_attributes pcl_attributes; + } + +and copy_class_expr_desc : + From.Parsetree.class_expr_desc -> To.Parsetree.class_expr_desc = function + | From.Parsetree.Pcl_constr (x0, x1) -> + To.Parsetree.Pcl_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Pcl_structure x0 -> + To.Parsetree.Pcl_structure (copy_class_structure x0) + | From.Parsetree.Pcl_fun (x0, x1, x2, x3) -> + To.Parsetree.Pcl_fun + ( copy_arg_label x0, + copy_option copy_expression x1, + copy_pattern x2, + copy_class_expr x3 ) + | From.Parsetree.Pcl_apply (x0, x1) -> + To.Parsetree.Pcl_apply + ( copy_class_expr x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | From.Parsetree.Pcl_let (x0, x1, x2) -> + To.Parsetree.Pcl_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_class_expr x2) + | From.Parsetree.Pcl_constraint (x0, x1) -> + To.Parsetree.Pcl_constraint (copy_class_expr x0, copy_class_type x1) + | From.Parsetree.Pcl_extension x0 -> + To.Parsetree.Pcl_extension (copy_extension x0) + | From.Parsetree.Pcl_open (x0, x1, x2) -> + To.Parsetree.Pcl_open + ( { + To.Parsetree.popen_expr = copy_loc copy_longident x1; + To.Parsetree.popen_override = copy_override_flag x0; + To.Parsetree.popen_loc = x1.Location.loc; + To.Parsetree.popen_attributes = []; + }, + copy_class_expr x2 ) + +and copy_class_structure : + From.Parsetree.class_structure -> To.Parsetree.class_structure = + fun { From.Parsetree.pcstr_self; From.Parsetree.pcstr_fields } -> + let fields = + List.sort + (fun (a : From.Parsetree.class_field) (b : From.Parsetree.class_field) -> + compare a.pcf_loc.loc_start.pos_cnum b.pcf_loc.loc_start.pos_cnum) + pcstr_fields + in + { + To.Parsetree.pcstr_self = copy_pattern pcstr_self; + To.Parsetree.pcstr_fields = List.map copy_class_field fields; + } + +and copy_class_field : From.Parsetree.class_field -> To.Parsetree.class_field = + fun { + From.Parsetree.pcf_desc; + From.Parsetree.pcf_loc; + From.Parsetree.pcf_attributes; + } -> + { + To.Parsetree.pcf_desc = copy_class_field_desc pcf_desc; + To.Parsetree.pcf_loc = copy_location pcf_loc; + To.Parsetree.pcf_attributes = copy_attributes pcf_attributes; + } + +and copy_class_field_desc : + From.Parsetree.class_field_desc -> To.Parsetree.class_field_desc = function + | From.Parsetree.Pcf_inherit (x0, x1, x2) -> + To.Parsetree.Pcf_inherit + ( copy_override_flag x0, + copy_class_expr x1, + copy_option (fun x -> copy_loc (fun x -> x) x) x2 ) + | From.Parsetree.Pcf_val x0 -> + To.Parsetree.Pcf_val + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_mutable_flag x1, copy_class_field_kind x2)) + | From.Parsetree.Pcf_method x0 -> + To.Parsetree.Pcf_method + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_private_flag x1, copy_class_field_kind x2)) + | From.Parsetree.Pcf_constraint x0 -> + To.Parsetree.Pcf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | From.Parsetree.Pcf_initializer x0 -> + To.Parsetree.Pcf_initializer (copy_expression x0) + | From.Parsetree.Pcf_attribute x0 -> + To.Parsetree.Pcf_attribute (copy_attribute x0) + | From.Parsetree.Pcf_extension x0 -> + To.Parsetree.Pcf_extension (copy_extension x0) + +and copy_class_field_kind : + From.Parsetree.class_field_kind -> To.Parsetree.class_field_kind = function + | From.Parsetree.Cfk_virtual x0 -> + To.Parsetree.Cfk_virtual (copy_core_type x0) + | From.Parsetree.Cfk_concrete (x0, x1) -> + To.Parsetree.Cfk_concrete (copy_override_flag x0, copy_expression x1) + +and copy_module_binding : + From.Parsetree.module_binding -> To.Parsetree.module_binding = + fun { + From.Parsetree.pmb_name; + From.Parsetree.pmb_expr; + From.Parsetree.pmb_attributes; + From.Parsetree.pmb_loc; + } -> + { + To.Parsetree.pmb_name = copy_loc (fun x -> x) pmb_name; + To.Parsetree.pmb_expr = copy_module_expr pmb_expr; + To.Parsetree.pmb_attributes = copy_attributes pmb_attributes; + To.Parsetree.pmb_loc = copy_location pmb_loc; + } + +and copy_module_expr : From.Parsetree.module_expr -> To.Parsetree.module_expr = + fun { + From.Parsetree.pmod_desc; + From.Parsetree.pmod_loc; + From.Parsetree.pmod_attributes; + } -> + { + To.Parsetree.pmod_desc = copy_module_expr_desc pmod_desc; + To.Parsetree.pmod_loc = copy_location pmod_loc; + To.Parsetree.pmod_attributes = copy_attributes pmod_attributes; + } + +and copy_module_expr_desc : + From.Parsetree.module_expr_desc -> To.Parsetree.module_expr_desc = function + | From.Parsetree.Pmod_ident x0 -> + To.Parsetree.Pmod_ident (copy_loc copy_longident x0) + | From.Parsetree.Pmod_structure x0 -> + To.Parsetree.Pmod_structure (copy_structure x0) + | From.Parsetree.Pmod_functor (x0, x1, x2) -> + To.Parsetree.Pmod_functor + ( copy_loc (fun x -> x) x0, + copy_option copy_module_type x1, + copy_module_expr x2 ) + | From.Parsetree.Pmod_apply (x0, x1) -> + To.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) + | From.Parsetree.Pmod_constraint (x0, x1) -> + To.Parsetree.Pmod_constraint (copy_module_expr x0, copy_module_type x1) + | From.Parsetree.Pmod_unpack x0 -> + To.Parsetree.Pmod_unpack (copy_expression x0) + | From.Parsetree.Pmod_extension x0 -> + To.Parsetree.Pmod_extension (copy_extension x0) + +and copy_module_type : From.Parsetree.module_type -> To.Parsetree.module_type = + fun { + From.Parsetree.pmty_desc; + From.Parsetree.pmty_loc; + From.Parsetree.pmty_attributes; + } -> + { + To.Parsetree.pmty_desc = copy_module_type_desc pmty_desc; + To.Parsetree.pmty_loc = copy_location pmty_loc; + To.Parsetree.pmty_attributes = copy_attributes pmty_attributes; + } + +and copy_module_type_desc : + From.Parsetree.module_type_desc -> To.Parsetree.module_type_desc = function + | From.Parsetree.Pmty_ident x0 -> + To.Parsetree.Pmty_ident (copy_loc copy_longident x0) + | From.Parsetree.Pmty_signature x0 -> + To.Parsetree.Pmty_signature (copy_signature x0) + | From.Parsetree.Pmty_functor (x0, x1, x2) -> + To.Parsetree.Pmty_functor + ( copy_loc (fun x -> x) x0, + copy_option copy_module_type x1, + copy_module_type x2 ) + | From.Parsetree.Pmty_with (x0, x1) -> + To.Parsetree.Pmty_with + (copy_module_type x0, List.map copy_with_constraint x1) + | From.Parsetree.Pmty_typeof x0 -> + To.Parsetree.Pmty_typeof (copy_module_expr x0) + | From.Parsetree.Pmty_extension x0 -> + To.Parsetree.Pmty_extension (copy_extension x0) + | From.Parsetree.Pmty_alias x0 -> + To.Parsetree.Pmty_alias (copy_loc copy_longident x0) + +and copy_with_constraint : + From.Parsetree.with_constraint -> To.Parsetree.with_constraint = function + | From.Parsetree.Pwith_type (x0, x1) -> + To.Parsetree.Pwith_type + (copy_loc copy_longident x0, copy_type_declaration x1) + | From.Parsetree.Pwith_module (x0, x1) -> + To.Parsetree.Pwith_module + (copy_loc copy_longident x0, copy_loc copy_longident x1) + | From.Parsetree.Pwith_typesubst (x0, x1) -> + To.Parsetree.Pwith_typesubst + (copy_loc copy_longident x0, copy_type_declaration x1) + | From.Parsetree.Pwith_modsubst (x0, x1) -> + To.Parsetree.Pwith_modsubst + (copy_loc copy_longident x0, copy_loc copy_longident x1) + +and copy_signature : From.Parsetree.signature -> To.Parsetree.signature = + fun x -> List.map copy_signature_item x + +and copy_signature_item : + From.Parsetree.signature_item -> To.Parsetree.signature_item = + fun { From.Parsetree.psig_desc; From.Parsetree.psig_loc } -> + { + To.Parsetree.psig_desc = copy_signature_item_desc psig_desc; + To.Parsetree.psig_loc = copy_location psig_loc; + } + +and copy_signature_item_desc : + From.Parsetree.signature_item_desc -> To.Parsetree.signature_item_desc = + function + | From.Parsetree.Psig_value x0 -> + To.Parsetree.Psig_value (copy_value_description x0) + | From.Parsetree.Psig_type (x0, x1) -> + To.Parsetree.Psig_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | From.Parsetree.Psig_typext x0 -> + To.Parsetree.Psig_typext (copy_type_extension x0) + | From.Parsetree.Psig_exception x0 -> + let atat, at = + List.partition + (function + | { Location.txt = "ocaml.deprecated" | "deprecated"; _ }, _ -> + false + | _ -> true) + x0.pext_attributes + in + let x0 = { x0 with pext_attributes = at } in + + To.Parsetree.Psig_exception + { + To.Parsetree.ptyexn_constructor = copy_extension_constructor x0; + To.Parsetree.ptyexn_loc = x0.From.Parsetree.pext_loc; + To.Parsetree.ptyexn_attributes = copy_attributes atat; + } + | From.Parsetree.Psig_module x0 -> + To.Parsetree.Psig_module (copy_module_declaration x0) + | From.Parsetree.Psig_recmodule x0 -> + To.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) + | From.Parsetree.Psig_modtype x0 -> + To.Parsetree.Psig_modtype (copy_module_type_declaration x0) + | From.Parsetree.Psig_open x0 -> + To.Parsetree.Psig_open (copy_open_description x0) + | From.Parsetree.Psig_include x0 -> + To.Parsetree.Psig_include (copy_include_description x0) + | From.Parsetree.Psig_class x0 -> + To.Parsetree.Psig_class (List.map copy_class_description x0) + | From.Parsetree.Psig_class_type x0 -> + To.Parsetree.Psig_class_type (List.map copy_class_type_declaration x0) + | From.Parsetree.Psig_attribute x0 -> + To.Parsetree.Psig_attribute (copy_attribute x0) + | From.Parsetree.Psig_extension (x0, x1) -> + To.Parsetree.Psig_extension (copy_extension x0, copy_attributes x1) + +and copy_class_type_declaration : + From.Parsetree.class_type_declaration -> To.Parsetree.class_type_declaration + = + fun x -> copy_class_infos copy_class_type x + +and copy_class_description : + From.Parsetree.class_description -> To.Parsetree.class_description = + fun x -> copy_class_infos copy_class_type x + +and copy_class_type : From.Parsetree.class_type -> To.Parsetree.class_type = + fun { + From.Parsetree.pcty_desc; + From.Parsetree.pcty_loc; + From.Parsetree.pcty_attributes; + } -> + { + To.Parsetree.pcty_desc = copy_class_type_desc pcty_desc; + To.Parsetree.pcty_loc = copy_location pcty_loc; + To.Parsetree.pcty_attributes = copy_attributes pcty_attributes; + } + +and copy_class_type_desc : + From.Parsetree.class_type_desc -> To.Parsetree.class_type_desc = function + | From.Parsetree.Pcty_constr (x0, x1) -> + To.Parsetree.Pcty_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Pcty_signature x0 -> + To.Parsetree.Pcty_signature (copy_class_signature x0) + | From.Parsetree.Pcty_arrow (x0, x1, x2) -> + To.Parsetree.Pcty_arrow + (copy_arg_label x0, copy_core_type x1, copy_class_type x2) + | From.Parsetree.Pcty_extension x0 -> + To.Parsetree.Pcty_extension (copy_extension x0) + | From.Parsetree.Pcty_open (x0, x1, x2) -> + To.Parsetree.Pcty_open + ( { + To.Parsetree.popen_expr = copy_loc copy_longident x1; + To.Parsetree.popen_override = copy_override_flag x0; + To.Parsetree.popen_loc = x1.Location.loc; + To.Parsetree.popen_attributes = []; + }, + copy_class_type x2 ) + +and copy_class_signature : + From.Parsetree.class_signature -> To.Parsetree.class_signature = + fun { From.Parsetree.pcsig_self; From.Parsetree.pcsig_fields } -> + let fields = + List.sort + (fun (a : From.Parsetree.class_type_field) + (b : From.Parsetree.class_type_field) -> + compare a.pctf_loc.loc_start.pos_cnum b.pctf_loc.loc_start.pos_cnum) + pcsig_fields + in + + { + To.Parsetree.pcsig_self = copy_core_type pcsig_self; + To.Parsetree.pcsig_fields = List.map copy_class_type_field fields; + } + +and copy_class_type_field : + From.Parsetree.class_type_field -> To.Parsetree.class_type_field = + fun { + From.Parsetree.pctf_desc; + From.Parsetree.pctf_loc; + From.Parsetree.pctf_attributes; + } -> + { + To.Parsetree.pctf_desc = copy_class_type_field_desc pctf_desc; + To.Parsetree.pctf_loc = copy_location pctf_loc; + To.Parsetree.pctf_attributes = copy_attributes pctf_attributes; + } + +and copy_class_type_field_desc : + From.Parsetree.class_type_field_desc -> To.Parsetree.class_type_field_desc = + function + | From.Parsetree.Pctf_inherit x0 -> + To.Parsetree.Pctf_inherit (copy_class_type x0) + | From.Parsetree.Pctf_val x0 -> + To.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 )) + | From.Parsetree.Pctf_method x0 -> + To.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 )) + | From.Parsetree.Pctf_constraint x0 -> + To.Parsetree.Pctf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | From.Parsetree.Pctf_attribute x0 -> + To.Parsetree.Pctf_attribute (copy_attribute x0) + | From.Parsetree.Pctf_extension x0 -> + To.Parsetree.Pctf_extension (copy_extension x0) + +and copy_extension : From.Parsetree.extension -> To.Parsetree.extension = + fun x -> + let x0, x1 = x in + let x1 = + match x0.txt with + | "ocaml.error" | "error" -> ( + match x1 with + | PStr (hd :: _ :: tl) -> From.Parsetree.PStr (hd :: tl) + | _ -> x1) + | _ -> x1 + in + (copy_loc (fun x -> x) x0, copy_payload x1) + +and copy_class_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 From.Parsetree.class_infos -> + 'g0 To.Parsetree.class_infos = + fun f0 + { + From.Parsetree.pci_virt; + From.Parsetree.pci_params; + From.Parsetree.pci_name; + From.Parsetree.pci_expr; + From.Parsetree.pci_loc; + From.Parsetree.pci_attributes; + } -> + { + To.Parsetree.pci_virt = copy_virtual_flag pci_virt; + To.Parsetree.pci_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + pci_params; + To.Parsetree.pci_name = copy_loc (fun x -> x) pci_name; + To.Parsetree.pci_expr = f0 pci_expr; + To.Parsetree.pci_loc = copy_location pci_loc; + To.Parsetree.pci_attributes = copy_attributes pci_attributes; + } + +and copy_virtual_flag : From.Asttypes.virtual_flag -> To.Asttypes.virtual_flag = + function + | From.Asttypes.Virtual -> To.Asttypes.Virtual + | From.Asttypes.Concrete -> To.Asttypes.Concrete + +and copy_include_description : + From.Parsetree.include_description -> To.Parsetree.include_description = + fun x -> copy_include_infos copy_module_type x + +and copy_include_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 From.Parsetree.include_infos -> + 'g0 To.Parsetree.include_infos = + fun f0 + { + From.Parsetree.pincl_mod; + From.Parsetree.pincl_loc; + From.Parsetree.pincl_attributes; + } -> + { + To.Parsetree.pincl_mod = f0 pincl_mod; + To.Parsetree.pincl_loc = copy_location pincl_loc; + To.Parsetree.pincl_attributes = copy_attributes pincl_attributes; + } + +and copy_open_description : + From.Parsetree.open_description -> To.Parsetree.open_description = + fun { + From.Parsetree.popen_lid; + From.Parsetree.popen_override; + From.Parsetree.popen_loc; + From.Parsetree.popen_attributes; + } -> + { + To.Parsetree.popen_expr = copy_loc copy_longident popen_lid; + To.Parsetree.popen_override = copy_override_flag popen_override; + To.Parsetree.popen_loc = copy_location popen_loc; + To.Parsetree.popen_attributes = copy_attributes popen_attributes; + } + +and copy_override_flag : + From.Asttypes.override_flag -> To.Asttypes.override_flag = function + | From.Asttypes.Override -> To.Asttypes.Override + | From.Asttypes.Fresh -> To.Asttypes.Fresh + +and copy_module_type_declaration : + From.Parsetree.module_type_declaration -> + To.Parsetree.module_type_declaration = + fun { + From.Parsetree.pmtd_name; + From.Parsetree.pmtd_type; + From.Parsetree.pmtd_attributes; + From.Parsetree.pmtd_loc; + } -> + { + To.Parsetree.pmtd_name = copy_loc (fun x -> x) pmtd_name; + To.Parsetree.pmtd_type = copy_option copy_module_type pmtd_type; + To.Parsetree.pmtd_attributes = copy_attributes pmtd_attributes; + To.Parsetree.pmtd_loc = copy_location pmtd_loc; + } + +and copy_module_declaration : + From.Parsetree.module_declaration -> To.Parsetree.module_declaration = + fun { + From.Parsetree.pmd_name; + From.Parsetree.pmd_type; + From.Parsetree.pmd_attributes; + From.Parsetree.pmd_loc; + } -> + { + To.Parsetree.pmd_name = copy_loc (fun x -> x) pmd_name; + To.Parsetree.pmd_type = copy_module_type pmd_type; + To.Parsetree.pmd_attributes = copy_attributes pmd_attributes; + To.Parsetree.pmd_loc = copy_location pmd_loc; + } + +and copy_type_extension : + From.Parsetree.type_extension -> To.Parsetree.type_extension = + fun { + From.Parsetree.ptyext_path; + From.Parsetree.ptyext_params; + From.Parsetree.ptyext_constructors; + From.Parsetree.ptyext_private; + From.Parsetree.ptyext_attributes; + } -> + { + To.Parsetree.ptyext_path = copy_loc copy_longident ptyext_path; + To.Parsetree.ptyext_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptyext_params; + To.Parsetree.ptyext_constructors = + List.map copy_extension_constructor ptyext_constructors; + To.Parsetree.ptyext_private = copy_private_flag ptyext_private; + To.Parsetree.ptyext_loc = ptyext_path.Location.loc; + To.Parsetree.ptyext_attributes = copy_attributes ptyext_attributes; + } + +and copy_extension_constructor : + From.Parsetree.extension_constructor -> To.Parsetree.extension_constructor = + fun { + From.Parsetree.pext_name; + From.Parsetree.pext_kind; + From.Parsetree.pext_loc; + From.Parsetree.pext_attributes; + } -> + { + To.Parsetree.pext_name = copy_loc (fun x -> x) pext_name; + To.Parsetree.pext_kind = copy_extension_constructor_kind pext_kind; + To.Parsetree.pext_loc = copy_location pext_loc; + To.Parsetree.pext_attributes = copy_attributes pext_attributes; + } + +and copy_extension_constructor_kind : + From.Parsetree.extension_constructor_kind -> + To.Parsetree.extension_constructor_kind = function + | From.Parsetree.Pext_decl (x0, x1) -> + To.Parsetree.Pext_decl + (copy_constructor_arguments x0, copy_option copy_core_type x1) + | From.Parsetree.Pext_rebind x0 -> + To.Parsetree.Pext_rebind (copy_loc copy_longident x0) + +and copy_type_declaration : + From.Parsetree.type_declaration -> To.Parsetree.type_declaration = + fun { + From.Parsetree.ptype_name; + From.Parsetree.ptype_params; + From.Parsetree.ptype_cstrs; + From.Parsetree.ptype_kind; + From.Parsetree.ptype_private; + From.Parsetree.ptype_manifest; + From.Parsetree.ptype_attributes; + From.Parsetree.ptype_loc; + } -> + { + To.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name; + To.Parsetree.ptype_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptype_params; + To.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; + To.Parsetree.ptype_kind = copy_type_kind ptype_kind; + To.Parsetree.ptype_private = copy_private_flag ptype_private; + To.Parsetree.ptype_manifest = copy_option copy_core_type ptype_manifest; + To.Parsetree.ptype_attributes = copy_attributes ptype_attributes; + To.Parsetree.ptype_loc = copy_location ptype_loc; + } + +and copy_private_flag : From.Asttypes.private_flag -> To.Asttypes.private_flag = + function + | From.Asttypes.Private -> To.Asttypes.Private + | From.Asttypes.Public -> To.Asttypes.Public + +and copy_type_kind : From.Parsetree.type_kind -> To.Parsetree.type_kind = + function + | From.Parsetree.Ptype_abstract -> To.Parsetree.Ptype_abstract + | From.Parsetree.Ptype_variant x0 -> + To.Parsetree.Ptype_variant (List.map copy_constructor_declaration x0) + | From.Parsetree.Ptype_record x0 -> + To.Parsetree.Ptype_record (List.map copy_label_declaration x0) + | From.Parsetree.Ptype_open -> To.Parsetree.Ptype_open + +and copy_constructor_declaration : + From.Parsetree.constructor_declaration -> + To.Parsetree.constructor_declaration = + fun { + From.Parsetree.pcd_name; + From.Parsetree.pcd_args; + From.Parsetree.pcd_res; + From.Parsetree.pcd_loc; + From.Parsetree.pcd_attributes; + } -> + { + To.Parsetree.pcd_name = copy_loc (fun x -> x) pcd_name; + To.Parsetree.pcd_args = copy_constructor_arguments pcd_args; + To.Parsetree.pcd_res = copy_option copy_core_type pcd_res; + To.Parsetree.pcd_loc = copy_location pcd_loc; + To.Parsetree.pcd_attributes = copy_attributes pcd_attributes; + } + +and copy_constructor_arguments : + From.Parsetree.constructor_arguments -> To.Parsetree.constructor_arguments = + function + | From.Parsetree.Pcstr_tuple x0 -> + To.Parsetree.Pcstr_tuple (List.map copy_core_type x0) + | From.Parsetree.Pcstr_record x0 -> + To.Parsetree.Pcstr_record (List.map copy_label_declaration x0) + +and copy_label_declaration : + From.Parsetree.label_declaration -> To.Parsetree.label_declaration = + fun { + From.Parsetree.pld_name; + From.Parsetree.pld_mutable; + From.Parsetree.pld_type; + From.Parsetree.pld_loc; + From.Parsetree.pld_attributes; + } -> + { + To.Parsetree.pld_name = copy_loc (fun x -> x) pld_name; + To.Parsetree.pld_mutable = copy_mutable_flag pld_mutable; + To.Parsetree.pld_type = copy_core_type pld_type; + To.Parsetree.pld_loc = copy_location pld_loc; + To.Parsetree.pld_attributes = copy_attributes pld_attributes; + } + +and copy_mutable_flag : From.Asttypes.mutable_flag -> To.Asttypes.mutable_flag = + function + | From.Asttypes.Immutable -> To.Asttypes.Immutable + | From.Asttypes.Mutable -> To.Asttypes.Mutable + +and copy_variance : From.Asttypes.variance -> To.Asttypes.variance = function + | From.Asttypes.Covariant -> To.Asttypes.Covariant + | From.Asttypes.Contravariant -> To.Asttypes.Contravariant + | From.Asttypes.Invariant -> To.Asttypes.Invariant + +and copy_value_description : + From.Parsetree.value_description -> To.Parsetree.value_description = + fun { + From.Parsetree.pval_name; + From.Parsetree.pval_type; + From.Parsetree.pval_prim; + From.Parsetree.pval_attributes; + From.Parsetree.pval_loc; + } -> + { + To.Parsetree.pval_name = copy_loc (fun x -> x) pval_name; + To.Parsetree.pval_type = copy_core_type pval_type; + To.Parsetree.pval_prim = List.map (fun x -> x) pval_prim; + To.Parsetree.pval_attributes = copy_attributes pval_attributes; + To.Parsetree.pval_loc = copy_location pval_loc; + } + +and copy_arg_label : From.Asttypes.arg_label -> To.Asttypes.arg_label = function + | From.Asttypes.Nolabel -> To.Asttypes.Nolabel + | From.Asttypes.Labelled x0 -> To.Asttypes.Labelled x0 + | From.Asttypes.Optional x0 -> To.Asttypes.Optional x0 + +and copy_closed_flag : From.Asttypes.closed_flag -> To.Asttypes.closed_flag = + function + | From.Asttypes.Closed -> To.Asttypes.Closed + | From.Asttypes.Open -> To.Asttypes.Open + +and copy_label : From.Asttypes.label -> To.Asttypes.label = fun x -> x + +and copy_rec_flag : From.Asttypes.rec_flag -> To.Asttypes.rec_flag = function + | From.Asttypes.Nonrecursive -> To.Asttypes.Nonrecursive + | From.Asttypes.Recursive -> To.Asttypes.Recursive + +and copy_constant : From.Parsetree.constant -> To.Parsetree.constant = function + | From.Parsetree.Pconst_integer (x0, x1) -> + To.Parsetree.Pconst_integer (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pconst_char x0 -> To.Parsetree.Pconst_char x0 + | From.Parsetree.Pconst_string (x0, x1) -> + To.Parsetree.Pconst_string (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pconst_float (x0, x1) -> + To.Parsetree.Pconst_float (x0, copy_option (fun x -> x) x1) + +and copy_option : 'f0 'g0. ('f0 -> 'g0) -> 'f0 option -> 'g0 option = + fun f0 -> function None -> None | Some x0 -> Some (f0 x0) + +and copy_longident : Longident.t -> Longident.t = fun x -> x + +and copy_loc : + 'f0 'g0. ('f0 -> 'g0) -> 'f0 From.Asttypes.loc -> 'g0 To.Asttypes.loc = + fun f0 { From.Asttypes.txt; From.Asttypes.loc } -> + { To.Asttypes.txt = f0 txt; To.Asttypes.loc = copy_location loc } + +and copy_location : Location.t -> Location.t = fun x -> x + +and copy_bool : bool -> bool = function false -> false | true -> true + +let copy_cases x = List.map copy_case x + +let copy_pat = copy_pattern + +let copy_expr = copy_expression + +let copy_typ = copy_core_type diff -Nru ppxlib-0.15.0/astlib/migrate_408_407.ml ppxlib-0.24.0/astlib/migrate_408_407.ml --- ppxlib-0.15.0/astlib/migrate_408_407.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/migrate_408_407.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1113 @@ +module From = Ast_408 +module To = Ast_407 + +let migration_error loc missing_feature = + Location.raise_errorf ~loc + "migration error: %s is not supported before OCaml 4.08" missing_feature + +let rec copy_toplevel_phrase : + From.Parsetree.toplevel_phrase -> To.Parsetree.toplevel_phrase = function + | From.Parsetree.Ptop_def x0 -> To.Parsetree.Ptop_def (copy_structure x0) + | From.Parsetree.Ptop_dir + { + From.Parsetree.pdir_name; + From.Parsetree.pdir_arg; + From.Parsetree.pdir_loc = _; + } -> + To.Parsetree.Ptop_dir + ( pdir_name.Location.txt, + match pdir_arg with + | None -> To.Parsetree.Pdir_none + | Some arg -> copy_directive_argument arg ) + +and copy_directive_argument : + From.Parsetree.directive_argument -> To.Parsetree.directive_argument = + fun { From.Parsetree.pdira_desc; From.Parsetree.pdira_loc = _pdira_loc } -> + copy_directive_argument_desc pdira_desc + +and copy_directive_argument_desc : + From.Parsetree.directive_argument_desc -> To.Parsetree.directive_argument = + function + | From.Parsetree.Pdir_string x0 -> To.Parsetree.Pdir_string x0 + | From.Parsetree.Pdir_int (x0, x1) -> + To.Parsetree.Pdir_int (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pdir_ident x0 -> To.Parsetree.Pdir_ident (copy_longident x0) + | From.Parsetree.Pdir_bool x0 -> To.Parsetree.Pdir_bool (copy_bool x0) + +and copy_expression : From.Parsetree.expression -> To.Parsetree.expression = + fun { + From.Parsetree.pexp_desc; + From.Parsetree.pexp_loc; + From.Parsetree.pexp_loc_stack = _; + From.Parsetree.pexp_attributes; + } -> + { + To.Parsetree.pexp_desc = copy_expression_desc pexp_desc; + To.Parsetree.pexp_loc = copy_location pexp_loc; + To.Parsetree.pexp_attributes = copy_attributes pexp_attributes; + } + +and copy_expression_desc : + From.Parsetree.expression_desc -> To.Parsetree.expression_desc = function + | From.Parsetree.Pexp_ident x0 -> + To.Parsetree.Pexp_ident (copy_loc copy_longident x0) + | From.Parsetree.Pexp_constant x0 -> + To.Parsetree.Pexp_constant (copy_constant x0) + | From.Parsetree.Pexp_let (x0, x1, x2) -> + To.Parsetree.Pexp_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_expression x2) + | From.Parsetree.Pexp_function x0 -> + To.Parsetree.Pexp_function (List.map copy_case x0) + | From.Parsetree.Pexp_fun (x0, x1, x2, x3) -> + To.Parsetree.Pexp_fun + ( copy_arg_label x0, + copy_option copy_expression x1, + copy_pattern x2, + copy_expression x3 ) + | From.Parsetree.Pexp_apply (x0, x1) -> + To.Parsetree.Pexp_apply + ( copy_expression x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | From.Parsetree.Pexp_match (x0, x1) -> + To.Parsetree.Pexp_match (copy_expression x0, List.map copy_case x1) + | From.Parsetree.Pexp_try (x0, x1) -> + To.Parsetree.Pexp_try (copy_expression x0, List.map copy_case x1) + | From.Parsetree.Pexp_tuple x0 -> + To.Parsetree.Pexp_tuple (List.map copy_expression x0) + | From.Parsetree.Pexp_construct (x0, x1) -> + To.Parsetree.Pexp_construct + (copy_loc copy_longident x0, copy_option copy_expression x1) + | From.Parsetree.Pexp_variant (x0, x1) -> + To.Parsetree.Pexp_variant (copy_label x0, copy_option copy_expression x1) + | From.Parsetree.Pexp_record (x0, x1) -> + To.Parsetree.Pexp_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_expression x1)) + x0, + copy_option copy_expression x1 ) + | From.Parsetree.Pexp_field (x0, x1) -> + To.Parsetree.Pexp_field (copy_expression x0, copy_loc copy_longident x1) + | From.Parsetree.Pexp_setfield (x0, x1, x2) -> + To.Parsetree.Pexp_setfield + (copy_expression x0, copy_loc copy_longident x1, copy_expression x2) + | From.Parsetree.Pexp_array x0 -> + To.Parsetree.Pexp_array (List.map copy_expression x0) + | From.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> + To.Parsetree.Pexp_ifthenelse + (copy_expression x0, copy_expression x1, copy_option copy_expression x2) + | From.Parsetree.Pexp_sequence (x0, x1) -> + To.Parsetree.Pexp_sequence (copy_expression x0, copy_expression x1) + | From.Parsetree.Pexp_while (x0, x1) -> + To.Parsetree.Pexp_while (copy_expression x0, copy_expression x1) + | From.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> + To.Parsetree.Pexp_for + ( copy_pattern x0, + copy_expression x1, + copy_expression x2, + copy_direction_flag x3, + copy_expression x4 ) + | From.Parsetree.Pexp_constraint (x0, x1) -> + To.Parsetree.Pexp_constraint (copy_expression x0, copy_core_type x1) + | From.Parsetree.Pexp_coerce (x0, x1, x2) -> + To.Parsetree.Pexp_coerce + (copy_expression x0, copy_option copy_core_type x1, copy_core_type x2) + | From.Parsetree.Pexp_send (x0, x1) -> + To.Parsetree.Pexp_send (copy_expression x0, copy_loc copy_label x1) + | From.Parsetree.Pexp_new x0 -> + To.Parsetree.Pexp_new (copy_loc copy_longident x0) + | From.Parsetree.Pexp_setinstvar (x0, x1) -> + To.Parsetree.Pexp_setinstvar (copy_loc copy_label x0, copy_expression x1) + | From.Parsetree.Pexp_override x0 -> + To.Parsetree.Pexp_override + (List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_label x0, copy_expression x1)) + x0) + | From.Parsetree.Pexp_letmodule (x0, x1, x2) -> + To.Parsetree.Pexp_letmodule + (copy_loc (fun x -> x) x0, copy_module_expr x1, copy_expression x2) + | From.Parsetree.Pexp_letexception (x0, x1) -> + To.Parsetree.Pexp_letexception + (copy_extension_constructor x0, copy_expression x1) + | From.Parsetree.Pexp_assert x0 -> + To.Parsetree.Pexp_assert (copy_expression x0) + | From.Parsetree.Pexp_lazy x0 -> To.Parsetree.Pexp_lazy (copy_expression x0) + | From.Parsetree.Pexp_poly (x0, x1) -> + To.Parsetree.Pexp_poly (copy_expression x0, copy_option copy_core_type x1) + | From.Parsetree.Pexp_object x0 -> + To.Parsetree.Pexp_object (copy_class_structure x0) + | From.Parsetree.Pexp_newtype (x0, x1) -> + To.Parsetree.Pexp_newtype (copy_loc (fun x -> x) x0, copy_expression x1) + | From.Parsetree.Pexp_pack x0 -> To.Parsetree.Pexp_pack (copy_module_expr x0) + | From.Parsetree.Pexp_open (x0, x1) -> ( + match x0.From.Parsetree.popen_expr.From.Parsetree.pmod_desc with + | Pmod_ident lid -> + To.Parsetree.Pexp_open + ( copy_override_flag x0.From.Parsetree.popen_override, + copy_loc copy_longident lid, + copy_expression x1 ) + | Pmod_structure _ | Pmod_functor _ | Pmod_apply _ | Pmod_constraint _ + | Pmod_unpack _ | Pmod_extension _ -> + migration_error x0.From.Parsetree.popen_loc "complex open") + | From.Parsetree.Pexp_letop { let_; ands = _; body = _ } -> + migration_error let_.pbop_op.loc "let operators" + | From.Parsetree.Pexp_extension x0 -> + To.Parsetree.Pexp_extension (copy_extension x0) + | From.Parsetree.Pexp_unreachable -> To.Parsetree.Pexp_unreachable + +and copy_direction_flag : + From.Asttypes.direction_flag -> To.Asttypes.direction_flag = function + | From.Asttypes.Upto -> To.Asttypes.Upto + | From.Asttypes.Downto -> To.Asttypes.Downto + +and copy_case : From.Parsetree.case -> To.Parsetree.case = + fun { From.Parsetree.pc_lhs; From.Parsetree.pc_guard; From.Parsetree.pc_rhs } -> + { + To.Parsetree.pc_lhs = copy_pattern pc_lhs; + To.Parsetree.pc_guard = copy_option copy_expression pc_guard; + To.Parsetree.pc_rhs = copy_expression pc_rhs; + } + +and copy_value_binding : + From.Parsetree.value_binding -> To.Parsetree.value_binding = + fun { + From.Parsetree.pvb_pat; + From.Parsetree.pvb_expr; + From.Parsetree.pvb_attributes; + From.Parsetree.pvb_loc; + } -> + { + To.Parsetree.pvb_pat = copy_pattern pvb_pat; + To.Parsetree.pvb_expr = copy_expression pvb_expr; + To.Parsetree.pvb_attributes = copy_attributes pvb_attributes; + To.Parsetree.pvb_loc = copy_location pvb_loc; + } + +and copy_pattern : From.Parsetree.pattern -> To.Parsetree.pattern = + fun { + From.Parsetree.ppat_desc; + From.Parsetree.ppat_loc; + From.Parsetree.ppat_loc_stack = _; + From.Parsetree.ppat_attributes; + } -> + { + To.Parsetree.ppat_desc = copy_pattern_desc ppat_desc; + To.Parsetree.ppat_loc = copy_location ppat_loc; + To.Parsetree.ppat_attributes = copy_attributes ppat_attributes; + } + +and copy_pattern_desc : From.Parsetree.pattern_desc -> To.Parsetree.pattern_desc + = function + | From.Parsetree.Ppat_any -> To.Parsetree.Ppat_any + | From.Parsetree.Ppat_var x0 -> + To.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) + | From.Parsetree.Ppat_alias (x0, x1) -> + To.Parsetree.Ppat_alias (copy_pattern x0, copy_loc (fun x -> x) x1) + | From.Parsetree.Ppat_constant x0 -> + To.Parsetree.Ppat_constant (copy_constant x0) + | From.Parsetree.Ppat_interval (x0, x1) -> + To.Parsetree.Ppat_interval (copy_constant x0, copy_constant x1) + | From.Parsetree.Ppat_tuple x0 -> + To.Parsetree.Ppat_tuple (List.map copy_pattern x0) + | From.Parsetree.Ppat_construct (x0, x1) -> + To.Parsetree.Ppat_construct + (copy_loc copy_longident x0, copy_option copy_pattern x1) + | From.Parsetree.Ppat_variant (x0, x1) -> + To.Parsetree.Ppat_variant (copy_label x0, copy_option copy_pattern x1) + | From.Parsetree.Ppat_record (x0, x1) -> + To.Parsetree.Ppat_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_pattern x1)) + x0, + copy_closed_flag x1 ) + | From.Parsetree.Ppat_array x0 -> + To.Parsetree.Ppat_array (List.map copy_pattern x0) + | From.Parsetree.Ppat_or (x0, x1) -> + To.Parsetree.Ppat_or (copy_pattern x0, copy_pattern x1) + | From.Parsetree.Ppat_constraint (x0, x1) -> + To.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1) + | From.Parsetree.Ppat_type x0 -> + To.Parsetree.Ppat_type (copy_loc copy_longident x0) + | From.Parsetree.Ppat_lazy x0 -> To.Parsetree.Ppat_lazy (copy_pattern x0) + | From.Parsetree.Ppat_unpack x0 -> + To.Parsetree.Ppat_unpack (copy_loc (fun x -> x) x0) + | From.Parsetree.Ppat_exception x0 -> + To.Parsetree.Ppat_exception (copy_pattern x0) + | From.Parsetree.Ppat_extension x0 -> + To.Parsetree.Ppat_extension (copy_extension x0) + | From.Parsetree.Ppat_open (x0, x1) -> + To.Parsetree.Ppat_open (copy_loc copy_longident x0, copy_pattern x1) + +and copy_core_type : From.Parsetree.core_type -> To.Parsetree.core_type = + fun { + From.Parsetree.ptyp_desc; + From.Parsetree.ptyp_loc; + From.Parsetree.ptyp_loc_stack = _; + From.Parsetree.ptyp_attributes; + } -> + { + To.Parsetree.ptyp_desc = copy_core_type_desc ptyp_desc; + To.Parsetree.ptyp_loc = copy_location ptyp_loc; + To.Parsetree.ptyp_attributes = copy_attributes ptyp_attributes; + } + +and copy_core_type_desc : + From.Parsetree.core_type_desc -> To.Parsetree.core_type_desc = function + | From.Parsetree.Ptyp_any -> To.Parsetree.Ptyp_any + | From.Parsetree.Ptyp_var x0 -> To.Parsetree.Ptyp_var x0 + | From.Parsetree.Ptyp_arrow (x0, x1, x2) -> + To.Parsetree.Ptyp_arrow + (copy_arg_label x0, copy_core_type x1, copy_core_type x2) + | From.Parsetree.Ptyp_tuple x0 -> + To.Parsetree.Ptyp_tuple (List.map copy_core_type x0) + | From.Parsetree.Ptyp_constr (x0, x1) -> + To.Parsetree.Ptyp_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Ptyp_object (x0, x1) -> + To.Parsetree.Ptyp_object + (List.map copy_object_field x0, copy_closed_flag x1) + | From.Parsetree.Ptyp_class (x0, x1) -> + To.Parsetree.Ptyp_class + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Ptyp_alias (x0, x1) -> + To.Parsetree.Ptyp_alias (copy_core_type x0, x1) + | From.Parsetree.Ptyp_variant (x0, x1, x2) -> + To.Parsetree.Ptyp_variant + ( List.map copy_row_field x0, + copy_closed_flag x1, + copy_option (fun x -> List.map copy_label x) x2 ) + | From.Parsetree.Ptyp_poly (x0, x1) -> + To.Parsetree.Ptyp_poly + (List.map (fun x -> copy_loc (fun x -> x) x) x0, copy_core_type x1) + | From.Parsetree.Ptyp_package x0 -> + To.Parsetree.Ptyp_package (copy_package_type x0) + | From.Parsetree.Ptyp_extension x0 -> + To.Parsetree.Ptyp_extension (copy_extension x0) + +and copy_package_type : From.Parsetree.package_type -> To.Parsetree.package_type + = + fun x -> + let x0, x1 = x in + ( copy_loc copy_longident x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_longident x0, copy_core_type x1)) + x1 ) + +and copy_row_field : From.Parsetree.row_field -> To.Parsetree.row_field = + fun { + From.Parsetree.prf_desc; + From.Parsetree.prf_loc = _; + From.Parsetree.prf_attributes; + } -> + match prf_desc with + | From.Parsetree.Rtag (x0, x1, x2) -> + To.Parsetree.Rtag + ( copy_loc copy_label x0, + copy_attributes prf_attributes, + copy_bool x1, + List.map copy_core_type x2 ) + | From.Parsetree.Rinherit x0 -> To.Parsetree.Rinherit (copy_core_type x0) + +and copy_object_field : From.Parsetree.object_field -> To.Parsetree.object_field + = + fun { + From.Parsetree.pof_desc; + From.Parsetree.pof_loc = _; + From.Parsetree.pof_attributes; + } -> + match pof_desc with + | From.Parsetree.Otag (x0, x1) -> + To.Parsetree.Otag + ( copy_loc copy_label x0, + copy_attributes pof_attributes, + copy_core_type x1 ) + | From.Parsetree.Oinherit x0 -> To.Parsetree.Oinherit (copy_core_type x0) + +and copy_attributes : From.Parsetree.attributes -> To.Parsetree.attributes = + fun x -> List.map copy_attribute x + +and copy_attribute : From.Parsetree.attribute -> To.Parsetree.attribute = + fun { + From.Parsetree.attr_name; + From.Parsetree.attr_payload; + From.Parsetree.attr_loc = _; + } -> + (copy_loc (fun x -> x) attr_name, copy_payload attr_payload) + +and copy_payload : From.Parsetree.payload -> To.Parsetree.payload = function + | From.Parsetree.PStr x0 -> To.Parsetree.PStr (copy_structure x0) + | From.Parsetree.PSig x0 -> To.Parsetree.PSig (copy_signature x0) + | From.Parsetree.PTyp x0 -> To.Parsetree.PTyp (copy_core_type x0) + | From.Parsetree.PPat (x0, x1) -> + To.Parsetree.PPat (copy_pattern x0, copy_option copy_expression x1) + +and copy_structure : From.Parsetree.structure -> To.Parsetree.structure = + fun x -> List.map copy_structure_item x + +and copy_structure_item : + From.Parsetree.structure_item -> To.Parsetree.structure_item = + fun { From.Parsetree.pstr_desc; From.Parsetree.pstr_loc } -> + { + To.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc; + To.Parsetree.pstr_loc = copy_location pstr_loc; + } + +and copy_structure_item_desc : + From.Parsetree.structure_item_desc -> To.Parsetree.structure_item_desc = + function + | From.Parsetree.Pstr_eval (x0, x1) -> + To.Parsetree.Pstr_eval (copy_expression x0, copy_attributes x1) + | From.Parsetree.Pstr_value (x0, x1) -> + To.Parsetree.Pstr_value (copy_rec_flag x0, List.map copy_value_binding x1) + | From.Parsetree.Pstr_primitive x0 -> + To.Parsetree.Pstr_primitive (copy_value_description x0) + | From.Parsetree.Pstr_type (x0, x1) -> + To.Parsetree.Pstr_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | From.Parsetree.Pstr_typext x0 -> + To.Parsetree.Pstr_typext (copy_type_extension x0) + | From.Parsetree.Pstr_exception x0 -> + To.Parsetree.Pstr_exception + (let e = + copy_extension_constructor x0.From.Parsetree.ptyexn_constructor + in + { + e with + pext_attributes = + e.pext_attributes @ copy_attributes x0.ptyexn_attributes; + }) + | From.Parsetree.Pstr_module x0 -> + To.Parsetree.Pstr_module (copy_module_binding x0) + | From.Parsetree.Pstr_recmodule x0 -> + To.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) + | From.Parsetree.Pstr_modtype x0 -> + To.Parsetree.Pstr_modtype (copy_module_type_declaration x0) + | From.Parsetree.Pstr_open x0 -> ( + match x0.From.Parsetree.popen_expr.From.Parsetree.pmod_desc with + | Pmod_ident lid -> + To.Parsetree.Pstr_open + { + To.Parsetree.popen_lid = copy_loc copy_longident lid; + To.Parsetree.popen_override = + copy_override_flag x0.From.Parsetree.popen_override; + To.Parsetree.popen_loc = copy_location x0.From.Parsetree.popen_loc; + To.Parsetree.popen_attributes = + copy_attributes x0.From.Parsetree.popen_attributes; + } + | Pmod_structure _ | Pmod_functor _ | Pmod_apply _ | Pmod_constraint _ + | Pmod_unpack _ | Pmod_extension _ -> + migration_error x0.From.Parsetree.popen_loc "complex open") + | From.Parsetree.Pstr_class x0 -> + To.Parsetree.Pstr_class (List.map copy_class_declaration x0) + | From.Parsetree.Pstr_class_type x0 -> + To.Parsetree.Pstr_class_type (List.map copy_class_type_declaration x0) + | From.Parsetree.Pstr_include x0 -> + To.Parsetree.Pstr_include (copy_include_declaration x0) + | From.Parsetree.Pstr_attribute x0 -> + To.Parsetree.Pstr_attribute (copy_attribute x0) + | From.Parsetree.Pstr_extension (x0, x1) -> + To.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1) + +and copy_include_declaration : + From.Parsetree.include_declaration -> To.Parsetree.include_declaration = + fun x -> copy_include_infos copy_module_expr x + +and copy_class_declaration : + From.Parsetree.class_declaration -> To.Parsetree.class_declaration = + fun x -> copy_class_infos copy_class_expr x + +and copy_class_expr : From.Parsetree.class_expr -> To.Parsetree.class_expr = + fun { + From.Parsetree.pcl_desc; + From.Parsetree.pcl_loc; + From.Parsetree.pcl_attributes; + } -> + { + To.Parsetree.pcl_desc = copy_class_expr_desc pcl_desc; + To.Parsetree.pcl_loc = copy_location pcl_loc; + To.Parsetree.pcl_attributes = copy_attributes pcl_attributes; + } + +and copy_class_expr_desc : + From.Parsetree.class_expr_desc -> To.Parsetree.class_expr_desc = function + | From.Parsetree.Pcl_constr (x0, x1) -> + To.Parsetree.Pcl_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Pcl_structure x0 -> + To.Parsetree.Pcl_structure (copy_class_structure x0) + | From.Parsetree.Pcl_fun (x0, x1, x2, x3) -> + To.Parsetree.Pcl_fun + ( copy_arg_label x0, + copy_option copy_expression x1, + copy_pattern x2, + copy_class_expr x3 ) + | From.Parsetree.Pcl_apply (x0, x1) -> + To.Parsetree.Pcl_apply + ( copy_class_expr x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | From.Parsetree.Pcl_let (x0, x1, x2) -> + To.Parsetree.Pcl_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_class_expr x2) + | From.Parsetree.Pcl_constraint (x0, x1) -> + To.Parsetree.Pcl_constraint (copy_class_expr x0, copy_class_type x1) + | From.Parsetree.Pcl_extension x0 -> + To.Parsetree.Pcl_extension (copy_extension x0) + | From.Parsetree.Pcl_open (x0, x1) -> + To.Parsetree.Pcl_open + ( copy_override_flag x0.From.Parsetree.popen_override, + copy_loc copy_longident x0.From.Parsetree.popen_expr, + copy_class_expr x1 ) + +and copy_class_structure : + From.Parsetree.class_structure -> To.Parsetree.class_structure = + fun { From.Parsetree.pcstr_self; From.Parsetree.pcstr_fields } -> + { + To.Parsetree.pcstr_self = copy_pattern pcstr_self; + To.Parsetree.pcstr_fields = List.map copy_class_field pcstr_fields; + } + +and copy_class_field : From.Parsetree.class_field -> To.Parsetree.class_field = + fun { + From.Parsetree.pcf_desc; + From.Parsetree.pcf_loc; + From.Parsetree.pcf_attributes; + } -> + { + To.Parsetree.pcf_desc = copy_class_field_desc pcf_desc; + To.Parsetree.pcf_loc = copy_location pcf_loc; + To.Parsetree.pcf_attributes = copy_attributes pcf_attributes; + } + +and copy_class_field_desc : + From.Parsetree.class_field_desc -> To.Parsetree.class_field_desc = function + | From.Parsetree.Pcf_inherit (x0, x1, x2) -> + To.Parsetree.Pcf_inherit + ( copy_override_flag x0, + copy_class_expr x1, + copy_option (fun x -> copy_loc (fun x -> x) x) x2 ) + | From.Parsetree.Pcf_val x0 -> + To.Parsetree.Pcf_val + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_mutable_flag x1, copy_class_field_kind x2)) + | From.Parsetree.Pcf_method x0 -> + To.Parsetree.Pcf_method + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_private_flag x1, copy_class_field_kind x2)) + | From.Parsetree.Pcf_constraint x0 -> + To.Parsetree.Pcf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | From.Parsetree.Pcf_initializer x0 -> + To.Parsetree.Pcf_initializer (copy_expression x0) + | From.Parsetree.Pcf_attribute x0 -> + To.Parsetree.Pcf_attribute (copy_attribute x0) + | From.Parsetree.Pcf_extension x0 -> + To.Parsetree.Pcf_extension (copy_extension x0) + +and copy_class_field_kind : + From.Parsetree.class_field_kind -> To.Parsetree.class_field_kind = function + | From.Parsetree.Cfk_virtual x0 -> + To.Parsetree.Cfk_virtual (copy_core_type x0) + | From.Parsetree.Cfk_concrete (x0, x1) -> + To.Parsetree.Cfk_concrete (copy_override_flag x0, copy_expression x1) + +and copy_module_binding : + From.Parsetree.module_binding -> To.Parsetree.module_binding = + fun { + From.Parsetree.pmb_name; + From.Parsetree.pmb_expr; + From.Parsetree.pmb_attributes; + From.Parsetree.pmb_loc; + } -> + { + To.Parsetree.pmb_name = copy_loc (fun x -> x) pmb_name; + To.Parsetree.pmb_expr = copy_module_expr pmb_expr; + To.Parsetree.pmb_attributes = copy_attributes pmb_attributes; + To.Parsetree.pmb_loc = copy_location pmb_loc; + } + +and copy_module_expr : From.Parsetree.module_expr -> To.Parsetree.module_expr = + fun { + From.Parsetree.pmod_desc; + From.Parsetree.pmod_loc; + From.Parsetree.pmod_attributes; + } -> + { + To.Parsetree.pmod_desc = copy_module_expr_desc pmod_desc; + To.Parsetree.pmod_loc = copy_location pmod_loc; + To.Parsetree.pmod_attributes = copy_attributes pmod_attributes; + } + +and copy_module_expr_desc : + From.Parsetree.module_expr_desc -> To.Parsetree.module_expr_desc = function + | From.Parsetree.Pmod_ident x0 -> + To.Parsetree.Pmod_ident (copy_loc copy_longident x0) + | From.Parsetree.Pmod_structure x0 -> + To.Parsetree.Pmod_structure (copy_structure x0) + | From.Parsetree.Pmod_functor (x0, x1, x2) -> + To.Parsetree.Pmod_functor + ( copy_loc (fun x -> x) x0, + copy_option copy_module_type x1, + copy_module_expr x2 ) + | From.Parsetree.Pmod_apply (x0, x1) -> + To.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) + | From.Parsetree.Pmod_constraint (x0, x1) -> + To.Parsetree.Pmod_constraint (copy_module_expr x0, copy_module_type x1) + | From.Parsetree.Pmod_unpack x0 -> + To.Parsetree.Pmod_unpack (copy_expression x0) + | From.Parsetree.Pmod_extension x0 -> + To.Parsetree.Pmod_extension (copy_extension x0) + +and copy_module_type : From.Parsetree.module_type -> To.Parsetree.module_type = + fun { + From.Parsetree.pmty_desc; + From.Parsetree.pmty_loc; + From.Parsetree.pmty_attributes; + } -> + { + To.Parsetree.pmty_desc = copy_module_type_desc pmty_desc; + To.Parsetree.pmty_loc = copy_location pmty_loc; + To.Parsetree.pmty_attributes = copy_attributes pmty_attributes; + } + +and copy_module_type_desc : + From.Parsetree.module_type_desc -> To.Parsetree.module_type_desc = function + | From.Parsetree.Pmty_ident x0 -> + To.Parsetree.Pmty_ident (copy_loc copy_longident x0) + | From.Parsetree.Pmty_signature x0 -> + To.Parsetree.Pmty_signature (copy_signature x0) + | From.Parsetree.Pmty_functor (x0, x1, x2) -> + To.Parsetree.Pmty_functor + ( copy_loc (fun x -> x) x0, + copy_option copy_module_type x1, + copy_module_type x2 ) + | From.Parsetree.Pmty_with (x0, x1) -> + To.Parsetree.Pmty_with + (copy_module_type x0, List.map copy_with_constraint x1) + | From.Parsetree.Pmty_typeof x0 -> + To.Parsetree.Pmty_typeof (copy_module_expr x0) + | From.Parsetree.Pmty_extension x0 -> + To.Parsetree.Pmty_extension (copy_extension x0) + | From.Parsetree.Pmty_alias x0 -> + To.Parsetree.Pmty_alias (copy_loc copy_longident x0) + +and copy_with_constraint : + From.Parsetree.with_constraint -> To.Parsetree.with_constraint = function + | From.Parsetree.Pwith_type (x0, x1) -> + To.Parsetree.Pwith_type + (copy_loc copy_longident x0, copy_type_declaration x1) + | From.Parsetree.Pwith_module (x0, x1) -> + To.Parsetree.Pwith_module + (copy_loc copy_longident x0, copy_loc copy_longident x1) + | From.Parsetree.Pwith_typesubst (x0, x1) -> + To.Parsetree.Pwith_typesubst + (copy_loc copy_longident x0, copy_type_declaration x1) + | From.Parsetree.Pwith_modsubst (x0, x1) -> + To.Parsetree.Pwith_modsubst + (copy_loc copy_longident x0, copy_loc copy_longident x1) + +and copy_signature : From.Parsetree.signature -> To.Parsetree.signature = + fun x -> List.map copy_signature_item x + +and copy_signature_item : + From.Parsetree.signature_item -> To.Parsetree.signature_item = + fun { From.Parsetree.psig_desc; From.Parsetree.psig_loc } -> + { + To.Parsetree.psig_desc = copy_signature_item_desc psig_desc; + To.Parsetree.psig_loc = copy_location psig_loc; + } + +and copy_signature_item_desc : + From.Parsetree.signature_item_desc -> To.Parsetree.signature_item_desc = + function + | From.Parsetree.Psig_value x0 -> + To.Parsetree.Psig_value (copy_value_description x0) + | From.Parsetree.Psig_type (x0, x1) -> + To.Parsetree.Psig_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | From.Parsetree.Psig_typesubst x0 -> + let x0_loc = + match x0 with + | [] -> Location.none + | { From.Parsetree.ptype_loc; _ } :: _ -> ptype_loc + in + migration_error x0_loc "type substitution in signatures" + | From.Parsetree.Psig_typext x0 -> + To.Parsetree.Psig_typext (copy_type_extension x0) + | From.Parsetree.Psig_exception x0 -> + To.Parsetree.Psig_exception + (let e = + copy_extension_constructor x0.From.Parsetree.ptyexn_constructor + in + { + e with + pext_attributes = + e.pext_attributes @ copy_attributes x0.ptyexn_attributes; + }) + | From.Parsetree.Psig_module x0 -> + To.Parsetree.Psig_module (copy_module_declaration x0) + | From.Parsetree.Psig_modsubst x0 -> + migration_error x0.pms_loc "module substitution in signatures" + | From.Parsetree.Psig_recmodule x0 -> + To.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) + | From.Parsetree.Psig_modtype x0 -> + To.Parsetree.Psig_modtype (copy_module_type_declaration x0) + | From.Parsetree.Psig_open x0 -> + To.Parsetree.Psig_open (copy_open_description x0) + | From.Parsetree.Psig_include x0 -> + To.Parsetree.Psig_include (copy_include_description x0) + | From.Parsetree.Psig_class x0 -> + To.Parsetree.Psig_class (List.map copy_class_description x0) + | From.Parsetree.Psig_class_type x0 -> + To.Parsetree.Psig_class_type (List.map copy_class_type_declaration x0) + | From.Parsetree.Psig_attribute x0 -> + To.Parsetree.Psig_attribute (copy_attribute x0) + | From.Parsetree.Psig_extension (x0, x1) -> + To.Parsetree.Psig_extension (copy_extension x0, copy_attributes x1) + +and copy_class_type_declaration : + From.Parsetree.class_type_declaration -> To.Parsetree.class_type_declaration + = + fun x -> copy_class_infos copy_class_type x + +and copy_class_description : + From.Parsetree.class_description -> To.Parsetree.class_description = + fun x -> copy_class_infos copy_class_type x + +and copy_class_type : From.Parsetree.class_type -> To.Parsetree.class_type = + fun { + From.Parsetree.pcty_desc; + From.Parsetree.pcty_loc; + From.Parsetree.pcty_attributes; + } -> + { + To.Parsetree.pcty_desc = copy_class_type_desc pcty_desc; + To.Parsetree.pcty_loc = copy_location pcty_loc; + To.Parsetree.pcty_attributes = copy_attributes pcty_attributes; + } + +and copy_class_type_desc : + From.Parsetree.class_type_desc -> To.Parsetree.class_type_desc = function + | From.Parsetree.Pcty_constr (x0, x1) -> + To.Parsetree.Pcty_constr + (copy_loc copy_longident x0, List.map copy_core_type x1) + | From.Parsetree.Pcty_signature x0 -> + To.Parsetree.Pcty_signature (copy_class_signature x0) + | From.Parsetree.Pcty_arrow (x0, x1, x2) -> + To.Parsetree.Pcty_arrow + (copy_arg_label x0, copy_core_type x1, copy_class_type x2) + | From.Parsetree.Pcty_extension x0 -> + To.Parsetree.Pcty_extension (copy_extension x0) + | From.Parsetree.Pcty_open (x0, x1) -> + To.Parsetree.Pcty_open + ( copy_override_flag x0.From.Parsetree.popen_override, + copy_loc copy_longident x0.From.Parsetree.popen_expr, + copy_class_type x1 ) + +and copy_class_signature : + From.Parsetree.class_signature -> To.Parsetree.class_signature = + fun { From.Parsetree.pcsig_self; From.Parsetree.pcsig_fields } -> + { + To.Parsetree.pcsig_self = copy_core_type pcsig_self; + To.Parsetree.pcsig_fields = List.map copy_class_type_field pcsig_fields; + } + +and copy_class_type_field : + From.Parsetree.class_type_field -> To.Parsetree.class_type_field = + fun { + From.Parsetree.pctf_desc; + From.Parsetree.pctf_loc; + From.Parsetree.pctf_attributes; + } -> + { + To.Parsetree.pctf_desc = copy_class_type_field_desc pctf_desc; + To.Parsetree.pctf_loc = copy_location pctf_loc; + To.Parsetree.pctf_attributes = copy_attributes pctf_attributes; + } + +and copy_class_type_field_desc : + From.Parsetree.class_type_field_desc -> To.Parsetree.class_type_field_desc = + function + | From.Parsetree.Pctf_inherit x0 -> + To.Parsetree.Pctf_inherit (copy_class_type x0) + | From.Parsetree.Pctf_val x0 -> + To.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 )) + | From.Parsetree.Pctf_method x0 -> + To.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 )) + | From.Parsetree.Pctf_constraint x0 -> + To.Parsetree.Pctf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | From.Parsetree.Pctf_attribute x0 -> + To.Parsetree.Pctf_attribute (copy_attribute x0) + | From.Parsetree.Pctf_extension x0 -> + To.Parsetree.Pctf_extension (copy_extension x0) + +and copy_extension : From.Parsetree.extension -> To.Parsetree.extension = + fun x -> + let x0, x1 = x in + let x1 = + match x0.txt with + | "ocaml.error" | "error" -> ( + match x1 with + | PStr (hd :: tl) -> From.Parsetree.PStr (hd :: hd :: tl) + | _ -> x1) + | _ -> x1 + in + (copy_loc (fun x -> x) x0, copy_payload x1) + +and copy_class_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 From.Parsetree.class_infos -> + 'g0 To.Parsetree.class_infos = + fun f0 + { + From.Parsetree.pci_virt; + From.Parsetree.pci_params; + From.Parsetree.pci_name; + From.Parsetree.pci_expr; + From.Parsetree.pci_loc; + From.Parsetree.pci_attributes; + } -> + { + To.Parsetree.pci_virt = copy_virtual_flag pci_virt; + To.Parsetree.pci_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + pci_params; + To.Parsetree.pci_name = copy_loc (fun x -> x) pci_name; + To.Parsetree.pci_expr = f0 pci_expr; + To.Parsetree.pci_loc = copy_location pci_loc; + To.Parsetree.pci_attributes = copy_attributes pci_attributes; + } + +and copy_virtual_flag : From.Asttypes.virtual_flag -> To.Asttypes.virtual_flag = + function + | From.Asttypes.Virtual -> To.Asttypes.Virtual + | From.Asttypes.Concrete -> To.Asttypes.Concrete + +and copy_include_description : + From.Parsetree.include_description -> To.Parsetree.include_description = + fun x -> copy_include_infos copy_module_type x + +and copy_include_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 From.Parsetree.include_infos -> + 'g0 To.Parsetree.include_infos = + fun f0 + { + From.Parsetree.pincl_mod; + From.Parsetree.pincl_loc; + From.Parsetree.pincl_attributes; + } -> + { + To.Parsetree.pincl_mod = f0 pincl_mod; + To.Parsetree.pincl_loc = copy_location pincl_loc; + To.Parsetree.pincl_attributes = copy_attributes pincl_attributes; + } + +and copy_open_description : + From.Parsetree.open_description -> To.Parsetree.open_description = + fun { + From.Parsetree.popen_expr; + From.Parsetree.popen_override; + From.Parsetree.popen_loc; + From.Parsetree.popen_attributes; + } -> + { + To.Parsetree.popen_lid = copy_loc copy_longident popen_expr; + To.Parsetree.popen_override = copy_override_flag popen_override; + To.Parsetree.popen_loc = copy_location popen_loc; + To.Parsetree.popen_attributes = copy_attributes popen_attributes; + } + +and copy_override_flag : + From.Asttypes.override_flag -> To.Asttypes.override_flag = function + | From.Asttypes.Override -> To.Asttypes.Override + | From.Asttypes.Fresh -> To.Asttypes.Fresh + +and copy_module_type_declaration : + From.Parsetree.module_type_declaration -> + To.Parsetree.module_type_declaration = + fun { + From.Parsetree.pmtd_name; + From.Parsetree.pmtd_type; + From.Parsetree.pmtd_attributes; + From.Parsetree.pmtd_loc; + } -> + { + To.Parsetree.pmtd_name = copy_loc (fun x -> x) pmtd_name; + To.Parsetree.pmtd_type = copy_option copy_module_type pmtd_type; + To.Parsetree.pmtd_attributes = copy_attributes pmtd_attributes; + To.Parsetree.pmtd_loc = copy_location pmtd_loc; + } + +and copy_module_declaration : + From.Parsetree.module_declaration -> To.Parsetree.module_declaration = + fun { + From.Parsetree.pmd_name; + From.Parsetree.pmd_type; + From.Parsetree.pmd_attributes; + From.Parsetree.pmd_loc; + } -> + { + To.Parsetree.pmd_name = copy_loc (fun x -> x) pmd_name; + To.Parsetree.pmd_type = copy_module_type pmd_type; + To.Parsetree.pmd_attributes = copy_attributes pmd_attributes; + To.Parsetree.pmd_loc = copy_location pmd_loc; + } + +(* and copy_type_exception : + From.Parsetree.type_exception -> To.Parsetree.type_exception = + fun + { From.Parsetree.ptyexn_constructor = ptyexn_constructor; + From.Parsetree.ptyexn_loc = ptyexn_loc; + From.Parsetree.ptyexn_attributes = ptyexn_attributes } + -> + { + To.Parsetree.ptyexn_constructor = + (copy_extension_constructor ptyexn_constructor); + To.Parsetree.ptyexn_loc = (copy_location ptyexn_loc); + To.Parsetree.ptyexn_attributes = + (copy_attributes ptyexn_attributes) + }*) +and copy_type_extension : + From.Parsetree.type_extension -> To.Parsetree.type_extension = + fun { + From.Parsetree.ptyext_path; + From.Parsetree.ptyext_params; + From.Parsetree.ptyext_constructors; + From.Parsetree.ptyext_private; + From.Parsetree.ptyext_loc = _; + From.Parsetree.ptyext_attributes; + } -> + { + To.Parsetree.ptyext_path = copy_loc copy_longident ptyext_path; + To.Parsetree.ptyext_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptyext_params; + To.Parsetree.ptyext_constructors = + List.map copy_extension_constructor ptyext_constructors; + To.Parsetree.ptyext_private = copy_private_flag ptyext_private; + To.Parsetree.ptyext_attributes = copy_attributes ptyext_attributes; + } + +and copy_extension_constructor : + From.Parsetree.extension_constructor -> To.Parsetree.extension_constructor = + fun { + From.Parsetree.pext_name; + From.Parsetree.pext_kind; + From.Parsetree.pext_loc; + From.Parsetree.pext_attributes; + } -> + { + To.Parsetree.pext_name = copy_loc (fun x -> x) pext_name; + To.Parsetree.pext_kind = copy_extension_constructor_kind pext_kind; + To.Parsetree.pext_loc = copy_location pext_loc; + To.Parsetree.pext_attributes = copy_attributes pext_attributes; + } + +and copy_extension_constructor_kind : + From.Parsetree.extension_constructor_kind -> + To.Parsetree.extension_constructor_kind = function + | From.Parsetree.Pext_decl (x0, x1) -> + To.Parsetree.Pext_decl + (copy_constructor_arguments x0, copy_option copy_core_type x1) + | From.Parsetree.Pext_rebind x0 -> + To.Parsetree.Pext_rebind (copy_loc copy_longident x0) + +and copy_type_declaration : + From.Parsetree.type_declaration -> To.Parsetree.type_declaration = + fun { + From.Parsetree.ptype_name; + From.Parsetree.ptype_params; + From.Parsetree.ptype_cstrs; + From.Parsetree.ptype_kind; + From.Parsetree.ptype_private; + From.Parsetree.ptype_manifest; + From.Parsetree.ptype_attributes; + From.Parsetree.ptype_loc; + } -> + { + To.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name; + To.Parsetree.ptype_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptype_params; + To.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; + To.Parsetree.ptype_kind = copy_type_kind ptype_kind; + To.Parsetree.ptype_private = copy_private_flag ptype_private; + To.Parsetree.ptype_manifest = copy_option copy_core_type ptype_manifest; + To.Parsetree.ptype_attributes = copy_attributes ptype_attributes; + To.Parsetree.ptype_loc = copy_location ptype_loc; + } + +and copy_private_flag : From.Asttypes.private_flag -> To.Asttypes.private_flag = + function + | From.Asttypes.Private -> To.Asttypes.Private + | From.Asttypes.Public -> To.Asttypes.Public + +and copy_type_kind : From.Parsetree.type_kind -> To.Parsetree.type_kind = + function + | From.Parsetree.Ptype_abstract -> To.Parsetree.Ptype_abstract + | From.Parsetree.Ptype_variant x0 -> + To.Parsetree.Ptype_variant (List.map copy_constructor_declaration x0) + | From.Parsetree.Ptype_record x0 -> + To.Parsetree.Ptype_record (List.map copy_label_declaration x0) + | From.Parsetree.Ptype_open -> To.Parsetree.Ptype_open + +and copy_constructor_declaration : + From.Parsetree.constructor_declaration -> + To.Parsetree.constructor_declaration = + fun { + From.Parsetree.pcd_name; + From.Parsetree.pcd_args; + From.Parsetree.pcd_res; + From.Parsetree.pcd_loc; + From.Parsetree.pcd_attributes; + } -> + { + To.Parsetree.pcd_name = copy_loc (fun x -> x) pcd_name; + To.Parsetree.pcd_args = copy_constructor_arguments pcd_args; + To.Parsetree.pcd_res = copy_option copy_core_type pcd_res; + To.Parsetree.pcd_loc = copy_location pcd_loc; + To.Parsetree.pcd_attributes = copy_attributes pcd_attributes; + } + +and copy_constructor_arguments : + From.Parsetree.constructor_arguments -> To.Parsetree.constructor_arguments = + function + | From.Parsetree.Pcstr_tuple x0 -> + To.Parsetree.Pcstr_tuple (List.map copy_core_type x0) + | From.Parsetree.Pcstr_record x0 -> + To.Parsetree.Pcstr_record (List.map copy_label_declaration x0) + +and copy_label_declaration : + From.Parsetree.label_declaration -> To.Parsetree.label_declaration = + fun { + From.Parsetree.pld_name; + From.Parsetree.pld_mutable; + From.Parsetree.pld_type; + From.Parsetree.pld_loc; + From.Parsetree.pld_attributes; + } -> + { + To.Parsetree.pld_name = copy_loc (fun x -> x) pld_name; + To.Parsetree.pld_mutable = copy_mutable_flag pld_mutable; + To.Parsetree.pld_type = copy_core_type pld_type; + To.Parsetree.pld_loc = copy_location pld_loc; + To.Parsetree.pld_attributes = copy_attributes pld_attributes; + } + +and copy_mutable_flag : From.Asttypes.mutable_flag -> To.Asttypes.mutable_flag = + function + | From.Asttypes.Immutable -> To.Asttypes.Immutable + | From.Asttypes.Mutable -> To.Asttypes.Mutable + +and copy_variance : From.Asttypes.variance -> To.Asttypes.variance = function + | From.Asttypes.Covariant -> To.Asttypes.Covariant + | From.Asttypes.Contravariant -> To.Asttypes.Contravariant + | From.Asttypes.Invariant -> To.Asttypes.Invariant + +and copy_value_description : + From.Parsetree.value_description -> To.Parsetree.value_description = + fun { + From.Parsetree.pval_name; + From.Parsetree.pval_type; + From.Parsetree.pval_prim; + From.Parsetree.pval_attributes; + From.Parsetree.pval_loc; + } -> + { + To.Parsetree.pval_name = copy_loc (fun x -> x) pval_name; + To.Parsetree.pval_type = copy_core_type pval_type; + To.Parsetree.pval_prim = List.map (fun x -> x) pval_prim; + To.Parsetree.pval_attributes = copy_attributes pval_attributes; + To.Parsetree.pval_loc = copy_location pval_loc; + } + +and copy_arg_label : From.Asttypes.arg_label -> To.Asttypes.arg_label = function + | From.Asttypes.Nolabel -> To.Asttypes.Nolabel + | From.Asttypes.Labelled x0 -> To.Asttypes.Labelled x0 + | From.Asttypes.Optional x0 -> To.Asttypes.Optional x0 + +and copy_closed_flag : From.Asttypes.closed_flag -> To.Asttypes.closed_flag = + function + | From.Asttypes.Closed -> To.Asttypes.Closed + | From.Asttypes.Open -> To.Asttypes.Open + +and copy_label : From.Asttypes.label -> To.Asttypes.label = fun x -> x + +and copy_rec_flag : From.Asttypes.rec_flag -> To.Asttypes.rec_flag = function + | From.Asttypes.Nonrecursive -> To.Asttypes.Nonrecursive + | From.Asttypes.Recursive -> To.Asttypes.Recursive + +and copy_constant : From.Parsetree.constant -> To.Parsetree.constant = function + | From.Parsetree.Pconst_integer (x0, x1) -> + To.Parsetree.Pconst_integer (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pconst_char x0 -> To.Parsetree.Pconst_char x0 + | From.Parsetree.Pconst_string (x0, x1) -> + To.Parsetree.Pconst_string (x0, copy_option (fun x -> x) x1) + | From.Parsetree.Pconst_float (x0, x1) -> + To.Parsetree.Pconst_float (x0, copy_option (fun x -> x) x1) + +and copy_option : 'f0 'g0. ('f0 -> 'g0) -> 'f0 option -> 'g0 option = + fun f0 -> function None -> None | Some x0 -> Some (f0 x0) + +and copy_longident : Longident.t -> Longident.t = fun x -> x + +and copy_loc : + 'f0 'g0. ('f0 -> 'g0) -> 'f0 From.Asttypes.loc -> 'g0 To.Asttypes.loc = + fun f0 { From.Asttypes.txt; From.Asttypes.loc } -> + { To.Asttypes.txt = f0 txt; To.Asttypes.loc = copy_location loc } + +and copy_location : Location.t -> Location.t = fun x -> x + +and copy_bool : bool -> bool = function false -> false | true -> true + +let copy_cases x = List.map copy_case x + +let copy_pat = copy_pattern + +let copy_expr = copy_expression + +let copy_typ = copy_core_type diff -Nru ppxlib-0.15.0/astlib/migrate_408_409.ml ppxlib-0.24.0/astlib/migrate_408_409.ml --- ppxlib-0.15.0/astlib/migrate_408_409.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/migrate_408_409.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1185 @@ +open Stdlib0 +module From = Ast_408 +module To = Ast_409 + +let rec copy_toplevel_phrase : + Ast_408.Parsetree.toplevel_phrase -> Ast_409.Parsetree.toplevel_phrase = + function + | Ast_408.Parsetree.Ptop_def x0 -> + Ast_409.Parsetree.Ptop_def (copy_structure x0) + | Ast_408.Parsetree.Ptop_dir x0 -> + Ast_409.Parsetree.Ptop_dir (copy_toplevel_directive x0) + +and copy_toplevel_directive : + Ast_408.Parsetree.toplevel_directive -> Ast_409.Parsetree.toplevel_directive + = + fun { + Ast_408.Parsetree.pdir_name; + Ast_408.Parsetree.pdir_arg; + Ast_408.Parsetree.pdir_loc; + } -> + { + Ast_409.Parsetree.pdir_name = copy_loc (fun x -> x) pdir_name; + Ast_409.Parsetree.pdir_arg = Option.map copy_directive_argument pdir_arg; + Ast_409.Parsetree.pdir_loc = copy_location pdir_loc; + } + +and copy_directive_argument : + Ast_408.Parsetree.directive_argument -> Ast_409.Parsetree.directive_argument + = + fun { Ast_408.Parsetree.pdira_desc; Ast_408.Parsetree.pdira_loc } -> + { + Ast_409.Parsetree.pdira_desc = copy_directive_argument_desc pdira_desc; + Ast_409.Parsetree.pdira_loc = copy_location pdira_loc; + } + +and copy_directive_argument_desc : + Ast_408.Parsetree.directive_argument_desc -> + Ast_409.Parsetree.directive_argument_desc = function + | Ast_408.Parsetree.Pdir_string x0 -> Ast_409.Parsetree.Pdir_string x0 + | Ast_408.Parsetree.Pdir_int (x0, x1) -> + Ast_409.Parsetree.Pdir_int (x0, Option.map (fun x -> x) x1) + | Ast_408.Parsetree.Pdir_ident x0 -> + Ast_409.Parsetree.Pdir_ident (copy_Longident_t x0) + | Ast_408.Parsetree.Pdir_bool x0 -> Ast_409.Parsetree.Pdir_bool x0 + +and copy_typ : Ast_408.Parsetree.typ -> Ast_409.Parsetree.typ = + fun x -> copy_core_type x + +and copy_pat : Ast_408.Parsetree.pat -> Ast_409.Parsetree.pat = + fun x -> copy_pattern x + +and copy_expr : Ast_408.Parsetree.expr -> Ast_409.Parsetree.expr = + fun x -> copy_expression x + +and copy_expression : + Ast_408.Parsetree.expression -> Ast_409.Parsetree.expression = + fun { + Ast_408.Parsetree.pexp_desc; + Ast_408.Parsetree.pexp_loc; + Ast_408.Parsetree.pexp_loc_stack; + Ast_408.Parsetree.pexp_attributes; + } -> + { + Ast_409.Parsetree.pexp_desc = copy_expression_desc pexp_desc; + Ast_409.Parsetree.pexp_loc = copy_location pexp_loc; + Ast_409.Parsetree.pexp_loc_stack = List.map copy_location pexp_loc_stack; + Ast_409.Parsetree.pexp_attributes = copy_attributes pexp_attributes; + } + +and copy_expression_desc : + Ast_408.Parsetree.expression_desc -> Ast_409.Parsetree.expression_desc = + function + | Ast_408.Parsetree.Pexp_ident x0 -> + Ast_409.Parsetree.Pexp_ident (copy_loc copy_Longident_t x0) + | Ast_408.Parsetree.Pexp_constant x0 -> + Ast_409.Parsetree.Pexp_constant (copy_constant x0) + | Ast_408.Parsetree.Pexp_let (x0, x1, x2) -> + Ast_409.Parsetree.Pexp_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_expression x2) + | Ast_408.Parsetree.Pexp_function x0 -> + Ast_409.Parsetree.Pexp_function (copy_cases x0) + | Ast_408.Parsetree.Pexp_fun (x0, x1, x2, x3) -> + Ast_409.Parsetree.Pexp_fun + ( copy_arg_label x0, + Option.map copy_expression x1, + copy_pattern x2, + copy_expression x3 ) + | Ast_408.Parsetree.Pexp_apply (x0, x1) -> + Ast_409.Parsetree.Pexp_apply + ( copy_expression x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | Ast_408.Parsetree.Pexp_match (x0, x1) -> + Ast_409.Parsetree.Pexp_match (copy_expression x0, copy_cases x1) + | Ast_408.Parsetree.Pexp_try (x0, x1) -> + Ast_409.Parsetree.Pexp_try (copy_expression x0, copy_cases x1) + | Ast_408.Parsetree.Pexp_tuple x0 -> + Ast_409.Parsetree.Pexp_tuple (List.map copy_expression x0) + | Ast_408.Parsetree.Pexp_construct (x0, x1) -> + Ast_409.Parsetree.Pexp_construct + (copy_loc copy_Longident_t x0, Option.map copy_expression x1) + | Ast_408.Parsetree.Pexp_variant (x0, x1) -> + Ast_409.Parsetree.Pexp_variant + (copy_label x0, Option.map copy_expression x1) + | Ast_408.Parsetree.Pexp_record (x0, x1) -> + Ast_409.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_408.Parsetree.Pexp_field (x0, x1) -> + Ast_409.Parsetree.Pexp_field + (copy_expression x0, copy_loc copy_Longident_t x1) + | Ast_408.Parsetree.Pexp_setfield (x0, x1, x2) -> + Ast_409.Parsetree.Pexp_setfield + (copy_expression x0, copy_loc copy_Longident_t x1, copy_expression x2) + | Ast_408.Parsetree.Pexp_array x0 -> + Ast_409.Parsetree.Pexp_array (List.map copy_expression x0) + | Ast_408.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> + Ast_409.Parsetree.Pexp_ifthenelse + (copy_expression x0, copy_expression x1, Option.map copy_expression x2) + | Ast_408.Parsetree.Pexp_sequence (x0, x1) -> + Ast_409.Parsetree.Pexp_sequence (copy_expression x0, copy_expression x1) + | Ast_408.Parsetree.Pexp_while (x0, x1) -> + Ast_409.Parsetree.Pexp_while (copy_expression x0, copy_expression x1) + | Ast_408.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> + Ast_409.Parsetree.Pexp_for + ( copy_pattern x0, + copy_expression x1, + copy_expression x2, + copy_direction_flag x3, + copy_expression x4 ) + | Ast_408.Parsetree.Pexp_constraint (x0, x1) -> + Ast_409.Parsetree.Pexp_constraint (copy_expression x0, copy_core_type x1) + | Ast_408.Parsetree.Pexp_coerce (x0, x1, x2) -> + Ast_409.Parsetree.Pexp_coerce + (copy_expression x0, Option.map copy_core_type x1, copy_core_type x2) + | Ast_408.Parsetree.Pexp_send (x0, x1) -> + Ast_409.Parsetree.Pexp_send (copy_expression x0, copy_loc copy_label x1) + | Ast_408.Parsetree.Pexp_new x0 -> + Ast_409.Parsetree.Pexp_new (copy_loc copy_Longident_t x0) + | Ast_408.Parsetree.Pexp_setinstvar (x0, x1) -> + Ast_409.Parsetree.Pexp_setinstvar + (copy_loc copy_label x0, copy_expression x1) + | Ast_408.Parsetree.Pexp_override x0 -> + Ast_409.Parsetree.Pexp_override + (List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_label x0, copy_expression x1)) + x0) + | Ast_408.Parsetree.Pexp_letmodule (x0, x1, x2) -> + Ast_409.Parsetree.Pexp_letmodule + (copy_loc (fun x -> x) x0, copy_module_expr x1, copy_expression x2) + | Ast_408.Parsetree.Pexp_letexception (x0, x1) -> + Ast_409.Parsetree.Pexp_letexception + (copy_extension_constructor x0, copy_expression x1) + | Ast_408.Parsetree.Pexp_assert x0 -> + Ast_409.Parsetree.Pexp_assert (copy_expression x0) + | Ast_408.Parsetree.Pexp_lazy x0 -> + Ast_409.Parsetree.Pexp_lazy (copy_expression x0) + | Ast_408.Parsetree.Pexp_poly (x0, x1) -> + Ast_409.Parsetree.Pexp_poly + (copy_expression x0, Option.map copy_core_type x1) + | Ast_408.Parsetree.Pexp_object x0 -> + Ast_409.Parsetree.Pexp_object (copy_class_structure x0) + | Ast_408.Parsetree.Pexp_newtype (x0, x1) -> + Ast_409.Parsetree.Pexp_newtype + (copy_loc (fun x -> x) x0, copy_expression x1) + | Ast_408.Parsetree.Pexp_pack x0 -> + Ast_409.Parsetree.Pexp_pack (copy_module_expr x0) + | Ast_408.Parsetree.Pexp_open (x0, x1) -> + Ast_409.Parsetree.Pexp_open (copy_open_declaration x0, copy_expression x1) + | Ast_408.Parsetree.Pexp_letop x0 -> + Ast_409.Parsetree.Pexp_letop (copy_letop x0) + | Ast_408.Parsetree.Pexp_extension x0 -> + Ast_409.Parsetree.Pexp_extension (copy_extension x0) + | Ast_408.Parsetree.Pexp_unreachable -> Ast_409.Parsetree.Pexp_unreachable + +and copy_letop : Ast_408.Parsetree.letop -> Ast_409.Parsetree.letop = + fun { Ast_408.Parsetree.let_; Ast_408.Parsetree.ands; Ast_408.Parsetree.body } -> + { + Ast_409.Parsetree.let_ = copy_binding_op let_; + Ast_409.Parsetree.ands = List.map copy_binding_op ands; + Ast_409.Parsetree.body = copy_expression body; + } + +and copy_binding_op : + Ast_408.Parsetree.binding_op -> Ast_409.Parsetree.binding_op = + fun { + Ast_408.Parsetree.pbop_op; + Ast_408.Parsetree.pbop_pat; + Ast_408.Parsetree.pbop_exp; + Ast_408.Parsetree.pbop_loc; + } -> + { + Ast_409.Parsetree.pbop_op = copy_loc (fun x -> x) pbop_op; + Ast_409.Parsetree.pbop_pat = copy_pattern pbop_pat; + Ast_409.Parsetree.pbop_exp = copy_expression pbop_exp; + Ast_409.Parsetree.pbop_loc = copy_location pbop_loc; + } + +and copy_direction_flag : + Ast_408.Asttypes.direction_flag -> Ast_409.Asttypes.direction_flag = + function + | Ast_408.Asttypes.Upto -> Ast_409.Asttypes.Upto + | Ast_408.Asttypes.Downto -> Ast_409.Asttypes.Downto + +and copy_cases : Ast_408.Parsetree.cases -> Ast_409.Parsetree.cases = + fun x -> List.map copy_case x + +and copy_case : Ast_408.Parsetree.case -> Ast_409.Parsetree.case = + fun { + Ast_408.Parsetree.pc_lhs; + Ast_408.Parsetree.pc_guard; + Ast_408.Parsetree.pc_rhs; + } -> + { + Ast_409.Parsetree.pc_lhs = copy_pattern pc_lhs; + Ast_409.Parsetree.pc_guard = Option.map copy_expression pc_guard; + Ast_409.Parsetree.pc_rhs = copy_expression pc_rhs; + } + +and copy_value_binding : + Ast_408.Parsetree.value_binding -> Ast_409.Parsetree.value_binding = + fun { + Ast_408.Parsetree.pvb_pat; + Ast_408.Parsetree.pvb_expr; + Ast_408.Parsetree.pvb_attributes; + Ast_408.Parsetree.pvb_loc; + } -> + { + Ast_409.Parsetree.pvb_pat = copy_pattern pvb_pat; + Ast_409.Parsetree.pvb_expr = copy_expression pvb_expr; + Ast_409.Parsetree.pvb_attributes = copy_attributes pvb_attributes; + Ast_409.Parsetree.pvb_loc = copy_location pvb_loc; + } + +and copy_pattern : Ast_408.Parsetree.pattern -> Ast_409.Parsetree.pattern = + fun { + Ast_408.Parsetree.ppat_desc; + Ast_408.Parsetree.ppat_loc; + Ast_408.Parsetree.ppat_loc_stack; + Ast_408.Parsetree.ppat_attributes; + } -> + { + Ast_409.Parsetree.ppat_desc = copy_pattern_desc ppat_desc; + Ast_409.Parsetree.ppat_loc = copy_location ppat_loc; + Ast_409.Parsetree.ppat_loc_stack = List.map copy_location ppat_loc_stack; + Ast_409.Parsetree.ppat_attributes = copy_attributes ppat_attributes; + } + +and copy_pattern_desc : + Ast_408.Parsetree.pattern_desc -> Ast_409.Parsetree.pattern_desc = function + | Ast_408.Parsetree.Ppat_any -> Ast_409.Parsetree.Ppat_any + | Ast_408.Parsetree.Ppat_var x0 -> + Ast_409.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) + | Ast_408.Parsetree.Ppat_alias (x0, x1) -> + Ast_409.Parsetree.Ppat_alias (copy_pattern x0, copy_loc (fun x -> x) x1) + | Ast_408.Parsetree.Ppat_constant x0 -> + Ast_409.Parsetree.Ppat_constant (copy_constant x0) + | Ast_408.Parsetree.Ppat_interval (x0, x1) -> + Ast_409.Parsetree.Ppat_interval (copy_constant x0, copy_constant x1) + | Ast_408.Parsetree.Ppat_tuple x0 -> + Ast_409.Parsetree.Ppat_tuple (List.map copy_pattern x0) + | Ast_408.Parsetree.Ppat_construct (x0, x1) -> + Ast_409.Parsetree.Ppat_construct + (copy_loc copy_Longident_t x0, Option.map copy_pattern x1) + | Ast_408.Parsetree.Ppat_variant (x0, x1) -> + Ast_409.Parsetree.Ppat_variant (copy_label x0, Option.map copy_pattern x1) + | Ast_408.Parsetree.Ppat_record (x0, x1) -> + Ast_409.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_408.Parsetree.Ppat_array x0 -> + Ast_409.Parsetree.Ppat_array (List.map copy_pattern x0) + | Ast_408.Parsetree.Ppat_or (x0, x1) -> + Ast_409.Parsetree.Ppat_or (copy_pattern x0, copy_pattern x1) + | Ast_408.Parsetree.Ppat_constraint (x0, x1) -> + Ast_409.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1) + | Ast_408.Parsetree.Ppat_type x0 -> + Ast_409.Parsetree.Ppat_type (copy_loc copy_Longident_t x0) + | Ast_408.Parsetree.Ppat_lazy x0 -> + Ast_409.Parsetree.Ppat_lazy (copy_pattern x0) + | Ast_408.Parsetree.Ppat_unpack x0 -> + Ast_409.Parsetree.Ppat_unpack (copy_loc (fun x -> x) x0) + | Ast_408.Parsetree.Ppat_exception x0 -> + Ast_409.Parsetree.Ppat_exception (copy_pattern x0) + | Ast_408.Parsetree.Ppat_extension x0 -> + Ast_409.Parsetree.Ppat_extension (copy_extension x0) + | Ast_408.Parsetree.Ppat_open (x0, x1) -> + Ast_409.Parsetree.Ppat_open (copy_loc copy_Longident_t x0, copy_pattern x1) + +and copy_core_type : Ast_408.Parsetree.core_type -> Ast_409.Parsetree.core_type + = + fun { + Ast_408.Parsetree.ptyp_desc; + Ast_408.Parsetree.ptyp_loc; + Ast_408.Parsetree.ptyp_loc_stack; + Ast_408.Parsetree.ptyp_attributes; + } -> + { + Ast_409.Parsetree.ptyp_desc = copy_core_type_desc ptyp_desc; + Ast_409.Parsetree.ptyp_loc = copy_location ptyp_loc; + Ast_409.Parsetree.ptyp_loc_stack = List.map copy_location ptyp_loc_stack; + Ast_409.Parsetree.ptyp_attributes = copy_attributes ptyp_attributes; + } + +and copy_core_type_desc : + Ast_408.Parsetree.core_type_desc -> Ast_409.Parsetree.core_type_desc = + function + | Ast_408.Parsetree.Ptyp_any -> Ast_409.Parsetree.Ptyp_any + | Ast_408.Parsetree.Ptyp_var x0 -> Ast_409.Parsetree.Ptyp_var x0 + | Ast_408.Parsetree.Ptyp_arrow (x0, x1, x2) -> + Ast_409.Parsetree.Ptyp_arrow + (copy_arg_label x0, copy_core_type x1, copy_core_type x2) + | Ast_408.Parsetree.Ptyp_tuple x0 -> + Ast_409.Parsetree.Ptyp_tuple (List.map copy_core_type x0) + | Ast_408.Parsetree.Ptyp_constr (x0, x1) -> + Ast_409.Parsetree.Ptyp_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_408.Parsetree.Ptyp_object (x0, x1) -> + Ast_409.Parsetree.Ptyp_object + (List.map copy_object_field x0, copy_closed_flag x1) + | Ast_408.Parsetree.Ptyp_class (x0, x1) -> + Ast_409.Parsetree.Ptyp_class + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_408.Parsetree.Ptyp_alias (x0, x1) -> + Ast_409.Parsetree.Ptyp_alias (copy_core_type x0, x1) + | Ast_408.Parsetree.Ptyp_variant (x0, x1, x2) -> + Ast_409.Parsetree.Ptyp_variant + ( List.map copy_row_field x0, + copy_closed_flag x1, + Option.map (fun x -> List.map copy_label x) x2 ) + | Ast_408.Parsetree.Ptyp_poly (x0, x1) -> + Ast_409.Parsetree.Ptyp_poly + (List.map (fun x -> copy_loc (fun x -> x) x) x0, copy_core_type x1) + | Ast_408.Parsetree.Ptyp_package x0 -> + Ast_409.Parsetree.Ptyp_package (copy_package_type x0) + | Ast_408.Parsetree.Ptyp_extension x0 -> + Ast_409.Parsetree.Ptyp_extension (copy_extension x0) + +and copy_package_type : + Ast_408.Parsetree.package_type -> Ast_409.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_408.Parsetree.row_field -> Ast_409.Parsetree.row_field + = + fun { + Ast_408.Parsetree.prf_desc; + Ast_408.Parsetree.prf_loc; + Ast_408.Parsetree.prf_attributes; + } -> + { + Ast_409.Parsetree.prf_desc = copy_row_field_desc prf_desc; + Ast_409.Parsetree.prf_loc = copy_location prf_loc; + Ast_409.Parsetree.prf_attributes = copy_attributes prf_attributes; + } + +and copy_row_field_desc : + Ast_408.Parsetree.row_field_desc -> Ast_409.Parsetree.row_field_desc = + function + | Ast_408.Parsetree.Rtag (x0, x1, x2) -> + Ast_409.Parsetree.Rtag + (copy_loc copy_label x0, x1, List.map copy_core_type x2) + | Ast_408.Parsetree.Rinherit x0 -> + Ast_409.Parsetree.Rinherit (copy_core_type x0) + +and copy_object_field : + Ast_408.Parsetree.object_field -> Ast_409.Parsetree.object_field = + fun { + Ast_408.Parsetree.pof_desc; + Ast_408.Parsetree.pof_loc; + Ast_408.Parsetree.pof_attributes; + } -> + { + Ast_409.Parsetree.pof_desc = copy_object_field_desc pof_desc; + Ast_409.Parsetree.pof_loc = copy_location pof_loc; + Ast_409.Parsetree.pof_attributes = copy_attributes pof_attributes; + } + +and copy_attributes : + Ast_408.Parsetree.attributes -> Ast_409.Parsetree.attributes = + fun x -> List.map copy_attribute x + +and copy_attribute : Ast_408.Parsetree.attribute -> Ast_409.Parsetree.attribute + = + fun { + Ast_408.Parsetree.attr_name; + Ast_408.Parsetree.attr_payload; + Ast_408.Parsetree.attr_loc; + } -> + { + Ast_409.Parsetree.attr_name = copy_loc (fun x -> x) attr_name; + Ast_409.Parsetree.attr_payload = copy_payload attr_payload; + Ast_409.Parsetree.attr_loc = copy_location attr_loc; + } + +and copy_payload : Ast_408.Parsetree.payload -> Ast_409.Parsetree.payload = + function + | Ast_408.Parsetree.PStr x0 -> Ast_409.Parsetree.PStr (copy_structure x0) + | Ast_408.Parsetree.PSig x0 -> Ast_409.Parsetree.PSig (copy_signature x0) + | Ast_408.Parsetree.PTyp x0 -> Ast_409.Parsetree.PTyp (copy_core_type x0) + | Ast_408.Parsetree.PPat (x0, x1) -> + Ast_409.Parsetree.PPat (copy_pattern x0, Option.map copy_expression x1) + +and copy_structure : Ast_408.Parsetree.structure -> Ast_409.Parsetree.structure + = + fun x -> List.map copy_structure_item x + +and copy_structure_item : + Ast_408.Parsetree.structure_item -> Ast_409.Parsetree.structure_item = + fun { Ast_408.Parsetree.pstr_desc; Ast_408.Parsetree.pstr_loc } -> + { + Ast_409.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc; + Ast_409.Parsetree.pstr_loc = copy_location pstr_loc; + } + +and copy_structure_item_desc : + Ast_408.Parsetree.structure_item_desc -> + Ast_409.Parsetree.structure_item_desc = function + | Ast_408.Parsetree.Pstr_eval (x0, x1) -> + Ast_409.Parsetree.Pstr_eval (copy_expression x0, copy_attributes x1) + | Ast_408.Parsetree.Pstr_value (x0, x1) -> + Ast_409.Parsetree.Pstr_value + (copy_rec_flag x0, List.map copy_value_binding x1) + | Ast_408.Parsetree.Pstr_primitive x0 -> + Ast_409.Parsetree.Pstr_primitive (copy_value_description x0) + | Ast_408.Parsetree.Pstr_type (x0, x1) -> + Ast_409.Parsetree.Pstr_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | Ast_408.Parsetree.Pstr_typext x0 -> + Ast_409.Parsetree.Pstr_typext (copy_type_extension x0) + | Ast_408.Parsetree.Pstr_exception x0 -> + Ast_409.Parsetree.Pstr_exception (copy_type_exception x0) + | Ast_408.Parsetree.Pstr_module x0 -> + Ast_409.Parsetree.Pstr_module (copy_module_binding x0) + | Ast_408.Parsetree.Pstr_recmodule x0 -> + Ast_409.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) + | Ast_408.Parsetree.Pstr_modtype x0 -> + Ast_409.Parsetree.Pstr_modtype (copy_module_type_declaration x0) + | Ast_408.Parsetree.Pstr_open x0 -> + Ast_409.Parsetree.Pstr_open (copy_open_declaration x0) + | Ast_408.Parsetree.Pstr_class x0 -> + Ast_409.Parsetree.Pstr_class (List.map copy_class_declaration x0) + | Ast_408.Parsetree.Pstr_class_type x0 -> + Ast_409.Parsetree.Pstr_class_type + (List.map copy_class_type_declaration x0) + | Ast_408.Parsetree.Pstr_include x0 -> + Ast_409.Parsetree.Pstr_include (copy_include_declaration x0) + | Ast_408.Parsetree.Pstr_attribute x0 -> + Ast_409.Parsetree.Pstr_attribute (copy_attribute x0) + | Ast_408.Parsetree.Pstr_extension (x0, x1) -> + Ast_409.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1) + +and copy_include_declaration : + Ast_408.Parsetree.include_declaration -> + Ast_409.Parsetree.include_declaration = + fun x -> copy_include_infos copy_module_expr x + +and copy_class_declaration : + Ast_408.Parsetree.class_declaration -> Ast_409.Parsetree.class_declaration = + fun x -> copy_class_infos copy_class_expr x + +and copy_class_expr : + Ast_408.Parsetree.class_expr -> Ast_409.Parsetree.class_expr = + fun { + Ast_408.Parsetree.pcl_desc; + Ast_408.Parsetree.pcl_loc; + Ast_408.Parsetree.pcl_attributes; + } -> + { + Ast_409.Parsetree.pcl_desc = copy_class_expr_desc pcl_desc; + Ast_409.Parsetree.pcl_loc = copy_location pcl_loc; + Ast_409.Parsetree.pcl_attributes = copy_attributes pcl_attributes; + } + +and copy_class_expr_desc : + Ast_408.Parsetree.class_expr_desc -> Ast_409.Parsetree.class_expr_desc = + function + | Ast_408.Parsetree.Pcl_constr (x0, x1) -> + Ast_409.Parsetree.Pcl_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_408.Parsetree.Pcl_structure x0 -> + Ast_409.Parsetree.Pcl_structure (copy_class_structure x0) + | Ast_408.Parsetree.Pcl_fun (x0, x1, x2, x3) -> + Ast_409.Parsetree.Pcl_fun + ( copy_arg_label x0, + Option.map copy_expression x1, + copy_pattern x2, + copy_class_expr x3 ) + | Ast_408.Parsetree.Pcl_apply (x0, x1) -> + Ast_409.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_408.Parsetree.Pcl_let (x0, x1, x2) -> + Ast_409.Parsetree.Pcl_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_class_expr x2) + | Ast_408.Parsetree.Pcl_constraint (x0, x1) -> + Ast_409.Parsetree.Pcl_constraint (copy_class_expr x0, copy_class_type x1) + | Ast_408.Parsetree.Pcl_extension x0 -> + Ast_409.Parsetree.Pcl_extension (copy_extension x0) + | Ast_408.Parsetree.Pcl_open (x0, x1) -> + Ast_409.Parsetree.Pcl_open (copy_open_description x0, copy_class_expr x1) + +and copy_class_structure : + Ast_408.Parsetree.class_structure -> Ast_409.Parsetree.class_structure = + fun { Ast_408.Parsetree.pcstr_self; Ast_408.Parsetree.pcstr_fields } -> + { + Ast_409.Parsetree.pcstr_self = copy_pattern pcstr_self; + Ast_409.Parsetree.pcstr_fields = List.map copy_class_field pcstr_fields; + } + +and copy_class_field : + Ast_408.Parsetree.class_field -> Ast_409.Parsetree.class_field = + fun { + Ast_408.Parsetree.pcf_desc; + Ast_408.Parsetree.pcf_loc; + Ast_408.Parsetree.pcf_attributes; + } -> + { + Ast_409.Parsetree.pcf_desc = copy_class_field_desc pcf_desc; + Ast_409.Parsetree.pcf_loc = copy_location pcf_loc; + Ast_409.Parsetree.pcf_attributes = copy_attributes pcf_attributes; + } + +and copy_class_field_desc : + Ast_408.Parsetree.class_field_desc -> Ast_409.Parsetree.class_field_desc = + function + | Ast_408.Parsetree.Pcf_inherit (x0, x1, x2) -> + Ast_409.Parsetree.Pcf_inherit + ( copy_override_flag x0, + copy_class_expr x1, + Option.map (fun x -> copy_loc (fun x -> x) x) x2 ) + | Ast_408.Parsetree.Pcf_val x0 -> + Ast_409.Parsetree.Pcf_val + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_mutable_flag x1, copy_class_field_kind x2)) + | Ast_408.Parsetree.Pcf_method x0 -> + Ast_409.Parsetree.Pcf_method + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_private_flag x1, copy_class_field_kind x2)) + | Ast_408.Parsetree.Pcf_constraint x0 -> + Ast_409.Parsetree.Pcf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | Ast_408.Parsetree.Pcf_initializer x0 -> + Ast_409.Parsetree.Pcf_initializer (copy_expression x0) + | Ast_408.Parsetree.Pcf_attribute x0 -> + Ast_409.Parsetree.Pcf_attribute (copy_attribute x0) + | Ast_408.Parsetree.Pcf_extension x0 -> + Ast_409.Parsetree.Pcf_extension (copy_extension x0) + +and copy_class_field_kind : + Ast_408.Parsetree.class_field_kind -> Ast_409.Parsetree.class_field_kind = + function + | Ast_408.Parsetree.Cfk_virtual x0 -> + Ast_409.Parsetree.Cfk_virtual (copy_core_type x0) + | Ast_408.Parsetree.Cfk_concrete (x0, x1) -> + Ast_409.Parsetree.Cfk_concrete (copy_override_flag x0, copy_expression x1) + +and copy_open_declaration : + Ast_408.Parsetree.open_declaration -> Ast_409.Parsetree.open_declaration = + fun x -> copy_open_infos copy_module_expr x + +and copy_module_binding : + Ast_408.Parsetree.module_binding -> Ast_409.Parsetree.module_binding = + fun { + Ast_408.Parsetree.pmb_name; + Ast_408.Parsetree.pmb_expr; + Ast_408.Parsetree.pmb_attributes; + Ast_408.Parsetree.pmb_loc; + } -> + { + Ast_409.Parsetree.pmb_name = copy_loc (fun x -> x) pmb_name; + Ast_409.Parsetree.pmb_expr = copy_module_expr pmb_expr; + Ast_409.Parsetree.pmb_attributes = copy_attributes pmb_attributes; + Ast_409.Parsetree.pmb_loc = copy_location pmb_loc; + } + +and copy_module_expr : + Ast_408.Parsetree.module_expr -> Ast_409.Parsetree.module_expr = + fun { + Ast_408.Parsetree.pmod_desc; + Ast_408.Parsetree.pmod_loc; + Ast_408.Parsetree.pmod_attributes; + } -> + { + Ast_409.Parsetree.pmod_desc = copy_module_expr_desc pmod_desc; + Ast_409.Parsetree.pmod_loc = copy_location pmod_loc; + Ast_409.Parsetree.pmod_attributes = copy_attributes pmod_attributes; + } + +and copy_module_expr_desc : + Ast_408.Parsetree.module_expr_desc -> Ast_409.Parsetree.module_expr_desc = + function + | Ast_408.Parsetree.Pmod_ident x0 -> + Ast_409.Parsetree.Pmod_ident (copy_loc copy_Longident_t x0) + | Ast_408.Parsetree.Pmod_structure x0 -> + Ast_409.Parsetree.Pmod_structure (copy_structure x0) + | Ast_408.Parsetree.Pmod_functor (x0, x1, x2) -> + Ast_409.Parsetree.Pmod_functor + ( copy_loc (fun x -> x) x0, + Option.map copy_module_type x1, + copy_module_expr x2 ) + | Ast_408.Parsetree.Pmod_apply (x0, x1) -> + Ast_409.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) + | Ast_408.Parsetree.Pmod_constraint (x0, x1) -> + Ast_409.Parsetree.Pmod_constraint + (copy_module_expr x0, copy_module_type x1) + | Ast_408.Parsetree.Pmod_unpack x0 -> + Ast_409.Parsetree.Pmod_unpack (copy_expression x0) + | Ast_408.Parsetree.Pmod_extension x0 -> + Ast_409.Parsetree.Pmod_extension (copy_extension x0) + +and copy_module_type : + Ast_408.Parsetree.module_type -> Ast_409.Parsetree.module_type = + fun { + Ast_408.Parsetree.pmty_desc; + Ast_408.Parsetree.pmty_loc; + Ast_408.Parsetree.pmty_attributes; + } -> + { + Ast_409.Parsetree.pmty_desc = copy_module_type_desc pmty_desc; + Ast_409.Parsetree.pmty_loc = copy_location pmty_loc; + Ast_409.Parsetree.pmty_attributes = copy_attributes pmty_attributes; + } + +and copy_module_type_desc : + Ast_408.Parsetree.module_type_desc -> Ast_409.Parsetree.module_type_desc = + function + | Ast_408.Parsetree.Pmty_ident x0 -> + Ast_409.Parsetree.Pmty_ident (copy_loc copy_Longident_t x0) + | Ast_408.Parsetree.Pmty_signature x0 -> + Ast_409.Parsetree.Pmty_signature (copy_signature x0) + | Ast_408.Parsetree.Pmty_functor (x0, x1, x2) -> + Ast_409.Parsetree.Pmty_functor + ( copy_loc (fun x -> x) x0, + Option.map copy_module_type x1, + copy_module_type x2 ) + | Ast_408.Parsetree.Pmty_with (x0, x1) -> + Ast_409.Parsetree.Pmty_with + (copy_module_type x0, List.map copy_with_constraint x1) + | Ast_408.Parsetree.Pmty_typeof x0 -> + Ast_409.Parsetree.Pmty_typeof (copy_module_expr x0) + | Ast_408.Parsetree.Pmty_extension x0 -> + Ast_409.Parsetree.Pmty_extension (copy_extension x0) + | Ast_408.Parsetree.Pmty_alias x0 -> + Ast_409.Parsetree.Pmty_alias (copy_loc copy_Longident_t x0) + +and copy_with_constraint : + Ast_408.Parsetree.with_constraint -> Ast_409.Parsetree.with_constraint = + function + | Ast_408.Parsetree.Pwith_type (x0, x1) -> + Ast_409.Parsetree.Pwith_type + (copy_loc copy_Longident_t x0, copy_type_declaration x1) + | Ast_408.Parsetree.Pwith_module (x0, x1) -> + Ast_409.Parsetree.Pwith_module + (copy_loc copy_Longident_t x0, copy_loc copy_Longident_t x1) + | Ast_408.Parsetree.Pwith_typesubst (x0, x1) -> + Ast_409.Parsetree.Pwith_typesubst + (copy_loc copy_Longident_t x0, copy_type_declaration x1) + | Ast_408.Parsetree.Pwith_modsubst (x0, x1) -> + Ast_409.Parsetree.Pwith_modsubst + (copy_loc copy_Longident_t x0, copy_loc copy_Longident_t x1) + +and copy_signature : Ast_408.Parsetree.signature -> Ast_409.Parsetree.signature + = + fun x -> List.map copy_signature_item x + +and copy_signature_item : + Ast_408.Parsetree.signature_item -> Ast_409.Parsetree.signature_item = + fun { Ast_408.Parsetree.psig_desc; Ast_408.Parsetree.psig_loc } -> + { + Ast_409.Parsetree.psig_desc = copy_signature_item_desc psig_desc; + Ast_409.Parsetree.psig_loc = copy_location psig_loc; + } + +and copy_signature_item_desc : + Ast_408.Parsetree.signature_item_desc -> + Ast_409.Parsetree.signature_item_desc = function + | Ast_408.Parsetree.Psig_value x0 -> + Ast_409.Parsetree.Psig_value (copy_value_description x0) + | Ast_408.Parsetree.Psig_type (x0, x1) -> + Ast_409.Parsetree.Psig_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | Ast_408.Parsetree.Psig_typesubst x0 -> + Ast_409.Parsetree.Psig_typesubst (List.map copy_type_declaration x0) + | Ast_408.Parsetree.Psig_typext x0 -> + Ast_409.Parsetree.Psig_typext (copy_type_extension x0) + | Ast_408.Parsetree.Psig_exception x0 -> + Ast_409.Parsetree.Psig_exception (copy_type_exception x0) + | Ast_408.Parsetree.Psig_module x0 -> + Ast_409.Parsetree.Psig_module (copy_module_declaration x0) + | Ast_408.Parsetree.Psig_modsubst x0 -> + Ast_409.Parsetree.Psig_modsubst (copy_module_substitution x0) + | Ast_408.Parsetree.Psig_recmodule x0 -> + Ast_409.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) + | Ast_408.Parsetree.Psig_modtype x0 -> + Ast_409.Parsetree.Psig_modtype (copy_module_type_declaration x0) + | Ast_408.Parsetree.Psig_open x0 -> + Ast_409.Parsetree.Psig_open (copy_open_description x0) + | Ast_408.Parsetree.Psig_include x0 -> + Ast_409.Parsetree.Psig_include (copy_include_description x0) + | Ast_408.Parsetree.Psig_class x0 -> + Ast_409.Parsetree.Psig_class (List.map copy_class_description x0) + | Ast_408.Parsetree.Psig_class_type x0 -> + Ast_409.Parsetree.Psig_class_type + (List.map copy_class_type_declaration x0) + | Ast_408.Parsetree.Psig_attribute x0 -> + Ast_409.Parsetree.Psig_attribute (copy_attribute x0) + | Ast_408.Parsetree.Psig_extension (x0, x1) -> + Ast_409.Parsetree.Psig_extension (copy_extension x0, copy_attributes x1) + +and copy_class_type_declaration : + Ast_408.Parsetree.class_type_declaration -> + Ast_409.Parsetree.class_type_declaration = + fun x -> copy_class_infos copy_class_type x + +and copy_class_description : + Ast_408.Parsetree.class_description -> Ast_409.Parsetree.class_description = + fun x -> copy_class_infos copy_class_type x + +and copy_class_type : + Ast_408.Parsetree.class_type -> Ast_409.Parsetree.class_type = + fun { + Ast_408.Parsetree.pcty_desc; + Ast_408.Parsetree.pcty_loc; + Ast_408.Parsetree.pcty_attributes; + } -> + { + Ast_409.Parsetree.pcty_desc = copy_class_type_desc pcty_desc; + Ast_409.Parsetree.pcty_loc = copy_location pcty_loc; + Ast_409.Parsetree.pcty_attributes = copy_attributes pcty_attributes; + } + +and copy_class_type_desc : + Ast_408.Parsetree.class_type_desc -> Ast_409.Parsetree.class_type_desc = + function + | Ast_408.Parsetree.Pcty_constr (x0, x1) -> + Ast_409.Parsetree.Pcty_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_408.Parsetree.Pcty_signature x0 -> + Ast_409.Parsetree.Pcty_signature (copy_class_signature x0) + | Ast_408.Parsetree.Pcty_arrow (x0, x1, x2) -> + Ast_409.Parsetree.Pcty_arrow + (copy_arg_label x0, copy_core_type x1, copy_class_type x2) + | Ast_408.Parsetree.Pcty_extension x0 -> + Ast_409.Parsetree.Pcty_extension (copy_extension x0) + | Ast_408.Parsetree.Pcty_open (x0, x1) -> + Ast_409.Parsetree.Pcty_open (copy_open_description x0, copy_class_type x1) + +and copy_class_signature : + Ast_408.Parsetree.class_signature -> Ast_409.Parsetree.class_signature = + fun { Ast_408.Parsetree.pcsig_self; Ast_408.Parsetree.pcsig_fields } -> + { + Ast_409.Parsetree.pcsig_self = copy_core_type pcsig_self; + Ast_409.Parsetree.pcsig_fields = List.map copy_class_type_field pcsig_fields; + } + +and copy_class_type_field : + Ast_408.Parsetree.class_type_field -> Ast_409.Parsetree.class_type_field = + fun { + Ast_408.Parsetree.pctf_desc; + Ast_408.Parsetree.pctf_loc; + Ast_408.Parsetree.pctf_attributes; + } -> + { + Ast_409.Parsetree.pctf_desc = copy_class_type_field_desc pctf_desc; + Ast_409.Parsetree.pctf_loc = copy_location pctf_loc; + Ast_409.Parsetree.pctf_attributes = copy_attributes pctf_attributes; + } + +and copy_class_type_field_desc : + Ast_408.Parsetree.class_type_field_desc -> + Ast_409.Parsetree.class_type_field_desc = function + | Ast_408.Parsetree.Pctf_inherit x0 -> + Ast_409.Parsetree.Pctf_inherit (copy_class_type x0) + | Ast_408.Parsetree.Pctf_val x0 -> + Ast_409.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_408.Parsetree.Pctf_method x0 -> + Ast_409.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_408.Parsetree.Pctf_constraint x0 -> + Ast_409.Parsetree.Pctf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | Ast_408.Parsetree.Pctf_attribute x0 -> + Ast_409.Parsetree.Pctf_attribute (copy_attribute x0) + | Ast_408.Parsetree.Pctf_extension x0 -> + Ast_409.Parsetree.Pctf_extension (copy_extension x0) + +and copy_extension : Ast_408.Parsetree.extension -> Ast_409.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_408.Parsetree.class_infos -> + 'g0 Ast_409.Parsetree.class_infos = + fun f0 + { + Ast_408.Parsetree.pci_virt; + Ast_408.Parsetree.pci_params; + Ast_408.Parsetree.pci_name; + Ast_408.Parsetree.pci_expr; + Ast_408.Parsetree.pci_loc; + Ast_408.Parsetree.pci_attributes; + } -> + { + Ast_409.Parsetree.pci_virt = copy_virtual_flag pci_virt; + Ast_409.Parsetree.pci_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + pci_params; + Ast_409.Parsetree.pci_name = copy_loc (fun x -> x) pci_name; + Ast_409.Parsetree.pci_expr = f0 pci_expr; + Ast_409.Parsetree.pci_loc = copy_location pci_loc; + Ast_409.Parsetree.pci_attributes = copy_attributes pci_attributes; + } + +and copy_virtual_flag : + Ast_408.Asttypes.virtual_flag -> Ast_409.Asttypes.virtual_flag = function + | Ast_408.Asttypes.Virtual -> Ast_409.Asttypes.Virtual + | Ast_408.Asttypes.Concrete -> Ast_409.Asttypes.Concrete + +and copy_include_description : + Ast_408.Parsetree.include_description -> + Ast_409.Parsetree.include_description = + fun x -> copy_include_infos copy_module_type x + +and copy_include_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 Ast_408.Parsetree.include_infos -> + 'g0 Ast_409.Parsetree.include_infos = + fun f0 + { + Ast_408.Parsetree.pincl_mod; + Ast_408.Parsetree.pincl_loc; + Ast_408.Parsetree.pincl_attributes; + } -> + { + Ast_409.Parsetree.pincl_mod = f0 pincl_mod; + Ast_409.Parsetree.pincl_loc = copy_location pincl_loc; + Ast_409.Parsetree.pincl_attributes = copy_attributes pincl_attributes; + } + +and copy_open_description : + Ast_408.Parsetree.open_description -> Ast_409.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_408.Parsetree.open_infos -> + 'g0 Ast_409.Parsetree.open_infos = + fun f0 + { + Ast_408.Parsetree.popen_expr; + Ast_408.Parsetree.popen_override; + Ast_408.Parsetree.popen_loc; + Ast_408.Parsetree.popen_attributes; + } -> + { + Ast_409.Parsetree.popen_expr = f0 popen_expr; + Ast_409.Parsetree.popen_override = copy_override_flag popen_override; + Ast_409.Parsetree.popen_loc = copy_location popen_loc; + Ast_409.Parsetree.popen_attributes = copy_attributes popen_attributes; + } + +and copy_override_flag : + Ast_408.Asttypes.override_flag -> Ast_409.Asttypes.override_flag = function + | Ast_408.Asttypes.Override -> Ast_409.Asttypes.Override + | Ast_408.Asttypes.Fresh -> Ast_409.Asttypes.Fresh + +and copy_module_type_declaration : + Ast_408.Parsetree.module_type_declaration -> + Ast_409.Parsetree.module_type_declaration = + fun { + Ast_408.Parsetree.pmtd_name; + Ast_408.Parsetree.pmtd_type; + Ast_408.Parsetree.pmtd_attributes; + Ast_408.Parsetree.pmtd_loc; + } -> + { + Ast_409.Parsetree.pmtd_name = copy_loc (fun x -> x) pmtd_name; + Ast_409.Parsetree.pmtd_type = Option.map copy_module_type pmtd_type; + Ast_409.Parsetree.pmtd_attributes = copy_attributes pmtd_attributes; + Ast_409.Parsetree.pmtd_loc = copy_location pmtd_loc; + } + +and copy_module_substitution : + Ast_408.Parsetree.module_substitution -> + Ast_409.Parsetree.module_substitution = + fun { + Ast_408.Parsetree.pms_name; + Ast_408.Parsetree.pms_manifest; + Ast_408.Parsetree.pms_attributes; + Ast_408.Parsetree.pms_loc; + } -> + { + Ast_409.Parsetree.pms_name = copy_loc (fun x -> x) pms_name; + Ast_409.Parsetree.pms_manifest = copy_loc copy_Longident_t pms_manifest; + Ast_409.Parsetree.pms_attributes = copy_attributes pms_attributes; + Ast_409.Parsetree.pms_loc = copy_location pms_loc; + } + +and copy_module_declaration : + Ast_408.Parsetree.module_declaration -> Ast_409.Parsetree.module_declaration + = + fun { + Ast_408.Parsetree.pmd_name; + Ast_408.Parsetree.pmd_type; + Ast_408.Parsetree.pmd_attributes; + Ast_408.Parsetree.pmd_loc; + } -> + { + Ast_409.Parsetree.pmd_name = copy_loc (fun x -> x) pmd_name; + Ast_409.Parsetree.pmd_type = copy_module_type pmd_type; + Ast_409.Parsetree.pmd_attributes = copy_attributes pmd_attributes; + Ast_409.Parsetree.pmd_loc = copy_location pmd_loc; + } + +and copy_type_exception : + Ast_408.Parsetree.type_exception -> Ast_409.Parsetree.type_exception = + fun { + Ast_408.Parsetree.ptyexn_constructor; + Ast_408.Parsetree.ptyexn_loc; + Ast_408.Parsetree.ptyexn_attributes; + } -> + { + Ast_409.Parsetree.ptyexn_constructor = + copy_extension_constructor ptyexn_constructor; + Ast_409.Parsetree.ptyexn_loc = copy_location ptyexn_loc; + Ast_409.Parsetree.ptyexn_attributes = copy_attributes ptyexn_attributes; + } + +and copy_type_extension : + Ast_408.Parsetree.type_extension -> Ast_409.Parsetree.type_extension = + fun { + Ast_408.Parsetree.ptyext_path; + Ast_408.Parsetree.ptyext_params; + Ast_408.Parsetree.ptyext_constructors; + Ast_408.Parsetree.ptyext_private; + Ast_408.Parsetree.ptyext_loc; + Ast_408.Parsetree.ptyext_attributes; + } -> + { + Ast_409.Parsetree.ptyext_path = copy_loc copy_Longident_t ptyext_path; + Ast_409.Parsetree.ptyext_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptyext_params; + Ast_409.Parsetree.ptyext_constructors = + List.map copy_extension_constructor ptyext_constructors; + Ast_409.Parsetree.ptyext_private = copy_private_flag ptyext_private; + Ast_409.Parsetree.ptyext_loc = copy_location ptyext_loc; + Ast_409.Parsetree.ptyext_attributes = copy_attributes ptyext_attributes; + } + +and copy_extension_constructor : + Ast_408.Parsetree.extension_constructor -> + Ast_409.Parsetree.extension_constructor = + fun { + Ast_408.Parsetree.pext_name; + Ast_408.Parsetree.pext_kind; + Ast_408.Parsetree.pext_loc; + Ast_408.Parsetree.pext_attributes; + } -> + { + Ast_409.Parsetree.pext_name = copy_loc (fun x -> x) pext_name; + Ast_409.Parsetree.pext_kind = copy_extension_constructor_kind pext_kind; + Ast_409.Parsetree.pext_loc = copy_location pext_loc; + Ast_409.Parsetree.pext_attributes = copy_attributes pext_attributes; + } + +and copy_extension_constructor_kind : + Ast_408.Parsetree.extension_constructor_kind -> + Ast_409.Parsetree.extension_constructor_kind = function + | Ast_408.Parsetree.Pext_decl (x0, x1) -> + Ast_409.Parsetree.Pext_decl + (copy_constructor_arguments x0, Option.map copy_core_type x1) + | Ast_408.Parsetree.Pext_rebind x0 -> + Ast_409.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0) + +and copy_type_declaration : + Ast_408.Parsetree.type_declaration -> Ast_409.Parsetree.type_declaration = + fun { + Ast_408.Parsetree.ptype_name; + Ast_408.Parsetree.ptype_params; + Ast_408.Parsetree.ptype_cstrs; + Ast_408.Parsetree.ptype_kind; + Ast_408.Parsetree.ptype_private; + Ast_408.Parsetree.ptype_manifest; + Ast_408.Parsetree.ptype_attributes; + Ast_408.Parsetree.ptype_loc; + } -> + { + Ast_409.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name; + Ast_409.Parsetree.ptype_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptype_params; + Ast_409.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_409.Parsetree.ptype_kind = copy_type_kind ptype_kind; + Ast_409.Parsetree.ptype_private = copy_private_flag ptype_private; + Ast_409.Parsetree.ptype_manifest = Option.map copy_core_type ptype_manifest; + Ast_409.Parsetree.ptype_attributes = copy_attributes ptype_attributes; + Ast_409.Parsetree.ptype_loc = copy_location ptype_loc; + } + +and copy_private_flag : + Ast_408.Asttypes.private_flag -> Ast_409.Asttypes.private_flag = function + | Ast_408.Asttypes.Private -> Ast_409.Asttypes.Private + | Ast_408.Asttypes.Public -> Ast_409.Asttypes.Public + +and copy_type_kind : Ast_408.Parsetree.type_kind -> Ast_409.Parsetree.type_kind + = function + | Ast_408.Parsetree.Ptype_abstract -> Ast_409.Parsetree.Ptype_abstract + | Ast_408.Parsetree.Ptype_variant x0 -> + Ast_409.Parsetree.Ptype_variant (List.map copy_constructor_declaration x0) + | Ast_408.Parsetree.Ptype_record x0 -> + Ast_409.Parsetree.Ptype_record (List.map copy_label_declaration x0) + | Ast_408.Parsetree.Ptype_open -> Ast_409.Parsetree.Ptype_open + +and copy_constructor_declaration : + Ast_408.Parsetree.constructor_declaration -> + Ast_409.Parsetree.constructor_declaration = + fun { + Ast_408.Parsetree.pcd_name; + Ast_408.Parsetree.pcd_args; + Ast_408.Parsetree.pcd_res; + Ast_408.Parsetree.pcd_loc; + Ast_408.Parsetree.pcd_attributes; + } -> + { + Ast_409.Parsetree.pcd_name = copy_loc (fun x -> x) pcd_name; + Ast_409.Parsetree.pcd_args = copy_constructor_arguments pcd_args; + Ast_409.Parsetree.pcd_res = Option.map copy_core_type pcd_res; + Ast_409.Parsetree.pcd_loc = copy_location pcd_loc; + Ast_409.Parsetree.pcd_attributes = copy_attributes pcd_attributes; + } + +and copy_constructor_arguments : + Ast_408.Parsetree.constructor_arguments -> + Ast_409.Parsetree.constructor_arguments = function + | Ast_408.Parsetree.Pcstr_tuple x0 -> + Ast_409.Parsetree.Pcstr_tuple (List.map copy_core_type x0) + | Ast_408.Parsetree.Pcstr_record x0 -> + Ast_409.Parsetree.Pcstr_record (List.map copy_label_declaration x0) + +and copy_label_declaration : + Ast_408.Parsetree.label_declaration -> Ast_409.Parsetree.label_declaration = + fun { + Ast_408.Parsetree.pld_name; + Ast_408.Parsetree.pld_mutable; + Ast_408.Parsetree.pld_type; + Ast_408.Parsetree.pld_loc; + Ast_408.Parsetree.pld_attributes; + } -> + { + Ast_409.Parsetree.pld_name = copy_loc (fun x -> x) pld_name; + Ast_409.Parsetree.pld_mutable = copy_mutable_flag pld_mutable; + Ast_409.Parsetree.pld_type = copy_core_type pld_type; + Ast_409.Parsetree.pld_loc = copy_location pld_loc; + Ast_409.Parsetree.pld_attributes = copy_attributes pld_attributes; + } + +and copy_mutable_flag : + Ast_408.Asttypes.mutable_flag -> Ast_409.Asttypes.mutable_flag = function + | Ast_408.Asttypes.Immutable -> Ast_409.Asttypes.Immutable + | Ast_408.Asttypes.Mutable -> Ast_409.Asttypes.Mutable + +and copy_variance : Ast_408.Asttypes.variance -> Ast_409.Asttypes.variance = + function + | Ast_408.Asttypes.Covariant -> Ast_409.Asttypes.Covariant + | Ast_408.Asttypes.Contravariant -> Ast_409.Asttypes.Contravariant + | Ast_408.Asttypes.Invariant -> Ast_409.Asttypes.Invariant + +and copy_value_description : + Ast_408.Parsetree.value_description -> Ast_409.Parsetree.value_description = + fun { + Ast_408.Parsetree.pval_name; + Ast_408.Parsetree.pval_type; + Ast_408.Parsetree.pval_prim; + Ast_408.Parsetree.pval_attributes; + Ast_408.Parsetree.pval_loc; + } -> + { + Ast_409.Parsetree.pval_name = copy_loc (fun x -> x) pval_name; + Ast_409.Parsetree.pval_type = copy_core_type pval_type; + Ast_409.Parsetree.pval_prim = List.map (fun x -> x) pval_prim; + Ast_409.Parsetree.pval_attributes = copy_attributes pval_attributes; + Ast_409.Parsetree.pval_loc = copy_location pval_loc; + } + +and copy_object_field_desc : + Ast_408.Parsetree.object_field_desc -> Ast_409.Parsetree.object_field_desc = + function + | Ast_408.Parsetree.Otag (x0, x1) -> + Ast_409.Parsetree.Otag (copy_loc copy_label x0, copy_core_type x1) + | Ast_408.Parsetree.Oinherit x0 -> + Ast_409.Parsetree.Oinherit (copy_core_type x0) + +and copy_arg_label : Ast_408.Asttypes.arg_label -> Ast_409.Asttypes.arg_label = + function + | Ast_408.Asttypes.Nolabel -> Ast_409.Asttypes.Nolabel + | Ast_408.Asttypes.Labelled x0 -> Ast_409.Asttypes.Labelled x0 + | Ast_408.Asttypes.Optional x0 -> Ast_409.Asttypes.Optional x0 + +and copy_closed_flag : + Ast_408.Asttypes.closed_flag -> Ast_409.Asttypes.closed_flag = function + | Ast_408.Asttypes.Closed -> Ast_409.Asttypes.Closed + | Ast_408.Asttypes.Open -> Ast_409.Asttypes.Open + +and copy_label : Ast_408.Asttypes.label -> Ast_409.Asttypes.label = fun x -> x + +and copy_rec_flag : Ast_408.Asttypes.rec_flag -> Ast_409.Asttypes.rec_flag = + function + | Ast_408.Asttypes.Nonrecursive -> Ast_409.Asttypes.Nonrecursive + | Ast_408.Asttypes.Recursive -> Ast_409.Asttypes.Recursive + +and copy_constant : Ast_408.Parsetree.constant -> Ast_409.Parsetree.constant = + function + | Ast_408.Parsetree.Pconst_integer (x0, x1) -> + Ast_409.Parsetree.Pconst_integer (x0, Option.map (fun x -> x) x1) + | Ast_408.Parsetree.Pconst_char x0 -> Ast_409.Parsetree.Pconst_char x0 + | Ast_408.Parsetree.Pconst_string (x0, x1) -> + Ast_409.Parsetree.Pconst_string (x0, Option.map (fun x -> x) x1) + | Ast_408.Parsetree.Pconst_float (x0, x1) -> + Ast_409.Parsetree.Pconst_float (x0, Option.map (fun x -> x) x1) + +and copy_Longident_t : Longident.t -> Longident.t = fun x -> x + +and copy_loc : + 'f0 'g0. + ('f0 -> 'g0) -> 'f0 Ast_408.Asttypes.loc -> 'g0 Ast_409.Asttypes.loc = + fun f0 { Ast_408.Asttypes.txt; Ast_408.Asttypes.loc } -> + { Ast_409.Asttypes.txt = f0 txt; Ast_409.Asttypes.loc = copy_location loc } + +and copy_location : Location.t -> Location.t = fun x -> x diff -Nru ppxlib-0.15.0/astlib/migrate_409_408.ml ppxlib-0.24.0/astlib/migrate_409_408.ml --- ppxlib-0.15.0/astlib/migrate_409_408.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/migrate_409_408.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1185 @@ +open Stdlib0 +module From = Ast_409 +module To = Ast_408 + +let rec copy_toplevel_phrase : + Ast_409.Parsetree.toplevel_phrase -> Ast_408.Parsetree.toplevel_phrase = + function + | Ast_409.Parsetree.Ptop_def x0 -> + Ast_408.Parsetree.Ptop_def (copy_structure x0) + | Ast_409.Parsetree.Ptop_dir x0 -> + Ast_408.Parsetree.Ptop_dir (copy_toplevel_directive x0) + +and copy_toplevel_directive : + Ast_409.Parsetree.toplevel_directive -> Ast_408.Parsetree.toplevel_directive + = + fun { + Ast_409.Parsetree.pdir_name; + Ast_409.Parsetree.pdir_arg; + Ast_409.Parsetree.pdir_loc; + } -> + { + Ast_408.Parsetree.pdir_name = copy_loc (fun x -> x) pdir_name; + Ast_408.Parsetree.pdir_arg = Option.map copy_directive_argument pdir_arg; + Ast_408.Parsetree.pdir_loc = copy_location pdir_loc; + } + +and copy_directive_argument : + Ast_409.Parsetree.directive_argument -> Ast_408.Parsetree.directive_argument + = + fun { Ast_409.Parsetree.pdira_desc; Ast_409.Parsetree.pdira_loc } -> + { + Ast_408.Parsetree.pdira_desc = copy_directive_argument_desc pdira_desc; + Ast_408.Parsetree.pdira_loc = copy_location pdira_loc; + } + +and copy_directive_argument_desc : + Ast_409.Parsetree.directive_argument_desc -> + Ast_408.Parsetree.directive_argument_desc = function + | Ast_409.Parsetree.Pdir_string x0 -> Ast_408.Parsetree.Pdir_string x0 + | Ast_409.Parsetree.Pdir_int (x0, x1) -> + Ast_408.Parsetree.Pdir_int (x0, Option.map (fun x -> x) x1) + | Ast_409.Parsetree.Pdir_ident x0 -> + Ast_408.Parsetree.Pdir_ident (copy_Longident_t x0) + | Ast_409.Parsetree.Pdir_bool x0 -> Ast_408.Parsetree.Pdir_bool x0 + +and copy_typ : Ast_409.Parsetree.typ -> Ast_408.Parsetree.typ = + fun x -> copy_core_type x + +and copy_pat : Ast_409.Parsetree.pat -> Ast_408.Parsetree.pat = + fun x -> copy_pattern x + +and copy_expr : Ast_409.Parsetree.expr -> Ast_408.Parsetree.expr = + fun x -> copy_expression x + +and copy_expression : + Ast_409.Parsetree.expression -> Ast_408.Parsetree.expression = + fun { + Ast_409.Parsetree.pexp_desc; + Ast_409.Parsetree.pexp_loc; + Ast_409.Parsetree.pexp_loc_stack; + Ast_409.Parsetree.pexp_attributes; + } -> + { + Ast_408.Parsetree.pexp_desc = copy_expression_desc pexp_desc; + Ast_408.Parsetree.pexp_loc = copy_location pexp_loc; + Ast_408.Parsetree.pexp_loc_stack = List.map copy_location pexp_loc_stack; + Ast_408.Parsetree.pexp_attributes = copy_attributes pexp_attributes; + } + +and copy_expression_desc : + Ast_409.Parsetree.expression_desc -> Ast_408.Parsetree.expression_desc = + function + | Ast_409.Parsetree.Pexp_ident x0 -> + Ast_408.Parsetree.Pexp_ident (copy_loc copy_Longident_t x0) + | Ast_409.Parsetree.Pexp_constant x0 -> + Ast_408.Parsetree.Pexp_constant (copy_constant x0) + | Ast_409.Parsetree.Pexp_let (x0, x1, x2) -> + Ast_408.Parsetree.Pexp_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_expression x2) + | Ast_409.Parsetree.Pexp_function x0 -> + Ast_408.Parsetree.Pexp_function (copy_cases x0) + | Ast_409.Parsetree.Pexp_fun (x0, x1, x2, x3) -> + Ast_408.Parsetree.Pexp_fun + ( copy_arg_label x0, + Option.map copy_expression x1, + copy_pattern x2, + copy_expression x3 ) + | Ast_409.Parsetree.Pexp_apply (x0, x1) -> + Ast_408.Parsetree.Pexp_apply + ( copy_expression x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | Ast_409.Parsetree.Pexp_match (x0, x1) -> + Ast_408.Parsetree.Pexp_match (copy_expression x0, copy_cases x1) + | Ast_409.Parsetree.Pexp_try (x0, x1) -> + Ast_408.Parsetree.Pexp_try (copy_expression x0, copy_cases x1) + | Ast_409.Parsetree.Pexp_tuple x0 -> + Ast_408.Parsetree.Pexp_tuple (List.map copy_expression x0) + | Ast_409.Parsetree.Pexp_construct (x0, x1) -> + Ast_408.Parsetree.Pexp_construct + (copy_loc copy_Longident_t x0, Option.map copy_expression x1) + | Ast_409.Parsetree.Pexp_variant (x0, x1) -> + Ast_408.Parsetree.Pexp_variant + (copy_label x0, Option.map copy_expression x1) + | Ast_409.Parsetree.Pexp_record (x0, x1) -> + Ast_408.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_409.Parsetree.Pexp_field (x0, x1) -> + Ast_408.Parsetree.Pexp_field + (copy_expression x0, copy_loc copy_Longident_t x1) + | Ast_409.Parsetree.Pexp_setfield (x0, x1, x2) -> + Ast_408.Parsetree.Pexp_setfield + (copy_expression x0, copy_loc copy_Longident_t x1, copy_expression x2) + | Ast_409.Parsetree.Pexp_array x0 -> + Ast_408.Parsetree.Pexp_array (List.map copy_expression x0) + | Ast_409.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> + Ast_408.Parsetree.Pexp_ifthenelse + (copy_expression x0, copy_expression x1, Option.map copy_expression x2) + | Ast_409.Parsetree.Pexp_sequence (x0, x1) -> + Ast_408.Parsetree.Pexp_sequence (copy_expression x0, copy_expression x1) + | Ast_409.Parsetree.Pexp_while (x0, x1) -> + Ast_408.Parsetree.Pexp_while (copy_expression x0, copy_expression x1) + | Ast_409.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> + Ast_408.Parsetree.Pexp_for + ( copy_pattern x0, + copy_expression x1, + copy_expression x2, + copy_direction_flag x3, + copy_expression x4 ) + | Ast_409.Parsetree.Pexp_constraint (x0, x1) -> + Ast_408.Parsetree.Pexp_constraint (copy_expression x0, copy_core_type x1) + | Ast_409.Parsetree.Pexp_coerce (x0, x1, x2) -> + Ast_408.Parsetree.Pexp_coerce + (copy_expression x0, Option.map copy_core_type x1, copy_core_type x2) + | Ast_409.Parsetree.Pexp_send (x0, x1) -> + Ast_408.Parsetree.Pexp_send (copy_expression x0, copy_loc copy_label x1) + | Ast_409.Parsetree.Pexp_new x0 -> + Ast_408.Parsetree.Pexp_new (copy_loc copy_Longident_t x0) + | Ast_409.Parsetree.Pexp_setinstvar (x0, x1) -> + Ast_408.Parsetree.Pexp_setinstvar + (copy_loc copy_label x0, copy_expression x1) + | Ast_409.Parsetree.Pexp_override x0 -> + Ast_408.Parsetree.Pexp_override + (List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_label x0, copy_expression x1)) + x0) + | Ast_409.Parsetree.Pexp_letmodule (x0, x1, x2) -> + Ast_408.Parsetree.Pexp_letmodule + (copy_loc (fun x -> x) x0, copy_module_expr x1, copy_expression x2) + | Ast_409.Parsetree.Pexp_letexception (x0, x1) -> + Ast_408.Parsetree.Pexp_letexception + (copy_extension_constructor x0, copy_expression x1) + | Ast_409.Parsetree.Pexp_assert x0 -> + Ast_408.Parsetree.Pexp_assert (copy_expression x0) + | Ast_409.Parsetree.Pexp_lazy x0 -> + Ast_408.Parsetree.Pexp_lazy (copy_expression x0) + | Ast_409.Parsetree.Pexp_poly (x0, x1) -> + Ast_408.Parsetree.Pexp_poly + (copy_expression x0, Option.map copy_core_type x1) + | Ast_409.Parsetree.Pexp_object x0 -> + Ast_408.Parsetree.Pexp_object (copy_class_structure x0) + | Ast_409.Parsetree.Pexp_newtype (x0, x1) -> + Ast_408.Parsetree.Pexp_newtype + (copy_loc (fun x -> x) x0, copy_expression x1) + | Ast_409.Parsetree.Pexp_pack x0 -> + Ast_408.Parsetree.Pexp_pack (copy_module_expr x0) + | Ast_409.Parsetree.Pexp_open (x0, x1) -> + Ast_408.Parsetree.Pexp_open (copy_open_declaration x0, copy_expression x1) + | Ast_409.Parsetree.Pexp_letop x0 -> + Ast_408.Parsetree.Pexp_letop (copy_letop x0) + | Ast_409.Parsetree.Pexp_extension x0 -> + Ast_408.Parsetree.Pexp_extension (copy_extension x0) + | Ast_409.Parsetree.Pexp_unreachable -> Ast_408.Parsetree.Pexp_unreachable + +and copy_letop : Ast_409.Parsetree.letop -> Ast_408.Parsetree.letop = + fun { Ast_409.Parsetree.let_; Ast_409.Parsetree.ands; Ast_409.Parsetree.body } -> + { + Ast_408.Parsetree.let_ = copy_binding_op let_; + Ast_408.Parsetree.ands = List.map copy_binding_op ands; + Ast_408.Parsetree.body = copy_expression body; + } + +and copy_binding_op : + Ast_409.Parsetree.binding_op -> Ast_408.Parsetree.binding_op = + fun { + Ast_409.Parsetree.pbop_op; + Ast_409.Parsetree.pbop_pat; + Ast_409.Parsetree.pbop_exp; + Ast_409.Parsetree.pbop_loc; + } -> + { + Ast_408.Parsetree.pbop_op = copy_loc (fun x -> x) pbop_op; + Ast_408.Parsetree.pbop_pat = copy_pattern pbop_pat; + Ast_408.Parsetree.pbop_exp = copy_expression pbop_exp; + Ast_408.Parsetree.pbop_loc = copy_location pbop_loc; + } + +and copy_direction_flag : + Ast_409.Asttypes.direction_flag -> Ast_408.Asttypes.direction_flag = + function + | Ast_409.Asttypes.Upto -> Ast_408.Asttypes.Upto + | Ast_409.Asttypes.Downto -> Ast_408.Asttypes.Downto + +and copy_cases : Ast_409.Parsetree.cases -> Ast_408.Parsetree.cases = + fun x -> List.map copy_case x + +and copy_case : Ast_409.Parsetree.case -> Ast_408.Parsetree.case = + fun { + Ast_409.Parsetree.pc_lhs; + Ast_409.Parsetree.pc_guard; + Ast_409.Parsetree.pc_rhs; + } -> + { + Ast_408.Parsetree.pc_lhs = copy_pattern pc_lhs; + Ast_408.Parsetree.pc_guard = Option.map copy_expression pc_guard; + Ast_408.Parsetree.pc_rhs = copy_expression pc_rhs; + } + +and copy_value_binding : + Ast_409.Parsetree.value_binding -> Ast_408.Parsetree.value_binding = + fun { + Ast_409.Parsetree.pvb_pat; + Ast_409.Parsetree.pvb_expr; + Ast_409.Parsetree.pvb_attributes; + Ast_409.Parsetree.pvb_loc; + } -> + { + Ast_408.Parsetree.pvb_pat = copy_pattern pvb_pat; + Ast_408.Parsetree.pvb_expr = copy_expression pvb_expr; + Ast_408.Parsetree.pvb_attributes = copy_attributes pvb_attributes; + Ast_408.Parsetree.pvb_loc = copy_location pvb_loc; + } + +and copy_pattern : Ast_409.Parsetree.pattern -> Ast_408.Parsetree.pattern = + fun { + Ast_409.Parsetree.ppat_desc; + Ast_409.Parsetree.ppat_loc; + Ast_409.Parsetree.ppat_loc_stack; + Ast_409.Parsetree.ppat_attributes; + } -> + { + Ast_408.Parsetree.ppat_desc = copy_pattern_desc ppat_desc; + Ast_408.Parsetree.ppat_loc = copy_location ppat_loc; + Ast_408.Parsetree.ppat_loc_stack = List.map copy_location ppat_loc_stack; + Ast_408.Parsetree.ppat_attributes = copy_attributes ppat_attributes; + } + +and copy_pattern_desc : + Ast_409.Parsetree.pattern_desc -> Ast_408.Parsetree.pattern_desc = function + | Ast_409.Parsetree.Ppat_any -> Ast_408.Parsetree.Ppat_any + | Ast_409.Parsetree.Ppat_var x0 -> + Ast_408.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) + | Ast_409.Parsetree.Ppat_alias (x0, x1) -> + Ast_408.Parsetree.Ppat_alias (copy_pattern x0, copy_loc (fun x -> x) x1) + | Ast_409.Parsetree.Ppat_constant x0 -> + Ast_408.Parsetree.Ppat_constant (copy_constant x0) + | Ast_409.Parsetree.Ppat_interval (x0, x1) -> + Ast_408.Parsetree.Ppat_interval (copy_constant x0, copy_constant x1) + | Ast_409.Parsetree.Ppat_tuple x0 -> + Ast_408.Parsetree.Ppat_tuple (List.map copy_pattern x0) + | Ast_409.Parsetree.Ppat_construct (x0, x1) -> + Ast_408.Parsetree.Ppat_construct + (copy_loc copy_Longident_t x0, Option.map copy_pattern x1) + | Ast_409.Parsetree.Ppat_variant (x0, x1) -> + Ast_408.Parsetree.Ppat_variant (copy_label x0, Option.map copy_pattern x1) + | Ast_409.Parsetree.Ppat_record (x0, x1) -> + Ast_408.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_409.Parsetree.Ppat_array x0 -> + Ast_408.Parsetree.Ppat_array (List.map copy_pattern x0) + | Ast_409.Parsetree.Ppat_or (x0, x1) -> + Ast_408.Parsetree.Ppat_or (copy_pattern x0, copy_pattern x1) + | Ast_409.Parsetree.Ppat_constraint (x0, x1) -> + Ast_408.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1) + | Ast_409.Parsetree.Ppat_type x0 -> + Ast_408.Parsetree.Ppat_type (copy_loc copy_Longident_t x0) + | Ast_409.Parsetree.Ppat_lazy x0 -> + Ast_408.Parsetree.Ppat_lazy (copy_pattern x0) + | Ast_409.Parsetree.Ppat_unpack x0 -> + Ast_408.Parsetree.Ppat_unpack (copy_loc (fun x -> x) x0) + | Ast_409.Parsetree.Ppat_exception x0 -> + Ast_408.Parsetree.Ppat_exception (copy_pattern x0) + | Ast_409.Parsetree.Ppat_extension x0 -> + Ast_408.Parsetree.Ppat_extension (copy_extension x0) + | Ast_409.Parsetree.Ppat_open (x0, x1) -> + Ast_408.Parsetree.Ppat_open (copy_loc copy_Longident_t x0, copy_pattern x1) + +and copy_core_type : Ast_409.Parsetree.core_type -> Ast_408.Parsetree.core_type + = + fun { + Ast_409.Parsetree.ptyp_desc; + Ast_409.Parsetree.ptyp_loc; + Ast_409.Parsetree.ptyp_loc_stack; + Ast_409.Parsetree.ptyp_attributes; + } -> + { + Ast_408.Parsetree.ptyp_desc = copy_core_type_desc ptyp_desc; + Ast_408.Parsetree.ptyp_loc = copy_location ptyp_loc; + Ast_408.Parsetree.ptyp_loc_stack = List.map copy_location ptyp_loc_stack; + Ast_408.Parsetree.ptyp_attributes = copy_attributes ptyp_attributes; + } + +and copy_core_type_desc : + Ast_409.Parsetree.core_type_desc -> Ast_408.Parsetree.core_type_desc = + function + | Ast_409.Parsetree.Ptyp_any -> Ast_408.Parsetree.Ptyp_any + | Ast_409.Parsetree.Ptyp_var x0 -> Ast_408.Parsetree.Ptyp_var x0 + | Ast_409.Parsetree.Ptyp_arrow (x0, x1, x2) -> + Ast_408.Parsetree.Ptyp_arrow + (copy_arg_label x0, copy_core_type x1, copy_core_type x2) + | Ast_409.Parsetree.Ptyp_tuple x0 -> + Ast_408.Parsetree.Ptyp_tuple (List.map copy_core_type x0) + | Ast_409.Parsetree.Ptyp_constr (x0, x1) -> + Ast_408.Parsetree.Ptyp_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_409.Parsetree.Ptyp_object (x0, x1) -> + Ast_408.Parsetree.Ptyp_object + (List.map copy_object_field x0, copy_closed_flag x1) + | Ast_409.Parsetree.Ptyp_class (x0, x1) -> + Ast_408.Parsetree.Ptyp_class + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_409.Parsetree.Ptyp_alias (x0, x1) -> + Ast_408.Parsetree.Ptyp_alias (copy_core_type x0, x1) + | Ast_409.Parsetree.Ptyp_variant (x0, x1, x2) -> + Ast_408.Parsetree.Ptyp_variant + ( List.map copy_row_field x0, + copy_closed_flag x1, + Option.map (fun x -> List.map copy_label x) x2 ) + | Ast_409.Parsetree.Ptyp_poly (x0, x1) -> + Ast_408.Parsetree.Ptyp_poly + (List.map (fun x -> copy_loc (fun x -> x) x) x0, copy_core_type x1) + | Ast_409.Parsetree.Ptyp_package x0 -> + Ast_408.Parsetree.Ptyp_package (copy_package_type x0) + | Ast_409.Parsetree.Ptyp_extension x0 -> + Ast_408.Parsetree.Ptyp_extension (copy_extension x0) + +and copy_package_type : + Ast_409.Parsetree.package_type -> Ast_408.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_409.Parsetree.row_field -> Ast_408.Parsetree.row_field + = + fun { + Ast_409.Parsetree.prf_desc; + Ast_409.Parsetree.prf_loc; + Ast_409.Parsetree.prf_attributes; + } -> + { + Ast_408.Parsetree.prf_desc = copy_row_field_desc prf_desc; + Ast_408.Parsetree.prf_loc = copy_location prf_loc; + Ast_408.Parsetree.prf_attributes = copy_attributes prf_attributes; + } + +and copy_row_field_desc : + Ast_409.Parsetree.row_field_desc -> Ast_408.Parsetree.row_field_desc = + function + | Ast_409.Parsetree.Rtag (x0, x1, x2) -> + Ast_408.Parsetree.Rtag + (copy_loc copy_label x0, x1, List.map copy_core_type x2) + | Ast_409.Parsetree.Rinherit x0 -> + Ast_408.Parsetree.Rinherit (copy_core_type x0) + +and copy_object_field : + Ast_409.Parsetree.object_field -> Ast_408.Parsetree.object_field = + fun { + Ast_409.Parsetree.pof_desc; + Ast_409.Parsetree.pof_loc; + Ast_409.Parsetree.pof_attributes; + } -> + { + Ast_408.Parsetree.pof_desc = copy_object_field_desc pof_desc; + Ast_408.Parsetree.pof_loc = copy_location pof_loc; + Ast_408.Parsetree.pof_attributes = copy_attributes pof_attributes; + } + +and copy_attributes : + Ast_409.Parsetree.attributes -> Ast_408.Parsetree.attributes = + fun x -> List.map copy_attribute x + +and copy_attribute : Ast_409.Parsetree.attribute -> Ast_408.Parsetree.attribute + = + fun { + Ast_409.Parsetree.attr_name; + Ast_409.Parsetree.attr_payload; + Ast_409.Parsetree.attr_loc; + } -> + { + Ast_408.Parsetree.attr_name = copy_loc (fun x -> x) attr_name; + Ast_408.Parsetree.attr_payload = copy_payload attr_payload; + Ast_408.Parsetree.attr_loc = copy_location attr_loc; + } + +and copy_payload : Ast_409.Parsetree.payload -> Ast_408.Parsetree.payload = + function + | Ast_409.Parsetree.PStr x0 -> Ast_408.Parsetree.PStr (copy_structure x0) + | Ast_409.Parsetree.PSig x0 -> Ast_408.Parsetree.PSig (copy_signature x0) + | Ast_409.Parsetree.PTyp x0 -> Ast_408.Parsetree.PTyp (copy_core_type x0) + | Ast_409.Parsetree.PPat (x0, x1) -> + Ast_408.Parsetree.PPat (copy_pattern x0, Option.map copy_expression x1) + +and copy_structure : Ast_409.Parsetree.structure -> Ast_408.Parsetree.structure + = + fun x -> List.map copy_structure_item x + +and copy_structure_item : + Ast_409.Parsetree.structure_item -> Ast_408.Parsetree.structure_item = + fun { Ast_409.Parsetree.pstr_desc; Ast_409.Parsetree.pstr_loc } -> + { + Ast_408.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc; + Ast_408.Parsetree.pstr_loc = copy_location pstr_loc; + } + +and copy_structure_item_desc : + Ast_409.Parsetree.structure_item_desc -> + Ast_408.Parsetree.structure_item_desc = function + | Ast_409.Parsetree.Pstr_eval (x0, x1) -> + Ast_408.Parsetree.Pstr_eval (copy_expression x0, copy_attributes x1) + | Ast_409.Parsetree.Pstr_value (x0, x1) -> + Ast_408.Parsetree.Pstr_value + (copy_rec_flag x0, List.map copy_value_binding x1) + | Ast_409.Parsetree.Pstr_primitive x0 -> + Ast_408.Parsetree.Pstr_primitive (copy_value_description x0) + | Ast_409.Parsetree.Pstr_type (x0, x1) -> + Ast_408.Parsetree.Pstr_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | Ast_409.Parsetree.Pstr_typext x0 -> + Ast_408.Parsetree.Pstr_typext (copy_type_extension x0) + | Ast_409.Parsetree.Pstr_exception x0 -> + Ast_408.Parsetree.Pstr_exception (copy_type_exception x0) + | Ast_409.Parsetree.Pstr_module x0 -> + Ast_408.Parsetree.Pstr_module (copy_module_binding x0) + | Ast_409.Parsetree.Pstr_recmodule x0 -> + Ast_408.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) + | Ast_409.Parsetree.Pstr_modtype x0 -> + Ast_408.Parsetree.Pstr_modtype (copy_module_type_declaration x0) + | Ast_409.Parsetree.Pstr_open x0 -> + Ast_408.Parsetree.Pstr_open (copy_open_declaration x0) + | Ast_409.Parsetree.Pstr_class x0 -> + Ast_408.Parsetree.Pstr_class (List.map copy_class_declaration x0) + | Ast_409.Parsetree.Pstr_class_type x0 -> + Ast_408.Parsetree.Pstr_class_type + (List.map copy_class_type_declaration x0) + | Ast_409.Parsetree.Pstr_include x0 -> + Ast_408.Parsetree.Pstr_include (copy_include_declaration x0) + | Ast_409.Parsetree.Pstr_attribute x0 -> + Ast_408.Parsetree.Pstr_attribute (copy_attribute x0) + | Ast_409.Parsetree.Pstr_extension (x0, x1) -> + Ast_408.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1) + +and copy_include_declaration : + Ast_409.Parsetree.include_declaration -> + Ast_408.Parsetree.include_declaration = + fun x -> copy_include_infos copy_module_expr x + +and copy_class_declaration : + Ast_409.Parsetree.class_declaration -> Ast_408.Parsetree.class_declaration = + fun x -> copy_class_infos copy_class_expr x + +and copy_class_expr : + Ast_409.Parsetree.class_expr -> Ast_408.Parsetree.class_expr = + fun { + Ast_409.Parsetree.pcl_desc; + Ast_409.Parsetree.pcl_loc; + Ast_409.Parsetree.pcl_attributes; + } -> + { + Ast_408.Parsetree.pcl_desc = copy_class_expr_desc pcl_desc; + Ast_408.Parsetree.pcl_loc = copy_location pcl_loc; + Ast_408.Parsetree.pcl_attributes = copy_attributes pcl_attributes; + } + +and copy_class_expr_desc : + Ast_409.Parsetree.class_expr_desc -> Ast_408.Parsetree.class_expr_desc = + function + | Ast_409.Parsetree.Pcl_constr (x0, x1) -> + Ast_408.Parsetree.Pcl_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_409.Parsetree.Pcl_structure x0 -> + Ast_408.Parsetree.Pcl_structure (copy_class_structure x0) + | Ast_409.Parsetree.Pcl_fun (x0, x1, x2, x3) -> + Ast_408.Parsetree.Pcl_fun + ( copy_arg_label x0, + Option.map copy_expression x1, + copy_pattern x2, + copy_class_expr x3 ) + | Ast_409.Parsetree.Pcl_apply (x0, x1) -> + Ast_408.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_409.Parsetree.Pcl_let (x0, x1, x2) -> + Ast_408.Parsetree.Pcl_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_class_expr x2) + | Ast_409.Parsetree.Pcl_constraint (x0, x1) -> + Ast_408.Parsetree.Pcl_constraint (copy_class_expr x0, copy_class_type x1) + | Ast_409.Parsetree.Pcl_extension x0 -> + Ast_408.Parsetree.Pcl_extension (copy_extension x0) + | Ast_409.Parsetree.Pcl_open (x0, x1) -> + Ast_408.Parsetree.Pcl_open (copy_open_description x0, copy_class_expr x1) + +and copy_class_structure : + Ast_409.Parsetree.class_structure -> Ast_408.Parsetree.class_structure = + fun { Ast_409.Parsetree.pcstr_self; Ast_409.Parsetree.pcstr_fields } -> + { + Ast_408.Parsetree.pcstr_self = copy_pattern pcstr_self; + Ast_408.Parsetree.pcstr_fields = List.map copy_class_field pcstr_fields; + } + +and copy_class_field : + Ast_409.Parsetree.class_field -> Ast_408.Parsetree.class_field = + fun { + Ast_409.Parsetree.pcf_desc; + Ast_409.Parsetree.pcf_loc; + Ast_409.Parsetree.pcf_attributes; + } -> + { + Ast_408.Parsetree.pcf_desc = copy_class_field_desc pcf_desc; + Ast_408.Parsetree.pcf_loc = copy_location pcf_loc; + Ast_408.Parsetree.pcf_attributes = copy_attributes pcf_attributes; + } + +and copy_class_field_desc : + Ast_409.Parsetree.class_field_desc -> Ast_408.Parsetree.class_field_desc = + function + | Ast_409.Parsetree.Pcf_inherit (x0, x1, x2) -> + Ast_408.Parsetree.Pcf_inherit + ( copy_override_flag x0, + copy_class_expr x1, + Option.map (fun x -> copy_loc (fun x -> x) x) x2 ) + | Ast_409.Parsetree.Pcf_val x0 -> + Ast_408.Parsetree.Pcf_val + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_mutable_flag x1, copy_class_field_kind x2)) + | Ast_409.Parsetree.Pcf_method x0 -> + Ast_408.Parsetree.Pcf_method + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_private_flag x1, copy_class_field_kind x2)) + | Ast_409.Parsetree.Pcf_constraint x0 -> + Ast_408.Parsetree.Pcf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | Ast_409.Parsetree.Pcf_initializer x0 -> + Ast_408.Parsetree.Pcf_initializer (copy_expression x0) + | Ast_409.Parsetree.Pcf_attribute x0 -> + Ast_408.Parsetree.Pcf_attribute (copy_attribute x0) + | Ast_409.Parsetree.Pcf_extension x0 -> + Ast_408.Parsetree.Pcf_extension (copy_extension x0) + +and copy_class_field_kind : + Ast_409.Parsetree.class_field_kind -> Ast_408.Parsetree.class_field_kind = + function + | Ast_409.Parsetree.Cfk_virtual x0 -> + Ast_408.Parsetree.Cfk_virtual (copy_core_type x0) + | Ast_409.Parsetree.Cfk_concrete (x0, x1) -> + Ast_408.Parsetree.Cfk_concrete (copy_override_flag x0, copy_expression x1) + +and copy_open_declaration : + Ast_409.Parsetree.open_declaration -> Ast_408.Parsetree.open_declaration = + fun x -> copy_open_infos copy_module_expr x + +and copy_module_binding : + Ast_409.Parsetree.module_binding -> Ast_408.Parsetree.module_binding = + fun { + Ast_409.Parsetree.pmb_name; + Ast_409.Parsetree.pmb_expr; + Ast_409.Parsetree.pmb_attributes; + Ast_409.Parsetree.pmb_loc; + } -> + { + Ast_408.Parsetree.pmb_name = copy_loc (fun x -> x) pmb_name; + Ast_408.Parsetree.pmb_expr = copy_module_expr pmb_expr; + Ast_408.Parsetree.pmb_attributes = copy_attributes pmb_attributes; + Ast_408.Parsetree.pmb_loc = copy_location pmb_loc; + } + +and copy_module_expr : + Ast_409.Parsetree.module_expr -> Ast_408.Parsetree.module_expr = + fun { + Ast_409.Parsetree.pmod_desc; + Ast_409.Parsetree.pmod_loc; + Ast_409.Parsetree.pmod_attributes; + } -> + { + Ast_408.Parsetree.pmod_desc = copy_module_expr_desc pmod_desc; + Ast_408.Parsetree.pmod_loc = copy_location pmod_loc; + Ast_408.Parsetree.pmod_attributes = copy_attributes pmod_attributes; + } + +and copy_module_expr_desc : + Ast_409.Parsetree.module_expr_desc -> Ast_408.Parsetree.module_expr_desc = + function + | Ast_409.Parsetree.Pmod_ident x0 -> + Ast_408.Parsetree.Pmod_ident (copy_loc copy_Longident_t x0) + | Ast_409.Parsetree.Pmod_structure x0 -> + Ast_408.Parsetree.Pmod_structure (copy_structure x0) + | Ast_409.Parsetree.Pmod_functor (x0, x1, x2) -> + Ast_408.Parsetree.Pmod_functor + ( copy_loc (fun x -> x) x0, + Option.map copy_module_type x1, + copy_module_expr x2 ) + | Ast_409.Parsetree.Pmod_apply (x0, x1) -> + Ast_408.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) + | Ast_409.Parsetree.Pmod_constraint (x0, x1) -> + Ast_408.Parsetree.Pmod_constraint + (copy_module_expr x0, copy_module_type x1) + | Ast_409.Parsetree.Pmod_unpack x0 -> + Ast_408.Parsetree.Pmod_unpack (copy_expression x0) + | Ast_409.Parsetree.Pmod_extension x0 -> + Ast_408.Parsetree.Pmod_extension (copy_extension x0) + +and copy_module_type : + Ast_409.Parsetree.module_type -> Ast_408.Parsetree.module_type = + fun { + Ast_409.Parsetree.pmty_desc; + Ast_409.Parsetree.pmty_loc; + Ast_409.Parsetree.pmty_attributes; + } -> + { + Ast_408.Parsetree.pmty_desc = copy_module_type_desc pmty_desc; + Ast_408.Parsetree.pmty_loc = copy_location pmty_loc; + Ast_408.Parsetree.pmty_attributes = copy_attributes pmty_attributes; + } + +and copy_module_type_desc : + Ast_409.Parsetree.module_type_desc -> Ast_408.Parsetree.module_type_desc = + function + | Ast_409.Parsetree.Pmty_ident x0 -> + Ast_408.Parsetree.Pmty_ident (copy_loc copy_Longident_t x0) + | Ast_409.Parsetree.Pmty_signature x0 -> + Ast_408.Parsetree.Pmty_signature (copy_signature x0) + | Ast_409.Parsetree.Pmty_functor (x0, x1, x2) -> + Ast_408.Parsetree.Pmty_functor + ( copy_loc (fun x -> x) x0, + Option.map copy_module_type x1, + copy_module_type x2 ) + | Ast_409.Parsetree.Pmty_with (x0, x1) -> + Ast_408.Parsetree.Pmty_with + (copy_module_type x0, List.map copy_with_constraint x1) + | Ast_409.Parsetree.Pmty_typeof x0 -> + Ast_408.Parsetree.Pmty_typeof (copy_module_expr x0) + | Ast_409.Parsetree.Pmty_extension x0 -> + Ast_408.Parsetree.Pmty_extension (copy_extension x0) + | Ast_409.Parsetree.Pmty_alias x0 -> + Ast_408.Parsetree.Pmty_alias (copy_loc copy_Longident_t x0) + +and copy_with_constraint : + Ast_409.Parsetree.with_constraint -> Ast_408.Parsetree.with_constraint = + function + | Ast_409.Parsetree.Pwith_type (x0, x1) -> + Ast_408.Parsetree.Pwith_type + (copy_loc copy_Longident_t x0, copy_type_declaration x1) + | Ast_409.Parsetree.Pwith_module (x0, x1) -> + Ast_408.Parsetree.Pwith_module + (copy_loc copy_Longident_t x0, copy_loc copy_Longident_t x1) + | Ast_409.Parsetree.Pwith_typesubst (x0, x1) -> + Ast_408.Parsetree.Pwith_typesubst + (copy_loc copy_Longident_t x0, copy_type_declaration x1) + | Ast_409.Parsetree.Pwith_modsubst (x0, x1) -> + Ast_408.Parsetree.Pwith_modsubst + (copy_loc copy_Longident_t x0, copy_loc copy_Longident_t x1) + +and copy_signature : Ast_409.Parsetree.signature -> Ast_408.Parsetree.signature + = + fun x -> List.map copy_signature_item x + +and copy_signature_item : + Ast_409.Parsetree.signature_item -> Ast_408.Parsetree.signature_item = + fun { Ast_409.Parsetree.psig_desc; Ast_409.Parsetree.psig_loc } -> + { + Ast_408.Parsetree.psig_desc = copy_signature_item_desc psig_desc; + Ast_408.Parsetree.psig_loc = copy_location psig_loc; + } + +and copy_signature_item_desc : + Ast_409.Parsetree.signature_item_desc -> + Ast_408.Parsetree.signature_item_desc = function + | Ast_409.Parsetree.Psig_value x0 -> + Ast_408.Parsetree.Psig_value (copy_value_description x0) + | Ast_409.Parsetree.Psig_type (x0, x1) -> + Ast_408.Parsetree.Psig_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | Ast_409.Parsetree.Psig_typesubst x0 -> + Ast_408.Parsetree.Psig_typesubst (List.map copy_type_declaration x0) + | Ast_409.Parsetree.Psig_typext x0 -> + Ast_408.Parsetree.Psig_typext (copy_type_extension x0) + | Ast_409.Parsetree.Psig_exception x0 -> + Ast_408.Parsetree.Psig_exception (copy_type_exception x0) + | Ast_409.Parsetree.Psig_module x0 -> + Ast_408.Parsetree.Psig_module (copy_module_declaration x0) + | Ast_409.Parsetree.Psig_modsubst x0 -> + Ast_408.Parsetree.Psig_modsubst (copy_module_substitution x0) + | Ast_409.Parsetree.Psig_recmodule x0 -> + Ast_408.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) + | Ast_409.Parsetree.Psig_modtype x0 -> + Ast_408.Parsetree.Psig_modtype (copy_module_type_declaration x0) + | Ast_409.Parsetree.Psig_open x0 -> + Ast_408.Parsetree.Psig_open (copy_open_description x0) + | Ast_409.Parsetree.Psig_include x0 -> + Ast_408.Parsetree.Psig_include (copy_include_description x0) + | Ast_409.Parsetree.Psig_class x0 -> + Ast_408.Parsetree.Psig_class (List.map copy_class_description x0) + | Ast_409.Parsetree.Psig_class_type x0 -> + Ast_408.Parsetree.Psig_class_type + (List.map copy_class_type_declaration x0) + | Ast_409.Parsetree.Psig_attribute x0 -> + Ast_408.Parsetree.Psig_attribute (copy_attribute x0) + | Ast_409.Parsetree.Psig_extension (x0, x1) -> + Ast_408.Parsetree.Psig_extension (copy_extension x0, copy_attributes x1) + +and copy_class_type_declaration : + Ast_409.Parsetree.class_type_declaration -> + Ast_408.Parsetree.class_type_declaration = + fun x -> copy_class_infos copy_class_type x + +and copy_class_description : + Ast_409.Parsetree.class_description -> Ast_408.Parsetree.class_description = + fun x -> copy_class_infos copy_class_type x + +and copy_class_type : + Ast_409.Parsetree.class_type -> Ast_408.Parsetree.class_type = + fun { + Ast_409.Parsetree.pcty_desc; + Ast_409.Parsetree.pcty_loc; + Ast_409.Parsetree.pcty_attributes; + } -> + { + Ast_408.Parsetree.pcty_desc = copy_class_type_desc pcty_desc; + Ast_408.Parsetree.pcty_loc = copy_location pcty_loc; + Ast_408.Parsetree.pcty_attributes = copy_attributes pcty_attributes; + } + +and copy_class_type_desc : + Ast_409.Parsetree.class_type_desc -> Ast_408.Parsetree.class_type_desc = + function + | Ast_409.Parsetree.Pcty_constr (x0, x1) -> + Ast_408.Parsetree.Pcty_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_409.Parsetree.Pcty_signature x0 -> + Ast_408.Parsetree.Pcty_signature (copy_class_signature x0) + | Ast_409.Parsetree.Pcty_arrow (x0, x1, x2) -> + Ast_408.Parsetree.Pcty_arrow + (copy_arg_label x0, copy_core_type x1, copy_class_type x2) + | Ast_409.Parsetree.Pcty_extension x0 -> + Ast_408.Parsetree.Pcty_extension (copy_extension x0) + | Ast_409.Parsetree.Pcty_open (x0, x1) -> + Ast_408.Parsetree.Pcty_open (copy_open_description x0, copy_class_type x1) + +and copy_class_signature : + Ast_409.Parsetree.class_signature -> Ast_408.Parsetree.class_signature = + fun { Ast_409.Parsetree.pcsig_self; Ast_409.Parsetree.pcsig_fields } -> + { + Ast_408.Parsetree.pcsig_self = copy_core_type pcsig_self; + Ast_408.Parsetree.pcsig_fields = List.map copy_class_type_field pcsig_fields; + } + +and copy_class_type_field : + Ast_409.Parsetree.class_type_field -> Ast_408.Parsetree.class_type_field = + fun { + Ast_409.Parsetree.pctf_desc; + Ast_409.Parsetree.pctf_loc; + Ast_409.Parsetree.pctf_attributes; + } -> + { + Ast_408.Parsetree.pctf_desc = copy_class_type_field_desc pctf_desc; + Ast_408.Parsetree.pctf_loc = copy_location pctf_loc; + Ast_408.Parsetree.pctf_attributes = copy_attributes pctf_attributes; + } + +and copy_class_type_field_desc : + Ast_409.Parsetree.class_type_field_desc -> + Ast_408.Parsetree.class_type_field_desc = function + | Ast_409.Parsetree.Pctf_inherit x0 -> + Ast_408.Parsetree.Pctf_inherit (copy_class_type x0) + | Ast_409.Parsetree.Pctf_val x0 -> + Ast_408.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_409.Parsetree.Pctf_method x0 -> + Ast_408.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_409.Parsetree.Pctf_constraint x0 -> + Ast_408.Parsetree.Pctf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | Ast_409.Parsetree.Pctf_attribute x0 -> + Ast_408.Parsetree.Pctf_attribute (copy_attribute x0) + | Ast_409.Parsetree.Pctf_extension x0 -> + Ast_408.Parsetree.Pctf_extension (copy_extension x0) + +and copy_extension : Ast_409.Parsetree.extension -> Ast_408.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_409.Parsetree.class_infos -> + 'g0 Ast_408.Parsetree.class_infos = + fun f0 + { + Ast_409.Parsetree.pci_virt; + Ast_409.Parsetree.pci_params; + Ast_409.Parsetree.pci_name; + Ast_409.Parsetree.pci_expr; + Ast_409.Parsetree.pci_loc; + Ast_409.Parsetree.pci_attributes; + } -> + { + Ast_408.Parsetree.pci_virt = copy_virtual_flag pci_virt; + Ast_408.Parsetree.pci_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + pci_params; + Ast_408.Parsetree.pci_name = copy_loc (fun x -> x) pci_name; + Ast_408.Parsetree.pci_expr = f0 pci_expr; + Ast_408.Parsetree.pci_loc = copy_location pci_loc; + Ast_408.Parsetree.pci_attributes = copy_attributes pci_attributes; + } + +and copy_virtual_flag : + Ast_409.Asttypes.virtual_flag -> Ast_408.Asttypes.virtual_flag = function + | Ast_409.Asttypes.Virtual -> Ast_408.Asttypes.Virtual + | Ast_409.Asttypes.Concrete -> Ast_408.Asttypes.Concrete + +and copy_include_description : + Ast_409.Parsetree.include_description -> + Ast_408.Parsetree.include_description = + fun x -> copy_include_infos copy_module_type x + +and copy_include_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 Ast_409.Parsetree.include_infos -> + 'g0 Ast_408.Parsetree.include_infos = + fun f0 + { + Ast_409.Parsetree.pincl_mod; + Ast_409.Parsetree.pincl_loc; + Ast_409.Parsetree.pincl_attributes; + } -> + { + Ast_408.Parsetree.pincl_mod = f0 pincl_mod; + Ast_408.Parsetree.pincl_loc = copy_location pincl_loc; + Ast_408.Parsetree.pincl_attributes = copy_attributes pincl_attributes; + } + +and copy_open_description : + Ast_409.Parsetree.open_description -> Ast_408.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_409.Parsetree.open_infos -> + 'g0 Ast_408.Parsetree.open_infos = + fun f0 + { + Ast_409.Parsetree.popen_expr; + Ast_409.Parsetree.popen_override; + Ast_409.Parsetree.popen_loc; + Ast_409.Parsetree.popen_attributes; + } -> + { + Ast_408.Parsetree.popen_expr = f0 popen_expr; + Ast_408.Parsetree.popen_override = copy_override_flag popen_override; + Ast_408.Parsetree.popen_loc = copy_location popen_loc; + Ast_408.Parsetree.popen_attributes = copy_attributes popen_attributes; + } + +and copy_override_flag : + Ast_409.Asttypes.override_flag -> Ast_408.Asttypes.override_flag = function + | Ast_409.Asttypes.Override -> Ast_408.Asttypes.Override + | Ast_409.Asttypes.Fresh -> Ast_408.Asttypes.Fresh + +and copy_module_type_declaration : + Ast_409.Parsetree.module_type_declaration -> + Ast_408.Parsetree.module_type_declaration = + fun { + Ast_409.Parsetree.pmtd_name; + Ast_409.Parsetree.pmtd_type; + Ast_409.Parsetree.pmtd_attributes; + Ast_409.Parsetree.pmtd_loc; + } -> + { + Ast_408.Parsetree.pmtd_name = copy_loc (fun x -> x) pmtd_name; + Ast_408.Parsetree.pmtd_type = Option.map copy_module_type pmtd_type; + Ast_408.Parsetree.pmtd_attributes = copy_attributes pmtd_attributes; + Ast_408.Parsetree.pmtd_loc = copy_location pmtd_loc; + } + +and copy_module_substitution : + Ast_409.Parsetree.module_substitution -> + Ast_408.Parsetree.module_substitution = + fun { + Ast_409.Parsetree.pms_name; + Ast_409.Parsetree.pms_manifest; + Ast_409.Parsetree.pms_attributes; + Ast_409.Parsetree.pms_loc; + } -> + { + Ast_408.Parsetree.pms_name = copy_loc (fun x -> x) pms_name; + Ast_408.Parsetree.pms_manifest = copy_loc copy_Longident_t pms_manifest; + Ast_408.Parsetree.pms_attributes = copy_attributes pms_attributes; + Ast_408.Parsetree.pms_loc = copy_location pms_loc; + } + +and copy_module_declaration : + Ast_409.Parsetree.module_declaration -> Ast_408.Parsetree.module_declaration + = + fun { + Ast_409.Parsetree.pmd_name; + Ast_409.Parsetree.pmd_type; + Ast_409.Parsetree.pmd_attributes; + Ast_409.Parsetree.pmd_loc; + } -> + { + Ast_408.Parsetree.pmd_name = copy_loc (fun x -> x) pmd_name; + Ast_408.Parsetree.pmd_type = copy_module_type pmd_type; + Ast_408.Parsetree.pmd_attributes = copy_attributes pmd_attributes; + Ast_408.Parsetree.pmd_loc = copy_location pmd_loc; + } + +and copy_type_exception : + Ast_409.Parsetree.type_exception -> Ast_408.Parsetree.type_exception = + fun { + Ast_409.Parsetree.ptyexn_constructor; + Ast_409.Parsetree.ptyexn_loc; + Ast_409.Parsetree.ptyexn_attributes; + } -> + { + Ast_408.Parsetree.ptyexn_constructor = + copy_extension_constructor ptyexn_constructor; + Ast_408.Parsetree.ptyexn_loc = copy_location ptyexn_loc; + Ast_408.Parsetree.ptyexn_attributes = copy_attributes ptyexn_attributes; + } + +and copy_type_extension : + Ast_409.Parsetree.type_extension -> Ast_408.Parsetree.type_extension = + fun { + Ast_409.Parsetree.ptyext_path; + Ast_409.Parsetree.ptyext_params; + Ast_409.Parsetree.ptyext_constructors; + Ast_409.Parsetree.ptyext_private; + Ast_409.Parsetree.ptyext_loc; + Ast_409.Parsetree.ptyext_attributes; + } -> + { + Ast_408.Parsetree.ptyext_path = copy_loc copy_Longident_t ptyext_path; + Ast_408.Parsetree.ptyext_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptyext_params; + Ast_408.Parsetree.ptyext_constructors = + List.map copy_extension_constructor ptyext_constructors; + Ast_408.Parsetree.ptyext_private = copy_private_flag ptyext_private; + Ast_408.Parsetree.ptyext_loc = copy_location ptyext_loc; + Ast_408.Parsetree.ptyext_attributes = copy_attributes ptyext_attributes; + } + +and copy_extension_constructor : + Ast_409.Parsetree.extension_constructor -> + Ast_408.Parsetree.extension_constructor = + fun { + Ast_409.Parsetree.pext_name; + Ast_409.Parsetree.pext_kind; + Ast_409.Parsetree.pext_loc; + Ast_409.Parsetree.pext_attributes; + } -> + { + Ast_408.Parsetree.pext_name = copy_loc (fun x -> x) pext_name; + Ast_408.Parsetree.pext_kind = copy_extension_constructor_kind pext_kind; + Ast_408.Parsetree.pext_loc = copy_location pext_loc; + Ast_408.Parsetree.pext_attributes = copy_attributes pext_attributes; + } + +and copy_extension_constructor_kind : + Ast_409.Parsetree.extension_constructor_kind -> + Ast_408.Parsetree.extension_constructor_kind = function + | Ast_409.Parsetree.Pext_decl (x0, x1) -> + Ast_408.Parsetree.Pext_decl + (copy_constructor_arguments x0, Option.map copy_core_type x1) + | Ast_409.Parsetree.Pext_rebind x0 -> + Ast_408.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0) + +and copy_type_declaration : + Ast_409.Parsetree.type_declaration -> Ast_408.Parsetree.type_declaration = + fun { + Ast_409.Parsetree.ptype_name; + Ast_409.Parsetree.ptype_params; + Ast_409.Parsetree.ptype_cstrs; + Ast_409.Parsetree.ptype_kind; + Ast_409.Parsetree.ptype_private; + Ast_409.Parsetree.ptype_manifest; + Ast_409.Parsetree.ptype_attributes; + Ast_409.Parsetree.ptype_loc; + } -> + { + Ast_408.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name; + Ast_408.Parsetree.ptype_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptype_params; + Ast_408.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_408.Parsetree.ptype_kind = copy_type_kind ptype_kind; + Ast_408.Parsetree.ptype_private = copy_private_flag ptype_private; + Ast_408.Parsetree.ptype_manifest = Option.map copy_core_type ptype_manifest; + Ast_408.Parsetree.ptype_attributes = copy_attributes ptype_attributes; + Ast_408.Parsetree.ptype_loc = copy_location ptype_loc; + } + +and copy_private_flag : + Ast_409.Asttypes.private_flag -> Ast_408.Asttypes.private_flag = function + | Ast_409.Asttypes.Private -> Ast_408.Asttypes.Private + | Ast_409.Asttypes.Public -> Ast_408.Asttypes.Public + +and copy_type_kind : Ast_409.Parsetree.type_kind -> Ast_408.Parsetree.type_kind + = function + | Ast_409.Parsetree.Ptype_abstract -> Ast_408.Parsetree.Ptype_abstract + | Ast_409.Parsetree.Ptype_variant x0 -> + Ast_408.Parsetree.Ptype_variant (List.map copy_constructor_declaration x0) + | Ast_409.Parsetree.Ptype_record x0 -> + Ast_408.Parsetree.Ptype_record (List.map copy_label_declaration x0) + | Ast_409.Parsetree.Ptype_open -> Ast_408.Parsetree.Ptype_open + +and copy_constructor_declaration : + Ast_409.Parsetree.constructor_declaration -> + Ast_408.Parsetree.constructor_declaration = + fun { + Ast_409.Parsetree.pcd_name; + Ast_409.Parsetree.pcd_args; + Ast_409.Parsetree.pcd_res; + Ast_409.Parsetree.pcd_loc; + Ast_409.Parsetree.pcd_attributes; + } -> + { + Ast_408.Parsetree.pcd_name = copy_loc (fun x -> x) pcd_name; + Ast_408.Parsetree.pcd_args = copy_constructor_arguments pcd_args; + Ast_408.Parsetree.pcd_res = Option.map copy_core_type pcd_res; + Ast_408.Parsetree.pcd_loc = copy_location pcd_loc; + Ast_408.Parsetree.pcd_attributes = copy_attributes pcd_attributes; + } + +and copy_constructor_arguments : + Ast_409.Parsetree.constructor_arguments -> + Ast_408.Parsetree.constructor_arguments = function + | Ast_409.Parsetree.Pcstr_tuple x0 -> + Ast_408.Parsetree.Pcstr_tuple (List.map copy_core_type x0) + | Ast_409.Parsetree.Pcstr_record x0 -> + Ast_408.Parsetree.Pcstr_record (List.map copy_label_declaration x0) + +and copy_label_declaration : + Ast_409.Parsetree.label_declaration -> Ast_408.Parsetree.label_declaration = + fun { + Ast_409.Parsetree.pld_name; + Ast_409.Parsetree.pld_mutable; + Ast_409.Parsetree.pld_type; + Ast_409.Parsetree.pld_loc; + Ast_409.Parsetree.pld_attributes; + } -> + { + Ast_408.Parsetree.pld_name = copy_loc (fun x -> x) pld_name; + Ast_408.Parsetree.pld_mutable = copy_mutable_flag pld_mutable; + Ast_408.Parsetree.pld_type = copy_core_type pld_type; + Ast_408.Parsetree.pld_loc = copy_location pld_loc; + Ast_408.Parsetree.pld_attributes = copy_attributes pld_attributes; + } + +and copy_mutable_flag : + Ast_409.Asttypes.mutable_flag -> Ast_408.Asttypes.mutable_flag = function + | Ast_409.Asttypes.Immutable -> Ast_408.Asttypes.Immutable + | Ast_409.Asttypes.Mutable -> Ast_408.Asttypes.Mutable + +and copy_variance : Ast_409.Asttypes.variance -> Ast_408.Asttypes.variance = + function + | Ast_409.Asttypes.Covariant -> Ast_408.Asttypes.Covariant + | Ast_409.Asttypes.Contravariant -> Ast_408.Asttypes.Contravariant + | Ast_409.Asttypes.Invariant -> Ast_408.Asttypes.Invariant + +and copy_value_description : + Ast_409.Parsetree.value_description -> Ast_408.Parsetree.value_description = + fun { + Ast_409.Parsetree.pval_name; + Ast_409.Parsetree.pval_type; + Ast_409.Parsetree.pval_prim; + Ast_409.Parsetree.pval_attributes; + Ast_409.Parsetree.pval_loc; + } -> + { + Ast_408.Parsetree.pval_name = copy_loc (fun x -> x) pval_name; + Ast_408.Parsetree.pval_type = copy_core_type pval_type; + Ast_408.Parsetree.pval_prim = List.map (fun x -> x) pval_prim; + Ast_408.Parsetree.pval_attributes = copy_attributes pval_attributes; + Ast_408.Parsetree.pval_loc = copy_location pval_loc; + } + +and copy_object_field_desc : + Ast_409.Parsetree.object_field_desc -> Ast_408.Parsetree.object_field_desc = + function + | Ast_409.Parsetree.Otag (x0, x1) -> + Ast_408.Parsetree.Otag (copy_loc copy_label x0, copy_core_type x1) + | Ast_409.Parsetree.Oinherit x0 -> + Ast_408.Parsetree.Oinherit (copy_core_type x0) + +and copy_arg_label : Ast_409.Asttypes.arg_label -> Ast_408.Asttypes.arg_label = + function + | Ast_409.Asttypes.Nolabel -> Ast_408.Asttypes.Nolabel + | Ast_409.Asttypes.Labelled x0 -> Ast_408.Asttypes.Labelled x0 + | Ast_409.Asttypes.Optional x0 -> Ast_408.Asttypes.Optional x0 + +and copy_closed_flag : + Ast_409.Asttypes.closed_flag -> Ast_408.Asttypes.closed_flag = function + | Ast_409.Asttypes.Closed -> Ast_408.Asttypes.Closed + | Ast_409.Asttypes.Open -> Ast_408.Asttypes.Open + +and copy_label : Ast_409.Asttypes.label -> Ast_408.Asttypes.label = fun x -> x + +and copy_rec_flag : Ast_409.Asttypes.rec_flag -> Ast_408.Asttypes.rec_flag = + function + | Ast_409.Asttypes.Nonrecursive -> Ast_408.Asttypes.Nonrecursive + | Ast_409.Asttypes.Recursive -> Ast_408.Asttypes.Recursive + +and copy_constant : Ast_409.Parsetree.constant -> Ast_408.Parsetree.constant = + function + | Ast_409.Parsetree.Pconst_integer (x0, x1) -> + Ast_408.Parsetree.Pconst_integer (x0, Option.map (fun x -> x) x1) + | Ast_409.Parsetree.Pconst_char x0 -> Ast_408.Parsetree.Pconst_char x0 + | Ast_409.Parsetree.Pconst_string (x0, x1) -> + Ast_408.Parsetree.Pconst_string (x0, Option.map (fun x -> x) x1) + | Ast_409.Parsetree.Pconst_float (x0, x1) -> + Ast_408.Parsetree.Pconst_float (x0, Option.map (fun x -> x) x1) + +and copy_Longident_t : Longident.t -> Longident.t = fun x -> x + +and copy_loc : + 'f0 'g0. + ('f0 -> 'g0) -> 'f0 Ast_409.Asttypes.loc -> 'g0 Ast_408.Asttypes.loc = + fun f0 { Ast_409.Asttypes.txt; Ast_409.Asttypes.loc } -> + { Ast_408.Asttypes.txt = f0 txt; Ast_408.Asttypes.loc = copy_location loc } + +and copy_location : Location.t -> Location.t = fun x -> x diff -Nru ppxlib-0.15.0/astlib/migrate_409_410.ml ppxlib-0.24.0/astlib/migrate_409_410.ml --- ppxlib-0.15.0/astlib/migrate_409_410.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/migrate_409_410.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1193 @@ +module From = Ast_409 +module To = Ast_410 + +let map_option f x = match x with None -> None | Some x -> Some (f x) + +let rec copy_toplevel_phrase : + Ast_409.Parsetree.toplevel_phrase -> Ast_410.Parsetree.toplevel_phrase = + function + | Ast_409.Parsetree.Ptop_def x0 -> + Ast_410.Parsetree.Ptop_def (copy_structure x0) + | Ast_409.Parsetree.Ptop_dir x0 -> + Ast_410.Parsetree.Ptop_dir (copy_toplevel_directive x0) + +and copy_toplevel_directive : + Ast_409.Parsetree.toplevel_directive -> Ast_410.Parsetree.toplevel_directive + = + fun { + Ast_409.Parsetree.pdir_name; + Ast_409.Parsetree.pdir_arg; + Ast_409.Parsetree.pdir_loc; + } -> + { + Ast_410.Parsetree.pdir_name = copy_loc (fun x -> x) pdir_name; + Ast_410.Parsetree.pdir_arg = map_option copy_directive_argument pdir_arg; + Ast_410.Parsetree.pdir_loc = copy_location pdir_loc; + } + +and copy_directive_argument : + Ast_409.Parsetree.directive_argument -> Ast_410.Parsetree.directive_argument + = + fun { Ast_409.Parsetree.pdira_desc; Ast_409.Parsetree.pdira_loc } -> + { + Ast_410.Parsetree.pdira_desc = copy_directive_argument_desc pdira_desc; + Ast_410.Parsetree.pdira_loc = copy_location pdira_loc; + } + +and copy_directive_argument_desc : + Ast_409.Parsetree.directive_argument_desc -> + Ast_410.Parsetree.directive_argument_desc = function + | Ast_409.Parsetree.Pdir_string x0 -> Ast_410.Parsetree.Pdir_string x0 + | Ast_409.Parsetree.Pdir_int (x0, x1) -> + Ast_410.Parsetree.Pdir_int (x0, map_option (fun x -> x) x1) + | Ast_409.Parsetree.Pdir_ident x0 -> + Ast_410.Parsetree.Pdir_ident (copy_Longident_t x0) + | Ast_409.Parsetree.Pdir_bool x0 -> Ast_410.Parsetree.Pdir_bool x0 + +and copy_expression : + Ast_409.Parsetree.expression -> Ast_410.Parsetree.expression = + fun { + Ast_409.Parsetree.pexp_desc; + Ast_409.Parsetree.pexp_loc; + Ast_409.Parsetree.pexp_loc_stack; + Ast_409.Parsetree.pexp_attributes; + } -> + { + Ast_410.Parsetree.pexp_desc = copy_expression_desc pexp_desc; + Ast_410.Parsetree.pexp_loc = copy_location pexp_loc; + Ast_410.Parsetree.pexp_loc_stack = List.map copy_location pexp_loc_stack; + Ast_410.Parsetree.pexp_attributes = copy_attributes pexp_attributes; + } + +and copy_expression_desc : + Ast_409.Parsetree.expression_desc -> Ast_410.Parsetree.expression_desc = + function + | Ast_409.Parsetree.Pexp_ident x0 -> + Ast_410.Parsetree.Pexp_ident (copy_loc copy_Longident_t x0) + | Ast_409.Parsetree.Pexp_constant x0 -> + Ast_410.Parsetree.Pexp_constant (copy_constant x0) + | Ast_409.Parsetree.Pexp_let (x0, x1, x2) -> + Ast_410.Parsetree.Pexp_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_expression x2) + | Ast_409.Parsetree.Pexp_function x0 -> + Ast_410.Parsetree.Pexp_function (copy_cases x0) + | Ast_409.Parsetree.Pexp_fun (x0, x1, x2, x3) -> + Ast_410.Parsetree.Pexp_fun + ( copy_arg_label x0, + map_option copy_expression x1, + copy_pattern x2, + copy_expression x3 ) + | Ast_409.Parsetree.Pexp_apply (x0, x1) -> + Ast_410.Parsetree.Pexp_apply + ( copy_expression x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | Ast_409.Parsetree.Pexp_match (x0, x1) -> + Ast_410.Parsetree.Pexp_match (copy_expression x0, copy_cases x1) + | Ast_409.Parsetree.Pexp_try (x0, x1) -> + Ast_410.Parsetree.Pexp_try (copy_expression x0, copy_cases x1) + | Ast_409.Parsetree.Pexp_tuple x0 -> + Ast_410.Parsetree.Pexp_tuple (List.map copy_expression x0) + | Ast_409.Parsetree.Pexp_construct (x0, x1) -> + Ast_410.Parsetree.Pexp_construct + (copy_loc copy_Longident_t x0, map_option copy_expression x1) + | Ast_409.Parsetree.Pexp_variant (x0, x1) -> + Ast_410.Parsetree.Pexp_variant + (copy_label x0, map_option copy_expression x1) + | Ast_409.Parsetree.Pexp_record (x0, x1) -> + Ast_410.Parsetree.Pexp_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_Longident_t x0, copy_expression x1)) + x0, + map_option copy_expression x1 ) + | Ast_409.Parsetree.Pexp_field (x0, x1) -> + Ast_410.Parsetree.Pexp_field + (copy_expression x0, copy_loc copy_Longident_t x1) + | Ast_409.Parsetree.Pexp_setfield (x0, x1, x2) -> + Ast_410.Parsetree.Pexp_setfield + (copy_expression x0, copy_loc copy_Longident_t x1, copy_expression x2) + | Ast_409.Parsetree.Pexp_array x0 -> + Ast_410.Parsetree.Pexp_array (List.map copy_expression x0) + | Ast_409.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> + Ast_410.Parsetree.Pexp_ifthenelse + (copy_expression x0, copy_expression x1, map_option copy_expression x2) + | Ast_409.Parsetree.Pexp_sequence (x0, x1) -> + Ast_410.Parsetree.Pexp_sequence (copy_expression x0, copy_expression x1) + | Ast_409.Parsetree.Pexp_while (x0, x1) -> + Ast_410.Parsetree.Pexp_while (copy_expression x0, copy_expression x1) + | Ast_409.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> + Ast_410.Parsetree.Pexp_for + ( copy_pattern x0, + copy_expression x1, + copy_expression x2, + copy_direction_flag x3, + copy_expression x4 ) + | Ast_409.Parsetree.Pexp_constraint (x0, x1) -> + Ast_410.Parsetree.Pexp_constraint (copy_expression x0, copy_core_type x1) + | Ast_409.Parsetree.Pexp_coerce (x0, x1, x2) -> + Ast_410.Parsetree.Pexp_coerce + (copy_expression x0, map_option copy_core_type x1, copy_core_type x2) + | Ast_409.Parsetree.Pexp_send (x0, x1) -> + Ast_410.Parsetree.Pexp_send (copy_expression x0, copy_loc copy_label x1) + | Ast_409.Parsetree.Pexp_new x0 -> + Ast_410.Parsetree.Pexp_new (copy_loc copy_Longident_t x0) + | Ast_409.Parsetree.Pexp_setinstvar (x0, x1) -> + Ast_410.Parsetree.Pexp_setinstvar + (copy_loc copy_label x0, copy_expression x1) + | Ast_409.Parsetree.Pexp_override x0 -> + Ast_410.Parsetree.Pexp_override + (List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_label x0, copy_expression x1)) + x0) + | Ast_409.Parsetree.Pexp_letmodule (x0, x1, x2) -> + Ast_410.Parsetree.Pexp_letmodule + (copy_loc (fun x -> Some x) x0, copy_module_expr x1, copy_expression x2) + | Ast_409.Parsetree.Pexp_letexception (x0, x1) -> + Ast_410.Parsetree.Pexp_letexception + (copy_extension_constructor x0, copy_expression x1) + | Ast_409.Parsetree.Pexp_assert x0 -> + Ast_410.Parsetree.Pexp_assert (copy_expression x0) + | Ast_409.Parsetree.Pexp_lazy x0 -> + Ast_410.Parsetree.Pexp_lazy (copy_expression x0) + | Ast_409.Parsetree.Pexp_poly (x0, x1) -> + Ast_410.Parsetree.Pexp_poly + (copy_expression x0, map_option copy_core_type x1) + | Ast_409.Parsetree.Pexp_object x0 -> + Ast_410.Parsetree.Pexp_object (copy_class_structure x0) + | Ast_409.Parsetree.Pexp_newtype (x0, x1) -> + Ast_410.Parsetree.Pexp_newtype + (copy_loc (fun x -> x) x0, copy_expression x1) + | Ast_409.Parsetree.Pexp_pack x0 -> + Ast_410.Parsetree.Pexp_pack (copy_module_expr x0) + | Ast_409.Parsetree.Pexp_open (x0, x1) -> + Ast_410.Parsetree.Pexp_open (copy_open_declaration x0, copy_expression x1) + | Ast_409.Parsetree.Pexp_letop x0 -> + Ast_410.Parsetree.Pexp_letop (copy_letop x0) + | Ast_409.Parsetree.Pexp_extension x0 -> + Ast_410.Parsetree.Pexp_extension (copy_extension x0) + | Ast_409.Parsetree.Pexp_unreachable -> Ast_410.Parsetree.Pexp_unreachable + +and copy_letop : Ast_409.Parsetree.letop -> Ast_410.Parsetree.letop = + fun { Ast_409.Parsetree.let_; Ast_409.Parsetree.ands; Ast_409.Parsetree.body } -> + { + Ast_410.Parsetree.let_ = copy_binding_op let_; + Ast_410.Parsetree.ands = List.map copy_binding_op ands; + Ast_410.Parsetree.body = copy_expression body; + } + +and copy_binding_op : + Ast_409.Parsetree.binding_op -> Ast_410.Parsetree.binding_op = + fun { + Ast_409.Parsetree.pbop_op; + Ast_409.Parsetree.pbop_pat; + Ast_409.Parsetree.pbop_exp; + Ast_409.Parsetree.pbop_loc; + } -> + { + Ast_410.Parsetree.pbop_op = copy_loc (fun x -> x) pbop_op; + Ast_410.Parsetree.pbop_pat = copy_pattern pbop_pat; + Ast_410.Parsetree.pbop_exp = copy_expression pbop_exp; + Ast_410.Parsetree.pbop_loc = copy_location pbop_loc; + } + +and copy_direction_flag : + Ast_409.Asttypes.direction_flag -> Ast_410.Asttypes.direction_flag = + function + | Ast_409.Asttypes.Upto -> Ast_410.Asttypes.Upto + | Ast_409.Asttypes.Downto -> Ast_410.Asttypes.Downto + +and copy_cases : Ast_409.Parsetree.cases -> Ast_410.Parsetree.case list = + fun x -> List.map copy_case x + +and copy_case : Ast_409.Parsetree.case -> Ast_410.Parsetree.case = + fun { + Ast_409.Parsetree.pc_lhs; + Ast_409.Parsetree.pc_guard; + Ast_409.Parsetree.pc_rhs; + } -> + { + Ast_410.Parsetree.pc_lhs = copy_pattern pc_lhs; + Ast_410.Parsetree.pc_guard = map_option copy_expression pc_guard; + Ast_410.Parsetree.pc_rhs = copy_expression pc_rhs; + } + +and copy_value_binding : + Ast_409.Parsetree.value_binding -> Ast_410.Parsetree.value_binding = + fun { + Ast_409.Parsetree.pvb_pat; + Ast_409.Parsetree.pvb_expr; + Ast_409.Parsetree.pvb_attributes; + Ast_409.Parsetree.pvb_loc; + } -> + { + Ast_410.Parsetree.pvb_pat = copy_pattern pvb_pat; + Ast_410.Parsetree.pvb_expr = copy_expression pvb_expr; + Ast_410.Parsetree.pvb_attributes = copy_attributes pvb_attributes; + Ast_410.Parsetree.pvb_loc = copy_location pvb_loc; + } + +and copy_pattern : Ast_409.Parsetree.pattern -> Ast_410.Parsetree.pattern = + fun { + Ast_409.Parsetree.ppat_desc; + Ast_409.Parsetree.ppat_loc; + Ast_409.Parsetree.ppat_loc_stack; + Ast_409.Parsetree.ppat_attributes; + } -> + { + Ast_410.Parsetree.ppat_desc = copy_pattern_desc ppat_desc; + Ast_410.Parsetree.ppat_loc = copy_location ppat_loc; + Ast_410.Parsetree.ppat_loc_stack = List.map copy_location ppat_loc_stack; + Ast_410.Parsetree.ppat_attributes = copy_attributes ppat_attributes; + } + +and copy_pattern_desc : + Ast_409.Parsetree.pattern_desc -> Ast_410.Parsetree.pattern_desc = function + | Ast_409.Parsetree.Ppat_any -> Ast_410.Parsetree.Ppat_any + | Ast_409.Parsetree.Ppat_var x0 -> + Ast_410.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) + | Ast_409.Parsetree.Ppat_alias (x0, x1) -> + Ast_410.Parsetree.Ppat_alias (copy_pattern x0, copy_loc (fun x -> x) x1) + | Ast_409.Parsetree.Ppat_constant x0 -> + Ast_410.Parsetree.Ppat_constant (copy_constant x0) + | Ast_409.Parsetree.Ppat_interval (x0, x1) -> + Ast_410.Parsetree.Ppat_interval (copy_constant x0, copy_constant x1) + | Ast_409.Parsetree.Ppat_tuple x0 -> + Ast_410.Parsetree.Ppat_tuple (List.map copy_pattern x0) + | Ast_409.Parsetree.Ppat_construct (x0, x1) -> + Ast_410.Parsetree.Ppat_construct + (copy_loc copy_Longident_t x0, map_option copy_pattern x1) + | Ast_409.Parsetree.Ppat_variant (x0, x1) -> + Ast_410.Parsetree.Ppat_variant (copy_label x0, map_option copy_pattern x1) + | Ast_409.Parsetree.Ppat_record (x0, x1) -> + Ast_410.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_409.Parsetree.Ppat_array x0 -> + Ast_410.Parsetree.Ppat_array (List.map copy_pattern x0) + | Ast_409.Parsetree.Ppat_or (x0, x1) -> + Ast_410.Parsetree.Ppat_or (copy_pattern x0, copy_pattern x1) + | Ast_409.Parsetree.Ppat_constraint (x0, x1) -> + Ast_410.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1) + | Ast_409.Parsetree.Ppat_type x0 -> + Ast_410.Parsetree.Ppat_type (copy_loc copy_Longident_t x0) + | Ast_409.Parsetree.Ppat_lazy x0 -> + Ast_410.Parsetree.Ppat_lazy (copy_pattern x0) + | Ast_409.Parsetree.Ppat_unpack x0 -> + Ast_410.Parsetree.Ppat_unpack (copy_loc (fun x -> Some x) x0) + | Ast_409.Parsetree.Ppat_exception x0 -> + Ast_410.Parsetree.Ppat_exception (copy_pattern x0) + | Ast_409.Parsetree.Ppat_extension x0 -> + Ast_410.Parsetree.Ppat_extension (copy_extension x0) + | Ast_409.Parsetree.Ppat_open (x0, x1) -> + Ast_410.Parsetree.Ppat_open (copy_loc copy_Longident_t x0, copy_pattern x1) + +and copy_core_type : Ast_409.Parsetree.core_type -> Ast_410.Parsetree.core_type + = + fun { + Ast_409.Parsetree.ptyp_desc; + Ast_409.Parsetree.ptyp_loc; + Ast_409.Parsetree.ptyp_loc_stack; + Ast_409.Parsetree.ptyp_attributes; + } -> + { + Ast_410.Parsetree.ptyp_desc = copy_core_type_desc ptyp_desc; + Ast_410.Parsetree.ptyp_loc = copy_location ptyp_loc; + Ast_410.Parsetree.ptyp_loc_stack = List.map copy_location ptyp_loc_stack; + Ast_410.Parsetree.ptyp_attributes = copy_attributes ptyp_attributes; + } + +and copy_core_type_desc : + Ast_409.Parsetree.core_type_desc -> Ast_410.Parsetree.core_type_desc = + function + | Ast_409.Parsetree.Ptyp_any -> Ast_410.Parsetree.Ptyp_any + | Ast_409.Parsetree.Ptyp_var x0 -> Ast_410.Parsetree.Ptyp_var x0 + | Ast_409.Parsetree.Ptyp_arrow (x0, x1, x2) -> + Ast_410.Parsetree.Ptyp_arrow + (copy_arg_label x0, copy_core_type x1, copy_core_type x2) + | Ast_409.Parsetree.Ptyp_tuple x0 -> + Ast_410.Parsetree.Ptyp_tuple (List.map copy_core_type x0) + | Ast_409.Parsetree.Ptyp_constr (x0, x1) -> + Ast_410.Parsetree.Ptyp_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_409.Parsetree.Ptyp_object (x0, x1) -> + Ast_410.Parsetree.Ptyp_object + (List.map copy_object_field x0, copy_closed_flag x1) + | Ast_409.Parsetree.Ptyp_class (x0, x1) -> + Ast_410.Parsetree.Ptyp_class + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_409.Parsetree.Ptyp_alias (x0, x1) -> + Ast_410.Parsetree.Ptyp_alias (copy_core_type x0, x1) + | Ast_409.Parsetree.Ptyp_variant (x0, x1, x2) -> + Ast_410.Parsetree.Ptyp_variant + ( List.map copy_row_field x0, + copy_closed_flag x1, + map_option (fun x -> List.map copy_label x) x2 ) + | Ast_409.Parsetree.Ptyp_poly (x0, x1) -> + Ast_410.Parsetree.Ptyp_poly + (List.map (fun x -> copy_loc (fun x -> x) x) x0, copy_core_type x1) + | Ast_409.Parsetree.Ptyp_package x0 -> + Ast_410.Parsetree.Ptyp_package (copy_package_type x0) + | Ast_409.Parsetree.Ptyp_extension x0 -> + Ast_410.Parsetree.Ptyp_extension (copy_extension x0) + +and copy_package_type : + Ast_409.Parsetree.package_type -> Ast_410.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_409.Parsetree.row_field -> Ast_410.Parsetree.row_field + = + fun { + Ast_409.Parsetree.prf_desc; + Ast_409.Parsetree.prf_loc; + Ast_409.Parsetree.prf_attributes; + } -> + { + Ast_410.Parsetree.prf_desc = copy_row_field_desc prf_desc; + Ast_410.Parsetree.prf_loc = copy_location prf_loc; + Ast_410.Parsetree.prf_attributes = copy_attributes prf_attributes; + } + +and copy_row_field_desc : + Ast_409.Parsetree.row_field_desc -> Ast_410.Parsetree.row_field_desc = + function + | Ast_409.Parsetree.Rtag (x0, x1, x2) -> + Ast_410.Parsetree.Rtag + (copy_loc copy_label x0, x1, List.map copy_core_type x2) + | Ast_409.Parsetree.Rinherit x0 -> + Ast_410.Parsetree.Rinherit (copy_core_type x0) + +and copy_object_field : + Ast_409.Parsetree.object_field -> Ast_410.Parsetree.object_field = + fun { + Ast_409.Parsetree.pof_desc; + Ast_409.Parsetree.pof_loc; + Ast_409.Parsetree.pof_attributes; + } -> + { + Ast_410.Parsetree.pof_desc = copy_object_field_desc pof_desc; + Ast_410.Parsetree.pof_loc = copy_location pof_loc; + Ast_410.Parsetree.pof_attributes = copy_attributes pof_attributes; + } + +and copy_attributes : + Ast_409.Parsetree.attributes -> Ast_410.Parsetree.attributes = + fun x -> List.map copy_attribute x + +and copy_attribute : Ast_409.Parsetree.attribute -> Ast_410.Parsetree.attribute + = + fun { + Ast_409.Parsetree.attr_name; + Ast_409.Parsetree.attr_payload; + Ast_409.Parsetree.attr_loc; + } -> + { + Ast_410.Parsetree.attr_name = copy_loc (fun x -> x) attr_name; + Ast_410.Parsetree.attr_payload = copy_payload attr_payload; + Ast_410.Parsetree.attr_loc = copy_location attr_loc; + } + +and copy_payload : Ast_409.Parsetree.payload -> Ast_410.Parsetree.payload = + function + | Ast_409.Parsetree.PStr x0 -> Ast_410.Parsetree.PStr (copy_structure x0) + | Ast_409.Parsetree.PSig x0 -> Ast_410.Parsetree.PSig (copy_signature x0) + | Ast_409.Parsetree.PTyp x0 -> Ast_410.Parsetree.PTyp (copy_core_type x0) + | Ast_409.Parsetree.PPat (x0, x1) -> + Ast_410.Parsetree.PPat (copy_pattern x0, map_option copy_expression x1) + +and copy_structure : Ast_409.Parsetree.structure -> Ast_410.Parsetree.structure + = + fun x -> List.map copy_structure_item x + +and copy_structure_item : + Ast_409.Parsetree.structure_item -> Ast_410.Parsetree.structure_item = + fun { Ast_409.Parsetree.pstr_desc; Ast_409.Parsetree.pstr_loc } -> + { + Ast_410.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc; + Ast_410.Parsetree.pstr_loc = copy_location pstr_loc; + } + +and copy_structure_item_desc : + Ast_409.Parsetree.structure_item_desc -> + Ast_410.Parsetree.structure_item_desc = function + | Ast_409.Parsetree.Pstr_eval (x0, x1) -> + Ast_410.Parsetree.Pstr_eval (copy_expression x0, copy_attributes x1) + | Ast_409.Parsetree.Pstr_value (x0, x1) -> + Ast_410.Parsetree.Pstr_value + (copy_rec_flag x0, List.map copy_value_binding x1) + | Ast_409.Parsetree.Pstr_primitive x0 -> + Ast_410.Parsetree.Pstr_primitive (copy_value_description x0) + | Ast_409.Parsetree.Pstr_type (x0, x1) -> + Ast_410.Parsetree.Pstr_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | Ast_409.Parsetree.Pstr_typext x0 -> + Ast_410.Parsetree.Pstr_typext (copy_type_extension x0) + | Ast_409.Parsetree.Pstr_exception x0 -> + Ast_410.Parsetree.Pstr_exception (copy_type_exception x0) + | Ast_409.Parsetree.Pstr_module x0 -> + Ast_410.Parsetree.Pstr_module (copy_module_binding x0) + | Ast_409.Parsetree.Pstr_recmodule x0 -> + Ast_410.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) + | Ast_409.Parsetree.Pstr_modtype x0 -> + Ast_410.Parsetree.Pstr_modtype (copy_module_type_declaration x0) + | Ast_409.Parsetree.Pstr_open x0 -> + Ast_410.Parsetree.Pstr_open (copy_open_declaration x0) + | Ast_409.Parsetree.Pstr_class x0 -> + Ast_410.Parsetree.Pstr_class (List.map copy_class_declaration x0) + | Ast_409.Parsetree.Pstr_class_type x0 -> + Ast_410.Parsetree.Pstr_class_type + (List.map copy_class_type_declaration x0) + | Ast_409.Parsetree.Pstr_include x0 -> + Ast_410.Parsetree.Pstr_include (copy_include_declaration x0) + | Ast_409.Parsetree.Pstr_attribute x0 -> + Ast_410.Parsetree.Pstr_attribute (copy_attribute x0) + | Ast_409.Parsetree.Pstr_extension (x0, x1) -> + Ast_410.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1) + +and copy_include_declaration : + Ast_409.Parsetree.include_declaration -> + Ast_410.Parsetree.include_declaration = + fun x -> copy_include_infos copy_module_expr x + +and copy_class_declaration : + Ast_409.Parsetree.class_declaration -> Ast_410.Parsetree.class_declaration = + fun x -> copy_class_infos copy_class_expr x + +and copy_class_expr : + Ast_409.Parsetree.class_expr -> Ast_410.Parsetree.class_expr = + fun { + Ast_409.Parsetree.pcl_desc; + Ast_409.Parsetree.pcl_loc; + Ast_409.Parsetree.pcl_attributes; + } -> + { + Ast_410.Parsetree.pcl_desc = copy_class_expr_desc pcl_desc; + Ast_410.Parsetree.pcl_loc = copy_location pcl_loc; + Ast_410.Parsetree.pcl_attributes = copy_attributes pcl_attributes; + } + +and copy_class_expr_desc : + Ast_409.Parsetree.class_expr_desc -> Ast_410.Parsetree.class_expr_desc = + function + | Ast_409.Parsetree.Pcl_constr (x0, x1) -> + Ast_410.Parsetree.Pcl_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_409.Parsetree.Pcl_structure x0 -> + Ast_410.Parsetree.Pcl_structure (copy_class_structure x0) + | Ast_409.Parsetree.Pcl_fun (x0, x1, x2, x3) -> + Ast_410.Parsetree.Pcl_fun + ( copy_arg_label x0, + map_option copy_expression x1, + copy_pattern x2, + copy_class_expr x3 ) + | Ast_409.Parsetree.Pcl_apply (x0, x1) -> + Ast_410.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_409.Parsetree.Pcl_let (x0, x1, x2) -> + Ast_410.Parsetree.Pcl_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_class_expr x2) + | Ast_409.Parsetree.Pcl_constraint (x0, x1) -> + Ast_410.Parsetree.Pcl_constraint (copy_class_expr x0, copy_class_type x1) + | Ast_409.Parsetree.Pcl_extension x0 -> + Ast_410.Parsetree.Pcl_extension (copy_extension x0) + | Ast_409.Parsetree.Pcl_open (x0, x1) -> + Ast_410.Parsetree.Pcl_open (copy_open_description x0, copy_class_expr x1) + +and copy_class_structure : + Ast_409.Parsetree.class_structure -> Ast_410.Parsetree.class_structure = + fun { Ast_409.Parsetree.pcstr_self; Ast_409.Parsetree.pcstr_fields } -> + { + Ast_410.Parsetree.pcstr_self = copy_pattern pcstr_self; + Ast_410.Parsetree.pcstr_fields = List.map copy_class_field pcstr_fields; + } + +and copy_class_field : + Ast_409.Parsetree.class_field -> Ast_410.Parsetree.class_field = + fun { + Ast_409.Parsetree.pcf_desc; + Ast_409.Parsetree.pcf_loc; + Ast_409.Parsetree.pcf_attributes; + } -> + { + Ast_410.Parsetree.pcf_desc = copy_class_field_desc pcf_desc; + Ast_410.Parsetree.pcf_loc = copy_location pcf_loc; + Ast_410.Parsetree.pcf_attributes = copy_attributes pcf_attributes; + } + +and copy_class_field_desc : + Ast_409.Parsetree.class_field_desc -> Ast_410.Parsetree.class_field_desc = + function + | Ast_409.Parsetree.Pcf_inherit (x0, x1, x2) -> + Ast_410.Parsetree.Pcf_inherit + ( copy_override_flag x0, + copy_class_expr x1, + map_option (fun x -> copy_loc (fun x -> x) x) x2 ) + | Ast_409.Parsetree.Pcf_val x0 -> + Ast_410.Parsetree.Pcf_val + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_mutable_flag x1, copy_class_field_kind x2)) + | Ast_409.Parsetree.Pcf_method x0 -> + Ast_410.Parsetree.Pcf_method + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_private_flag x1, copy_class_field_kind x2)) + | Ast_409.Parsetree.Pcf_constraint x0 -> + Ast_410.Parsetree.Pcf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | Ast_409.Parsetree.Pcf_initializer x0 -> + Ast_410.Parsetree.Pcf_initializer (copy_expression x0) + | Ast_409.Parsetree.Pcf_attribute x0 -> + Ast_410.Parsetree.Pcf_attribute (copy_attribute x0) + | Ast_409.Parsetree.Pcf_extension x0 -> + Ast_410.Parsetree.Pcf_extension (copy_extension x0) + +and copy_class_field_kind : + Ast_409.Parsetree.class_field_kind -> Ast_410.Parsetree.class_field_kind = + function + | Ast_409.Parsetree.Cfk_virtual x0 -> + Ast_410.Parsetree.Cfk_virtual (copy_core_type x0) + | Ast_409.Parsetree.Cfk_concrete (x0, x1) -> + Ast_410.Parsetree.Cfk_concrete (copy_override_flag x0, copy_expression x1) + +and copy_open_declaration : + Ast_409.Parsetree.open_declaration -> Ast_410.Parsetree.open_declaration = + fun x -> copy_open_infos copy_module_expr x + +and copy_module_binding : + Ast_409.Parsetree.module_binding -> Ast_410.Parsetree.module_binding = + fun { + Ast_409.Parsetree.pmb_name; + Ast_409.Parsetree.pmb_expr; + Ast_409.Parsetree.pmb_attributes; + Ast_409.Parsetree.pmb_loc; + } -> + { + Ast_410.Parsetree.pmb_name = copy_loc (fun x -> Some x) pmb_name; + Ast_410.Parsetree.pmb_expr = copy_module_expr pmb_expr; + Ast_410.Parsetree.pmb_attributes = copy_attributes pmb_attributes; + Ast_410.Parsetree.pmb_loc = copy_location pmb_loc; + } + +and copy_module_expr : + Ast_409.Parsetree.module_expr -> Ast_410.Parsetree.module_expr = + fun { + Ast_409.Parsetree.pmod_desc; + Ast_409.Parsetree.pmod_loc; + Ast_409.Parsetree.pmod_attributes; + } -> + { + Ast_410.Parsetree.pmod_desc = copy_module_expr_desc pmod_desc; + Ast_410.Parsetree.pmod_loc = copy_location pmod_loc; + Ast_410.Parsetree.pmod_attributes = copy_attributes pmod_attributes; + } + +and copy_module_expr_desc : + Ast_409.Parsetree.module_expr_desc -> Ast_410.Parsetree.module_expr_desc = + function + | Ast_409.Parsetree.Pmod_ident x0 -> + Ast_410.Parsetree.Pmod_ident (copy_loc copy_Longident_t x0) + | Ast_409.Parsetree.Pmod_structure x0 -> + Ast_410.Parsetree.Pmod_structure (copy_structure x0) + | Ast_409.Parsetree.Pmod_functor (x0, x1, x2) -> + Ast_410.Parsetree.Pmod_functor + ( (match (x0.txt, x1) with + | "*", None -> Unit + | "_", Some mt -> + Named (copy_loc (fun _ -> None) x0, copy_module_type mt) + | _, Some mt -> + Named (copy_loc (fun x -> Some x) x0, copy_module_type mt) + | _ -> assert false), + copy_module_expr x2 ) + | Ast_409.Parsetree.Pmod_apply (x0, x1) -> + Ast_410.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) + | Ast_409.Parsetree.Pmod_constraint (x0, x1) -> + Ast_410.Parsetree.Pmod_constraint + (copy_module_expr x0, copy_module_type x1) + | Ast_409.Parsetree.Pmod_unpack x0 -> + Ast_410.Parsetree.Pmod_unpack (copy_expression x0) + | Ast_409.Parsetree.Pmod_extension x0 -> + Ast_410.Parsetree.Pmod_extension (copy_extension x0) + +and copy_module_type : + Ast_409.Parsetree.module_type -> Ast_410.Parsetree.module_type = + fun { + Ast_409.Parsetree.pmty_desc; + Ast_409.Parsetree.pmty_loc; + Ast_409.Parsetree.pmty_attributes; + } -> + { + Ast_410.Parsetree.pmty_desc = copy_module_type_desc pmty_desc; + Ast_410.Parsetree.pmty_loc = copy_location pmty_loc; + Ast_410.Parsetree.pmty_attributes = copy_attributes pmty_attributes; + } + +and copy_module_type_desc : + Ast_409.Parsetree.module_type_desc -> Ast_410.Parsetree.module_type_desc = + function + | Ast_409.Parsetree.Pmty_ident x0 -> + Ast_410.Parsetree.Pmty_ident (copy_loc copy_Longident_t x0) + | Ast_409.Parsetree.Pmty_signature x0 -> + Ast_410.Parsetree.Pmty_signature (copy_signature x0) + | Ast_409.Parsetree.Pmty_functor (x0, x1, x2) -> + Ast_410.Parsetree.Pmty_functor + ( (match (x0.txt, x1) with + | "*", None -> Unit + | "_", Some mt -> + Named (copy_loc (fun _ -> None) x0, copy_module_type mt) + | _, Some mt -> + Named (copy_loc (fun x -> Some x) x0, copy_module_type mt) + | _ -> assert false), + copy_module_type x2 ) + | Ast_409.Parsetree.Pmty_with (x0, x1) -> + Ast_410.Parsetree.Pmty_with + (copy_module_type x0, List.map copy_with_constraint x1) + | Ast_409.Parsetree.Pmty_typeof x0 -> + Ast_410.Parsetree.Pmty_typeof (copy_module_expr x0) + | Ast_409.Parsetree.Pmty_extension x0 -> + Ast_410.Parsetree.Pmty_extension (copy_extension x0) + | Ast_409.Parsetree.Pmty_alias x0 -> + Ast_410.Parsetree.Pmty_alias (copy_loc copy_Longident_t x0) + +and copy_with_constraint : + Ast_409.Parsetree.with_constraint -> Ast_410.Parsetree.with_constraint = + function + | Ast_409.Parsetree.Pwith_type (x0, x1) -> + Ast_410.Parsetree.Pwith_type + (copy_loc copy_Longident_t x0, copy_type_declaration x1) + | Ast_409.Parsetree.Pwith_module (x0, x1) -> + Ast_410.Parsetree.Pwith_module + (copy_loc copy_Longident_t x0, copy_loc copy_Longident_t x1) + | Ast_409.Parsetree.Pwith_typesubst (x0, x1) -> + Ast_410.Parsetree.Pwith_typesubst + (copy_loc copy_Longident_t x0, copy_type_declaration x1) + | Ast_409.Parsetree.Pwith_modsubst (x0, x1) -> + Ast_410.Parsetree.Pwith_modsubst + (copy_loc copy_Longident_t x0, copy_loc copy_Longident_t x1) + +and copy_signature : Ast_409.Parsetree.signature -> Ast_410.Parsetree.signature + = + fun x -> List.map copy_signature_item x + +and copy_signature_item : + Ast_409.Parsetree.signature_item -> Ast_410.Parsetree.signature_item = + fun { Ast_409.Parsetree.psig_desc; Ast_409.Parsetree.psig_loc } -> + { + Ast_410.Parsetree.psig_desc = copy_signature_item_desc psig_desc; + Ast_410.Parsetree.psig_loc = copy_location psig_loc; + } + +and copy_signature_item_desc : + Ast_409.Parsetree.signature_item_desc -> + Ast_410.Parsetree.signature_item_desc = function + | Ast_409.Parsetree.Psig_value x0 -> + Ast_410.Parsetree.Psig_value (copy_value_description x0) + | Ast_409.Parsetree.Psig_type (x0, x1) -> + Ast_410.Parsetree.Psig_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | Ast_409.Parsetree.Psig_typesubst x0 -> + Ast_410.Parsetree.Psig_typesubst (List.map copy_type_declaration x0) + | Ast_409.Parsetree.Psig_typext x0 -> + Ast_410.Parsetree.Psig_typext (copy_type_extension x0) + | Ast_409.Parsetree.Psig_exception x0 -> + Ast_410.Parsetree.Psig_exception (copy_type_exception x0) + | Ast_409.Parsetree.Psig_module x0 -> + Ast_410.Parsetree.Psig_module (copy_module_declaration x0) + | Ast_409.Parsetree.Psig_modsubst x0 -> + Ast_410.Parsetree.Psig_modsubst (copy_module_substitution x0) + | Ast_409.Parsetree.Psig_recmodule x0 -> + Ast_410.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) + | Ast_409.Parsetree.Psig_modtype x0 -> + Ast_410.Parsetree.Psig_modtype (copy_module_type_declaration x0) + | Ast_409.Parsetree.Psig_open x0 -> + Ast_410.Parsetree.Psig_open (copy_open_description x0) + | Ast_409.Parsetree.Psig_include x0 -> + Ast_410.Parsetree.Psig_include (copy_include_description x0) + | Ast_409.Parsetree.Psig_class x0 -> + Ast_410.Parsetree.Psig_class (List.map copy_class_description x0) + | Ast_409.Parsetree.Psig_class_type x0 -> + Ast_410.Parsetree.Psig_class_type + (List.map copy_class_type_declaration x0) + | Ast_409.Parsetree.Psig_attribute x0 -> + Ast_410.Parsetree.Psig_attribute (copy_attribute x0) + | Ast_409.Parsetree.Psig_extension (x0, x1) -> + Ast_410.Parsetree.Psig_extension (copy_extension x0, copy_attributes x1) + +and copy_class_type_declaration : + Ast_409.Parsetree.class_type_declaration -> + Ast_410.Parsetree.class_type_declaration = + fun x -> copy_class_infos copy_class_type x + +and copy_class_description : + Ast_409.Parsetree.class_description -> Ast_410.Parsetree.class_description = + fun x -> copy_class_infos copy_class_type x + +and copy_class_type : + Ast_409.Parsetree.class_type -> Ast_410.Parsetree.class_type = + fun { + Ast_409.Parsetree.pcty_desc; + Ast_409.Parsetree.pcty_loc; + Ast_409.Parsetree.pcty_attributes; + } -> + { + Ast_410.Parsetree.pcty_desc = copy_class_type_desc pcty_desc; + Ast_410.Parsetree.pcty_loc = copy_location pcty_loc; + Ast_410.Parsetree.pcty_attributes = copy_attributes pcty_attributes; + } + +and copy_class_type_desc : + Ast_409.Parsetree.class_type_desc -> Ast_410.Parsetree.class_type_desc = + function + | Ast_409.Parsetree.Pcty_constr (x0, x1) -> + Ast_410.Parsetree.Pcty_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_409.Parsetree.Pcty_signature x0 -> + Ast_410.Parsetree.Pcty_signature (copy_class_signature x0) + | Ast_409.Parsetree.Pcty_arrow (x0, x1, x2) -> + Ast_410.Parsetree.Pcty_arrow + (copy_arg_label x0, copy_core_type x1, copy_class_type x2) + | Ast_409.Parsetree.Pcty_extension x0 -> + Ast_410.Parsetree.Pcty_extension (copy_extension x0) + | Ast_409.Parsetree.Pcty_open (x0, x1) -> + Ast_410.Parsetree.Pcty_open (copy_open_description x0, copy_class_type x1) + +and copy_class_signature : + Ast_409.Parsetree.class_signature -> Ast_410.Parsetree.class_signature = + fun { Ast_409.Parsetree.pcsig_self; Ast_409.Parsetree.pcsig_fields } -> + { + Ast_410.Parsetree.pcsig_self = copy_core_type pcsig_self; + Ast_410.Parsetree.pcsig_fields = List.map copy_class_type_field pcsig_fields; + } + +and copy_class_type_field : + Ast_409.Parsetree.class_type_field -> Ast_410.Parsetree.class_type_field = + fun { + Ast_409.Parsetree.pctf_desc; + Ast_409.Parsetree.pctf_loc; + Ast_409.Parsetree.pctf_attributes; + } -> + { + Ast_410.Parsetree.pctf_desc = copy_class_type_field_desc pctf_desc; + Ast_410.Parsetree.pctf_loc = copy_location pctf_loc; + Ast_410.Parsetree.pctf_attributes = copy_attributes pctf_attributes; + } + +and copy_class_type_field_desc : + Ast_409.Parsetree.class_type_field_desc -> + Ast_410.Parsetree.class_type_field_desc = function + | Ast_409.Parsetree.Pctf_inherit x0 -> + Ast_410.Parsetree.Pctf_inherit (copy_class_type x0) + | Ast_409.Parsetree.Pctf_val x0 -> + Ast_410.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_409.Parsetree.Pctf_method x0 -> + Ast_410.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_409.Parsetree.Pctf_constraint x0 -> + Ast_410.Parsetree.Pctf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | Ast_409.Parsetree.Pctf_attribute x0 -> + Ast_410.Parsetree.Pctf_attribute (copy_attribute x0) + | Ast_409.Parsetree.Pctf_extension x0 -> + Ast_410.Parsetree.Pctf_extension (copy_extension x0) + +and copy_extension : Ast_409.Parsetree.extension -> Ast_410.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_409.Parsetree.class_infos -> + 'g0 Ast_410.Parsetree.class_infos = + fun f0 + { + Ast_409.Parsetree.pci_virt; + Ast_409.Parsetree.pci_params; + Ast_409.Parsetree.pci_name; + Ast_409.Parsetree.pci_expr; + Ast_409.Parsetree.pci_loc; + Ast_409.Parsetree.pci_attributes; + } -> + { + Ast_410.Parsetree.pci_virt = copy_virtual_flag pci_virt; + Ast_410.Parsetree.pci_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + pci_params; + Ast_410.Parsetree.pci_name = copy_loc (fun x -> x) pci_name; + Ast_410.Parsetree.pci_expr = f0 pci_expr; + Ast_410.Parsetree.pci_loc = copy_location pci_loc; + Ast_410.Parsetree.pci_attributes = copy_attributes pci_attributes; + } + +and copy_virtual_flag : + Ast_409.Asttypes.virtual_flag -> Ast_410.Asttypes.virtual_flag = function + | Ast_409.Asttypes.Virtual -> Ast_410.Asttypes.Virtual + | Ast_409.Asttypes.Concrete -> Ast_410.Asttypes.Concrete + +and copy_include_description : + Ast_409.Parsetree.include_description -> + Ast_410.Parsetree.include_description = + fun x -> copy_include_infos copy_module_type x + +and copy_include_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 Ast_409.Parsetree.include_infos -> + 'g0 Ast_410.Parsetree.include_infos = + fun f0 + { + Ast_409.Parsetree.pincl_mod; + Ast_409.Parsetree.pincl_loc; + Ast_409.Parsetree.pincl_attributes; + } -> + { + Ast_410.Parsetree.pincl_mod = f0 pincl_mod; + Ast_410.Parsetree.pincl_loc = copy_location pincl_loc; + Ast_410.Parsetree.pincl_attributes = copy_attributes pincl_attributes; + } + +and copy_open_description : + Ast_409.Parsetree.open_description -> Ast_410.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_409.Parsetree.open_infos -> + 'g0 Ast_410.Parsetree.open_infos = + fun f0 + { + Ast_409.Parsetree.popen_expr; + Ast_409.Parsetree.popen_override; + Ast_409.Parsetree.popen_loc; + Ast_409.Parsetree.popen_attributes; + } -> + { + Ast_410.Parsetree.popen_expr = f0 popen_expr; + Ast_410.Parsetree.popen_override = copy_override_flag popen_override; + Ast_410.Parsetree.popen_loc = copy_location popen_loc; + Ast_410.Parsetree.popen_attributes = copy_attributes popen_attributes; + } + +and copy_override_flag : + Ast_409.Asttypes.override_flag -> Ast_410.Asttypes.override_flag = function + | Ast_409.Asttypes.Override -> Ast_410.Asttypes.Override + | Ast_409.Asttypes.Fresh -> Ast_410.Asttypes.Fresh + +and copy_module_type_declaration : + Ast_409.Parsetree.module_type_declaration -> + Ast_410.Parsetree.module_type_declaration = + fun { + Ast_409.Parsetree.pmtd_name; + Ast_409.Parsetree.pmtd_type; + Ast_409.Parsetree.pmtd_attributes; + Ast_409.Parsetree.pmtd_loc; + } -> + { + Ast_410.Parsetree.pmtd_name = copy_loc (fun x -> x) pmtd_name; + Ast_410.Parsetree.pmtd_type = map_option copy_module_type pmtd_type; + Ast_410.Parsetree.pmtd_attributes = copy_attributes pmtd_attributes; + Ast_410.Parsetree.pmtd_loc = copy_location pmtd_loc; + } + +and copy_module_substitution : + Ast_409.Parsetree.module_substitution -> + Ast_410.Parsetree.module_substitution = + fun { + Ast_409.Parsetree.pms_name; + Ast_409.Parsetree.pms_manifest; + Ast_409.Parsetree.pms_attributes; + Ast_409.Parsetree.pms_loc; + } -> + { + Ast_410.Parsetree.pms_name = copy_loc (fun x -> x) pms_name; + Ast_410.Parsetree.pms_manifest = copy_loc copy_Longident_t pms_manifest; + Ast_410.Parsetree.pms_attributes = copy_attributes pms_attributes; + Ast_410.Parsetree.pms_loc = copy_location pms_loc; + } + +and copy_module_declaration : + Ast_409.Parsetree.module_declaration -> Ast_410.Parsetree.module_declaration + = + fun { + Ast_409.Parsetree.pmd_name; + Ast_409.Parsetree.pmd_type; + Ast_409.Parsetree.pmd_attributes; + Ast_409.Parsetree.pmd_loc; + } -> + { + Ast_410.Parsetree.pmd_name = copy_loc (fun x -> Some x) pmd_name; + Ast_410.Parsetree.pmd_type = copy_module_type pmd_type; + Ast_410.Parsetree.pmd_attributes = copy_attributes pmd_attributes; + Ast_410.Parsetree.pmd_loc = copy_location pmd_loc; + } + +and copy_type_exception : + Ast_409.Parsetree.type_exception -> Ast_410.Parsetree.type_exception = + fun { + Ast_409.Parsetree.ptyexn_constructor; + Ast_409.Parsetree.ptyexn_loc; + Ast_409.Parsetree.ptyexn_attributes; + } -> + { + Ast_410.Parsetree.ptyexn_constructor = + copy_extension_constructor ptyexn_constructor; + Ast_410.Parsetree.ptyexn_loc = copy_location ptyexn_loc; + Ast_410.Parsetree.ptyexn_attributes = copy_attributes ptyexn_attributes; + } + +and copy_type_extension : + Ast_409.Parsetree.type_extension -> Ast_410.Parsetree.type_extension = + fun { + Ast_409.Parsetree.ptyext_path; + Ast_409.Parsetree.ptyext_params; + Ast_409.Parsetree.ptyext_constructors; + Ast_409.Parsetree.ptyext_private; + Ast_409.Parsetree.ptyext_loc; + Ast_409.Parsetree.ptyext_attributes; + } -> + { + Ast_410.Parsetree.ptyext_path = copy_loc copy_Longident_t ptyext_path; + Ast_410.Parsetree.ptyext_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptyext_params; + Ast_410.Parsetree.ptyext_constructors = + List.map copy_extension_constructor ptyext_constructors; + Ast_410.Parsetree.ptyext_private = copy_private_flag ptyext_private; + Ast_410.Parsetree.ptyext_loc = copy_location ptyext_loc; + Ast_410.Parsetree.ptyext_attributes = copy_attributes ptyext_attributes; + } + +and copy_extension_constructor : + Ast_409.Parsetree.extension_constructor -> + Ast_410.Parsetree.extension_constructor = + fun { + Ast_409.Parsetree.pext_name; + Ast_409.Parsetree.pext_kind; + Ast_409.Parsetree.pext_loc; + Ast_409.Parsetree.pext_attributes; + } -> + { + Ast_410.Parsetree.pext_name = copy_loc (fun x -> x) pext_name; + Ast_410.Parsetree.pext_kind = copy_extension_constructor_kind pext_kind; + Ast_410.Parsetree.pext_loc = copy_location pext_loc; + Ast_410.Parsetree.pext_attributes = copy_attributes pext_attributes; + } + +and copy_extension_constructor_kind : + Ast_409.Parsetree.extension_constructor_kind -> + Ast_410.Parsetree.extension_constructor_kind = function + | Ast_409.Parsetree.Pext_decl (x0, x1) -> + Ast_410.Parsetree.Pext_decl + (copy_constructor_arguments x0, map_option copy_core_type x1) + | Ast_409.Parsetree.Pext_rebind x0 -> + Ast_410.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0) + +and copy_type_declaration : + Ast_409.Parsetree.type_declaration -> Ast_410.Parsetree.type_declaration = + fun { + Ast_409.Parsetree.ptype_name; + Ast_409.Parsetree.ptype_params; + Ast_409.Parsetree.ptype_cstrs; + Ast_409.Parsetree.ptype_kind; + Ast_409.Parsetree.ptype_private; + Ast_409.Parsetree.ptype_manifest; + Ast_409.Parsetree.ptype_attributes; + Ast_409.Parsetree.ptype_loc; + } -> + { + Ast_410.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name; + Ast_410.Parsetree.ptype_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptype_params; + Ast_410.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_410.Parsetree.ptype_kind = copy_type_kind ptype_kind; + Ast_410.Parsetree.ptype_private = copy_private_flag ptype_private; + Ast_410.Parsetree.ptype_manifest = map_option copy_core_type ptype_manifest; + Ast_410.Parsetree.ptype_attributes = copy_attributes ptype_attributes; + Ast_410.Parsetree.ptype_loc = copy_location ptype_loc; + } + +and copy_private_flag : + Ast_409.Asttypes.private_flag -> Ast_410.Asttypes.private_flag = function + | Ast_409.Asttypes.Private -> Ast_410.Asttypes.Private + | Ast_409.Asttypes.Public -> Ast_410.Asttypes.Public + +and copy_type_kind : Ast_409.Parsetree.type_kind -> Ast_410.Parsetree.type_kind + = function + | Ast_409.Parsetree.Ptype_abstract -> Ast_410.Parsetree.Ptype_abstract + | Ast_409.Parsetree.Ptype_variant x0 -> + Ast_410.Parsetree.Ptype_variant (List.map copy_constructor_declaration x0) + | Ast_409.Parsetree.Ptype_record x0 -> + Ast_410.Parsetree.Ptype_record (List.map copy_label_declaration x0) + | Ast_409.Parsetree.Ptype_open -> Ast_410.Parsetree.Ptype_open + +and copy_constructor_declaration : + Ast_409.Parsetree.constructor_declaration -> + Ast_410.Parsetree.constructor_declaration = + fun { + Ast_409.Parsetree.pcd_name; + Ast_409.Parsetree.pcd_args; + Ast_409.Parsetree.pcd_res; + Ast_409.Parsetree.pcd_loc; + Ast_409.Parsetree.pcd_attributes; + } -> + { + Ast_410.Parsetree.pcd_name = copy_loc (fun x -> x) pcd_name; + Ast_410.Parsetree.pcd_args = copy_constructor_arguments pcd_args; + Ast_410.Parsetree.pcd_res = map_option copy_core_type pcd_res; + Ast_410.Parsetree.pcd_loc = copy_location pcd_loc; + Ast_410.Parsetree.pcd_attributes = copy_attributes pcd_attributes; + } + +and copy_constructor_arguments : + Ast_409.Parsetree.constructor_arguments -> + Ast_410.Parsetree.constructor_arguments = function + | Ast_409.Parsetree.Pcstr_tuple x0 -> + Ast_410.Parsetree.Pcstr_tuple (List.map copy_core_type x0) + | Ast_409.Parsetree.Pcstr_record x0 -> + Ast_410.Parsetree.Pcstr_record (List.map copy_label_declaration x0) + +and copy_label_declaration : + Ast_409.Parsetree.label_declaration -> Ast_410.Parsetree.label_declaration = + fun { + Ast_409.Parsetree.pld_name; + Ast_409.Parsetree.pld_mutable; + Ast_409.Parsetree.pld_type; + Ast_409.Parsetree.pld_loc; + Ast_409.Parsetree.pld_attributes; + } -> + { + Ast_410.Parsetree.pld_name = copy_loc (fun x -> x) pld_name; + Ast_410.Parsetree.pld_mutable = copy_mutable_flag pld_mutable; + Ast_410.Parsetree.pld_type = copy_core_type pld_type; + Ast_410.Parsetree.pld_loc = copy_location pld_loc; + Ast_410.Parsetree.pld_attributes = copy_attributes pld_attributes; + } + +and copy_mutable_flag : + Ast_409.Asttypes.mutable_flag -> Ast_410.Asttypes.mutable_flag = function + | Ast_409.Asttypes.Immutable -> Ast_410.Asttypes.Immutable + | Ast_409.Asttypes.Mutable -> Ast_410.Asttypes.Mutable + +and copy_variance : Ast_409.Asttypes.variance -> Ast_410.Asttypes.variance = + function + | Ast_409.Asttypes.Covariant -> Ast_410.Asttypes.Covariant + | Ast_409.Asttypes.Contravariant -> Ast_410.Asttypes.Contravariant + | Ast_409.Asttypes.Invariant -> Ast_410.Asttypes.Invariant + +and copy_value_description : + Ast_409.Parsetree.value_description -> Ast_410.Parsetree.value_description = + fun { + Ast_409.Parsetree.pval_name; + Ast_409.Parsetree.pval_type; + Ast_409.Parsetree.pval_prim; + Ast_409.Parsetree.pval_attributes; + Ast_409.Parsetree.pval_loc; + } -> + { + Ast_410.Parsetree.pval_name = copy_loc (fun x -> x) pval_name; + Ast_410.Parsetree.pval_type = copy_core_type pval_type; + Ast_410.Parsetree.pval_prim = List.map (fun x -> x) pval_prim; + Ast_410.Parsetree.pval_attributes = copy_attributes pval_attributes; + Ast_410.Parsetree.pval_loc = copy_location pval_loc; + } + +and copy_object_field_desc : + Ast_409.Parsetree.object_field_desc -> Ast_410.Parsetree.object_field_desc = + function + | Ast_409.Parsetree.Otag (x0, x1) -> + Ast_410.Parsetree.Otag (copy_loc copy_label x0, copy_core_type x1) + | Ast_409.Parsetree.Oinherit x0 -> + Ast_410.Parsetree.Oinherit (copy_core_type x0) + +and copy_arg_label : Ast_409.Asttypes.arg_label -> Ast_410.Asttypes.arg_label = + function + | Ast_409.Asttypes.Nolabel -> Ast_410.Asttypes.Nolabel + | Ast_409.Asttypes.Labelled x0 -> Ast_410.Asttypes.Labelled x0 + | Ast_409.Asttypes.Optional x0 -> Ast_410.Asttypes.Optional x0 + +and copy_closed_flag : + Ast_409.Asttypes.closed_flag -> Ast_410.Asttypes.closed_flag = function + | Ast_409.Asttypes.Closed -> Ast_410.Asttypes.Closed + | Ast_409.Asttypes.Open -> Ast_410.Asttypes.Open + +and copy_label : Ast_409.Asttypes.label -> Ast_410.Asttypes.label = fun x -> x + +and copy_rec_flag : Ast_409.Asttypes.rec_flag -> Ast_410.Asttypes.rec_flag = + function + | Ast_409.Asttypes.Nonrecursive -> Ast_410.Asttypes.Nonrecursive + | Ast_409.Asttypes.Recursive -> Ast_410.Asttypes.Recursive + +and copy_constant : Ast_409.Parsetree.constant -> Ast_410.Parsetree.constant = + function + | Ast_409.Parsetree.Pconst_integer (x0, x1) -> + Ast_410.Parsetree.Pconst_integer (x0, map_option (fun x -> x) x1) + | Ast_409.Parsetree.Pconst_char x0 -> Ast_410.Parsetree.Pconst_char x0 + | Ast_409.Parsetree.Pconst_string (x0, x1) -> + Ast_410.Parsetree.Pconst_string (x0, map_option (fun x -> x) x1) + | Ast_409.Parsetree.Pconst_float (x0, x1) -> + Ast_410.Parsetree.Pconst_float (x0, map_option (fun x -> x) x1) + +and copy_Longident_t : Longident.t -> Longident.t = fun x -> x + +and copy_loc : + 'f0 'g0. + ('f0 -> 'g0) -> 'f0 Ast_409.Asttypes.loc -> 'g0 Ast_410.Asttypes.loc = + fun f0 { Ast_409.Asttypes.txt; Ast_409.Asttypes.loc } -> + { Ast_410.Asttypes.txt = f0 txt; Ast_410.Asttypes.loc = copy_location loc } + +and copy_location : Location.t -> Location.t = fun x -> x + +let copy_expr = copy_expression + +let copy_pat = copy_pattern + +let copy_typ = copy_core_type diff -Nru ppxlib-0.15.0/astlib/migrate_410_409.ml ppxlib-0.24.0/astlib/migrate_410_409.ml --- ppxlib-0.15.0/astlib/migrate_410_409.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/migrate_410_409.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1215 @@ +module From = Ast_410 +module To = Ast_409 + +let migration_error loc missing_feature = + Location.raise_errorf ~loc + "migration error: %s is not supported before OCaml 4.10" missing_feature + +let map_option f x = match x with None -> None | Some x -> Some (f x) + +let rec copy_toplevel_phrase : + Ast_410.Parsetree.toplevel_phrase -> Ast_409.Parsetree.toplevel_phrase = + function + | Ast_410.Parsetree.Ptop_def x0 -> + Ast_409.Parsetree.Ptop_def (copy_structure x0) + | Ast_410.Parsetree.Ptop_dir x0 -> + Ast_409.Parsetree.Ptop_dir (copy_toplevel_directive x0) + +and copy_toplevel_directive : + Ast_410.Parsetree.toplevel_directive -> Ast_409.Parsetree.toplevel_directive + = + fun { + Ast_410.Parsetree.pdir_name; + Ast_410.Parsetree.pdir_arg; + Ast_410.Parsetree.pdir_loc; + } -> + { + Ast_409.Parsetree.pdir_name = copy_loc (fun x -> x) pdir_name; + Ast_409.Parsetree.pdir_arg = map_option copy_directive_argument pdir_arg; + Ast_409.Parsetree.pdir_loc = copy_location pdir_loc; + } + +and copy_directive_argument : + Ast_410.Parsetree.directive_argument -> Ast_409.Parsetree.directive_argument + = + fun { Ast_410.Parsetree.pdira_desc; Ast_410.Parsetree.pdira_loc } -> + { + Ast_409.Parsetree.pdira_desc = copy_directive_argument_desc pdira_desc; + Ast_409.Parsetree.pdira_loc = copy_location pdira_loc; + } + +and copy_directive_argument_desc : + Ast_410.Parsetree.directive_argument_desc -> + Ast_409.Parsetree.directive_argument_desc = function + | Ast_410.Parsetree.Pdir_string x0 -> Ast_409.Parsetree.Pdir_string x0 + | Ast_410.Parsetree.Pdir_int (x0, x1) -> + Ast_409.Parsetree.Pdir_int (x0, map_option (fun x -> x) x1) + | Ast_410.Parsetree.Pdir_ident x0 -> + Ast_409.Parsetree.Pdir_ident (copy_Longident_t x0) + | Ast_410.Parsetree.Pdir_bool x0 -> Ast_409.Parsetree.Pdir_bool x0 + +and copy_expression : + Ast_410.Parsetree.expression -> Ast_409.Parsetree.expression = + fun { + Ast_410.Parsetree.pexp_desc; + Ast_410.Parsetree.pexp_loc; + Ast_410.Parsetree.pexp_loc_stack; + Ast_410.Parsetree.pexp_attributes; + } -> + { + Ast_409.Parsetree.pexp_desc = copy_expression_desc pexp_desc; + Ast_409.Parsetree.pexp_loc = copy_location pexp_loc; + Ast_409.Parsetree.pexp_loc_stack = copy_location_stack pexp_loc_stack; + Ast_409.Parsetree.pexp_attributes = copy_attributes pexp_attributes; + } + +and copy_expression_desc : + Ast_410.Parsetree.expression_desc -> Ast_409.Parsetree.expression_desc = + function + | Ast_410.Parsetree.Pexp_ident x0 -> + Ast_409.Parsetree.Pexp_ident (copy_loc copy_Longident_t x0) + | Ast_410.Parsetree.Pexp_constant x0 -> + Ast_409.Parsetree.Pexp_constant (copy_constant x0) + | Ast_410.Parsetree.Pexp_let (x0, x1, x2) -> + Ast_409.Parsetree.Pexp_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_expression x2) + | Ast_410.Parsetree.Pexp_function x0 -> + Ast_409.Parsetree.Pexp_function (List.map copy_case x0) + | Ast_410.Parsetree.Pexp_fun (x0, x1, x2, x3) -> + Ast_409.Parsetree.Pexp_fun + ( copy_arg_label x0, + map_option copy_expression x1, + copy_pattern x2, + copy_expression x3 ) + | Ast_410.Parsetree.Pexp_apply (x0, x1) -> + Ast_409.Parsetree.Pexp_apply + ( copy_expression x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | Ast_410.Parsetree.Pexp_match (x0, x1) -> + Ast_409.Parsetree.Pexp_match (copy_expression x0, List.map copy_case x1) + | Ast_410.Parsetree.Pexp_try (x0, x1) -> + Ast_409.Parsetree.Pexp_try (copy_expression x0, List.map copy_case x1) + | Ast_410.Parsetree.Pexp_tuple x0 -> + Ast_409.Parsetree.Pexp_tuple (List.map copy_expression x0) + | Ast_410.Parsetree.Pexp_construct (x0, x1) -> + Ast_409.Parsetree.Pexp_construct + (copy_loc copy_Longident_t x0, map_option copy_expression x1) + | Ast_410.Parsetree.Pexp_variant (x0, x1) -> + Ast_409.Parsetree.Pexp_variant + (copy_label x0, map_option copy_expression x1) + | Ast_410.Parsetree.Pexp_record (x0, x1) -> + Ast_409.Parsetree.Pexp_record + ( List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_Longident_t x0, copy_expression x1)) + x0, + map_option copy_expression x1 ) + | Ast_410.Parsetree.Pexp_field (x0, x1) -> + Ast_409.Parsetree.Pexp_field + (copy_expression x0, copy_loc copy_Longident_t x1) + | Ast_410.Parsetree.Pexp_setfield (x0, x1, x2) -> + Ast_409.Parsetree.Pexp_setfield + (copy_expression x0, copy_loc copy_Longident_t x1, copy_expression x2) + | Ast_410.Parsetree.Pexp_array x0 -> + Ast_409.Parsetree.Pexp_array (List.map copy_expression x0) + | Ast_410.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> + Ast_409.Parsetree.Pexp_ifthenelse + (copy_expression x0, copy_expression x1, map_option copy_expression x2) + | Ast_410.Parsetree.Pexp_sequence (x0, x1) -> + Ast_409.Parsetree.Pexp_sequence (copy_expression x0, copy_expression x1) + | Ast_410.Parsetree.Pexp_while (x0, x1) -> + Ast_409.Parsetree.Pexp_while (copy_expression x0, copy_expression x1) + | Ast_410.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> + Ast_409.Parsetree.Pexp_for + ( copy_pattern x0, + copy_expression x1, + copy_expression x2, + copy_direction_flag x3, + copy_expression x4 ) + | Ast_410.Parsetree.Pexp_constraint (x0, x1) -> + Ast_409.Parsetree.Pexp_constraint (copy_expression x0, copy_core_type x1) + | Ast_410.Parsetree.Pexp_coerce (x0, x1, x2) -> + Ast_409.Parsetree.Pexp_coerce + (copy_expression x0, map_option copy_core_type x1, copy_core_type x2) + | Ast_410.Parsetree.Pexp_send (x0, x1) -> + Ast_409.Parsetree.Pexp_send (copy_expression x0, copy_loc copy_label x1) + | Ast_410.Parsetree.Pexp_new x0 -> + Ast_409.Parsetree.Pexp_new (copy_loc copy_Longident_t x0) + | Ast_410.Parsetree.Pexp_setinstvar (x0, x1) -> + Ast_409.Parsetree.Pexp_setinstvar + (copy_loc copy_label x0, copy_expression x1) + | Ast_410.Parsetree.Pexp_override x0 -> + Ast_409.Parsetree.Pexp_override + (List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_label x0, copy_expression x1)) + x0) + | Ast_410.Parsetree.Pexp_letmodule (x0, x1, x2) -> + Ast_409.Parsetree.Pexp_letmodule + ( copy_loc + (function + | None -> migration_error x0.loc "anonymous let module" + | Some x -> x) + x0, + copy_module_expr x1, + copy_expression x2 ) + | Ast_410.Parsetree.Pexp_letexception (x0, x1) -> + Ast_409.Parsetree.Pexp_letexception + (copy_extension_constructor x0, copy_expression x1) + | Ast_410.Parsetree.Pexp_assert x0 -> + Ast_409.Parsetree.Pexp_assert (copy_expression x0) + | Ast_410.Parsetree.Pexp_lazy x0 -> + Ast_409.Parsetree.Pexp_lazy (copy_expression x0) + | Ast_410.Parsetree.Pexp_poly (x0, x1) -> + Ast_409.Parsetree.Pexp_poly + (copy_expression x0, map_option copy_core_type x1) + | Ast_410.Parsetree.Pexp_object x0 -> + Ast_409.Parsetree.Pexp_object (copy_class_structure x0) + | Ast_410.Parsetree.Pexp_newtype (x0, x1) -> + Ast_409.Parsetree.Pexp_newtype + (copy_loc (fun x -> x) x0, copy_expression x1) + | Ast_410.Parsetree.Pexp_pack x0 -> + Ast_409.Parsetree.Pexp_pack (copy_module_expr x0) + | Ast_410.Parsetree.Pexp_open (x0, x1) -> + Ast_409.Parsetree.Pexp_open (copy_open_declaration x0, copy_expression x1) + | Ast_410.Parsetree.Pexp_letop x0 -> + Ast_409.Parsetree.Pexp_letop (copy_letop x0) + | Ast_410.Parsetree.Pexp_extension x0 -> + Ast_409.Parsetree.Pexp_extension (copy_extension x0) + | Ast_410.Parsetree.Pexp_unreachable -> Ast_409.Parsetree.Pexp_unreachable + +and copy_letop : Ast_410.Parsetree.letop -> Ast_409.Parsetree.letop = + fun { Ast_410.Parsetree.let_; Ast_410.Parsetree.ands; Ast_410.Parsetree.body } -> + { + Ast_409.Parsetree.let_ = copy_binding_op let_; + Ast_409.Parsetree.ands = List.map copy_binding_op ands; + Ast_409.Parsetree.body = copy_expression body; + } + +and copy_binding_op : + Ast_410.Parsetree.binding_op -> Ast_409.Parsetree.binding_op = + fun { + Ast_410.Parsetree.pbop_op; + Ast_410.Parsetree.pbop_pat; + Ast_410.Parsetree.pbop_exp; + Ast_410.Parsetree.pbop_loc; + } -> + { + Ast_409.Parsetree.pbop_op = copy_loc (fun x -> x) pbop_op; + Ast_409.Parsetree.pbop_pat = copy_pattern pbop_pat; + Ast_409.Parsetree.pbop_exp = copy_expression pbop_exp; + Ast_409.Parsetree.pbop_loc = copy_location pbop_loc; + } + +and copy_direction_flag : + Ast_410.Asttypes.direction_flag -> Ast_409.Asttypes.direction_flag = + function + | Ast_410.Asttypes.Upto -> Ast_409.Asttypes.Upto + | Ast_410.Asttypes.Downto -> Ast_409.Asttypes.Downto + +and copy_case : Ast_410.Parsetree.case -> Ast_409.Parsetree.case = + fun { + Ast_410.Parsetree.pc_lhs; + Ast_410.Parsetree.pc_guard; + Ast_410.Parsetree.pc_rhs; + } -> + { + Ast_409.Parsetree.pc_lhs = copy_pattern pc_lhs; + Ast_409.Parsetree.pc_guard = map_option copy_expression pc_guard; + Ast_409.Parsetree.pc_rhs = copy_expression pc_rhs; + } + +and copy_cases : Ast_410.Parsetree.case list -> Ast_409.Parsetree.cases = + fun x -> List.map copy_case x + +and copy_value_binding : + Ast_410.Parsetree.value_binding -> Ast_409.Parsetree.value_binding = + fun { + Ast_410.Parsetree.pvb_pat; + Ast_410.Parsetree.pvb_expr; + Ast_410.Parsetree.pvb_attributes; + Ast_410.Parsetree.pvb_loc; + } -> + { + Ast_409.Parsetree.pvb_pat = copy_pattern pvb_pat; + Ast_409.Parsetree.pvb_expr = copy_expression pvb_expr; + Ast_409.Parsetree.pvb_attributes = copy_attributes pvb_attributes; + Ast_409.Parsetree.pvb_loc = copy_location pvb_loc; + } + +and copy_pattern : Ast_410.Parsetree.pattern -> Ast_409.Parsetree.pattern = + fun { + Ast_410.Parsetree.ppat_desc; + Ast_410.Parsetree.ppat_loc; + Ast_410.Parsetree.ppat_loc_stack; + Ast_410.Parsetree.ppat_attributes; + } -> + { + Ast_409.Parsetree.ppat_desc = copy_pattern_desc ppat_desc; + Ast_409.Parsetree.ppat_loc = copy_location ppat_loc; + Ast_409.Parsetree.ppat_loc_stack = copy_location_stack ppat_loc_stack; + Ast_409.Parsetree.ppat_attributes = copy_attributes ppat_attributes; + } + +and copy_pattern_desc : + Ast_410.Parsetree.pattern_desc -> Ast_409.Parsetree.pattern_desc = function + | Ast_410.Parsetree.Ppat_any -> Ast_409.Parsetree.Ppat_any + | Ast_410.Parsetree.Ppat_var x0 -> + Ast_409.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) + | Ast_410.Parsetree.Ppat_alias (x0, x1) -> + Ast_409.Parsetree.Ppat_alias (copy_pattern x0, copy_loc (fun x -> x) x1) + | Ast_410.Parsetree.Ppat_constant x0 -> + Ast_409.Parsetree.Ppat_constant (copy_constant x0) + | Ast_410.Parsetree.Ppat_interval (x0, x1) -> + Ast_409.Parsetree.Ppat_interval (copy_constant x0, copy_constant x1) + | Ast_410.Parsetree.Ppat_tuple x0 -> + Ast_409.Parsetree.Ppat_tuple (List.map copy_pattern x0) + | Ast_410.Parsetree.Ppat_construct (x0, x1) -> + Ast_409.Parsetree.Ppat_construct + (copy_loc copy_Longident_t x0, map_option copy_pattern x1) + | Ast_410.Parsetree.Ppat_variant (x0, x1) -> + Ast_409.Parsetree.Ppat_variant (copy_label x0, map_option copy_pattern x1) + | Ast_410.Parsetree.Ppat_record (x0, x1) -> + Ast_409.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_410.Parsetree.Ppat_array x0 -> + Ast_409.Parsetree.Ppat_array (List.map copy_pattern x0) + | Ast_410.Parsetree.Ppat_or (x0, x1) -> + Ast_409.Parsetree.Ppat_or (copy_pattern x0, copy_pattern x1) + | Ast_410.Parsetree.Ppat_constraint (x0, x1) -> + Ast_409.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1) + | Ast_410.Parsetree.Ppat_type x0 -> + Ast_409.Parsetree.Ppat_type (copy_loc copy_Longident_t x0) + | Ast_410.Parsetree.Ppat_lazy x0 -> + Ast_409.Parsetree.Ppat_lazy (copy_pattern x0) + | Ast_410.Parsetree.Ppat_unpack x0 -> + Ast_409.Parsetree.Ppat_unpack + (copy_loc + (function + | None -> migration_error x0.loc "anynymous unpack" | Some x -> x) + x0) + | Ast_410.Parsetree.Ppat_exception x0 -> + Ast_409.Parsetree.Ppat_exception (copy_pattern x0) + | Ast_410.Parsetree.Ppat_extension x0 -> + Ast_409.Parsetree.Ppat_extension (copy_extension x0) + | Ast_410.Parsetree.Ppat_open (x0, x1) -> + Ast_409.Parsetree.Ppat_open (copy_loc copy_Longident_t x0, copy_pattern x1) + +and copy_core_type : Ast_410.Parsetree.core_type -> Ast_409.Parsetree.core_type + = + fun { + Ast_410.Parsetree.ptyp_desc; + Ast_410.Parsetree.ptyp_loc; + Ast_410.Parsetree.ptyp_loc_stack; + Ast_410.Parsetree.ptyp_attributes; + } -> + { + Ast_409.Parsetree.ptyp_desc = copy_core_type_desc ptyp_desc; + Ast_409.Parsetree.ptyp_loc = copy_location ptyp_loc; + Ast_409.Parsetree.ptyp_loc_stack = copy_location_stack ptyp_loc_stack; + Ast_409.Parsetree.ptyp_attributes = copy_attributes ptyp_attributes; + } + +and copy_location_stack : Ast_410.Parsetree.location_stack -> Location.t list = + fun x -> List.map copy_location x + +and copy_core_type_desc : + Ast_410.Parsetree.core_type_desc -> Ast_409.Parsetree.core_type_desc = + function + | Ast_410.Parsetree.Ptyp_any -> Ast_409.Parsetree.Ptyp_any + | Ast_410.Parsetree.Ptyp_var x0 -> Ast_409.Parsetree.Ptyp_var x0 + | Ast_410.Parsetree.Ptyp_arrow (x0, x1, x2) -> + Ast_409.Parsetree.Ptyp_arrow + (copy_arg_label x0, copy_core_type x1, copy_core_type x2) + | Ast_410.Parsetree.Ptyp_tuple x0 -> + Ast_409.Parsetree.Ptyp_tuple (List.map copy_core_type x0) + | Ast_410.Parsetree.Ptyp_constr (x0, x1) -> + Ast_409.Parsetree.Ptyp_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_410.Parsetree.Ptyp_object (x0, x1) -> + Ast_409.Parsetree.Ptyp_object + (List.map copy_object_field x0, copy_closed_flag x1) + | Ast_410.Parsetree.Ptyp_class (x0, x1) -> + Ast_409.Parsetree.Ptyp_class + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_410.Parsetree.Ptyp_alias (x0, x1) -> + Ast_409.Parsetree.Ptyp_alias (copy_core_type x0, x1) + | Ast_410.Parsetree.Ptyp_variant (x0, x1, x2) -> + Ast_409.Parsetree.Ptyp_variant + ( List.map copy_row_field x0, + copy_closed_flag x1, + map_option (fun x -> List.map copy_label x) x2 ) + | Ast_410.Parsetree.Ptyp_poly (x0, x1) -> + Ast_409.Parsetree.Ptyp_poly + (List.map (fun x -> copy_loc (fun x -> x) x) x0, copy_core_type x1) + | Ast_410.Parsetree.Ptyp_package x0 -> + Ast_409.Parsetree.Ptyp_package (copy_package_type x0) + | Ast_410.Parsetree.Ptyp_extension x0 -> + Ast_409.Parsetree.Ptyp_extension (copy_extension x0) + +and copy_package_type : + Ast_410.Parsetree.package_type -> Ast_409.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_410.Parsetree.row_field -> Ast_409.Parsetree.row_field + = + fun { + Ast_410.Parsetree.prf_desc; + Ast_410.Parsetree.prf_loc; + Ast_410.Parsetree.prf_attributes; + } -> + { + Ast_409.Parsetree.prf_desc = copy_row_field_desc prf_desc; + Ast_409.Parsetree.prf_loc = copy_location prf_loc; + Ast_409.Parsetree.prf_attributes = copy_attributes prf_attributes; + } + +and copy_row_field_desc : + Ast_410.Parsetree.row_field_desc -> Ast_409.Parsetree.row_field_desc = + function + | Ast_410.Parsetree.Rtag (x0, x1, x2) -> + Ast_409.Parsetree.Rtag + (copy_loc copy_label x0, x1, List.map copy_core_type x2) + | Ast_410.Parsetree.Rinherit x0 -> + Ast_409.Parsetree.Rinherit (copy_core_type x0) + +and copy_object_field : + Ast_410.Parsetree.object_field -> Ast_409.Parsetree.object_field = + fun { + Ast_410.Parsetree.pof_desc; + Ast_410.Parsetree.pof_loc; + Ast_410.Parsetree.pof_attributes; + } -> + { + Ast_409.Parsetree.pof_desc = copy_object_field_desc pof_desc; + Ast_409.Parsetree.pof_loc = copy_location pof_loc; + Ast_409.Parsetree.pof_attributes = copy_attributes pof_attributes; + } + +and copy_attributes : + Ast_410.Parsetree.attributes -> Ast_409.Parsetree.attributes = + fun x -> List.map copy_attribute x + +and copy_attribute : Ast_410.Parsetree.attribute -> Ast_409.Parsetree.attribute + = + fun { + Ast_410.Parsetree.attr_name; + Ast_410.Parsetree.attr_payload; + Ast_410.Parsetree.attr_loc; + } -> + { + Ast_409.Parsetree.attr_name = copy_loc (fun x -> x) attr_name; + Ast_409.Parsetree.attr_payload = copy_payload attr_payload; + Ast_409.Parsetree.attr_loc = copy_location attr_loc; + } + +and copy_payload : Ast_410.Parsetree.payload -> Ast_409.Parsetree.payload = + function + | Ast_410.Parsetree.PStr x0 -> Ast_409.Parsetree.PStr (copy_structure x0) + | Ast_410.Parsetree.PSig x0 -> Ast_409.Parsetree.PSig (copy_signature x0) + | Ast_410.Parsetree.PTyp x0 -> Ast_409.Parsetree.PTyp (copy_core_type x0) + | Ast_410.Parsetree.PPat (x0, x1) -> + Ast_409.Parsetree.PPat (copy_pattern x0, map_option copy_expression x1) + +and copy_structure : Ast_410.Parsetree.structure -> Ast_409.Parsetree.structure + = + fun x -> List.map copy_structure_item x + +and copy_structure_item : + Ast_410.Parsetree.structure_item -> Ast_409.Parsetree.structure_item = + fun { Ast_410.Parsetree.pstr_desc; Ast_410.Parsetree.pstr_loc } -> + { + Ast_409.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc; + Ast_409.Parsetree.pstr_loc = copy_location pstr_loc; + } + +and copy_structure_item_desc : + Ast_410.Parsetree.structure_item_desc -> + Ast_409.Parsetree.structure_item_desc = function + | Ast_410.Parsetree.Pstr_eval (x0, x1) -> + Ast_409.Parsetree.Pstr_eval (copy_expression x0, copy_attributes x1) + | Ast_410.Parsetree.Pstr_value (x0, x1) -> + Ast_409.Parsetree.Pstr_value + (copy_rec_flag x0, List.map copy_value_binding x1) + | Ast_410.Parsetree.Pstr_primitive x0 -> + Ast_409.Parsetree.Pstr_primitive (copy_value_description x0) + | Ast_410.Parsetree.Pstr_type (x0, x1) -> + Ast_409.Parsetree.Pstr_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | Ast_410.Parsetree.Pstr_typext x0 -> + Ast_409.Parsetree.Pstr_typext (copy_type_extension x0) + | Ast_410.Parsetree.Pstr_exception x0 -> + Ast_409.Parsetree.Pstr_exception (copy_type_exception x0) + | Ast_410.Parsetree.Pstr_module x0 -> + Ast_409.Parsetree.Pstr_module (copy_module_binding x0) + | Ast_410.Parsetree.Pstr_recmodule x0 -> + Ast_409.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) + | Ast_410.Parsetree.Pstr_modtype x0 -> + Ast_409.Parsetree.Pstr_modtype (copy_module_type_declaration x0) + | Ast_410.Parsetree.Pstr_open x0 -> + Ast_409.Parsetree.Pstr_open (copy_open_declaration x0) + | Ast_410.Parsetree.Pstr_class x0 -> + Ast_409.Parsetree.Pstr_class (List.map copy_class_declaration x0) + | Ast_410.Parsetree.Pstr_class_type x0 -> + Ast_409.Parsetree.Pstr_class_type + (List.map copy_class_type_declaration x0) + | Ast_410.Parsetree.Pstr_include x0 -> + Ast_409.Parsetree.Pstr_include (copy_include_declaration x0) + | Ast_410.Parsetree.Pstr_attribute x0 -> + Ast_409.Parsetree.Pstr_attribute (copy_attribute x0) + | Ast_410.Parsetree.Pstr_extension (x0, x1) -> + Ast_409.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1) + +and copy_include_declaration : + Ast_410.Parsetree.include_declaration -> + Ast_409.Parsetree.include_declaration = + fun x -> copy_include_infos copy_module_expr x + +and copy_class_declaration : + Ast_410.Parsetree.class_declaration -> Ast_409.Parsetree.class_declaration = + fun x -> copy_class_infos copy_class_expr x + +and copy_class_expr : + Ast_410.Parsetree.class_expr -> Ast_409.Parsetree.class_expr = + fun { + Ast_410.Parsetree.pcl_desc; + Ast_410.Parsetree.pcl_loc; + Ast_410.Parsetree.pcl_attributes; + } -> + { + Ast_409.Parsetree.pcl_desc = copy_class_expr_desc pcl_desc; + Ast_409.Parsetree.pcl_loc = copy_location pcl_loc; + Ast_409.Parsetree.pcl_attributes = copy_attributes pcl_attributes; + } + +and copy_class_expr_desc : + Ast_410.Parsetree.class_expr_desc -> Ast_409.Parsetree.class_expr_desc = + function + | Ast_410.Parsetree.Pcl_constr (x0, x1) -> + Ast_409.Parsetree.Pcl_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_410.Parsetree.Pcl_structure x0 -> + Ast_409.Parsetree.Pcl_structure (copy_class_structure x0) + | Ast_410.Parsetree.Pcl_fun (x0, x1, x2, x3) -> + Ast_409.Parsetree.Pcl_fun + ( copy_arg_label x0, + map_option copy_expression x1, + copy_pattern x2, + copy_class_expr x3 ) + | Ast_410.Parsetree.Pcl_apply (x0, x1) -> + Ast_409.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_410.Parsetree.Pcl_let (x0, x1, x2) -> + Ast_409.Parsetree.Pcl_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_class_expr x2) + | Ast_410.Parsetree.Pcl_constraint (x0, x1) -> + Ast_409.Parsetree.Pcl_constraint (copy_class_expr x0, copy_class_type x1) + | Ast_410.Parsetree.Pcl_extension x0 -> + Ast_409.Parsetree.Pcl_extension (copy_extension x0) + | Ast_410.Parsetree.Pcl_open (x0, x1) -> + Ast_409.Parsetree.Pcl_open (copy_open_description x0, copy_class_expr x1) + +and copy_class_structure : + Ast_410.Parsetree.class_structure -> Ast_409.Parsetree.class_structure = + fun { Ast_410.Parsetree.pcstr_self; Ast_410.Parsetree.pcstr_fields } -> + { + Ast_409.Parsetree.pcstr_self = copy_pattern pcstr_self; + Ast_409.Parsetree.pcstr_fields = List.map copy_class_field pcstr_fields; + } + +and copy_class_field : + Ast_410.Parsetree.class_field -> Ast_409.Parsetree.class_field = + fun { + Ast_410.Parsetree.pcf_desc; + Ast_410.Parsetree.pcf_loc; + Ast_410.Parsetree.pcf_attributes; + } -> + { + Ast_409.Parsetree.pcf_desc = copy_class_field_desc pcf_desc; + Ast_409.Parsetree.pcf_loc = copy_location pcf_loc; + Ast_409.Parsetree.pcf_attributes = copy_attributes pcf_attributes; + } + +and copy_class_field_desc : + Ast_410.Parsetree.class_field_desc -> Ast_409.Parsetree.class_field_desc = + function + | Ast_410.Parsetree.Pcf_inherit (x0, x1, x2) -> + Ast_409.Parsetree.Pcf_inherit + ( copy_override_flag x0, + copy_class_expr x1, + map_option (fun x -> copy_loc (fun x -> x) x) x2 ) + | Ast_410.Parsetree.Pcf_val x0 -> + Ast_409.Parsetree.Pcf_val + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_mutable_flag x1, copy_class_field_kind x2)) + | Ast_410.Parsetree.Pcf_method x0 -> + Ast_409.Parsetree.Pcf_method + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_private_flag x1, copy_class_field_kind x2)) + | Ast_410.Parsetree.Pcf_constraint x0 -> + Ast_409.Parsetree.Pcf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | Ast_410.Parsetree.Pcf_initializer x0 -> + Ast_409.Parsetree.Pcf_initializer (copy_expression x0) + | Ast_410.Parsetree.Pcf_attribute x0 -> + Ast_409.Parsetree.Pcf_attribute (copy_attribute x0) + | Ast_410.Parsetree.Pcf_extension x0 -> + Ast_409.Parsetree.Pcf_extension (copy_extension x0) + +and copy_class_field_kind : + Ast_410.Parsetree.class_field_kind -> Ast_409.Parsetree.class_field_kind = + function + | Ast_410.Parsetree.Cfk_virtual x0 -> + Ast_409.Parsetree.Cfk_virtual (copy_core_type x0) + | Ast_410.Parsetree.Cfk_concrete (x0, x1) -> + Ast_409.Parsetree.Cfk_concrete (copy_override_flag x0, copy_expression x1) + +and copy_open_declaration : + Ast_410.Parsetree.open_declaration -> Ast_409.Parsetree.open_declaration = + fun x -> copy_open_infos copy_module_expr x + +and copy_module_binding : + Ast_410.Parsetree.module_binding -> Ast_409.Parsetree.module_binding = + fun { + Ast_410.Parsetree.pmb_name; + Ast_410.Parsetree.pmb_expr; + Ast_410.Parsetree.pmb_attributes; + Ast_410.Parsetree.pmb_loc; + } -> + { + Ast_409.Parsetree.pmb_name = + copy_loc + (function + | Some x -> x + | None -> migration_error pmb_name.loc "anonymous module binding") + pmb_name; + Ast_409.Parsetree.pmb_expr = copy_module_expr pmb_expr; + Ast_409.Parsetree.pmb_attributes = copy_attributes pmb_attributes; + Ast_409.Parsetree.pmb_loc = copy_location pmb_loc; + } + +and copy_module_expr : + Ast_410.Parsetree.module_expr -> Ast_409.Parsetree.module_expr = + fun { + Ast_410.Parsetree.pmod_desc; + Ast_410.Parsetree.pmod_loc; + Ast_410.Parsetree.pmod_attributes; + } -> + { + Ast_409.Parsetree.pmod_desc = copy_module_expr_desc pmod_desc; + Ast_409.Parsetree.pmod_loc = copy_location pmod_loc; + Ast_409.Parsetree.pmod_attributes = copy_attributes pmod_attributes; + } + +and copy_module_expr_desc : + Ast_410.Parsetree.module_expr_desc -> Ast_409.Parsetree.module_expr_desc = + function + | Ast_410.Parsetree.Pmod_ident x0 -> + Ast_409.Parsetree.Pmod_ident (copy_loc copy_Longident_t x0) + | Ast_410.Parsetree.Pmod_structure x0 -> + Ast_409.Parsetree.Pmod_structure (copy_structure x0) + | Ast_410.Parsetree.Pmod_functor (x0, x1) -> + let x, y = copy_functor_parameter x0 in + Ast_409.Parsetree.Pmod_functor (x, y, copy_module_expr x1) + | Ast_410.Parsetree.Pmod_apply (x0, x1) -> + Ast_409.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) + | Ast_410.Parsetree.Pmod_constraint (x0, x1) -> + Ast_409.Parsetree.Pmod_constraint + (copy_module_expr x0, copy_module_type x1) + | Ast_410.Parsetree.Pmod_unpack x0 -> + Ast_409.Parsetree.Pmod_unpack (copy_expression x0) + | Ast_410.Parsetree.Pmod_extension x0 -> + Ast_409.Parsetree.Pmod_extension (copy_extension x0) + +and copy_functor_parameter : + Ast_410.Parsetree.functor_parameter -> + string Ast_409.Asttypes.loc * Ast_409.Parsetree.module_type option = + function + | Ast_410.Parsetree.Unit -> ({ loc = Location.none; txt = "*" }, None) + | Ast_410.Parsetree.Named (x0, x1) -> + ( copy_loc (function None -> "_" | Some x -> x) x0, + Some (copy_module_type x1) ) + +and copy_module_type : + Ast_410.Parsetree.module_type -> Ast_409.Parsetree.module_type = + fun { + Ast_410.Parsetree.pmty_desc; + Ast_410.Parsetree.pmty_loc; + Ast_410.Parsetree.pmty_attributes; + } -> + { + Ast_409.Parsetree.pmty_desc = copy_module_type_desc pmty_desc; + Ast_409.Parsetree.pmty_loc = copy_location pmty_loc; + Ast_409.Parsetree.pmty_attributes = copy_attributes pmty_attributes; + } + +and copy_module_type_desc : + Ast_410.Parsetree.module_type_desc -> Ast_409.Parsetree.module_type_desc = + function + | Ast_410.Parsetree.Pmty_ident x0 -> + Ast_409.Parsetree.Pmty_ident (copy_loc copy_Longident_t x0) + | Ast_410.Parsetree.Pmty_signature x0 -> + Ast_409.Parsetree.Pmty_signature (copy_signature x0) + | Ast_410.Parsetree.Pmty_functor (x0, x1) -> + let x, y = copy_functor_parameter x0 in + Ast_409.Parsetree.Pmty_functor (x, y, copy_module_type x1) + | Ast_410.Parsetree.Pmty_with (x0, x1) -> + Ast_409.Parsetree.Pmty_with + (copy_module_type x0, List.map copy_with_constraint x1) + | Ast_410.Parsetree.Pmty_typeof x0 -> + Ast_409.Parsetree.Pmty_typeof (copy_module_expr x0) + | Ast_410.Parsetree.Pmty_extension x0 -> + Ast_409.Parsetree.Pmty_extension (copy_extension x0) + | Ast_410.Parsetree.Pmty_alias x0 -> + Ast_409.Parsetree.Pmty_alias (copy_loc copy_Longident_t x0) + +and copy_with_constraint : + Ast_410.Parsetree.with_constraint -> Ast_409.Parsetree.with_constraint = + function + | Ast_410.Parsetree.Pwith_type (x0, x1) -> + Ast_409.Parsetree.Pwith_type + (copy_loc copy_Longident_t x0, copy_type_declaration x1) + | Ast_410.Parsetree.Pwith_module (x0, x1) -> + Ast_409.Parsetree.Pwith_module + (copy_loc copy_Longident_t x0, copy_loc copy_Longident_t x1) + | Ast_410.Parsetree.Pwith_typesubst (x0, x1) -> + Ast_409.Parsetree.Pwith_typesubst + (copy_loc copy_Longident_t x0, copy_type_declaration x1) + | Ast_410.Parsetree.Pwith_modsubst (x0, x1) -> + Ast_409.Parsetree.Pwith_modsubst + (copy_loc copy_Longident_t x0, copy_loc copy_Longident_t x1) + +and copy_signature : Ast_410.Parsetree.signature -> Ast_409.Parsetree.signature + = + fun x -> List.map copy_signature_item x + +and copy_signature_item : + Ast_410.Parsetree.signature_item -> Ast_409.Parsetree.signature_item = + fun { Ast_410.Parsetree.psig_desc; Ast_410.Parsetree.psig_loc } -> + { + Ast_409.Parsetree.psig_desc = copy_signature_item_desc psig_desc; + Ast_409.Parsetree.psig_loc = copy_location psig_loc; + } + +and copy_signature_item_desc : + Ast_410.Parsetree.signature_item_desc -> + Ast_409.Parsetree.signature_item_desc = function + | Ast_410.Parsetree.Psig_value x0 -> + Ast_409.Parsetree.Psig_value (copy_value_description x0) + | Ast_410.Parsetree.Psig_type (x0, x1) -> + Ast_409.Parsetree.Psig_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | Ast_410.Parsetree.Psig_typesubst x0 -> + Ast_409.Parsetree.Psig_typesubst (List.map copy_type_declaration x0) + | Ast_410.Parsetree.Psig_typext x0 -> + Ast_409.Parsetree.Psig_typext (copy_type_extension x0) + | Ast_410.Parsetree.Psig_exception x0 -> + Ast_409.Parsetree.Psig_exception (copy_type_exception x0) + | Ast_410.Parsetree.Psig_module x0 -> + Ast_409.Parsetree.Psig_module (copy_module_declaration x0) + | Ast_410.Parsetree.Psig_modsubst x0 -> + Ast_409.Parsetree.Psig_modsubst (copy_module_substitution x0) + | Ast_410.Parsetree.Psig_recmodule x0 -> + Ast_409.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) + | Ast_410.Parsetree.Psig_modtype x0 -> + Ast_409.Parsetree.Psig_modtype (copy_module_type_declaration x0) + | Ast_410.Parsetree.Psig_open x0 -> + Ast_409.Parsetree.Psig_open (copy_open_description x0) + | Ast_410.Parsetree.Psig_include x0 -> + Ast_409.Parsetree.Psig_include (copy_include_description x0) + | Ast_410.Parsetree.Psig_class x0 -> + Ast_409.Parsetree.Psig_class (List.map copy_class_description x0) + | Ast_410.Parsetree.Psig_class_type x0 -> + Ast_409.Parsetree.Psig_class_type + (List.map copy_class_type_declaration x0) + | Ast_410.Parsetree.Psig_attribute x0 -> + Ast_409.Parsetree.Psig_attribute (copy_attribute x0) + | Ast_410.Parsetree.Psig_extension (x0, x1) -> + Ast_409.Parsetree.Psig_extension (copy_extension x0, copy_attributes x1) + +and copy_class_type_declaration : + Ast_410.Parsetree.class_type_declaration -> + Ast_409.Parsetree.class_type_declaration = + fun x -> copy_class_infos copy_class_type x + +and copy_class_description : + Ast_410.Parsetree.class_description -> Ast_409.Parsetree.class_description = + fun x -> copy_class_infos copy_class_type x + +and copy_class_type : + Ast_410.Parsetree.class_type -> Ast_409.Parsetree.class_type = + fun { + Ast_410.Parsetree.pcty_desc; + Ast_410.Parsetree.pcty_loc; + Ast_410.Parsetree.pcty_attributes; + } -> + { + Ast_409.Parsetree.pcty_desc = copy_class_type_desc pcty_desc; + Ast_409.Parsetree.pcty_loc = copy_location pcty_loc; + Ast_409.Parsetree.pcty_attributes = copy_attributes pcty_attributes; + } + +and copy_class_type_desc : + Ast_410.Parsetree.class_type_desc -> Ast_409.Parsetree.class_type_desc = + function + | Ast_410.Parsetree.Pcty_constr (x0, x1) -> + Ast_409.Parsetree.Pcty_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_410.Parsetree.Pcty_signature x0 -> + Ast_409.Parsetree.Pcty_signature (copy_class_signature x0) + | Ast_410.Parsetree.Pcty_arrow (x0, x1, x2) -> + Ast_409.Parsetree.Pcty_arrow + (copy_arg_label x0, copy_core_type x1, copy_class_type x2) + | Ast_410.Parsetree.Pcty_extension x0 -> + Ast_409.Parsetree.Pcty_extension (copy_extension x0) + | Ast_410.Parsetree.Pcty_open (x0, x1) -> + Ast_409.Parsetree.Pcty_open (copy_open_description x0, copy_class_type x1) + +and copy_class_signature : + Ast_410.Parsetree.class_signature -> Ast_409.Parsetree.class_signature = + fun { Ast_410.Parsetree.pcsig_self; Ast_410.Parsetree.pcsig_fields } -> + { + Ast_409.Parsetree.pcsig_self = copy_core_type pcsig_self; + Ast_409.Parsetree.pcsig_fields = List.map copy_class_type_field pcsig_fields; + } + +and copy_class_type_field : + Ast_410.Parsetree.class_type_field -> Ast_409.Parsetree.class_type_field = + fun { + Ast_410.Parsetree.pctf_desc; + Ast_410.Parsetree.pctf_loc; + Ast_410.Parsetree.pctf_attributes; + } -> + { + Ast_409.Parsetree.pctf_desc = copy_class_type_field_desc pctf_desc; + Ast_409.Parsetree.pctf_loc = copy_location pctf_loc; + Ast_409.Parsetree.pctf_attributes = copy_attributes pctf_attributes; + } + +and copy_class_type_field_desc : + Ast_410.Parsetree.class_type_field_desc -> + Ast_409.Parsetree.class_type_field_desc = function + | Ast_410.Parsetree.Pctf_inherit x0 -> + Ast_409.Parsetree.Pctf_inherit (copy_class_type x0) + | Ast_410.Parsetree.Pctf_val x0 -> + Ast_409.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_410.Parsetree.Pctf_method x0 -> + Ast_409.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_410.Parsetree.Pctf_constraint x0 -> + Ast_409.Parsetree.Pctf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | Ast_410.Parsetree.Pctf_attribute x0 -> + Ast_409.Parsetree.Pctf_attribute (copy_attribute x0) + | Ast_410.Parsetree.Pctf_extension x0 -> + Ast_409.Parsetree.Pctf_extension (copy_extension x0) + +and copy_extension : Ast_410.Parsetree.extension -> Ast_409.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_410.Parsetree.class_infos -> + 'g0 Ast_409.Parsetree.class_infos = + fun f0 + { + Ast_410.Parsetree.pci_virt; + Ast_410.Parsetree.pci_params; + Ast_410.Parsetree.pci_name; + Ast_410.Parsetree.pci_expr; + Ast_410.Parsetree.pci_loc; + Ast_410.Parsetree.pci_attributes; + } -> + { + Ast_409.Parsetree.pci_virt = copy_virtual_flag pci_virt; + Ast_409.Parsetree.pci_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + pci_params; + Ast_409.Parsetree.pci_name = copy_loc (fun x -> x) pci_name; + Ast_409.Parsetree.pci_expr = f0 pci_expr; + Ast_409.Parsetree.pci_loc = copy_location pci_loc; + Ast_409.Parsetree.pci_attributes = copy_attributes pci_attributes; + } + +and copy_virtual_flag : + Ast_410.Asttypes.virtual_flag -> Ast_409.Asttypes.virtual_flag = function + | Ast_410.Asttypes.Virtual -> Ast_409.Asttypes.Virtual + | Ast_410.Asttypes.Concrete -> Ast_409.Asttypes.Concrete + +and copy_include_description : + Ast_410.Parsetree.include_description -> + Ast_409.Parsetree.include_description = + fun x -> copy_include_infos copy_module_type x + +and copy_include_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 Ast_410.Parsetree.include_infos -> + 'g0 Ast_409.Parsetree.include_infos = + fun f0 + { + Ast_410.Parsetree.pincl_mod; + Ast_410.Parsetree.pincl_loc; + Ast_410.Parsetree.pincl_attributes; + } -> + { + Ast_409.Parsetree.pincl_mod = f0 pincl_mod; + Ast_409.Parsetree.pincl_loc = copy_location pincl_loc; + Ast_409.Parsetree.pincl_attributes = copy_attributes pincl_attributes; + } + +and copy_open_description : + Ast_410.Parsetree.open_description -> Ast_409.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_410.Parsetree.open_infos -> + 'g0 Ast_409.Parsetree.open_infos = + fun f0 + { + Ast_410.Parsetree.popen_expr; + Ast_410.Parsetree.popen_override; + Ast_410.Parsetree.popen_loc; + Ast_410.Parsetree.popen_attributes; + } -> + { + Ast_409.Parsetree.popen_expr = f0 popen_expr; + Ast_409.Parsetree.popen_override = copy_override_flag popen_override; + Ast_409.Parsetree.popen_loc = copy_location popen_loc; + Ast_409.Parsetree.popen_attributes = copy_attributes popen_attributes; + } + +and copy_override_flag : + Ast_410.Asttypes.override_flag -> Ast_409.Asttypes.override_flag = function + | Ast_410.Asttypes.Override -> Ast_409.Asttypes.Override + | Ast_410.Asttypes.Fresh -> Ast_409.Asttypes.Fresh + +and copy_module_type_declaration : + Ast_410.Parsetree.module_type_declaration -> + Ast_409.Parsetree.module_type_declaration = + fun { + Ast_410.Parsetree.pmtd_name; + Ast_410.Parsetree.pmtd_type; + Ast_410.Parsetree.pmtd_attributes; + Ast_410.Parsetree.pmtd_loc; + } -> + { + Ast_409.Parsetree.pmtd_name = copy_loc (fun x -> x) pmtd_name; + Ast_409.Parsetree.pmtd_type = map_option copy_module_type pmtd_type; + Ast_409.Parsetree.pmtd_attributes = copy_attributes pmtd_attributes; + Ast_409.Parsetree.pmtd_loc = copy_location pmtd_loc; + } + +and copy_module_substitution : + Ast_410.Parsetree.module_substitution -> + Ast_409.Parsetree.module_substitution = + fun { + Ast_410.Parsetree.pms_name; + Ast_410.Parsetree.pms_manifest; + Ast_410.Parsetree.pms_attributes; + Ast_410.Parsetree.pms_loc; + } -> + { + Ast_409.Parsetree.pms_name = copy_loc (fun x -> x) pms_name; + Ast_409.Parsetree.pms_manifest = copy_loc copy_Longident_t pms_manifest; + Ast_409.Parsetree.pms_attributes = copy_attributes pms_attributes; + Ast_409.Parsetree.pms_loc = copy_location pms_loc; + } + +and copy_module_declaration : + Ast_410.Parsetree.module_declaration -> Ast_409.Parsetree.module_declaration + = + fun { + Ast_410.Parsetree.pmd_name; + Ast_410.Parsetree.pmd_type; + Ast_410.Parsetree.pmd_attributes; + Ast_410.Parsetree.pmd_loc; + } -> + { + Ast_409.Parsetree.pmd_name = + copy_loc + (function + | None -> migration_error pmd_name.loc "anonymous module declaration" + | Some x -> x) + pmd_name; + Ast_409.Parsetree.pmd_type = copy_module_type pmd_type; + Ast_409.Parsetree.pmd_attributes = copy_attributes pmd_attributes; + Ast_409.Parsetree.pmd_loc = copy_location pmd_loc; + } + +and copy_type_exception : + Ast_410.Parsetree.type_exception -> Ast_409.Parsetree.type_exception = + fun { + Ast_410.Parsetree.ptyexn_constructor; + Ast_410.Parsetree.ptyexn_loc; + Ast_410.Parsetree.ptyexn_attributes; + } -> + { + Ast_409.Parsetree.ptyexn_constructor = + copy_extension_constructor ptyexn_constructor; + Ast_409.Parsetree.ptyexn_loc = copy_location ptyexn_loc; + Ast_409.Parsetree.ptyexn_attributes = copy_attributes ptyexn_attributes; + } + +and copy_type_extension : + Ast_410.Parsetree.type_extension -> Ast_409.Parsetree.type_extension = + fun { + Ast_410.Parsetree.ptyext_path; + Ast_410.Parsetree.ptyext_params; + Ast_410.Parsetree.ptyext_constructors; + Ast_410.Parsetree.ptyext_private; + Ast_410.Parsetree.ptyext_loc; + Ast_410.Parsetree.ptyext_attributes; + } -> + { + Ast_409.Parsetree.ptyext_path = copy_loc copy_Longident_t ptyext_path; + Ast_409.Parsetree.ptyext_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptyext_params; + Ast_409.Parsetree.ptyext_constructors = + List.map copy_extension_constructor ptyext_constructors; + Ast_409.Parsetree.ptyext_private = copy_private_flag ptyext_private; + Ast_409.Parsetree.ptyext_loc = copy_location ptyext_loc; + Ast_409.Parsetree.ptyext_attributes = copy_attributes ptyext_attributes; + } + +and copy_extension_constructor : + Ast_410.Parsetree.extension_constructor -> + Ast_409.Parsetree.extension_constructor = + fun { + Ast_410.Parsetree.pext_name; + Ast_410.Parsetree.pext_kind; + Ast_410.Parsetree.pext_loc; + Ast_410.Parsetree.pext_attributes; + } -> + { + Ast_409.Parsetree.pext_name = copy_loc (fun x -> x) pext_name; + Ast_409.Parsetree.pext_kind = copy_extension_constructor_kind pext_kind; + Ast_409.Parsetree.pext_loc = copy_location pext_loc; + Ast_409.Parsetree.pext_attributes = copy_attributes pext_attributes; + } + +and copy_extension_constructor_kind : + Ast_410.Parsetree.extension_constructor_kind -> + Ast_409.Parsetree.extension_constructor_kind = function + | Ast_410.Parsetree.Pext_decl (x0, x1) -> + Ast_409.Parsetree.Pext_decl + (copy_constructor_arguments x0, map_option copy_core_type x1) + | Ast_410.Parsetree.Pext_rebind x0 -> + Ast_409.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0) + +and copy_type_declaration : + Ast_410.Parsetree.type_declaration -> Ast_409.Parsetree.type_declaration = + fun { + Ast_410.Parsetree.ptype_name; + Ast_410.Parsetree.ptype_params; + Ast_410.Parsetree.ptype_cstrs; + Ast_410.Parsetree.ptype_kind; + Ast_410.Parsetree.ptype_private; + Ast_410.Parsetree.ptype_manifest; + Ast_410.Parsetree.ptype_attributes; + Ast_410.Parsetree.ptype_loc; + } -> + { + Ast_409.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name; + Ast_409.Parsetree.ptype_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptype_params; + Ast_409.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_409.Parsetree.ptype_kind = copy_type_kind ptype_kind; + Ast_409.Parsetree.ptype_private = copy_private_flag ptype_private; + Ast_409.Parsetree.ptype_manifest = map_option copy_core_type ptype_manifest; + Ast_409.Parsetree.ptype_attributes = copy_attributes ptype_attributes; + Ast_409.Parsetree.ptype_loc = copy_location ptype_loc; + } + +and copy_private_flag : + Ast_410.Asttypes.private_flag -> Ast_409.Asttypes.private_flag = function + | Ast_410.Asttypes.Private -> Ast_409.Asttypes.Private + | Ast_410.Asttypes.Public -> Ast_409.Asttypes.Public + +and copy_type_kind : Ast_410.Parsetree.type_kind -> Ast_409.Parsetree.type_kind + = function + | Ast_410.Parsetree.Ptype_abstract -> Ast_409.Parsetree.Ptype_abstract + | Ast_410.Parsetree.Ptype_variant x0 -> + Ast_409.Parsetree.Ptype_variant (List.map copy_constructor_declaration x0) + | Ast_410.Parsetree.Ptype_record x0 -> + Ast_409.Parsetree.Ptype_record (List.map copy_label_declaration x0) + | Ast_410.Parsetree.Ptype_open -> Ast_409.Parsetree.Ptype_open + +and copy_constructor_declaration : + Ast_410.Parsetree.constructor_declaration -> + Ast_409.Parsetree.constructor_declaration = + fun { + Ast_410.Parsetree.pcd_name; + Ast_410.Parsetree.pcd_args; + Ast_410.Parsetree.pcd_res; + Ast_410.Parsetree.pcd_loc; + Ast_410.Parsetree.pcd_attributes; + } -> + { + Ast_409.Parsetree.pcd_name = copy_loc (fun x -> x) pcd_name; + Ast_409.Parsetree.pcd_args = copy_constructor_arguments pcd_args; + Ast_409.Parsetree.pcd_res = map_option copy_core_type pcd_res; + Ast_409.Parsetree.pcd_loc = copy_location pcd_loc; + Ast_409.Parsetree.pcd_attributes = copy_attributes pcd_attributes; + } + +and copy_constructor_arguments : + Ast_410.Parsetree.constructor_arguments -> + Ast_409.Parsetree.constructor_arguments = function + | Ast_410.Parsetree.Pcstr_tuple x0 -> + Ast_409.Parsetree.Pcstr_tuple (List.map copy_core_type x0) + | Ast_410.Parsetree.Pcstr_record x0 -> + Ast_409.Parsetree.Pcstr_record (List.map copy_label_declaration x0) + +and copy_label_declaration : + Ast_410.Parsetree.label_declaration -> Ast_409.Parsetree.label_declaration = + fun { + Ast_410.Parsetree.pld_name; + Ast_410.Parsetree.pld_mutable; + Ast_410.Parsetree.pld_type; + Ast_410.Parsetree.pld_loc; + Ast_410.Parsetree.pld_attributes; + } -> + { + Ast_409.Parsetree.pld_name = copy_loc (fun x -> x) pld_name; + Ast_409.Parsetree.pld_mutable = copy_mutable_flag pld_mutable; + Ast_409.Parsetree.pld_type = copy_core_type pld_type; + Ast_409.Parsetree.pld_loc = copy_location pld_loc; + Ast_409.Parsetree.pld_attributes = copy_attributes pld_attributes; + } + +and copy_mutable_flag : + Ast_410.Asttypes.mutable_flag -> Ast_409.Asttypes.mutable_flag = function + | Ast_410.Asttypes.Immutable -> Ast_409.Asttypes.Immutable + | Ast_410.Asttypes.Mutable -> Ast_409.Asttypes.Mutable + +and copy_variance : Ast_410.Asttypes.variance -> Ast_409.Asttypes.variance = + function + | Ast_410.Asttypes.Covariant -> Ast_409.Asttypes.Covariant + | Ast_410.Asttypes.Contravariant -> Ast_409.Asttypes.Contravariant + | Ast_410.Asttypes.Invariant -> Ast_409.Asttypes.Invariant + +and copy_value_description : + Ast_410.Parsetree.value_description -> Ast_409.Parsetree.value_description = + fun { + Ast_410.Parsetree.pval_name; + Ast_410.Parsetree.pval_type; + Ast_410.Parsetree.pval_prim; + Ast_410.Parsetree.pval_attributes; + Ast_410.Parsetree.pval_loc; + } -> + { + Ast_409.Parsetree.pval_name = copy_loc (fun x -> x) pval_name; + Ast_409.Parsetree.pval_type = copy_core_type pval_type; + Ast_409.Parsetree.pval_prim = List.map (fun x -> x) pval_prim; + Ast_409.Parsetree.pval_attributes = copy_attributes pval_attributes; + Ast_409.Parsetree.pval_loc = copy_location pval_loc; + } + +and copy_object_field_desc : + Ast_410.Parsetree.object_field_desc -> Ast_409.Parsetree.object_field_desc = + function + | Ast_410.Parsetree.Otag (x0, x1) -> + Ast_409.Parsetree.Otag (copy_loc copy_label x0, copy_core_type x1) + | Ast_410.Parsetree.Oinherit x0 -> + Ast_409.Parsetree.Oinherit (copy_core_type x0) + +and copy_arg_label : Ast_410.Asttypes.arg_label -> Ast_409.Asttypes.arg_label = + function + | Ast_410.Asttypes.Nolabel -> Ast_409.Asttypes.Nolabel + | Ast_410.Asttypes.Labelled x0 -> Ast_409.Asttypes.Labelled x0 + | Ast_410.Asttypes.Optional x0 -> Ast_409.Asttypes.Optional x0 + +and copy_closed_flag : + Ast_410.Asttypes.closed_flag -> Ast_409.Asttypes.closed_flag = function + | Ast_410.Asttypes.Closed -> Ast_409.Asttypes.Closed + | Ast_410.Asttypes.Open -> Ast_409.Asttypes.Open + +and copy_label : Ast_410.Asttypes.label -> Ast_409.Asttypes.label = fun x -> x + +and copy_rec_flag : Ast_410.Asttypes.rec_flag -> Ast_409.Asttypes.rec_flag = + function + | Ast_410.Asttypes.Nonrecursive -> Ast_409.Asttypes.Nonrecursive + | Ast_410.Asttypes.Recursive -> Ast_409.Asttypes.Recursive + +and copy_constant : Ast_410.Parsetree.constant -> Ast_409.Parsetree.constant = + function + | Ast_410.Parsetree.Pconst_integer (x0, x1) -> + Ast_409.Parsetree.Pconst_integer (x0, map_option (fun x -> x) x1) + | Ast_410.Parsetree.Pconst_char x0 -> Ast_409.Parsetree.Pconst_char x0 + | Ast_410.Parsetree.Pconst_string (x0, x1) -> + Ast_409.Parsetree.Pconst_string (x0, map_option (fun x -> x) x1) + | Ast_410.Parsetree.Pconst_float (x0, x1) -> + Ast_409.Parsetree.Pconst_float (x0, map_option (fun x -> x) x1) + +and copy_Longident_t : Longident.t -> Longident.t = fun x -> x + +and copy_loc : + 'f0 'g0. + ('f0 -> 'g0) -> 'f0 Ast_410.Asttypes.loc -> 'g0 Ast_409.Asttypes.loc = + fun f0 { Ast_410.Asttypes.txt; Ast_410.Asttypes.loc } -> + { Ast_409.Asttypes.txt = f0 txt; Ast_409.Asttypes.loc = copy_location loc } + +and copy_location : Location.t -> Location.t = fun x -> x + +let copy_expr = copy_expression + +let copy_pat = copy_pattern + +let copy_typ = copy_core_type diff -Nru ppxlib-0.15.0/astlib/migrate_410_411.ml ppxlib-0.24.0/astlib/migrate_410_411.ml --- ppxlib-0.15.0/astlib/migrate_410_411.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/migrate_410_411.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1196 @@ +open Stdlib0 +module From = Ast_410 +module To = Ast_411 + +let rec copy_toplevel_phrase : + Ast_410.Parsetree.toplevel_phrase -> Ast_411.Parsetree.toplevel_phrase = + function + | Ast_410.Parsetree.Ptop_def x0 -> + Ast_411.Parsetree.Ptop_def (copy_structure x0) + | Ast_410.Parsetree.Ptop_dir x0 -> + Ast_411.Parsetree.Ptop_dir (copy_toplevel_directive x0) + +and copy_toplevel_directive : + Ast_410.Parsetree.toplevel_directive -> Ast_411.Parsetree.toplevel_directive + = + fun { + Ast_410.Parsetree.pdir_name; + Ast_410.Parsetree.pdir_arg; + Ast_410.Parsetree.pdir_loc; + } -> + { + Ast_411.Parsetree.pdir_name = copy_loc (fun x -> x) pdir_name; + Ast_411.Parsetree.pdir_arg = Option.map copy_directive_argument pdir_arg; + Ast_411.Parsetree.pdir_loc = copy_location pdir_loc; + } + +and copy_directive_argument : + Ast_410.Parsetree.directive_argument -> Ast_411.Parsetree.directive_argument + = + fun { Ast_410.Parsetree.pdira_desc; Ast_410.Parsetree.pdira_loc } -> + { + Ast_411.Parsetree.pdira_desc = copy_directive_argument_desc pdira_desc; + Ast_411.Parsetree.pdira_loc = copy_location pdira_loc; + } + +and copy_directive_argument_desc : + Ast_410.Parsetree.directive_argument_desc -> + Ast_411.Parsetree.directive_argument_desc = function + | Ast_410.Parsetree.Pdir_string x0 -> Ast_411.Parsetree.Pdir_string x0 + | Ast_410.Parsetree.Pdir_int (x0, x1) -> + Ast_411.Parsetree.Pdir_int (x0, Option.map (fun x -> x) x1) + | Ast_410.Parsetree.Pdir_ident x0 -> + Ast_411.Parsetree.Pdir_ident (copy_Longident_t x0) + | Ast_410.Parsetree.Pdir_bool x0 -> Ast_411.Parsetree.Pdir_bool x0 + +and copy_expression : + Ast_410.Parsetree.expression -> Ast_411.Parsetree.expression = + fun { + Ast_410.Parsetree.pexp_desc; + Ast_410.Parsetree.pexp_loc; + Ast_410.Parsetree.pexp_loc_stack; + Ast_410.Parsetree.pexp_attributes; + } -> + { + Ast_411.Parsetree.pexp_desc = copy_expression_desc pexp_desc; + Ast_411.Parsetree.pexp_loc = copy_location pexp_loc; + Ast_411.Parsetree.pexp_loc_stack = copy_location_stack pexp_loc_stack; + Ast_411.Parsetree.pexp_attributes = copy_attributes pexp_attributes; + } + +and copy_expr x = copy_expression x + +and copy_expression_desc : + Ast_410.Parsetree.expression_desc -> Ast_411.Parsetree.expression_desc = + function + | Ast_410.Parsetree.Pexp_ident x0 -> + Ast_411.Parsetree.Pexp_ident (copy_loc copy_Longident_t x0) + | Ast_410.Parsetree.Pexp_constant x0 -> + Ast_411.Parsetree.Pexp_constant (copy_constant x0) + | Ast_410.Parsetree.Pexp_let (x0, x1, x2) -> + Ast_411.Parsetree.Pexp_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_expression x2) + | Ast_410.Parsetree.Pexp_function x0 -> + Ast_411.Parsetree.Pexp_function (List.map copy_case x0) + | Ast_410.Parsetree.Pexp_fun (x0, x1, x2, x3) -> + Ast_411.Parsetree.Pexp_fun + ( copy_arg_label x0, + Option.map copy_expression x1, + copy_pattern x2, + copy_expression x3 ) + | Ast_410.Parsetree.Pexp_apply (x0, x1) -> + Ast_411.Parsetree.Pexp_apply + ( copy_expression x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | Ast_410.Parsetree.Pexp_match (x0, x1) -> + Ast_411.Parsetree.Pexp_match (copy_expression x0, List.map copy_case x1) + | Ast_410.Parsetree.Pexp_try (x0, x1) -> + Ast_411.Parsetree.Pexp_try (copy_expression x0, List.map copy_case x1) + | Ast_410.Parsetree.Pexp_tuple x0 -> + Ast_411.Parsetree.Pexp_tuple (List.map copy_expression x0) + | Ast_410.Parsetree.Pexp_construct (x0, x1) -> + Ast_411.Parsetree.Pexp_construct + (copy_loc copy_Longident_t x0, Option.map copy_expression x1) + | Ast_410.Parsetree.Pexp_variant (x0, x1) -> + Ast_411.Parsetree.Pexp_variant + (copy_label x0, Option.map copy_expression x1) + | Ast_410.Parsetree.Pexp_record (x0, x1) -> + Ast_411.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_410.Parsetree.Pexp_field (x0, x1) -> + Ast_411.Parsetree.Pexp_field + (copy_expression x0, copy_loc copy_Longident_t x1) + | Ast_410.Parsetree.Pexp_setfield (x0, x1, x2) -> + Ast_411.Parsetree.Pexp_setfield + (copy_expression x0, copy_loc copy_Longident_t x1, copy_expression x2) + | Ast_410.Parsetree.Pexp_array x0 -> + Ast_411.Parsetree.Pexp_array (List.map copy_expression x0) + | Ast_410.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> + Ast_411.Parsetree.Pexp_ifthenelse + (copy_expression x0, copy_expression x1, Option.map copy_expression x2) + | Ast_410.Parsetree.Pexp_sequence (x0, x1) -> + Ast_411.Parsetree.Pexp_sequence (copy_expression x0, copy_expression x1) + | Ast_410.Parsetree.Pexp_while (x0, x1) -> + Ast_411.Parsetree.Pexp_while (copy_expression x0, copy_expression x1) + | Ast_410.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> + Ast_411.Parsetree.Pexp_for + ( copy_pattern x0, + copy_expression x1, + copy_expression x2, + copy_direction_flag x3, + copy_expression x4 ) + | Ast_410.Parsetree.Pexp_constraint (x0, x1) -> + Ast_411.Parsetree.Pexp_constraint (copy_expression x0, copy_core_type x1) + | Ast_410.Parsetree.Pexp_coerce (x0, x1, x2) -> + Ast_411.Parsetree.Pexp_coerce + (copy_expression x0, Option.map copy_core_type x1, copy_core_type x2) + | Ast_410.Parsetree.Pexp_send (x0, x1) -> + Ast_411.Parsetree.Pexp_send (copy_expression x0, copy_loc copy_label x1) + | Ast_410.Parsetree.Pexp_new x0 -> + Ast_411.Parsetree.Pexp_new (copy_loc copy_Longident_t x0) + | Ast_410.Parsetree.Pexp_setinstvar (x0, x1) -> + Ast_411.Parsetree.Pexp_setinstvar + (copy_loc copy_label x0, copy_expression x1) + | Ast_410.Parsetree.Pexp_override x0 -> + Ast_411.Parsetree.Pexp_override + (List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_label x0, copy_expression x1)) + x0) + | Ast_410.Parsetree.Pexp_letmodule (x0, x1, x2) -> + Ast_411.Parsetree.Pexp_letmodule + ( copy_loc (fun x -> Option.map (fun x -> x) x) x0, + copy_module_expr x1, + copy_expression x2 ) + | Ast_410.Parsetree.Pexp_letexception (x0, x1) -> + Ast_411.Parsetree.Pexp_letexception + (copy_extension_constructor x0, copy_expression x1) + | Ast_410.Parsetree.Pexp_assert x0 -> + Ast_411.Parsetree.Pexp_assert (copy_expression x0) + | Ast_410.Parsetree.Pexp_lazy x0 -> + Ast_411.Parsetree.Pexp_lazy (copy_expression x0) + | Ast_410.Parsetree.Pexp_poly (x0, x1) -> + Ast_411.Parsetree.Pexp_poly + (copy_expression x0, Option.map copy_core_type x1) + | Ast_410.Parsetree.Pexp_object x0 -> + Ast_411.Parsetree.Pexp_object (copy_class_structure x0) + | Ast_410.Parsetree.Pexp_newtype (x0, x1) -> + Ast_411.Parsetree.Pexp_newtype + (copy_loc (fun x -> x) x0, copy_expression x1) + | Ast_410.Parsetree.Pexp_pack x0 -> + Ast_411.Parsetree.Pexp_pack (copy_module_expr x0) + | Ast_410.Parsetree.Pexp_open (x0, x1) -> + Ast_411.Parsetree.Pexp_open (copy_open_declaration x0, copy_expression x1) + | Ast_410.Parsetree.Pexp_letop x0 -> + Ast_411.Parsetree.Pexp_letop (copy_letop x0) + | Ast_410.Parsetree.Pexp_extension x0 -> + Ast_411.Parsetree.Pexp_extension (copy_extension x0) + | Ast_410.Parsetree.Pexp_unreachable -> Ast_411.Parsetree.Pexp_unreachable + +and copy_letop : Ast_410.Parsetree.letop -> Ast_411.Parsetree.letop = + fun { Ast_410.Parsetree.let_; Ast_410.Parsetree.ands; Ast_410.Parsetree.body } -> + { + Ast_411.Parsetree.let_ = copy_binding_op let_; + Ast_411.Parsetree.ands = List.map copy_binding_op ands; + Ast_411.Parsetree.body = copy_expression body; + } + +and copy_binding_op : + Ast_410.Parsetree.binding_op -> Ast_411.Parsetree.binding_op = + fun { + Ast_410.Parsetree.pbop_op; + Ast_410.Parsetree.pbop_pat; + Ast_410.Parsetree.pbop_exp; + Ast_410.Parsetree.pbop_loc; + } -> + { + Ast_411.Parsetree.pbop_op = copy_loc (fun x -> x) pbop_op; + Ast_411.Parsetree.pbop_pat = copy_pattern pbop_pat; + Ast_411.Parsetree.pbop_exp = copy_expression pbop_exp; + Ast_411.Parsetree.pbop_loc = copy_location pbop_loc; + } + +and copy_direction_flag : + Ast_410.Asttypes.direction_flag -> Ast_411.Asttypes.direction_flag = + function + | Ast_410.Asttypes.Upto -> Ast_411.Asttypes.Upto + | Ast_410.Asttypes.Downto -> Ast_411.Asttypes.Downto + +and copy_case : Ast_410.Parsetree.case -> Ast_411.Parsetree.case = + fun { + Ast_410.Parsetree.pc_lhs; + Ast_410.Parsetree.pc_guard; + Ast_410.Parsetree.pc_rhs; + } -> + { + Ast_411.Parsetree.pc_lhs = copy_pattern pc_lhs; + Ast_411.Parsetree.pc_guard = Option.map copy_expression pc_guard; + Ast_411.Parsetree.pc_rhs = copy_expression pc_rhs; + } + +and copy_cases : Ast_410.Parsetree.case list -> Ast_411.Parsetree.case list = + fun x -> List.map copy_case x + +and copy_value_binding : + Ast_410.Parsetree.value_binding -> Ast_411.Parsetree.value_binding = + fun { + Ast_410.Parsetree.pvb_pat; + Ast_410.Parsetree.pvb_expr; + Ast_410.Parsetree.pvb_attributes; + Ast_410.Parsetree.pvb_loc; + } -> + { + Ast_411.Parsetree.pvb_pat = copy_pattern pvb_pat; + Ast_411.Parsetree.pvb_expr = copy_expression pvb_expr; + Ast_411.Parsetree.pvb_attributes = copy_attributes pvb_attributes; + Ast_411.Parsetree.pvb_loc = copy_location pvb_loc; + } + +and copy_pattern : Ast_410.Parsetree.pattern -> Ast_411.Parsetree.pattern = + fun { + Ast_410.Parsetree.ppat_desc; + Ast_410.Parsetree.ppat_loc; + Ast_410.Parsetree.ppat_loc_stack; + Ast_410.Parsetree.ppat_attributes; + } -> + { + Ast_411.Parsetree.ppat_desc = copy_pattern_desc ppat_desc; + Ast_411.Parsetree.ppat_loc = copy_location ppat_loc; + Ast_411.Parsetree.ppat_loc_stack = copy_location_stack ppat_loc_stack; + Ast_411.Parsetree.ppat_attributes = copy_attributes ppat_attributes; + } + +and copy_pat x = copy_pattern x + +and copy_pattern_desc : + Ast_410.Parsetree.pattern_desc -> Ast_411.Parsetree.pattern_desc = function + | Ast_410.Parsetree.Ppat_any -> Ast_411.Parsetree.Ppat_any + | Ast_410.Parsetree.Ppat_var x0 -> + Ast_411.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) + | Ast_410.Parsetree.Ppat_alias (x0, x1) -> + Ast_411.Parsetree.Ppat_alias (copy_pattern x0, copy_loc (fun x -> x) x1) + | Ast_410.Parsetree.Ppat_constant x0 -> + Ast_411.Parsetree.Ppat_constant (copy_constant x0) + | Ast_410.Parsetree.Ppat_interval (x0, x1) -> + Ast_411.Parsetree.Ppat_interval (copy_constant x0, copy_constant x1) + | Ast_410.Parsetree.Ppat_tuple x0 -> + Ast_411.Parsetree.Ppat_tuple (List.map copy_pattern x0) + | Ast_410.Parsetree.Ppat_construct (x0, x1) -> + Ast_411.Parsetree.Ppat_construct + (copy_loc copy_Longident_t x0, Option.map copy_pattern x1) + | Ast_410.Parsetree.Ppat_variant (x0, x1) -> + Ast_411.Parsetree.Ppat_variant (copy_label x0, Option.map copy_pattern x1) + | Ast_410.Parsetree.Ppat_record (x0, x1) -> + Ast_411.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_410.Parsetree.Ppat_array x0 -> + Ast_411.Parsetree.Ppat_array (List.map copy_pattern x0) + | Ast_410.Parsetree.Ppat_or (x0, x1) -> + Ast_411.Parsetree.Ppat_or (copy_pattern x0, copy_pattern x1) + | Ast_410.Parsetree.Ppat_constraint (x0, x1) -> + Ast_411.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1) + | Ast_410.Parsetree.Ppat_type x0 -> + Ast_411.Parsetree.Ppat_type (copy_loc copy_Longident_t x0) + | Ast_410.Parsetree.Ppat_lazy x0 -> + Ast_411.Parsetree.Ppat_lazy (copy_pattern x0) + | Ast_410.Parsetree.Ppat_unpack x0 -> + Ast_411.Parsetree.Ppat_unpack + (copy_loc (fun x -> Option.map (fun x -> x) x) x0) + | Ast_410.Parsetree.Ppat_exception x0 -> + Ast_411.Parsetree.Ppat_exception (copy_pattern x0) + | Ast_410.Parsetree.Ppat_extension x0 -> + Ast_411.Parsetree.Ppat_extension (copy_extension x0) + | Ast_410.Parsetree.Ppat_open (x0, x1) -> + Ast_411.Parsetree.Ppat_open (copy_loc copy_Longident_t x0, copy_pattern x1) + +and copy_core_type : Ast_410.Parsetree.core_type -> Ast_411.Parsetree.core_type + = + fun { + Ast_410.Parsetree.ptyp_desc; + Ast_410.Parsetree.ptyp_loc; + Ast_410.Parsetree.ptyp_loc_stack; + Ast_410.Parsetree.ptyp_attributes; + } -> + { + Ast_411.Parsetree.ptyp_desc = copy_core_type_desc ptyp_desc; + Ast_411.Parsetree.ptyp_loc = copy_location ptyp_loc; + Ast_411.Parsetree.ptyp_loc_stack = copy_location_stack ptyp_loc_stack; + Ast_411.Parsetree.ptyp_attributes = copy_attributes ptyp_attributes; + } + +and copy_typ x = copy_core_type x + +and copy_location_stack : + Ast_410.Parsetree.location_stack -> Ast_411.Parsetree.location_stack = + fun x -> List.map copy_location x + +and copy_core_type_desc : + Ast_410.Parsetree.core_type_desc -> Ast_411.Parsetree.core_type_desc = + function + | Ast_410.Parsetree.Ptyp_any -> Ast_411.Parsetree.Ptyp_any + | Ast_410.Parsetree.Ptyp_var x0 -> Ast_411.Parsetree.Ptyp_var x0 + | Ast_410.Parsetree.Ptyp_arrow (x0, x1, x2) -> + Ast_411.Parsetree.Ptyp_arrow + (copy_arg_label x0, copy_core_type x1, copy_core_type x2) + | Ast_410.Parsetree.Ptyp_tuple x0 -> + Ast_411.Parsetree.Ptyp_tuple (List.map copy_core_type x0) + | Ast_410.Parsetree.Ptyp_constr (x0, x1) -> + Ast_411.Parsetree.Ptyp_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_410.Parsetree.Ptyp_object (x0, x1) -> + Ast_411.Parsetree.Ptyp_object + (List.map copy_object_field x0, copy_closed_flag x1) + | Ast_410.Parsetree.Ptyp_class (x0, x1) -> + Ast_411.Parsetree.Ptyp_class + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_410.Parsetree.Ptyp_alias (x0, x1) -> + Ast_411.Parsetree.Ptyp_alias (copy_core_type x0, x1) + | Ast_410.Parsetree.Ptyp_variant (x0, x1, x2) -> + Ast_411.Parsetree.Ptyp_variant + ( List.map copy_row_field x0, + copy_closed_flag x1, + Option.map (fun x -> List.map copy_label x) x2 ) + | Ast_410.Parsetree.Ptyp_poly (x0, x1) -> + Ast_411.Parsetree.Ptyp_poly + (List.map (fun x -> copy_loc (fun x -> x) x) x0, copy_core_type x1) + | Ast_410.Parsetree.Ptyp_package x0 -> + Ast_411.Parsetree.Ptyp_package (copy_package_type x0) + | Ast_410.Parsetree.Ptyp_extension x0 -> + Ast_411.Parsetree.Ptyp_extension (copy_extension x0) + +and copy_package_type : + Ast_410.Parsetree.package_type -> Ast_411.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_410.Parsetree.row_field -> Ast_411.Parsetree.row_field + = + fun { + Ast_410.Parsetree.prf_desc; + Ast_410.Parsetree.prf_loc; + Ast_410.Parsetree.prf_attributes; + } -> + { + Ast_411.Parsetree.prf_desc = copy_row_field_desc prf_desc; + Ast_411.Parsetree.prf_loc = copy_location prf_loc; + Ast_411.Parsetree.prf_attributes = copy_attributes prf_attributes; + } + +and copy_row_field_desc : + Ast_410.Parsetree.row_field_desc -> Ast_411.Parsetree.row_field_desc = + function + | Ast_410.Parsetree.Rtag (x0, x1, x2) -> + Ast_411.Parsetree.Rtag + (copy_loc copy_label x0, x1, List.map copy_core_type x2) + | Ast_410.Parsetree.Rinherit x0 -> + Ast_411.Parsetree.Rinherit (copy_core_type x0) + +and copy_object_field : + Ast_410.Parsetree.object_field -> Ast_411.Parsetree.object_field = + fun { + Ast_410.Parsetree.pof_desc; + Ast_410.Parsetree.pof_loc; + Ast_410.Parsetree.pof_attributes; + } -> + { + Ast_411.Parsetree.pof_desc = copy_object_field_desc pof_desc; + Ast_411.Parsetree.pof_loc = copy_location pof_loc; + Ast_411.Parsetree.pof_attributes = copy_attributes pof_attributes; + } + +and copy_attributes : + Ast_410.Parsetree.attributes -> Ast_411.Parsetree.attributes = + fun x -> List.map copy_attribute x + +and copy_attribute : Ast_410.Parsetree.attribute -> Ast_411.Parsetree.attribute + = + fun { + Ast_410.Parsetree.attr_name; + Ast_410.Parsetree.attr_payload; + Ast_410.Parsetree.attr_loc; + } -> + { + Ast_411.Parsetree.attr_name = copy_loc (fun x -> x) attr_name; + Ast_411.Parsetree.attr_payload = copy_payload attr_payload; + Ast_411.Parsetree.attr_loc = copy_location attr_loc; + } + +and copy_payload : Ast_410.Parsetree.payload -> Ast_411.Parsetree.payload = + function + | Ast_410.Parsetree.PStr x0 -> Ast_411.Parsetree.PStr (copy_structure x0) + | Ast_410.Parsetree.PSig x0 -> Ast_411.Parsetree.PSig (copy_signature x0) + | Ast_410.Parsetree.PTyp x0 -> Ast_411.Parsetree.PTyp (copy_core_type x0) + | Ast_410.Parsetree.PPat (x0, x1) -> + Ast_411.Parsetree.PPat (copy_pattern x0, Option.map copy_expression x1) + +and copy_structure : Ast_410.Parsetree.structure -> Ast_411.Parsetree.structure + = + fun x -> List.map copy_structure_item x + +and copy_structure_item : + Ast_410.Parsetree.structure_item -> Ast_411.Parsetree.structure_item = + fun { Ast_410.Parsetree.pstr_desc; Ast_410.Parsetree.pstr_loc } -> + { + Ast_411.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc; + Ast_411.Parsetree.pstr_loc = copy_location pstr_loc; + } + +and copy_structure_item_desc : + Ast_410.Parsetree.structure_item_desc -> + Ast_411.Parsetree.structure_item_desc = function + | Ast_410.Parsetree.Pstr_eval (x0, x1) -> + Ast_411.Parsetree.Pstr_eval (copy_expression x0, copy_attributes x1) + | Ast_410.Parsetree.Pstr_value (x0, x1) -> + Ast_411.Parsetree.Pstr_value + (copy_rec_flag x0, List.map copy_value_binding x1) + | Ast_410.Parsetree.Pstr_primitive x0 -> + Ast_411.Parsetree.Pstr_primitive (copy_value_description x0) + | Ast_410.Parsetree.Pstr_type (x0, x1) -> + Ast_411.Parsetree.Pstr_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | Ast_410.Parsetree.Pstr_typext x0 -> + Ast_411.Parsetree.Pstr_typext (copy_type_extension x0) + | Ast_410.Parsetree.Pstr_exception x0 -> + Ast_411.Parsetree.Pstr_exception (copy_type_exception x0) + | Ast_410.Parsetree.Pstr_module x0 -> + Ast_411.Parsetree.Pstr_module (copy_module_binding x0) + | Ast_410.Parsetree.Pstr_recmodule x0 -> + Ast_411.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) + | Ast_410.Parsetree.Pstr_modtype x0 -> + Ast_411.Parsetree.Pstr_modtype (copy_module_type_declaration x0) + | Ast_410.Parsetree.Pstr_open x0 -> + Ast_411.Parsetree.Pstr_open (copy_open_declaration x0) + | Ast_410.Parsetree.Pstr_class x0 -> + Ast_411.Parsetree.Pstr_class (List.map copy_class_declaration x0) + | Ast_410.Parsetree.Pstr_class_type x0 -> + Ast_411.Parsetree.Pstr_class_type + (List.map copy_class_type_declaration x0) + | Ast_410.Parsetree.Pstr_include x0 -> + Ast_411.Parsetree.Pstr_include (copy_include_declaration x0) + | Ast_410.Parsetree.Pstr_attribute x0 -> + Ast_411.Parsetree.Pstr_attribute (copy_attribute x0) + | Ast_410.Parsetree.Pstr_extension (x0, x1) -> + Ast_411.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1) + +and copy_include_declaration : + Ast_410.Parsetree.include_declaration -> + Ast_411.Parsetree.include_declaration = + fun x -> copy_include_infos copy_module_expr x + +and copy_class_declaration : + Ast_410.Parsetree.class_declaration -> Ast_411.Parsetree.class_declaration = + fun x -> copy_class_infos copy_class_expr x + +and copy_class_expr : + Ast_410.Parsetree.class_expr -> Ast_411.Parsetree.class_expr = + fun { + Ast_410.Parsetree.pcl_desc; + Ast_410.Parsetree.pcl_loc; + Ast_410.Parsetree.pcl_attributes; + } -> + { + Ast_411.Parsetree.pcl_desc = copy_class_expr_desc pcl_desc; + Ast_411.Parsetree.pcl_loc = copy_location pcl_loc; + Ast_411.Parsetree.pcl_attributes = copy_attributes pcl_attributes; + } + +and copy_class_expr_desc : + Ast_410.Parsetree.class_expr_desc -> Ast_411.Parsetree.class_expr_desc = + function + | Ast_410.Parsetree.Pcl_constr (x0, x1) -> + Ast_411.Parsetree.Pcl_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_410.Parsetree.Pcl_structure x0 -> + Ast_411.Parsetree.Pcl_structure (copy_class_structure x0) + | Ast_410.Parsetree.Pcl_fun (x0, x1, x2, x3) -> + Ast_411.Parsetree.Pcl_fun + ( copy_arg_label x0, + Option.map copy_expression x1, + copy_pattern x2, + copy_class_expr x3 ) + | Ast_410.Parsetree.Pcl_apply (x0, x1) -> + Ast_411.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_410.Parsetree.Pcl_let (x0, x1, x2) -> + Ast_411.Parsetree.Pcl_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_class_expr x2) + | Ast_410.Parsetree.Pcl_constraint (x0, x1) -> + Ast_411.Parsetree.Pcl_constraint (copy_class_expr x0, copy_class_type x1) + | Ast_410.Parsetree.Pcl_extension x0 -> + Ast_411.Parsetree.Pcl_extension (copy_extension x0) + | Ast_410.Parsetree.Pcl_open (x0, x1) -> + Ast_411.Parsetree.Pcl_open (copy_open_description x0, copy_class_expr x1) + +and copy_class_structure : + Ast_410.Parsetree.class_structure -> Ast_411.Parsetree.class_structure = + fun { Ast_410.Parsetree.pcstr_self; Ast_410.Parsetree.pcstr_fields } -> + { + Ast_411.Parsetree.pcstr_self = copy_pattern pcstr_self; + Ast_411.Parsetree.pcstr_fields = List.map copy_class_field pcstr_fields; + } + +and copy_class_field : + Ast_410.Parsetree.class_field -> Ast_411.Parsetree.class_field = + fun { + Ast_410.Parsetree.pcf_desc; + Ast_410.Parsetree.pcf_loc; + Ast_410.Parsetree.pcf_attributes; + } -> + { + Ast_411.Parsetree.pcf_desc = copy_class_field_desc pcf_desc; + Ast_411.Parsetree.pcf_loc = copy_location pcf_loc; + Ast_411.Parsetree.pcf_attributes = copy_attributes pcf_attributes; + } + +and copy_class_field_desc : + Ast_410.Parsetree.class_field_desc -> Ast_411.Parsetree.class_field_desc = + function + | Ast_410.Parsetree.Pcf_inherit (x0, x1, x2) -> + Ast_411.Parsetree.Pcf_inherit + ( copy_override_flag x0, + copy_class_expr x1, + Option.map (fun x -> copy_loc (fun x -> x) x) x2 ) + | Ast_410.Parsetree.Pcf_val x0 -> + Ast_411.Parsetree.Pcf_val + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_mutable_flag x1, copy_class_field_kind x2)) + | Ast_410.Parsetree.Pcf_method x0 -> + Ast_411.Parsetree.Pcf_method + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_private_flag x1, copy_class_field_kind x2)) + | Ast_410.Parsetree.Pcf_constraint x0 -> + Ast_411.Parsetree.Pcf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | Ast_410.Parsetree.Pcf_initializer x0 -> + Ast_411.Parsetree.Pcf_initializer (copy_expression x0) + | Ast_410.Parsetree.Pcf_attribute x0 -> + Ast_411.Parsetree.Pcf_attribute (copy_attribute x0) + | Ast_410.Parsetree.Pcf_extension x0 -> + Ast_411.Parsetree.Pcf_extension (copy_extension x0) + +and copy_class_field_kind : + Ast_410.Parsetree.class_field_kind -> Ast_411.Parsetree.class_field_kind = + function + | Ast_410.Parsetree.Cfk_virtual x0 -> + Ast_411.Parsetree.Cfk_virtual (copy_core_type x0) + | Ast_410.Parsetree.Cfk_concrete (x0, x1) -> + Ast_411.Parsetree.Cfk_concrete (copy_override_flag x0, copy_expression x1) + +and copy_open_declaration : + Ast_410.Parsetree.open_declaration -> Ast_411.Parsetree.open_declaration = + fun x -> copy_open_infos copy_module_expr x + +and copy_module_binding : + Ast_410.Parsetree.module_binding -> Ast_411.Parsetree.module_binding = + fun { + Ast_410.Parsetree.pmb_name; + Ast_410.Parsetree.pmb_expr; + Ast_410.Parsetree.pmb_attributes; + Ast_410.Parsetree.pmb_loc; + } -> + { + Ast_411.Parsetree.pmb_name = + copy_loc (fun x -> Option.map (fun x -> x) x) pmb_name; + Ast_411.Parsetree.pmb_expr = copy_module_expr pmb_expr; + Ast_411.Parsetree.pmb_attributes = copy_attributes pmb_attributes; + Ast_411.Parsetree.pmb_loc = copy_location pmb_loc; + } + +and copy_module_expr : + Ast_410.Parsetree.module_expr -> Ast_411.Parsetree.module_expr = + fun { + Ast_410.Parsetree.pmod_desc; + Ast_410.Parsetree.pmod_loc; + Ast_410.Parsetree.pmod_attributes; + } -> + { + Ast_411.Parsetree.pmod_desc = copy_module_expr_desc pmod_desc; + Ast_411.Parsetree.pmod_loc = copy_location pmod_loc; + Ast_411.Parsetree.pmod_attributes = copy_attributes pmod_attributes; + } + +and copy_module_expr_desc : + Ast_410.Parsetree.module_expr_desc -> Ast_411.Parsetree.module_expr_desc = + function + | Ast_410.Parsetree.Pmod_ident x0 -> + Ast_411.Parsetree.Pmod_ident (copy_loc copy_Longident_t x0) + | Ast_410.Parsetree.Pmod_structure x0 -> + Ast_411.Parsetree.Pmod_structure (copy_structure x0) + | Ast_410.Parsetree.Pmod_functor (x0, x1) -> + Ast_411.Parsetree.Pmod_functor + (copy_functor_parameter x0, copy_module_expr x1) + | Ast_410.Parsetree.Pmod_apply (x0, x1) -> + Ast_411.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) + | Ast_410.Parsetree.Pmod_constraint (x0, x1) -> + Ast_411.Parsetree.Pmod_constraint + (copy_module_expr x0, copy_module_type x1) + | Ast_410.Parsetree.Pmod_unpack x0 -> + Ast_411.Parsetree.Pmod_unpack (copy_expression x0) + | Ast_410.Parsetree.Pmod_extension x0 -> + Ast_411.Parsetree.Pmod_extension (copy_extension x0) + +and copy_functor_parameter : + Ast_410.Parsetree.functor_parameter -> Ast_411.Parsetree.functor_parameter = + function + | Ast_410.Parsetree.Unit -> Ast_411.Parsetree.Unit + | Ast_410.Parsetree.Named (x0, x1) -> + Ast_411.Parsetree.Named + (copy_loc (fun x -> Option.map (fun x -> x) x) x0, copy_module_type x1) + +and copy_module_type : + Ast_410.Parsetree.module_type -> Ast_411.Parsetree.module_type = + fun { + Ast_410.Parsetree.pmty_desc; + Ast_410.Parsetree.pmty_loc; + Ast_410.Parsetree.pmty_attributes; + } -> + { + Ast_411.Parsetree.pmty_desc = copy_module_type_desc pmty_desc; + Ast_411.Parsetree.pmty_loc = copy_location pmty_loc; + Ast_411.Parsetree.pmty_attributes = copy_attributes pmty_attributes; + } + +and copy_module_type_desc : + Ast_410.Parsetree.module_type_desc -> Ast_411.Parsetree.module_type_desc = + function + | Ast_410.Parsetree.Pmty_ident x0 -> + Ast_411.Parsetree.Pmty_ident (copy_loc copy_Longident_t x0) + | Ast_410.Parsetree.Pmty_signature x0 -> + Ast_411.Parsetree.Pmty_signature (copy_signature x0) + | Ast_410.Parsetree.Pmty_functor (x0, x1) -> + Ast_411.Parsetree.Pmty_functor + (copy_functor_parameter x0, copy_module_type x1) + | Ast_410.Parsetree.Pmty_with (x0, x1) -> + Ast_411.Parsetree.Pmty_with + (copy_module_type x0, List.map copy_with_constraint x1) + | Ast_410.Parsetree.Pmty_typeof x0 -> + Ast_411.Parsetree.Pmty_typeof (copy_module_expr x0) + | Ast_410.Parsetree.Pmty_extension x0 -> + Ast_411.Parsetree.Pmty_extension (copy_extension x0) + | Ast_410.Parsetree.Pmty_alias x0 -> + Ast_411.Parsetree.Pmty_alias (copy_loc copy_Longident_t x0) + +and copy_with_constraint : + Ast_410.Parsetree.with_constraint -> Ast_411.Parsetree.with_constraint = + function + | Ast_410.Parsetree.Pwith_type (x0, x1) -> + Ast_411.Parsetree.Pwith_type + (copy_loc copy_Longident_t x0, copy_type_declaration x1) + | Ast_410.Parsetree.Pwith_module (x0, x1) -> + Ast_411.Parsetree.Pwith_module + (copy_loc copy_Longident_t x0, copy_loc copy_Longident_t x1) + | Ast_410.Parsetree.Pwith_typesubst (x0, x1) -> + Ast_411.Parsetree.Pwith_typesubst + (copy_loc copy_Longident_t x0, copy_type_declaration x1) + | Ast_410.Parsetree.Pwith_modsubst (x0, x1) -> + Ast_411.Parsetree.Pwith_modsubst + (copy_loc copy_Longident_t x0, copy_loc copy_Longident_t x1) + +and copy_signature : Ast_410.Parsetree.signature -> Ast_411.Parsetree.signature + = + fun x -> List.map copy_signature_item x + +and copy_signature_item : + Ast_410.Parsetree.signature_item -> Ast_411.Parsetree.signature_item = + fun { Ast_410.Parsetree.psig_desc; Ast_410.Parsetree.psig_loc } -> + { + Ast_411.Parsetree.psig_desc = copy_signature_item_desc psig_desc; + Ast_411.Parsetree.psig_loc = copy_location psig_loc; + } + +and copy_signature_item_desc : + Ast_410.Parsetree.signature_item_desc -> + Ast_411.Parsetree.signature_item_desc = function + | Ast_410.Parsetree.Psig_value x0 -> + Ast_411.Parsetree.Psig_value (copy_value_description x0) + | Ast_410.Parsetree.Psig_type (x0, x1) -> + Ast_411.Parsetree.Psig_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | Ast_410.Parsetree.Psig_typesubst x0 -> + Ast_411.Parsetree.Psig_typesubst (List.map copy_type_declaration x0) + | Ast_410.Parsetree.Psig_typext x0 -> + Ast_411.Parsetree.Psig_typext (copy_type_extension x0) + | Ast_410.Parsetree.Psig_exception x0 -> + Ast_411.Parsetree.Psig_exception (copy_type_exception x0) + | Ast_410.Parsetree.Psig_module x0 -> + Ast_411.Parsetree.Psig_module (copy_module_declaration x0) + | Ast_410.Parsetree.Psig_modsubst x0 -> + Ast_411.Parsetree.Psig_modsubst (copy_module_substitution x0) + | Ast_410.Parsetree.Psig_recmodule x0 -> + Ast_411.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) + | Ast_410.Parsetree.Psig_modtype x0 -> + Ast_411.Parsetree.Psig_modtype (copy_module_type_declaration x0) + | Ast_410.Parsetree.Psig_open x0 -> + Ast_411.Parsetree.Psig_open (copy_open_description x0) + | Ast_410.Parsetree.Psig_include x0 -> + Ast_411.Parsetree.Psig_include (copy_include_description x0) + | Ast_410.Parsetree.Psig_class x0 -> + Ast_411.Parsetree.Psig_class (List.map copy_class_description x0) + | Ast_410.Parsetree.Psig_class_type x0 -> + Ast_411.Parsetree.Psig_class_type + (List.map copy_class_type_declaration x0) + | Ast_410.Parsetree.Psig_attribute x0 -> + Ast_411.Parsetree.Psig_attribute (copy_attribute x0) + | Ast_410.Parsetree.Psig_extension (x0, x1) -> + Ast_411.Parsetree.Psig_extension (copy_extension x0, copy_attributes x1) + +and copy_class_type_declaration : + Ast_410.Parsetree.class_type_declaration -> + Ast_411.Parsetree.class_type_declaration = + fun x -> copy_class_infos copy_class_type x + +and copy_class_description : + Ast_410.Parsetree.class_description -> Ast_411.Parsetree.class_description = + fun x -> copy_class_infos copy_class_type x + +and copy_class_type : + Ast_410.Parsetree.class_type -> Ast_411.Parsetree.class_type = + fun { + Ast_410.Parsetree.pcty_desc; + Ast_410.Parsetree.pcty_loc; + Ast_410.Parsetree.pcty_attributes; + } -> + { + Ast_411.Parsetree.pcty_desc = copy_class_type_desc pcty_desc; + Ast_411.Parsetree.pcty_loc = copy_location pcty_loc; + Ast_411.Parsetree.pcty_attributes = copy_attributes pcty_attributes; + } + +and copy_class_type_desc : + Ast_410.Parsetree.class_type_desc -> Ast_411.Parsetree.class_type_desc = + function + | Ast_410.Parsetree.Pcty_constr (x0, x1) -> + Ast_411.Parsetree.Pcty_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_410.Parsetree.Pcty_signature x0 -> + Ast_411.Parsetree.Pcty_signature (copy_class_signature x0) + | Ast_410.Parsetree.Pcty_arrow (x0, x1, x2) -> + Ast_411.Parsetree.Pcty_arrow + (copy_arg_label x0, copy_core_type x1, copy_class_type x2) + | Ast_410.Parsetree.Pcty_extension x0 -> + Ast_411.Parsetree.Pcty_extension (copy_extension x0) + | Ast_410.Parsetree.Pcty_open (x0, x1) -> + Ast_411.Parsetree.Pcty_open (copy_open_description x0, copy_class_type x1) + +and copy_class_signature : + Ast_410.Parsetree.class_signature -> Ast_411.Parsetree.class_signature = + fun { Ast_410.Parsetree.pcsig_self; Ast_410.Parsetree.pcsig_fields } -> + { + Ast_411.Parsetree.pcsig_self = copy_core_type pcsig_self; + Ast_411.Parsetree.pcsig_fields = List.map copy_class_type_field pcsig_fields; + } + +and copy_class_type_field : + Ast_410.Parsetree.class_type_field -> Ast_411.Parsetree.class_type_field = + fun { + Ast_410.Parsetree.pctf_desc; + Ast_410.Parsetree.pctf_loc; + Ast_410.Parsetree.pctf_attributes; + } -> + { + Ast_411.Parsetree.pctf_desc = copy_class_type_field_desc pctf_desc; + Ast_411.Parsetree.pctf_loc = copy_location pctf_loc; + Ast_411.Parsetree.pctf_attributes = copy_attributes pctf_attributes; + } + +and copy_class_type_field_desc : + Ast_410.Parsetree.class_type_field_desc -> + Ast_411.Parsetree.class_type_field_desc = function + | Ast_410.Parsetree.Pctf_inherit x0 -> + Ast_411.Parsetree.Pctf_inherit (copy_class_type x0) + | Ast_410.Parsetree.Pctf_val x0 -> + Ast_411.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_410.Parsetree.Pctf_method x0 -> + Ast_411.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_410.Parsetree.Pctf_constraint x0 -> + Ast_411.Parsetree.Pctf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | Ast_410.Parsetree.Pctf_attribute x0 -> + Ast_411.Parsetree.Pctf_attribute (copy_attribute x0) + | Ast_410.Parsetree.Pctf_extension x0 -> + Ast_411.Parsetree.Pctf_extension (copy_extension x0) + +and copy_extension : Ast_410.Parsetree.extension -> Ast_411.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_410.Parsetree.class_infos -> + 'g0 Ast_411.Parsetree.class_infos = + fun f0 + { + Ast_410.Parsetree.pci_virt; + Ast_410.Parsetree.pci_params; + Ast_410.Parsetree.pci_name; + Ast_410.Parsetree.pci_expr; + Ast_410.Parsetree.pci_loc; + Ast_410.Parsetree.pci_attributes; + } -> + { + Ast_411.Parsetree.pci_virt = copy_virtual_flag pci_virt; + Ast_411.Parsetree.pci_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + pci_params; + Ast_411.Parsetree.pci_name = copy_loc (fun x -> x) pci_name; + Ast_411.Parsetree.pci_expr = f0 pci_expr; + Ast_411.Parsetree.pci_loc = copy_location pci_loc; + Ast_411.Parsetree.pci_attributes = copy_attributes pci_attributes; + } + +and copy_virtual_flag : + Ast_410.Asttypes.virtual_flag -> Ast_411.Asttypes.virtual_flag = function + | Ast_410.Asttypes.Virtual -> Ast_411.Asttypes.Virtual + | Ast_410.Asttypes.Concrete -> Ast_411.Asttypes.Concrete + +and copy_include_description : + Ast_410.Parsetree.include_description -> + Ast_411.Parsetree.include_description = + fun x -> copy_include_infos copy_module_type x + +and copy_include_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 Ast_410.Parsetree.include_infos -> + 'g0 Ast_411.Parsetree.include_infos = + fun f0 + { + Ast_410.Parsetree.pincl_mod; + Ast_410.Parsetree.pincl_loc; + Ast_410.Parsetree.pincl_attributes; + } -> + { + Ast_411.Parsetree.pincl_mod = f0 pincl_mod; + Ast_411.Parsetree.pincl_loc = copy_location pincl_loc; + Ast_411.Parsetree.pincl_attributes = copy_attributes pincl_attributes; + } + +and copy_open_description : + Ast_410.Parsetree.open_description -> Ast_411.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_410.Parsetree.open_infos -> + 'g0 Ast_411.Parsetree.open_infos = + fun f0 + { + Ast_410.Parsetree.popen_expr; + Ast_410.Parsetree.popen_override; + Ast_410.Parsetree.popen_loc; + Ast_410.Parsetree.popen_attributes; + } -> + { + Ast_411.Parsetree.popen_expr = f0 popen_expr; + Ast_411.Parsetree.popen_override = copy_override_flag popen_override; + Ast_411.Parsetree.popen_loc = copy_location popen_loc; + Ast_411.Parsetree.popen_attributes = copy_attributes popen_attributes; + } + +and copy_override_flag : + Ast_410.Asttypes.override_flag -> Ast_411.Asttypes.override_flag = function + | Ast_410.Asttypes.Override -> Ast_411.Asttypes.Override + | Ast_410.Asttypes.Fresh -> Ast_411.Asttypes.Fresh + +and copy_module_type_declaration : + Ast_410.Parsetree.module_type_declaration -> + Ast_411.Parsetree.module_type_declaration = + fun { + Ast_410.Parsetree.pmtd_name; + Ast_410.Parsetree.pmtd_type; + Ast_410.Parsetree.pmtd_attributes; + Ast_410.Parsetree.pmtd_loc; + } -> + { + Ast_411.Parsetree.pmtd_name = copy_loc (fun x -> x) pmtd_name; + Ast_411.Parsetree.pmtd_type = Option.map copy_module_type pmtd_type; + Ast_411.Parsetree.pmtd_attributes = copy_attributes pmtd_attributes; + Ast_411.Parsetree.pmtd_loc = copy_location pmtd_loc; + } + +and copy_module_substitution : + Ast_410.Parsetree.module_substitution -> + Ast_411.Parsetree.module_substitution = + fun { + Ast_410.Parsetree.pms_name; + Ast_410.Parsetree.pms_manifest; + Ast_410.Parsetree.pms_attributes; + Ast_410.Parsetree.pms_loc; + } -> + { + Ast_411.Parsetree.pms_name = copy_loc (fun x -> x) pms_name; + Ast_411.Parsetree.pms_manifest = copy_loc copy_Longident_t pms_manifest; + Ast_411.Parsetree.pms_attributes = copy_attributes pms_attributes; + Ast_411.Parsetree.pms_loc = copy_location pms_loc; + } + +and copy_module_declaration : + Ast_410.Parsetree.module_declaration -> Ast_411.Parsetree.module_declaration + = + fun { + Ast_410.Parsetree.pmd_name; + Ast_410.Parsetree.pmd_type; + Ast_410.Parsetree.pmd_attributes; + Ast_410.Parsetree.pmd_loc; + } -> + { + Ast_411.Parsetree.pmd_name = + copy_loc (fun x -> Option.map (fun x -> x) x) pmd_name; + Ast_411.Parsetree.pmd_type = copy_module_type pmd_type; + Ast_411.Parsetree.pmd_attributes = copy_attributes pmd_attributes; + Ast_411.Parsetree.pmd_loc = copy_location pmd_loc; + } + +and copy_type_exception : + Ast_410.Parsetree.type_exception -> Ast_411.Parsetree.type_exception = + fun { + Ast_410.Parsetree.ptyexn_constructor; + Ast_410.Parsetree.ptyexn_loc; + Ast_410.Parsetree.ptyexn_attributes; + } -> + { + Ast_411.Parsetree.ptyexn_constructor = + copy_extension_constructor ptyexn_constructor; + Ast_411.Parsetree.ptyexn_loc = copy_location ptyexn_loc; + Ast_411.Parsetree.ptyexn_attributes = copy_attributes ptyexn_attributes; + } + +and copy_type_extension : + Ast_410.Parsetree.type_extension -> Ast_411.Parsetree.type_extension = + fun { + Ast_410.Parsetree.ptyext_path; + Ast_410.Parsetree.ptyext_params; + Ast_410.Parsetree.ptyext_constructors; + Ast_410.Parsetree.ptyext_private; + Ast_410.Parsetree.ptyext_loc; + Ast_410.Parsetree.ptyext_attributes; + } -> + { + Ast_411.Parsetree.ptyext_path = copy_loc copy_Longident_t ptyext_path; + Ast_411.Parsetree.ptyext_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptyext_params; + Ast_411.Parsetree.ptyext_constructors = + List.map copy_extension_constructor ptyext_constructors; + Ast_411.Parsetree.ptyext_private = copy_private_flag ptyext_private; + Ast_411.Parsetree.ptyext_loc = copy_location ptyext_loc; + Ast_411.Parsetree.ptyext_attributes = copy_attributes ptyext_attributes; + } + +and copy_extension_constructor : + Ast_410.Parsetree.extension_constructor -> + Ast_411.Parsetree.extension_constructor = + fun { + Ast_410.Parsetree.pext_name; + Ast_410.Parsetree.pext_kind; + Ast_410.Parsetree.pext_loc; + Ast_410.Parsetree.pext_attributes; + } -> + { + Ast_411.Parsetree.pext_name = copy_loc (fun x -> x) pext_name; + Ast_411.Parsetree.pext_kind = copy_extension_constructor_kind pext_kind; + Ast_411.Parsetree.pext_loc = copy_location pext_loc; + Ast_411.Parsetree.pext_attributes = copy_attributes pext_attributes; + } + +and copy_extension_constructor_kind : + Ast_410.Parsetree.extension_constructor_kind -> + Ast_411.Parsetree.extension_constructor_kind = function + | Ast_410.Parsetree.Pext_decl (x0, x1) -> + Ast_411.Parsetree.Pext_decl + (copy_constructor_arguments x0, Option.map copy_core_type x1) + | Ast_410.Parsetree.Pext_rebind x0 -> + Ast_411.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0) + +and copy_type_declaration : + Ast_410.Parsetree.type_declaration -> Ast_411.Parsetree.type_declaration = + fun { + Ast_410.Parsetree.ptype_name; + Ast_410.Parsetree.ptype_params; + Ast_410.Parsetree.ptype_cstrs; + Ast_410.Parsetree.ptype_kind; + Ast_410.Parsetree.ptype_private; + Ast_410.Parsetree.ptype_manifest; + Ast_410.Parsetree.ptype_attributes; + Ast_410.Parsetree.ptype_loc; + } -> + { + Ast_411.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name; + Ast_411.Parsetree.ptype_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptype_params; + Ast_411.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_411.Parsetree.ptype_kind = copy_type_kind ptype_kind; + Ast_411.Parsetree.ptype_private = copy_private_flag ptype_private; + Ast_411.Parsetree.ptype_manifest = Option.map copy_core_type ptype_manifest; + Ast_411.Parsetree.ptype_attributes = copy_attributes ptype_attributes; + Ast_411.Parsetree.ptype_loc = copy_location ptype_loc; + } + +and copy_private_flag : + Ast_410.Asttypes.private_flag -> Ast_411.Asttypes.private_flag = function + | Ast_410.Asttypes.Private -> Ast_411.Asttypes.Private + | Ast_410.Asttypes.Public -> Ast_411.Asttypes.Public + +and copy_type_kind : Ast_410.Parsetree.type_kind -> Ast_411.Parsetree.type_kind + = function + | Ast_410.Parsetree.Ptype_abstract -> Ast_411.Parsetree.Ptype_abstract + | Ast_410.Parsetree.Ptype_variant x0 -> + Ast_411.Parsetree.Ptype_variant (List.map copy_constructor_declaration x0) + | Ast_410.Parsetree.Ptype_record x0 -> + Ast_411.Parsetree.Ptype_record (List.map copy_label_declaration x0) + | Ast_410.Parsetree.Ptype_open -> Ast_411.Parsetree.Ptype_open + +and copy_constructor_declaration : + Ast_410.Parsetree.constructor_declaration -> + Ast_411.Parsetree.constructor_declaration = + fun { + Ast_410.Parsetree.pcd_name; + Ast_410.Parsetree.pcd_args; + Ast_410.Parsetree.pcd_res; + Ast_410.Parsetree.pcd_loc; + Ast_410.Parsetree.pcd_attributes; + } -> + { + Ast_411.Parsetree.pcd_name = copy_loc (fun x -> x) pcd_name; + Ast_411.Parsetree.pcd_args = copy_constructor_arguments pcd_args; + Ast_411.Parsetree.pcd_res = Option.map copy_core_type pcd_res; + Ast_411.Parsetree.pcd_loc = copy_location pcd_loc; + Ast_411.Parsetree.pcd_attributes = copy_attributes pcd_attributes; + } + +and copy_constructor_arguments : + Ast_410.Parsetree.constructor_arguments -> + Ast_411.Parsetree.constructor_arguments = function + | Ast_410.Parsetree.Pcstr_tuple x0 -> + Ast_411.Parsetree.Pcstr_tuple (List.map copy_core_type x0) + | Ast_410.Parsetree.Pcstr_record x0 -> + Ast_411.Parsetree.Pcstr_record (List.map copy_label_declaration x0) + +and copy_label_declaration : + Ast_410.Parsetree.label_declaration -> Ast_411.Parsetree.label_declaration = + fun { + Ast_410.Parsetree.pld_name; + Ast_410.Parsetree.pld_mutable; + Ast_410.Parsetree.pld_type; + Ast_410.Parsetree.pld_loc; + Ast_410.Parsetree.pld_attributes; + } -> + { + Ast_411.Parsetree.pld_name = copy_loc (fun x -> x) pld_name; + Ast_411.Parsetree.pld_mutable = copy_mutable_flag pld_mutable; + Ast_411.Parsetree.pld_type = copy_core_type pld_type; + Ast_411.Parsetree.pld_loc = copy_location pld_loc; + Ast_411.Parsetree.pld_attributes = copy_attributes pld_attributes; + } + +and copy_mutable_flag : + Ast_410.Asttypes.mutable_flag -> Ast_411.Asttypes.mutable_flag = function + | Ast_410.Asttypes.Immutable -> Ast_411.Asttypes.Immutable + | Ast_410.Asttypes.Mutable -> Ast_411.Asttypes.Mutable + +and copy_variance : Ast_410.Asttypes.variance -> Ast_411.Asttypes.variance = + function + | Ast_410.Asttypes.Covariant -> Ast_411.Asttypes.Covariant + | Ast_410.Asttypes.Contravariant -> Ast_411.Asttypes.Contravariant + | Ast_410.Asttypes.Invariant -> Ast_411.Asttypes.Invariant + +and copy_value_description : + Ast_410.Parsetree.value_description -> Ast_411.Parsetree.value_description = + fun { + Ast_410.Parsetree.pval_name; + Ast_410.Parsetree.pval_type; + Ast_410.Parsetree.pval_prim; + Ast_410.Parsetree.pval_attributes; + Ast_410.Parsetree.pval_loc; + } -> + { + Ast_411.Parsetree.pval_name = copy_loc (fun x -> x) pval_name; + Ast_411.Parsetree.pval_type = copy_core_type pval_type; + Ast_411.Parsetree.pval_prim = List.map (fun x -> x) pval_prim; + Ast_411.Parsetree.pval_attributes = copy_attributes pval_attributes; + Ast_411.Parsetree.pval_loc = copy_location pval_loc; + } + +and copy_object_field_desc : + Ast_410.Parsetree.object_field_desc -> Ast_411.Parsetree.object_field_desc = + function + | Ast_410.Parsetree.Otag (x0, x1) -> + Ast_411.Parsetree.Otag (copy_loc copy_label x0, copy_core_type x1) + | Ast_410.Parsetree.Oinherit x0 -> + Ast_411.Parsetree.Oinherit (copy_core_type x0) + +and copy_arg_label : Ast_410.Asttypes.arg_label -> Ast_411.Asttypes.arg_label = + function + | Ast_410.Asttypes.Nolabel -> Ast_411.Asttypes.Nolabel + | Ast_410.Asttypes.Labelled x0 -> Ast_411.Asttypes.Labelled x0 + | Ast_410.Asttypes.Optional x0 -> Ast_411.Asttypes.Optional x0 + +and copy_closed_flag : + Ast_410.Asttypes.closed_flag -> Ast_411.Asttypes.closed_flag = function + | Ast_410.Asttypes.Closed -> Ast_411.Asttypes.Closed + | Ast_410.Asttypes.Open -> Ast_411.Asttypes.Open + +and copy_label : Ast_410.Asttypes.label -> Ast_411.Asttypes.label = fun x -> x + +and copy_rec_flag : Ast_410.Asttypes.rec_flag -> Ast_411.Asttypes.rec_flag = + function + | Ast_410.Asttypes.Nonrecursive -> Ast_411.Asttypes.Nonrecursive + | Ast_410.Asttypes.Recursive -> Ast_411.Asttypes.Recursive + +and copy_constant : Ast_410.Parsetree.constant -> Ast_411.Parsetree.constant = + function + | Ast_410.Parsetree.Pconst_integer (x0, x1) -> + Ast_411.Parsetree.Pconst_integer (x0, Option.map (fun x -> x) x1) + | Ast_410.Parsetree.Pconst_char x0 -> Ast_411.Parsetree.Pconst_char x0 + | Ast_410.Parsetree.Pconst_string (x0, x1) -> + Ast_411.Parsetree.Pconst_string + (x0, Location.none, Option.map (fun x -> x) x1) + | Ast_410.Parsetree.Pconst_float (x0, x1) -> + Ast_411.Parsetree.Pconst_float (x0, Option.map (fun x -> x) x1) + +and copy_Longident_t : Longident.t -> Longident.t = fun x -> x + +and copy_loc : + 'f0 'g0. + ('f0 -> 'g0) -> 'f0 Ast_410.Asttypes.loc -> 'g0 Ast_411.Asttypes.loc = + fun f0 { Ast_410.Asttypes.txt; Ast_410.Asttypes.loc } -> + { Ast_411.Asttypes.txt = f0 txt; Ast_411.Asttypes.loc = copy_location loc } + +and copy_location : Location.t -> Location.t = fun x -> x diff -Nru ppxlib-0.15.0/astlib/migrate_411_410.ml ppxlib-0.24.0/astlib/migrate_411_410.ml --- ppxlib-0.15.0/astlib/migrate_411_410.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/migrate_411_410.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1195 @@ +open Stdlib0 +module From = Ast_411 +module To = Ast_410 + +let rec copy_toplevel_phrase : + Ast_411.Parsetree.toplevel_phrase -> Ast_410.Parsetree.toplevel_phrase = + function + | Ast_411.Parsetree.Ptop_def x0 -> + Ast_410.Parsetree.Ptop_def (copy_structure x0) + | Ast_411.Parsetree.Ptop_dir x0 -> + Ast_410.Parsetree.Ptop_dir (copy_toplevel_directive x0) + +and copy_toplevel_directive : + Ast_411.Parsetree.toplevel_directive -> Ast_410.Parsetree.toplevel_directive + = + fun { + Ast_411.Parsetree.pdir_name; + Ast_411.Parsetree.pdir_arg; + Ast_411.Parsetree.pdir_loc; + } -> + { + Ast_410.Parsetree.pdir_name = copy_loc (fun x -> x) pdir_name; + Ast_410.Parsetree.pdir_arg = Option.map copy_directive_argument pdir_arg; + Ast_410.Parsetree.pdir_loc = copy_location pdir_loc; + } + +and copy_directive_argument : + Ast_411.Parsetree.directive_argument -> Ast_410.Parsetree.directive_argument + = + fun { Ast_411.Parsetree.pdira_desc; Ast_411.Parsetree.pdira_loc } -> + { + Ast_410.Parsetree.pdira_desc = copy_directive_argument_desc pdira_desc; + Ast_410.Parsetree.pdira_loc = copy_location pdira_loc; + } + +and copy_directive_argument_desc : + Ast_411.Parsetree.directive_argument_desc -> + Ast_410.Parsetree.directive_argument_desc = function + | Ast_411.Parsetree.Pdir_string x0 -> Ast_410.Parsetree.Pdir_string x0 + | Ast_411.Parsetree.Pdir_int (x0, x1) -> + Ast_410.Parsetree.Pdir_int (x0, Option.map (fun x -> x) x1) + | Ast_411.Parsetree.Pdir_ident x0 -> + Ast_410.Parsetree.Pdir_ident (copy_Longident_t x0) + | Ast_411.Parsetree.Pdir_bool x0 -> Ast_410.Parsetree.Pdir_bool x0 + +and copy_expression : + Ast_411.Parsetree.expression -> Ast_410.Parsetree.expression = + fun { + Ast_411.Parsetree.pexp_desc; + Ast_411.Parsetree.pexp_loc; + Ast_411.Parsetree.pexp_loc_stack; + Ast_411.Parsetree.pexp_attributes; + } -> + { + Ast_410.Parsetree.pexp_desc = copy_expression_desc pexp_desc; + Ast_410.Parsetree.pexp_loc = copy_location pexp_loc; + Ast_410.Parsetree.pexp_loc_stack = copy_location_stack pexp_loc_stack; + Ast_410.Parsetree.pexp_attributes = copy_attributes pexp_attributes; + } + +and copy_expr x = copy_expression x + +and copy_expression_desc : + Ast_411.Parsetree.expression_desc -> Ast_410.Parsetree.expression_desc = + function + | Ast_411.Parsetree.Pexp_ident x0 -> + Ast_410.Parsetree.Pexp_ident (copy_loc copy_Longident_t x0) + | Ast_411.Parsetree.Pexp_constant x0 -> + Ast_410.Parsetree.Pexp_constant (copy_constant x0) + | Ast_411.Parsetree.Pexp_let (x0, x1, x2) -> + Ast_410.Parsetree.Pexp_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_expression x2) + | Ast_411.Parsetree.Pexp_function x0 -> + Ast_410.Parsetree.Pexp_function (List.map copy_case x0) + | Ast_411.Parsetree.Pexp_fun (x0, x1, x2, x3) -> + Ast_410.Parsetree.Pexp_fun + ( copy_arg_label x0, + Option.map copy_expression x1, + copy_pattern x2, + copy_expression x3 ) + | Ast_411.Parsetree.Pexp_apply (x0, x1) -> + Ast_410.Parsetree.Pexp_apply + ( copy_expression x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | Ast_411.Parsetree.Pexp_match (x0, x1) -> + Ast_410.Parsetree.Pexp_match (copy_expression x0, List.map copy_case x1) + | Ast_411.Parsetree.Pexp_try (x0, x1) -> + Ast_410.Parsetree.Pexp_try (copy_expression x0, List.map copy_case x1) + | Ast_411.Parsetree.Pexp_tuple x0 -> + Ast_410.Parsetree.Pexp_tuple (List.map copy_expression x0) + | Ast_411.Parsetree.Pexp_construct (x0, x1) -> + Ast_410.Parsetree.Pexp_construct + (copy_loc copy_Longident_t x0, Option.map copy_expression x1) + | Ast_411.Parsetree.Pexp_variant (x0, x1) -> + Ast_410.Parsetree.Pexp_variant + (copy_label x0, Option.map copy_expression x1) + | Ast_411.Parsetree.Pexp_record (x0, x1) -> + Ast_410.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_411.Parsetree.Pexp_field (x0, x1) -> + Ast_410.Parsetree.Pexp_field + (copy_expression x0, copy_loc copy_Longident_t x1) + | Ast_411.Parsetree.Pexp_setfield (x0, x1, x2) -> + Ast_410.Parsetree.Pexp_setfield + (copy_expression x0, copy_loc copy_Longident_t x1, copy_expression x2) + | Ast_411.Parsetree.Pexp_array x0 -> + Ast_410.Parsetree.Pexp_array (List.map copy_expression x0) + | Ast_411.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> + Ast_410.Parsetree.Pexp_ifthenelse + (copy_expression x0, copy_expression x1, Option.map copy_expression x2) + | Ast_411.Parsetree.Pexp_sequence (x0, x1) -> + Ast_410.Parsetree.Pexp_sequence (copy_expression x0, copy_expression x1) + | Ast_411.Parsetree.Pexp_while (x0, x1) -> + Ast_410.Parsetree.Pexp_while (copy_expression x0, copy_expression x1) + | Ast_411.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> + Ast_410.Parsetree.Pexp_for + ( copy_pattern x0, + copy_expression x1, + copy_expression x2, + copy_direction_flag x3, + copy_expression x4 ) + | Ast_411.Parsetree.Pexp_constraint (x0, x1) -> + Ast_410.Parsetree.Pexp_constraint (copy_expression x0, copy_core_type x1) + | Ast_411.Parsetree.Pexp_coerce (x0, x1, x2) -> + Ast_410.Parsetree.Pexp_coerce + (copy_expression x0, Option.map copy_core_type x1, copy_core_type x2) + | Ast_411.Parsetree.Pexp_send (x0, x1) -> + Ast_410.Parsetree.Pexp_send (copy_expression x0, copy_loc copy_label x1) + | Ast_411.Parsetree.Pexp_new x0 -> + Ast_410.Parsetree.Pexp_new (copy_loc copy_Longident_t x0) + | Ast_411.Parsetree.Pexp_setinstvar (x0, x1) -> + Ast_410.Parsetree.Pexp_setinstvar + (copy_loc copy_label x0, copy_expression x1) + | Ast_411.Parsetree.Pexp_override x0 -> + Ast_410.Parsetree.Pexp_override + (List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_label x0, copy_expression x1)) + x0) + | Ast_411.Parsetree.Pexp_letmodule (x0, x1, x2) -> + Ast_410.Parsetree.Pexp_letmodule + ( copy_loc (fun x -> Option.map (fun x -> x) x) x0, + copy_module_expr x1, + copy_expression x2 ) + | Ast_411.Parsetree.Pexp_letexception (x0, x1) -> + Ast_410.Parsetree.Pexp_letexception + (copy_extension_constructor x0, copy_expression x1) + | Ast_411.Parsetree.Pexp_assert x0 -> + Ast_410.Parsetree.Pexp_assert (copy_expression x0) + | Ast_411.Parsetree.Pexp_lazy x0 -> + Ast_410.Parsetree.Pexp_lazy (copy_expression x0) + | Ast_411.Parsetree.Pexp_poly (x0, x1) -> + Ast_410.Parsetree.Pexp_poly + (copy_expression x0, Option.map copy_core_type x1) + | Ast_411.Parsetree.Pexp_object x0 -> + Ast_410.Parsetree.Pexp_object (copy_class_structure x0) + | Ast_411.Parsetree.Pexp_newtype (x0, x1) -> + Ast_410.Parsetree.Pexp_newtype + (copy_loc (fun x -> x) x0, copy_expression x1) + | Ast_411.Parsetree.Pexp_pack x0 -> + Ast_410.Parsetree.Pexp_pack (copy_module_expr x0) + | Ast_411.Parsetree.Pexp_open (x0, x1) -> + Ast_410.Parsetree.Pexp_open (copy_open_declaration x0, copy_expression x1) + | Ast_411.Parsetree.Pexp_letop x0 -> + Ast_410.Parsetree.Pexp_letop (copy_letop x0) + | Ast_411.Parsetree.Pexp_extension x0 -> + Ast_410.Parsetree.Pexp_extension (copy_extension x0) + | Ast_411.Parsetree.Pexp_unreachable -> Ast_410.Parsetree.Pexp_unreachable + +and copy_letop : Ast_411.Parsetree.letop -> Ast_410.Parsetree.letop = + fun { Ast_411.Parsetree.let_; Ast_411.Parsetree.ands; Ast_411.Parsetree.body } -> + { + Ast_410.Parsetree.let_ = copy_binding_op let_; + Ast_410.Parsetree.ands = List.map copy_binding_op ands; + Ast_410.Parsetree.body = copy_expression body; + } + +and copy_binding_op : + Ast_411.Parsetree.binding_op -> Ast_410.Parsetree.binding_op = + fun { + Ast_411.Parsetree.pbop_op; + Ast_411.Parsetree.pbop_pat; + Ast_411.Parsetree.pbop_exp; + Ast_411.Parsetree.pbop_loc; + } -> + { + Ast_410.Parsetree.pbop_op = copy_loc (fun x -> x) pbop_op; + Ast_410.Parsetree.pbop_pat = copy_pattern pbop_pat; + Ast_410.Parsetree.pbop_exp = copy_expression pbop_exp; + Ast_410.Parsetree.pbop_loc = copy_location pbop_loc; + } + +and copy_direction_flag : + Ast_411.Asttypes.direction_flag -> Ast_410.Asttypes.direction_flag = + function + | Ast_411.Asttypes.Upto -> Ast_410.Asttypes.Upto + | Ast_411.Asttypes.Downto -> Ast_410.Asttypes.Downto + +and copy_case : Ast_411.Parsetree.case -> Ast_410.Parsetree.case = + fun { + Ast_411.Parsetree.pc_lhs; + Ast_411.Parsetree.pc_guard; + Ast_411.Parsetree.pc_rhs; + } -> + { + Ast_410.Parsetree.pc_lhs = copy_pattern pc_lhs; + Ast_410.Parsetree.pc_guard = Option.map copy_expression pc_guard; + Ast_410.Parsetree.pc_rhs = copy_expression pc_rhs; + } + +and copy_cases : Ast_411.Parsetree.case list -> Ast_410.Parsetree.case list = + fun x -> List.map copy_case x + +and copy_value_binding : + Ast_411.Parsetree.value_binding -> Ast_410.Parsetree.value_binding = + fun { + Ast_411.Parsetree.pvb_pat; + Ast_411.Parsetree.pvb_expr; + Ast_411.Parsetree.pvb_attributes; + Ast_411.Parsetree.pvb_loc; + } -> + { + Ast_410.Parsetree.pvb_pat = copy_pattern pvb_pat; + Ast_410.Parsetree.pvb_expr = copy_expression pvb_expr; + Ast_410.Parsetree.pvb_attributes = copy_attributes pvb_attributes; + Ast_410.Parsetree.pvb_loc = copy_location pvb_loc; + } + +and copy_pattern : Ast_411.Parsetree.pattern -> Ast_410.Parsetree.pattern = + fun { + Ast_411.Parsetree.ppat_desc; + Ast_411.Parsetree.ppat_loc; + Ast_411.Parsetree.ppat_loc_stack; + Ast_411.Parsetree.ppat_attributes; + } -> + { + Ast_410.Parsetree.ppat_desc = copy_pattern_desc ppat_desc; + Ast_410.Parsetree.ppat_loc = copy_location ppat_loc; + Ast_410.Parsetree.ppat_loc_stack = copy_location_stack ppat_loc_stack; + Ast_410.Parsetree.ppat_attributes = copy_attributes ppat_attributes; + } + +and copy_pat x = copy_pattern x + +and copy_pattern_desc : + Ast_411.Parsetree.pattern_desc -> Ast_410.Parsetree.pattern_desc = function + | Ast_411.Parsetree.Ppat_any -> Ast_410.Parsetree.Ppat_any + | Ast_411.Parsetree.Ppat_var x0 -> + Ast_410.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) + | Ast_411.Parsetree.Ppat_alias (x0, x1) -> + Ast_410.Parsetree.Ppat_alias (copy_pattern x0, copy_loc (fun x -> x) x1) + | Ast_411.Parsetree.Ppat_constant x0 -> + Ast_410.Parsetree.Ppat_constant (copy_constant x0) + | Ast_411.Parsetree.Ppat_interval (x0, x1) -> + Ast_410.Parsetree.Ppat_interval (copy_constant x0, copy_constant x1) + | Ast_411.Parsetree.Ppat_tuple x0 -> + Ast_410.Parsetree.Ppat_tuple (List.map copy_pattern x0) + | Ast_411.Parsetree.Ppat_construct (x0, x1) -> + Ast_410.Parsetree.Ppat_construct + (copy_loc copy_Longident_t x0, Option.map copy_pattern x1) + | Ast_411.Parsetree.Ppat_variant (x0, x1) -> + Ast_410.Parsetree.Ppat_variant (copy_label x0, Option.map copy_pattern x1) + | Ast_411.Parsetree.Ppat_record (x0, x1) -> + Ast_410.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_411.Parsetree.Ppat_array x0 -> + Ast_410.Parsetree.Ppat_array (List.map copy_pattern x0) + | Ast_411.Parsetree.Ppat_or (x0, x1) -> + Ast_410.Parsetree.Ppat_or (copy_pattern x0, copy_pattern x1) + | Ast_411.Parsetree.Ppat_constraint (x0, x1) -> + Ast_410.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1) + | Ast_411.Parsetree.Ppat_type x0 -> + Ast_410.Parsetree.Ppat_type (copy_loc copy_Longident_t x0) + | Ast_411.Parsetree.Ppat_lazy x0 -> + Ast_410.Parsetree.Ppat_lazy (copy_pattern x0) + | Ast_411.Parsetree.Ppat_unpack x0 -> + Ast_410.Parsetree.Ppat_unpack + (copy_loc (fun x -> Option.map (fun x -> x) x) x0) + | Ast_411.Parsetree.Ppat_exception x0 -> + Ast_410.Parsetree.Ppat_exception (copy_pattern x0) + | Ast_411.Parsetree.Ppat_extension x0 -> + Ast_410.Parsetree.Ppat_extension (copy_extension x0) + | Ast_411.Parsetree.Ppat_open (x0, x1) -> + Ast_410.Parsetree.Ppat_open (copy_loc copy_Longident_t x0, copy_pattern x1) + +and copy_core_type : Ast_411.Parsetree.core_type -> Ast_410.Parsetree.core_type + = + fun { + Ast_411.Parsetree.ptyp_desc; + Ast_411.Parsetree.ptyp_loc; + Ast_411.Parsetree.ptyp_loc_stack; + Ast_411.Parsetree.ptyp_attributes; + } -> + { + Ast_410.Parsetree.ptyp_desc = copy_core_type_desc ptyp_desc; + Ast_410.Parsetree.ptyp_loc = copy_location ptyp_loc; + Ast_410.Parsetree.ptyp_loc_stack = copy_location_stack ptyp_loc_stack; + Ast_410.Parsetree.ptyp_attributes = copy_attributes ptyp_attributes; + } + +and copy_typ x = copy_core_type x + +and copy_location_stack : + Ast_411.Parsetree.location_stack -> Ast_410.Parsetree.location_stack = + fun x -> List.map copy_location x + +and copy_core_type_desc : + Ast_411.Parsetree.core_type_desc -> Ast_410.Parsetree.core_type_desc = + function + | Ast_411.Parsetree.Ptyp_any -> Ast_410.Parsetree.Ptyp_any + | Ast_411.Parsetree.Ptyp_var x0 -> Ast_410.Parsetree.Ptyp_var x0 + | Ast_411.Parsetree.Ptyp_arrow (x0, x1, x2) -> + Ast_410.Parsetree.Ptyp_arrow + (copy_arg_label x0, copy_core_type x1, copy_core_type x2) + | Ast_411.Parsetree.Ptyp_tuple x0 -> + Ast_410.Parsetree.Ptyp_tuple (List.map copy_core_type x0) + | Ast_411.Parsetree.Ptyp_constr (x0, x1) -> + Ast_410.Parsetree.Ptyp_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_411.Parsetree.Ptyp_object (x0, x1) -> + Ast_410.Parsetree.Ptyp_object + (List.map copy_object_field x0, copy_closed_flag x1) + | Ast_411.Parsetree.Ptyp_class (x0, x1) -> + Ast_410.Parsetree.Ptyp_class + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_411.Parsetree.Ptyp_alias (x0, x1) -> + Ast_410.Parsetree.Ptyp_alias (copy_core_type x0, x1) + | Ast_411.Parsetree.Ptyp_variant (x0, x1, x2) -> + Ast_410.Parsetree.Ptyp_variant + ( List.map copy_row_field x0, + copy_closed_flag x1, + Option.map (fun x -> List.map copy_label x) x2 ) + | Ast_411.Parsetree.Ptyp_poly (x0, x1) -> + Ast_410.Parsetree.Ptyp_poly + (List.map (fun x -> copy_loc (fun x -> x) x) x0, copy_core_type x1) + | Ast_411.Parsetree.Ptyp_package x0 -> + Ast_410.Parsetree.Ptyp_package (copy_package_type x0) + | Ast_411.Parsetree.Ptyp_extension x0 -> + Ast_410.Parsetree.Ptyp_extension (copy_extension x0) + +and copy_package_type : + Ast_411.Parsetree.package_type -> Ast_410.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_411.Parsetree.row_field -> Ast_410.Parsetree.row_field + = + fun { + Ast_411.Parsetree.prf_desc; + Ast_411.Parsetree.prf_loc; + Ast_411.Parsetree.prf_attributes; + } -> + { + Ast_410.Parsetree.prf_desc = copy_row_field_desc prf_desc; + Ast_410.Parsetree.prf_loc = copy_location prf_loc; + Ast_410.Parsetree.prf_attributes = copy_attributes prf_attributes; + } + +and copy_row_field_desc : + Ast_411.Parsetree.row_field_desc -> Ast_410.Parsetree.row_field_desc = + function + | Ast_411.Parsetree.Rtag (x0, x1, x2) -> + Ast_410.Parsetree.Rtag + (copy_loc copy_label x0, x1, List.map copy_core_type x2) + | Ast_411.Parsetree.Rinherit x0 -> + Ast_410.Parsetree.Rinherit (copy_core_type x0) + +and copy_object_field : + Ast_411.Parsetree.object_field -> Ast_410.Parsetree.object_field = + fun { + Ast_411.Parsetree.pof_desc; + Ast_411.Parsetree.pof_loc; + Ast_411.Parsetree.pof_attributes; + } -> + { + Ast_410.Parsetree.pof_desc = copy_object_field_desc pof_desc; + Ast_410.Parsetree.pof_loc = copy_location pof_loc; + Ast_410.Parsetree.pof_attributes = copy_attributes pof_attributes; + } + +and copy_attributes : + Ast_411.Parsetree.attributes -> Ast_410.Parsetree.attributes = + fun x -> List.map copy_attribute x + +and copy_attribute : Ast_411.Parsetree.attribute -> Ast_410.Parsetree.attribute + = + fun { + Ast_411.Parsetree.attr_name; + Ast_411.Parsetree.attr_payload; + Ast_411.Parsetree.attr_loc; + } -> + { + Ast_410.Parsetree.attr_name = copy_loc (fun x -> x) attr_name; + Ast_410.Parsetree.attr_payload = copy_payload attr_payload; + Ast_410.Parsetree.attr_loc = copy_location attr_loc; + } + +and copy_payload : Ast_411.Parsetree.payload -> Ast_410.Parsetree.payload = + function + | Ast_411.Parsetree.PStr x0 -> Ast_410.Parsetree.PStr (copy_structure x0) + | Ast_411.Parsetree.PSig x0 -> Ast_410.Parsetree.PSig (copy_signature x0) + | Ast_411.Parsetree.PTyp x0 -> Ast_410.Parsetree.PTyp (copy_core_type x0) + | Ast_411.Parsetree.PPat (x0, x1) -> + Ast_410.Parsetree.PPat (copy_pattern x0, Option.map copy_expression x1) + +and copy_structure : Ast_411.Parsetree.structure -> Ast_410.Parsetree.structure + = + fun x -> List.map copy_structure_item x + +and copy_structure_item : + Ast_411.Parsetree.structure_item -> Ast_410.Parsetree.structure_item = + fun { Ast_411.Parsetree.pstr_desc; Ast_411.Parsetree.pstr_loc } -> + { + Ast_410.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc; + Ast_410.Parsetree.pstr_loc = copy_location pstr_loc; + } + +and copy_structure_item_desc : + Ast_411.Parsetree.structure_item_desc -> + Ast_410.Parsetree.structure_item_desc = function + | Ast_411.Parsetree.Pstr_eval (x0, x1) -> + Ast_410.Parsetree.Pstr_eval (copy_expression x0, copy_attributes x1) + | Ast_411.Parsetree.Pstr_value (x0, x1) -> + Ast_410.Parsetree.Pstr_value + (copy_rec_flag x0, List.map copy_value_binding x1) + | Ast_411.Parsetree.Pstr_primitive x0 -> + Ast_410.Parsetree.Pstr_primitive (copy_value_description x0) + | Ast_411.Parsetree.Pstr_type (x0, x1) -> + Ast_410.Parsetree.Pstr_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | Ast_411.Parsetree.Pstr_typext x0 -> + Ast_410.Parsetree.Pstr_typext (copy_type_extension x0) + | Ast_411.Parsetree.Pstr_exception x0 -> + Ast_410.Parsetree.Pstr_exception (copy_type_exception x0) + | Ast_411.Parsetree.Pstr_module x0 -> + Ast_410.Parsetree.Pstr_module (copy_module_binding x0) + | Ast_411.Parsetree.Pstr_recmodule x0 -> + Ast_410.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) + | Ast_411.Parsetree.Pstr_modtype x0 -> + Ast_410.Parsetree.Pstr_modtype (copy_module_type_declaration x0) + | Ast_411.Parsetree.Pstr_open x0 -> + Ast_410.Parsetree.Pstr_open (copy_open_declaration x0) + | Ast_411.Parsetree.Pstr_class x0 -> + Ast_410.Parsetree.Pstr_class (List.map copy_class_declaration x0) + | Ast_411.Parsetree.Pstr_class_type x0 -> + Ast_410.Parsetree.Pstr_class_type + (List.map copy_class_type_declaration x0) + | Ast_411.Parsetree.Pstr_include x0 -> + Ast_410.Parsetree.Pstr_include (copy_include_declaration x0) + | Ast_411.Parsetree.Pstr_attribute x0 -> + Ast_410.Parsetree.Pstr_attribute (copy_attribute x0) + | Ast_411.Parsetree.Pstr_extension (x0, x1) -> + Ast_410.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1) + +and copy_include_declaration : + Ast_411.Parsetree.include_declaration -> + Ast_410.Parsetree.include_declaration = + fun x -> copy_include_infos copy_module_expr x + +and copy_class_declaration : + Ast_411.Parsetree.class_declaration -> Ast_410.Parsetree.class_declaration = + fun x -> copy_class_infos copy_class_expr x + +and copy_class_expr : + Ast_411.Parsetree.class_expr -> Ast_410.Parsetree.class_expr = + fun { + Ast_411.Parsetree.pcl_desc; + Ast_411.Parsetree.pcl_loc; + Ast_411.Parsetree.pcl_attributes; + } -> + { + Ast_410.Parsetree.pcl_desc = copy_class_expr_desc pcl_desc; + Ast_410.Parsetree.pcl_loc = copy_location pcl_loc; + Ast_410.Parsetree.pcl_attributes = copy_attributes pcl_attributes; + } + +and copy_class_expr_desc : + Ast_411.Parsetree.class_expr_desc -> Ast_410.Parsetree.class_expr_desc = + function + | Ast_411.Parsetree.Pcl_constr (x0, x1) -> + Ast_410.Parsetree.Pcl_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_411.Parsetree.Pcl_structure x0 -> + Ast_410.Parsetree.Pcl_structure (copy_class_structure x0) + | Ast_411.Parsetree.Pcl_fun (x0, x1, x2, x3) -> + Ast_410.Parsetree.Pcl_fun + ( copy_arg_label x0, + Option.map copy_expression x1, + copy_pattern x2, + copy_class_expr x3 ) + | Ast_411.Parsetree.Pcl_apply (x0, x1) -> + Ast_410.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_411.Parsetree.Pcl_let (x0, x1, x2) -> + Ast_410.Parsetree.Pcl_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_class_expr x2) + | Ast_411.Parsetree.Pcl_constraint (x0, x1) -> + Ast_410.Parsetree.Pcl_constraint (copy_class_expr x0, copy_class_type x1) + | Ast_411.Parsetree.Pcl_extension x0 -> + Ast_410.Parsetree.Pcl_extension (copy_extension x0) + | Ast_411.Parsetree.Pcl_open (x0, x1) -> + Ast_410.Parsetree.Pcl_open (copy_open_description x0, copy_class_expr x1) + +and copy_class_structure : + Ast_411.Parsetree.class_structure -> Ast_410.Parsetree.class_structure = + fun { Ast_411.Parsetree.pcstr_self; Ast_411.Parsetree.pcstr_fields } -> + { + Ast_410.Parsetree.pcstr_self = copy_pattern pcstr_self; + Ast_410.Parsetree.pcstr_fields = List.map copy_class_field pcstr_fields; + } + +and copy_class_field : + Ast_411.Parsetree.class_field -> Ast_410.Parsetree.class_field = + fun { + Ast_411.Parsetree.pcf_desc; + Ast_411.Parsetree.pcf_loc; + Ast_411.Parsetree.pcf_attributes; + } -> + { + Ast_410.Parsetree.pcf_desc = copy_class_field_desc pcf_desc; + Ast_410.Parsetree.pcf_loc = copy_location pcf_loc; + Ast_410.Parsetree.pcf_attributes = copy_attributes pcf_attributes; + } + +and copy_class_field_desc : + Ast_411.Parsetree.class_field_desc -> Ast_410.Parsetree.class_field_desc = + function + | Ast_411.Parsetree.Pcf_inherit (x0, x1, x2) -> + Ast_410.Parsetree.Pcf_inherit + ( copy_override_flag x0, + copy_class_expr x1, + Option.map (fun x -> copy_loc (fun x -> x) x) x2 ) + | Ast_411.Parsetree.Pcf_val x0 -> + Ast_410.Parsetree.Pcf_val + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_mutable_flag x1, copy_class_field_kind x2)) + | Ast_411.Parsetree.Pcf_method x0 -> + Ast_410.Parsetree.Pcf_method + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_private_flag x1, copy_class_field_kind x2)) + | Ast_411.Parsetree.Pcf_constraint x0 -> + Ast_410.Parsetree.Pcf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | Ast_411.Parsetree.Pcf_initializer x0 -> + Ast_410.Parsetree.Pcf_initializer (copy_expression x0) + | Ast_411.Parsetree.Pcf_attribute x0 -> + Ast_410.Parsetree.Pcf_attribute (copy_attribute x0) + | Ast_411.Parsetree.Pcf_extension x0 -> + Ast_410.Parsetree.Pcf_extension (copy_extension x0) + +and copy_class_field_kind : + Ast_411.Parsetree.class_field_kind -> Ast_410.Parsetree.class_field_kind = + function + | Ast_411.Parsetree.Cfk_virtual x0 -> + Ast_410.Parsetree.Cfk_virtual (copy_core_type x0) + | Ast_411.Parsetree.Cfk_concrete (x0, x1) -> + Ast_410.Parsetree.Cfk_concrete (copy_override_flag x0, copy_expression x1) + +and copy_open_declaration : + Ast_411.Parsetree.open_declaration -> Ast_410.Parsetree.open_declaration = + fun x -> copy_open_infos copy_module_expr x + +and copy_module_binding : + Ast_411.Parsetree.module_binding -> Ast_410.Parsetree.module_binding = + fun { + Ast_411.Parsetree.pmb_name; + Ast_411.Parsetree.pmb_expr; + Ast_411.Parsetree.pmb_attributes; + Ast_411.Parsetree.pmb_loc; + } -> + { + Ast_410.Parsetree.pmb_name = + copy_loc (fun x -> Option.map (fun x -> x) x) pmb_name; + Ast_410.Parsetree.pmb_expr = copy_module_expr pmb_expr; + Ast_410.Parsetree.pmb_attributes = copy_attributes pmb_attributes; + Ast_410.Parsetree.pmb_loc = copy_location pmb_loc; + } + +and copy_module_expr : + Ast_411.Parsetree.module_expr -> Ast_410.Parsetree.module_expr = + fun { + Ast_411.Parsetree.pmod_desc; + Ast_411.Parsetree.pmod_loc; + Ast_411.Parsetree.pmod_attributes; + } -> + { + Ast_410.Parsetree.pmod_desc = copy_module_expr_desc pmod_desc; + Ast_410.Parsetree.pmod_loc = copy_location pmod_loc; + Ast_410.Parsetree.pmod_attributes = copy_attributes pmod_attributes; + } + +and copy_module_expr_desc : + Ast_411.Parsetree.module_expr_desc -> Ast_410.Parsetree.module_expr_desc = + function + | Ast_411.Parsetree.Pmod_ident x0 -> + Ast_410.Parsetree.Pmod_ident (copy_loc copy_Longident_t x0) + | Ast_411.Parsetree.Pmod_structure x0 -> + Ast_410.Parsetree.Pmod_structure (copy_structure x0) + | Ast_411.Parsetree.Pmod_functor (x0, x1) -> + Ast_410.Parsetree.Pmod_functor + (copy_functor_parameter x0, copy_module_expr x1) + | Ast_411.Parsetree.Pmod_apply (x0, x1) -> + Ast_410.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) + | Ast_411.Parsetree.Pmod_constraint (x0, x1) -> + Ast_410.Parsetree.Pmod_constraint + (copy_module_expr x0, copy_module_type x1) + | Ast_411.Parsetree.Pmod_unpack x0 -> + Ast_410.Parsetree.Pmod_unpack (copy_expression x0) + | Ast_411.Parsetree.Pmod_extension x0 -> + Ast_410.Parsetree.Pmod_extension (copy_extension x0) + +and copy_functor_parameter : + Ast_411.Parsetree.functor_parameter -> Ast_410.Parsetree.functor_parameter = + function + | Ast_411.Parsetree.Unit -> Ast_410.Parsetree.Unit + | Ast_411.Parsetree.Named (x0, x1) -> + Ast_410.Parsetree.Named + (copy_loc (fun x -> Option.map (fun x -> x) x) x0, copy_module_type x1) + +and copy_module_type : + Ast_411.Parsetree.module_type -> Ast_410.Parsetree.module_type = + fun { + Ast_411.Parsetree.pmty_desc; + Ast_411.Parsetree.pmty_loc; + Ast_411.Parsetree.pmty_attributes; + } -> + { + Ast_410.Parsetree.pmty_desc = copy_module_type_desc pmty_desc; + Ast_410.Parsetree.pmty_loc = copy_location pmty_loc; + Ast_410.Parsetree.pmty_attributes = copy_attributes pmty_attributes; + } + +and copy_module_type_desc : + Ast_411.Parsetree.module_type_desc -> Ast_410.Parsetree.module_type_desc = + function + | Ast_411.Parsetree.Pmty_ident x0 -> + Ast_410.Parsetree.Pmty_ident (copy_loc copy_Longident_t x0) + | Ast_411.Parsetree.Pmty_signature x0 -> + Ast_410.Parsetree.Pmty_signature (copy_signature x0) + | Ast_411.Parsetree.Pmty_functor (x0, x1) -> + Ast_410.Parsetree.Pmty_functor + (copy_functor_parameter x0, copy_module_type x1) + | Ast_411.Parsetree.Pmty_with (x0, x1) -> + Ast_410.Parsetree.Pmty_with + (copy_module_type x0, List.map copy_with_constraint x1) + | Ast_411.Parsetree.Pmty_typeof x0 -> + Ast_410.Parsetree.Pmty_typeof (copy_module_expr x0) + | Ast_411.Parsetree.Pmty_extension x0 -> + Ast_410.Parsetree.Pmty_extension (copy_extension x0) + | Ast_411.Parsetree.Pmty_alias x0 -> + Ast_410.Parsetree.Pmty_alias (copy_loc copy_Longident_t x0) + +and copy_with_constraint : + Ast_411.Parsetree.with_constraint -> Ast_410.Parsetree.with_constraint = + function + | Ast_411.Parsetree.Pwith_type (x0, x1) -> + Ast_410.Parsetree.Pwith_type + (copy_loc copy_Longident_t x0, copy_type_declaration x1) + | Ast_411.Parsetree.Pwith_module (x0, x1) -> + Ast_410.Parsetree.Pwith_module + (copy_loc copy_Longident_t x0, copy_loc copy_Longident_t x1) + | Ast_411.Parsetree.Pwith_typesubst (x0, x1) -> + Ast_410.Parsetree.Pwith_typesubst + (copy_loc copy_Longident_t x0, copy_type_declaration x1) + | Ast_411.Parsetree.Pwith_modsubst (x0, x1) -> + Ast_410.Parsetree.Pwith_modsubst + (copy_loc copy_Longident_t x0, copy_loc copy_Longident_t x1) + +and copy_signature : Ast_411.Parsetree.signature -> Ast_410.Parsetree.signature + = + fun x -> List.map copy_signature_item x + +and copy_signature_item : + Ast_411.Parsetree.signature_item -> Ast_410.Parsetree.signature_item = + fun { Ast_411.Parsetree.psig_desc; Ast_411.Parsetree.psig_loc } -> + { + Ast_410.Parsetree.psig_desc = copy_signature_item_desc psig_desc; + Ast_410.Parsetree.psig_loc = copy_location psig_loc; + } + +and copy_signature_item_desc : + Ast_411.Parsetree.signature_item_desc -> + Ast_410.Parsetree.signature_item_desc = function + | Ast_411.Parsetree.Psig_value x0 -> + Ast_410.Parsetree.Psig_value (copy_value_description x0) + | Ast_411.Parsetree.Psig_type (x0, x1) -> + Ast_410.Parsetree.Psig_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | Ast_411.Parsetree.Psig_typesubst x0 -> + Ast_410.Parsetree.Psig_typesubst (List.map copy_type_declaration x0) + | Ast_411.Parsetree.Psig_typext x0 -> + Ast_410.Parsetree.Psig_typext (copy_type_extension x0) + | Ast_411.Parsetree.Psig_exception x0 -> + Ast_410.Parsetree.Psig_exception (copy_type_exception x0) + | Ast_411.Parsetree.Psig_module x0 -> + Ast_410.Parsetree.Psig_module (copy_module_declaration x0) + | Ast_411.Parsetree.Psig_modsubst x0 -> + Ast_410.Parsetree.Psig_modsubst (copy_module_substitution x0) + | Ast_411.Parsetree.Psig_recmodule x0 -> + Ast_410.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) + | Ast_411.Parsetree.Psig_modtype x0 -> + Ast_410.Parsetree.Psig_modtype (copy_module_type_declaration x0) + | Ast_411.Parsetree.Psig_open x0 -> + Ast_410.Parsetree.Psig_open (copy_open_description x0) + | Ast_411.Parsetree.Psig_include x0 -> + Ast_410.Parsetree.Psig_include (copy_include_description x0) + | Ast_411.Parsetree.Psig_class x0 -> + Ast_410.Parsetree.Psig_class (List.map copy_class_description x0) + | Ast_411.Parsetree.Psig_class_type x0 -> + Ast_410.Parsetree.Psig_class_type + (List.map copy_class_type_declaration x0) + | Ast_411.Parsetree.Psig_attribute x0 -> + Ast_410.Parsetree.Psig_attribute (copy_attribute x0) + | Ast_411.Parsetree.Psig_extension (x0, x1) -> + Ast_410.Parsetree.Psig_extension (copy_extension x0, copy_attributes x1) + +and copy_class_type_declaration : + Ast_411.Parsetree.class_type_declaration -> + Ast_410.Parsetree.class_type_declaration = + fun x -> copy_class_infos copy_class_type x + +and copy_class_description : + Ast_411.Parsetree.class_description -> Ast_410.Parsetree.class_description = + fun x -> copy_class_infos copy_class_type x + +and copy_class_type : + Ast_411.Parsetree.class_type -> Ast_410.Parsetree.class_type = + fun { + Ast_411.Parsetree.pcty_desc; + Ast_411.Parsetree.pcty_loc; + Ast_411.Parsetree.pcty_attributes; + } -> + { + Ast_410.Parsetree.pcty_desc = copy_class_type_desc pcty_desc; + Ast_410.Parsetree.pcty_loc = copy_location pcty_loc; + Ast_410.Parsetree.pcty_attributes = copy_attributes pcty_attributes; + } + +and copy_class_type_desc : + Ast_411.Parsetree.class_type_desc -> Ast_410.Parsetree.class_type_desc = + function + | Ast_411.Parsetree.Pcty_constr (x0, x1) -> + Ast_410.Parsetree.Pcty_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_411.Parsetree.Pcty_signature x0 -> + Ast_410.Parsetree.Pcty_signature (copy_class_signature x0) + | Ast_411.Parsetree.Pcty_arrow (x0, x1, x2) -> + Ast_410.Parsetree.Pcty_arrow + (copy_arg_label x0, copy_core_type x1, copy_class_type x2) + | Ast_411.Parsetree.Pcty_extension x0 -> + Ast_410.Parsetree.Pcty_extension (copy_extension x0) + | Ast_411.Parsetree.Pcty_open (x0, x1) -> + Ast_410.Parsetree.Pcty_open (copy_open_description x0, copy_class_type x1) + +and copy_class_signature : + Ast_411.Parsetree.class_signature -> Ast_410.Parsetree.class_signature = + fun { Ast_411.Parsetree.pcsig_self; Ast_411.Parsetree.pcsig_fields } -> + { + Ast_410.Parsetree.pcsig_self = copy_core_type pcsig_self; + Ast_410.Parsetree.pcsig_fields = List.map copy_class_type_field pcsig_fields; + } + +and copy_class_type_field : + Ast_411.Parsetree.class_type_field -> Ast_410.Parsetree.class_type_field = + fun { + Ast_411.Parsetree.pctf_desc; + Ast_411.Parsetree.pctf_loc; + Ast_411.Parsetree.pctf_attributes; + } -> + { + Ast_410.Parsetree.pctf_desc = copy_class_type_field_desc pctf_desc; + Ast_410.Parsetree.pctf_loc = copy_location pctf_loc; + Ast_410.Parsetree.pctf_attributes = copy_attributes pctf_attributes; + } + +and copy_class_type_field_desc : + Ast_411.Parsetree.class_type_field_desc -> + Ast_410.Parsetree.class_type_field_desc = function + | Ast_411.Parsetree.Pctf_inherit x0 -> + Ast_410.Parsetree.Pctf_inherit (copy_class_type x0) + | Ast_411.Parsetree.Pctf_val x0 -> + Ast_410.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_411.Parsetree.Pctf_method x0 -> + Ast_410.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_411.Parsetree.Pctf_constraint x0 -> + Ast_410.Parsetree.Pctf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | Ast_411.Parsetree.Pctf_attribute x0 -> + Ast_410.Parsetree.Pctf_attribute (copy_attribute x0) + | Ast_411.Parsetree.Pctf_extension x0 -> + Ast_410.Parsetree.Pctf_extension (copy_extension x0) + +and copy_extension : Ast_411.Parsetree.extension -> Ast_410.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_411.Parsetree.class_infos -> + 'g0 Ast_410.Parsetree.class_infos = + fun f0 + { + Ast_411.Parsetree.pci_virt; + Ast_411.Parsetree.pci_params; + Ast_411.Parsetree.pci_name; + Ast_411.Parsetree.pci_expr; + Ast_411.Parsetree.pci_loc; + Ast_411.Parsetree.pci_attributes; + } -> + { + Ast_410.Parsetree.pci_virt = copy_virtual_flag pci_virt; + Ast_410.Parsetree.pci_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + pci_params; + Ast_410.Parsetree.pci_name = copy_loc (fun x -> x) pci_name; + Ast_410.Parsetree.pci_expr = f0 pci_expr; + Ast_410.Parsetree.pci_loc = copy_location pci_loc; + Ast_410.Parsetree.pci_attributes = copy_attributes pci_attributes; + } + +and copy_virtual_flag : + Ast_411.Asttypes.virtual_flag -> Ast_410.Asttypes.virtual_flag = function + | Ast_411.Asttypes.Virtual -> Ast_410.Asttypes.Virtual + | Ast_411.Asttypes.Concrete -> Ast_410.Asttypes.Concrete + +and copy_include_description : + Ast_411.Parsetree.include_description -> + Ast_410.Parsetree.include_description = + fun x -> copy_include_infos copy_module_type x + +and copy_include_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 Ast_411.Parsetree.include_infos -> + 'g0 Ast_410.Parsetree.include_infos = + fun f0 + { + Ast_411.Parsetree.pincl_mod; + Ast_411.Parsetree.pincl_loc; + Ast_411.Parsetree.pincl_attributes; + } -> + { + Ast_410.Parsetree.pincl_mod = f0 pincl_mod; + Ast_410.Parsetree.pincl_loc = copy_location pincl_loc; + Ast_410.Parsetree.pincl_attributes = copy_attributes pincl_attributes; + } + +and copy_open_description : + Ast_411.Parsetree.open_description -> Ast_410.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_411.Parsetree.open_infos -> + 'g0 Ast_410.Parsetree.open_infos = + fun f0 + { + Ast_411.Parsetree.popen_expr; + Ast_411.Parsetree.popen_override; + Ast_411.Parsetree.popen_loc; + Ast_411.Parsetree.popen_attributes; + } -> + { + Ast_410.Parsetree.popen_expr = f0 popen_expr; + Ast_410.Parsetree.popen_override = copy_override_flag popen_override; + Ast_410.Parsetree.popen_loc = copy_location popen_loc; + Ast_410.Parsetree.popen_attributes = copy_attributes popen_attributes; + } + +and copy_override_flag : + Ast_411.Asttypes.override_flag -> Ast_410.Asttypes.override_flag = function + | Ast_411.Asttypes.Override -> Ast_410.Asttypes.Override + | Ast_411.Asttypes.Fresh -> Ast_410.Asttypes.Fresh + +and copy_module_type_declaration : + Ast_411.Parsetree.module_type_declaration -> + Ast_410.Parsetree.module_type_declaration = + fun { + Ast_411.Parsetree.pmtd_name; + Ast_411.Parsetree.pmtd_type; + Ast_411.Parsetree.pmtd_attributes; + Ast_411.Parsetree.pmtd_loc; + } -> + { + Ast_410.Parsetree.pmtd_name = copy_loc (fun x -> x) pmtd_name; + Ast_410.Parsetree.pmtd_type = Option.map copy_module_type pmtd_type; + Ast_410.Parsetree.pmtd_attributes = copy_attributes pmtd_attributes; + Ast_410.Parsetree.pmtd_loc = copy_location pmtd_loc; + } + +and copy_module_substitution : + Ast_411.Parsetree.module_substitution -> + Ast_410.Parsetree.module_substitution = + fun { + Ast_411.Parsetree.pms_name; + Ast_411.Parsetree.pms_manifest; + Ast_411.Parsetree.pms_attributes; + Ast_411.Parsetree.pms_loc; + } -> + { + Ast_410.Parsetree.pms_name = copy_loc (fun x -> x) pms_name; + Ast_410.Parsetree.pms_manifest = copy_loc copy_Longident_t pms_manifest; + Ast_410.Parsetree.pms_attributes = copy_attributes pms_attributes; + Ast_410.Parsetree.pms_loc = copy_location pms_loc; + } + +and copy_module_declaration : + Ast_411.Parsetree.module_declaration -> Ast_410.Parsetree.module_declaration + = + fun { + Ast_411.Parsetree.pmd_name; + Ast_411.Parsetree.pmd_type; + Ast_411.Parsetree.pmd_attributes; + Ast_411.Parsetree.pmd_loc; + } -> + { + Ast_410.Parsetree.pmd_name = + copy_loc (fun x -> Option.map (fun x -> x) x) pmd_name; + Ast_410.Parsetree.pmd_type = copy_module_type pmd_type; + Ast_410.Parsetree.pmd_attributes = copy_attributes pmd_attributes; + Ast_410.Parsetree.pmd_loc = copy_location pmd_loc; + } + +and copy_type_exception : + Ast_411.Parsetree.type_exception -> Ast_410.Parsetree.type_exception = + fun { + Ast_411.Parsetree.ptyexn_constructor; + Ast_411.Parsetree.ptyexn_loc; + Ast_411.Parsetree.ptyexn_attributes; + } -> + { + Ast_410.Parsetree.ptyexn_constructor = + copy_extension_constructor ptyexn_constructor; + Ast_410.Parsetree.ptyexn_loc = copy_location ptyexn_loc; + Ast_410.Parsetree.ptyexn_attributes = copy_attributes ptyexn_attributes; + } + +and copy_type_extension : + Ast_411.Parsetree.type_extension -> Ast_410.Parsetree.type_extension = + fun { + Ast_411.Parsetree.ptyext_path; + Ast_411.Parsetree.ptyext_params; + Ast_411.Parsetree.ptyext_constructors; + Ast_411.Parsetree.ptyext_private; + Ast_411.Parsetree.ptyext_loc; + Ast_411.Parsetree.ptyext_attributes; + } -> + { + Ast_410.Parsetree.ptyext_path = copy_loc copy_Longident_t ptyext_path; + Ast_410.Parsetree.ptyext_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptyext_params; + Ast_410.Parsetree.ptyext_constructors = + List.map copy_extension_constructor ptyext_constructors; + Ast_410.Parsetree.ptyext_private = copy_private_flag ptyext_private; + Ast_410.Parsetree.ptyext_loc = copy_location ptyext_loc; + Ast_410.Parsetree.ptyext_attributes = copy_attributes ptyext_attributes; + } + +and copy_extension_constructor : + Ast_411.Parsetree.extension_constructor -> + Ast_410.Parsetree.extension_constructor = + fun { + Ast_411.Parsetree.pext_name; + Ast_411.Parsetree.pext_kind; + Ast_411.Parsetree.pext_loc; + Ast_411.Parsetree.pext_attributes; + } -> + { + Ast_410.Parsetree.pext_name = copy_loc (fun x -> x) pext_name; + Ast_410.Parsetree.pext_kind = copy_extension_constructor_kind pext_kind; + Ast_410.Parsetree.pext_loc = copy_location pext_loc; + Ast_410.Parsetree.pext_attributes = copy_attributes pext_attributes; + } + +and copy_extension_constructor_kind : + Ast_411.Parsetree.extension_constructor_kind -> + Ast_410.Parsetree.extension_constructor_kind = function + | Ast_411.Parsetree.Pext_decl (x0, x1) -> + Ast_410.Parsetree.Pext_decl + (copy_constructor_arguments x0, Option.map copy_core_type x1) + | Ast_411.Parsetree.Pext_rebind x0 -> + Ast_410.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0) + +and copy_type_declaration : + Ast_411.Parsetree.type_declaration -> Ast_410.Parsetree.type_declaration = + fun { + Ast_411.Parsetree.ptype_name; + Ast_411.Parsetree.ptype_params; + Ast_411.Parsetree.ptype_cstrs; + Ast_411.Parsetree.ptype_kind; + Ast_411.Parsetree.ptype_private; + Ast_411.Parsetree.ptype_manifest; + Ast_411.Parsetree.ptype_attributes; + Ast_411.Parsetree.ptype_loc; + } -> + { + Ast_410.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name; + Ast_410.Parsetree.ptype_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, copy_variance x1)) + ptype_params; + Ast_410.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_410.Parsetree.ptype_kind = copy_type_kind ptype_kind; + Ast_410.Parsetree.ptype_private = copy_private_flag ptype_private; + Ast_410.Parsetree.ptype_manifest = Option.map copy_core_type ptype_manifest; + Ast_410.Parsetree.ptype_attributes = copy_attributes ptype_attributes; + Ast_410.Parsetree.ptype_loc = copy_location ptype_loc; + } + +and copy_private_flag : + Ast_411.Asttypes.private_flag -> Ast_410.Asttypes.private_flag = function + | Ast_411.Asttypes.Private -> Ast_410.Asttypes.Private + | Ast_411.Asttypes.Public -> Ast_410.Asttypes.Public + +and copy_type_kind : Ast_411.Parsetree.type_kind -> Ast_410.Parsetree.type_kind + = function + | Ast_411.Parsetree.Ptype_abstract -> Ast_410.Parsetree.Ptype_abstract + | Ast_411.Parsetree.Ptype_variant x0 -> + Ast_410.Parsetree.Ptype_variant (List.map copy_constructor_declaration x0) + | Ast_411.Parsetree.Ptype_record x0 -> + Ast_410.Parsetree.Ptype_record (List.map copy_label_declaration x0) + | Ast_411.Parsetree.Ptype_open -> Ast_410.Parsetree.Ptype_open + +and copy_constructor_declaration : + Ast_411.Parsetree.constructor_declaration -> + Ast_410.Parsetree.constructor_declaration = + fun { + Ast_411.Parsetree.pcd_name; + Ast_411.Parsetree.pcd_args; + Ast_411.Parsetree.pcd_res; + Ast_411.Parsetree.pcd_loc; + Ast_411.Parsetree.pcd_attributes; + } -> + { + Ast_410.Parsetree.pcd_name = copy_loc (fun x -> x) pcd_name; + Ast_410.Parsetree.pcd_args = copy_constructor_arguments pcd_args; + Ast_410.Parsetree.pcd_res = Option.map copy_core_type pcd_res; + Ast_410.Parsetree.pcd_loc = copy_location pcd_loc; + Ast_410.Parsetree.pcd_attributes = copy_attributes pcd_attributes; + } + +and copy_constructor_arguments : + Ast_411.Parsetree.constructor_arguments -> + Ast_410.Parsetree.constructor_arguments = function + | Ast_411.Parsetree.Pcstr_tuple x0 -> + Ast_410.Parsetree.Pcstr_tuple (List.map copy_core_type x0) + | Ast_411.Parsetree.Pcstr_record x0 -> + Ast_410.Parsetree.Pcstr_record (List.map copy_label_declaration x0) + +and copy_label_declaration : + Ast_411.Parsetree.label_declaration -> Ast_410.Parsetree.label_declaration = + fun { + Ast_411.Parsetree.pld_name; + Ast_411.Parsetree.pld_mutable; + Ast_411.Parsetree.pld_type; + Ast_411.Parsetree.pld_loc; + Ast_411.Parsetree.pld_attributes; + } -> + { + Ast_410.Parsetree.pld_name = copy_loc (fun x -> x) pld_name; + Ast_410.Parsetree.pld_mutable = copy_mutable_flag pld_mutable; + Ast_410.Parsetree.pld_type = copy_core_type pld_type; + Ast_410.Parsetree.pld_loc = copy_location pld_loc; + Ast_410.Parsetree.pld_attributes = copy_attributes pld_attributes; + } + +and copy_mutable_flag : + Ast_411.Asttypes.mutable_flag -> Ast_410.Asttypes.mutable_flag = function + | Ast_411.Asttypes.Immutable -> Ast_410.Asttypes.Immutable + | Ast_411.Asttypes.Mutable -> Ast_410.Asttypes.Mutable + +and copy_variance : Ast_411.Asttypes.variance -> Ast_410.Asttypes.variance = + function + | Ast_411.Asttypes.Covariant -> Ast_410.Asttypes.Covariant + | Ast_411.Asttypes.Contravariant -> Ast_410.Asttypes.Contravariant + | Ast_411.Asttypes.Invariant -> Ast_410.Asttypes.Invariant + +and copy_value_description : + Ast_411.Parsetree.value_description -> Ast_410.Parsetree.value_description = + fun { + Ast_411.Parsetree.pval_name; + Ast_411.Parsetree.pval_type; + Ast_411.Parsetree.pval_prim; + Ast_411.Parsetree.pval_attributes; + Ast_411.Parsetree.pval_loc; + } -> + { + Ast_410.Parsetree.pval_name = copy_loc (fun x -> x) pval_name; + Ast_410.Parsetree.pval_type = copy_core_type pval_type; + Ast_410.Parsetree.pval_prim = List.map (fun x -> x) pval_prim; + Ast_410.Parsetree.pval_attributes = copy_attributes pval_attributes; + Ast_410.Parsetree.pval_loc = copy_location pval_loc; + } + +and copy_object_field_desc : + Ast_411.Parsetree.object_field_desc -> Ast_410.Parsetree.object_field_desc = + function + | Ast_411.Parsetree.Otag (x0, x1) -> + Ast_410.Parsetree.Otag (copy_loc copy_label x0, copy_core_type x1) + | Ast_411.Parsetree.Oinherit x0 -> + Ast_410.Parsetree.Oinherit (copy_core_type x0) + +and copy_arg_label : Ast_411.Asttypes.arg_label -> Ast_410.Asttypes.arg_label = + function + | Ast_411.Asttypes.Nolabel -> Ast_410.Asttypes.Nolabel + | Ast_411.Asttypes.Labelled x0 -> Ast_410.Asttypes.Labelled x0 + | Ast_411.Asttypes.Optional x0 -> Ast_410.Asttypes.Optional x0 + +and copy_closed_flag : + Ast_411.Asttypes.closed_flag -> Ast_410.Asttypes.closed_flag = function + | Ast_411.Asttypes.Closed -> Ast_410.Asttypes.Closed + | Ast_411.Asttypes.Open -> Ast_410.Asttypes.Open + +and copy_label : Ast_411.Asttypes.label -> Ast_410.Asttypes.label = fun x -> x + +and copy_rec_flag : Ast_411.Asttypes.rec_flag -> Ast_410.Asttypes.rec_flag = + function + | Ast_411.Asttypes.Nonrecursive -> Ast_410.Asttypes.Nonrecursive + | Ast_411.Asttypes.Recursive -> Ast_410.Asttypes.Recursive + +and copy_constant : Ast_411.Parsetree.constant -> Ast_410.Parsetree.constant = + function + | Ast_411.Parsetree.Pconst_integer (x0, x1) -> + Ast_410.Parsetree.Pconst_integer (x0, Option.map (fun x -> x) x1) + | Ast_411.Parsetree.Pconst_char x0 -> Ast_410.Parsetree.Pconst_char x0 + | Ast_411.Parsetree.Pconst_string (x0, _, x2) -> + Ast_410.Parsetree.Pconst_string (x0, Option.map (fun x -> x) x2) + | Ast_411.Parsetree.Pconst_float (x0, x1) -> + Ast_410.Parsetree.Pconst_float (x0, Option.map (fun x -> x) x1) + +and copy_Longident_t : Longident.t -> Longident.t = fun x -> x + +and copy_loc : + 'f0 'g0. + ('f0 -> 'g0) -> 'f0 Ast_411.Asttypes.loc -> 'g0 Ast_410.Asttypes.loc = + fun f0 { Ast_411.Asttypes.txt; Ast_411.Asttypes.loc } -> + { Ast_410.Asttypes.txt = f0 txt; Ast_410.Asttypes.loc = copy_location loc } + +and copy_location : Location.t -> Location.t = fun x -> x diff -Nru ppxlib-0.15.0/astlib/migrate_411_412.ml ppxlib-0.24.0/astlib/migrate_411_412.ml --- ppxlib-0.15.0/astlib/migrate_411_412.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/migrate_411_412.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1187 @@ +open Stdlib0 +module From = Ast_411 +module To = Ast_412 + +let rec copy_toplevel_phrase : + Ast_411.Parsetree.toplevel_phrase -> Ast_412.Parsetree.toplevel_phrase = + function + | Ast_411.Parsetree.Ptop_def x0 -> + Ast_412.Parsetree.Ptop_def (copy_structure x0) + | Ast_411.Parsetree.Ptop_dir x0 -> + Ast_412.Parsetree.Ptop_dir (copy_toplevel_directive x0) + +and copy_toplevel_directive : + Ast_411.Parsetree.toplevel_directive -> Ast_412.Parsetree.toplevel_directive + = + fun { + Ast_411.Parsetree.pdir_name; + Ast_411.Parsetree.pdir_arg; + Ast_411.Parsetree.pdir_loc; + } -> + { + Ast_412.Parsetree.pdir_name = copy_loc (fun x -> x) pdir_name; + Ast_412.Parsetree.pdir_arg = Option.map copy_directive_argument pdir_arg; + Ast_412.Parsetree.pdir_loc = copy_location pdir_loc; + } + +and copy_directive_argument : + Ast_411.Parsetree.directive_argument -> Ast_412.Parsetree.directive_argument + = + fun { Ast_411.Parsetree.pdira_desc; Ast_411.Parsetree.pdira_loc } -> + { + Ast_412.Parsetree.pdira_desc = copy_directive_argument_desc pdira_desc; + Ast_412.Parsetree.pdira_loc = copy_location pdira_loc; + } + +and copy_directive_argument_desc : + Ast_411.Parsetree.directive_argument_desc -> + Ast_412.Parsetree.directive_argument_desc = function + | Ast_411.Parsetree.Pdir_string x0 -> Ast_412.Parsetree.Pdir_string x0 + | Ast_411.Parsetree.Pdir_int (x0, x1) -> + Ast_412.Parsetree.Pdir_int (x0, Option.map (fun x -> x) x1) + | Ast_411.Parsetree.Pdir_ident x0 -> + Ast_412.Parsetree.Pdir_ident (copy_Longident_t x0) + | Ast_411.Parsetree.Pdir_bool x0 -> Ast_412.Parsetree.Pdir_bool x0 + +and copy_expression : + Ast_411.Parsetree.expression -> Ast_412.Parsetree.expression = + fun { + Ast_411.Parsetree.pexp_desc; + Ast_411.Parsetree.pexp_loc; + Ast_411.Parsetree.pexp_loc_stack; + Ast_411.Parsetree.pexp_attributes; + } -> + { + Ast_412.Parsetree.pexp_desc = copy_expression_desc pexp_desc; + Ast_412.Parsetree.pexp_loc = copy_location pexp_loc; + Ast_412.Parsetree.pexp_loc_stack = copy_location_stack pexp_loc_stack; + Ast_412.Parsetree.pexp_attributes = copy_attributes pexp_attributes; + } + +and copy_expression_desc : + Ast_411.Parsetree.expression_desc -> Ast_412.Parsetree.expression_desc = + function + | Ast_411.Parsetree.Pexp_ident x0 -> + Ast_412.Parsetree.Pexp_ident (copy_loc copy_Longident_t x0) + | Ast_411.Parsetree.Pexp_constant x0 -> + Ast_412.Parsetree.Pexp_constant (copy_constant x0) + | Ast_411.Parsetree.Pexp_let (x0, x1, x2) -> + Ast_412.Parsetree.Pexp_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_expression x2) + | Ast_411.Parsetree.Pexp_function x0 -> + Ast_412.Parsetree.Pexp_function (List.map copy_case x0) + | Ast_411.Parsetree.Pexp_fun (x0, x1, x2, x3) -> + Ast_412.Parsetree.Pexp_fun + ( copy_arg_label x0, + Option.map copy_expression x1, + copy_pattern x2, + copy_expression x3 ) + | Ast_411.Parsetree.Pexp_apply (x0, x1) -> + Ast_412.Parsetree.Pexp_apply + ( copy_expression x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | Ast_411.Parsetree.Pexp_match (x0, x1) -> + Ast_412.Parsetree.Pexp_match (copy_expression x0, List.map copy_case x1) + | Ast_411.Parsetree.Pexp_try (x0, x1) -> + Ast_412.Parsetree.Pexp_try (copy_expression x0, List.map copy_case x1) + | Ast_411.Parsetree.Pexp_tuple x0 -> + Ast_412.Parsetree.Pexp_tuple (List.map copy_expression x0) + | Ast_411.Parsetree.Pexp_construct (x0, x1) -> + Ast_412.Parsetree.Pexp_construct + (copy_loc copy_Longident_t x0, Option.map copy_expression x1) + | Ast_411.Parsetree.Pexp_variant (x0, x1) -> + Ast_412.Parsetree.Pexp_variant + (copy_label x0, Option.map copy_expression x1) + | Ast_411.Parsetree.Pexp_record (x0, x1) -> + Ast_412.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_411.Parsetree.Pexp_field (x0, x1) -> + Ast_412.Parsetree.Pexp_field + (copy_expression x0, copy_loc copy_Longident_t x1) + | Ast_411.Parsetree.Pexp_setfield (x0, x1, x2) -> + Ast_412.Parsetree.Pexp_setfield + (copy_expression x0, copy_loc copy_Longident_t x1, copy_expression x2) + | Ast_411.Parsetree.Pexp_array x0 -> + Ast_412.Parsetree.Pexp_array (List.map copy_expression x0) + | Ast_411.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> + Ast_412.Parsetree.Pexp_ifthenelse + (copy_expression x0, copy_expression x1, Option.map copy_expression x2) + | Ast_411.Parsetree.Pexp_sequence (x0, x1) -> + Ast_412.Parsetree.Pexp_sequence (copy_expression x0, copy_expression x1) + | Ast_411.Parsetree.Pexp_while (x0, x1) -> + Ast_412.Parsetree.Pexp_while (copy_expression x0, copy_expression x1) + | Ast_411.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> + Ast_412.Parsetree.Pexp_for + ( copy_pattern x0, + copy_expression x1, + copy_expression x2, + copy_direction_flag x3, + copy_expression x4 ) + | Ast_411.Parsetree.Pexp_constraint (x0, x1) -> + Ast_412.Parsetree.Pexp_constraint (copy_expression x0, copy_core_type x1) + | Ast_411.Parsetree.Pexp_coerce (x0, x1, x2) -> + Ast_412.Parsetree.Pexp_coerce + (copy_expression x0, Option.map copy_core_type x1, copy_core_type x2) + | Ast_411.Parsetree.Pexp_send (x0, x1) -> + Ast_412.Parsetree.Pexp_send (copy_expression x0, copy_loc copy_label x1) + | Ast_411.Parsetree.Pexp_new x0 -> + Ast_412.Parsetree.Pexp_new (copy_loc copy_Longident_t x0) + | Ast_411.Parsetree.Pexp_setinstvar (x0, x1) -> + Ast_412.Parsetree.Pexp_setinstvar + (copy_loc copy_label x0, copy_expression x1) + | Ast_411.Parsetree.Pexp_override x0 -> + Ast_412.Parsetree.Pexp_override + (List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_label x0, copy_expression x1)) + x0) + | Ast_411.Parsetree.Pexp_letmodule (x0, x1, x2) -> + Ast_412.Parsetree.Pexp_letmodule + ( copy_loc (fun x -> Option.map (fun x -> x) x) x0, + copy_module_expr x1, + copy_expression x2 ) + | Ast_411.Parsetree.Pexp_letexception (x0, x1) -> + Ast_412.Parsetree.Pexp_letexception + (copy_extension_constructor x0, copy_expression x1) + | Ast_411.Parsetree.Pexp_assert x0 -> + Ast_412.Parsetree.Pexp_assert (copy_expression x0) + | Ast_411.Parsetree.Pexp_lazy x0 -> + Ast_412.Parsetree.Pexp_lazy (copy_expression x0) + | Ast_411.Parsetree.Pexp_poly (x0, x1) -> + Ast_412.Parsetree.Pexp_poly + (copy_expression x0, Option.map copy_core_type x1) + | Ast_411.Parsetree.Pexp_object x0 -> + Ast_412.Parsetree.Pexp_object (copy_class_structure x0) + | Ast_411.Parsetree.Pexp_newtype (x0, x1) -> + Ast_412.Parsetree.Pexp_newtype + (copy_loc (fun x -> x) x0, copy_expression x1) + | Ast_411.Parsetree.Pexp_pack x0 -> + Ast_412.Parsetree.Pexp_pack (copy_module_expr x0) + | Ast_411.Parsetree.Pexp_open (x0, x1) -> + Ast_412.Parsetree.Pexp_open (copy_open_declaration x0, copy_expression x1) + | Ast_411.Parsetree.Pexp_letop x0 -> + Ast_412.Parsetree.Pexp_letop (copy_letop x0) + | Ast_411.Parsetree.Pexp_extension x0 -> + Ast_412.Parsetree.Pexp_extension (copy_extension x0) + | Ast_411.Parsetree.Pexp_unreachable -> Ast_412.Parsetree.Pexp_unreachable + +and copy_letop : Ast_411.Parsetree.letop -> Ast_412.Parsetree.letop = + fun { Ast_411.Parsetree.let_; Ast_411.Parsetree.ands; Ast_411.Parsetree.body } -> + { + Ast_412.Parsetree.let_ = copy_binding_op let_; + Ast_412.Parsetree.ands = List.map copy_binding_op ands; + Ast_412.Parsetree.body = copy_expression body; + } + +and copy_binding_op : + Ast_411.Parsetree.binding_op -> Ast_412.Parsetree.binding_op = + fun { + Ast_411.Parsetree.pbop_op; + Ast_411.Parsetree.pbop_pat; + Ast_411.Parsetree.pbop_exp; + Ast_411.Parsetree.pbop_loc; + } -> + { + Ast_412.Parsetree.pbop_op = copy_loc (fun x -> x) pbop_op; + Ast_412.Parsetree.pbop_pat = copy_pattern pbop_pat; + Ast_412.Parsetree.pbop_exp = copy_expression pbop_exp; + Ast_412.Parsetree.pbop_loc = copy_location pbop_loc; + } + +and copy_direction_flag : + Ast_411.Asttypes.direction_flag -> Ast_412.Asttypes.direction_flag = + function + | Ast_411.Asttypes.Upto -> Ast_412.Asttypes.Upto + | Ast_411.Asttypes.Downto -> Ast_412.Asttypes.Downto + +and copy_case : Ast_411.Parsetree.case -> Ast_412.Parsetree.case = + fun { + Ast_411.Parsetree.pc_lhs; + Ast_411.Parsetree.pc_guard; + Ast_411.Parsetree.pc_rhs; + } -> + { + Ast_412.Parsetree.pc_lhs = copy_pattern pc_lhs; + Ast_412.Parsetree.pc_guard = Option.map copy_expression pc_guard; + Ast_412.Parsetree.pc_rhs = copy_expression pc_rhs; + } + +and copy_value_binding : + Ast_411.Parsetree.value_binding -> Ast_412.Parsetree.value_binding = + fun { + Ast_411.Parsetree.pvb_pat; + Ast_411.Parsetree.pvb_expr; + Ast_411.Parsetree.pvb_attributes; + Ast_411.Parsetree.pvb_loc; + } -> + { + Ast_412.Parsetree.pvb_pat = copy_pattern pvb_pat; + Ast_412.Parsetree.pvb_expr = copy_expression pvb_expr; + Ast_412.Parsetree.pvb_attributes = copy_attributes pvb_attributes; + Ast_412.Parsetree.pvb_loc = copy_location pvb_loc; + } + +and copy_pattern : Ast_411.Parsetree.pattern -> Ast_412.Parsetree.pattern = + fun { + Ast_411.Parsetree.ppat_desc; + Ast_411.Parsetree.ppat_loc; + Ast_411.Parsetree.ppat_loc_stack; + Ast_411.Parsetree.ppat_attributes; + } -> + { + Ast_412.Parsetree.ppat_desc = copy_pattern_desc ppat_desc; + Ast_412.Parsetree.ppat_loc = copy_location ppat_loc; + Ast_412.Parsetree.ppat_loc_stack = copy_location_stack ppat_loc_stack; + Ast_412.Parsetree.ppat_attributes = copy_attributes ppat_attributes; + } + +and copy_pattern_desc : + Ast_411.Parsetree.pattern_desc -> Ast_412.Parsetree.pattern_desc = function + | Ast_411.Parsetree.Ppat_any -> Ast_412.Parsetree.Ppat_any + | Ast_411.Parsetree.Ppat_var x0 -> + Ast_412.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) + | Ast_411.Parsetree.Ppat_alias (x0, x1) -> + Ast_412.Parsetree.Ppat_alias (copy_pattern x0, copy_loc (fun x -> x) x1) + | Ast_411.Parsetree.Ppat_constant x0 -> + Ast_412.Parsetree.Ppat_constant (copy_constant x0) + | Ast_411.Parsetree.Ppat_interval (x0, x1) -> + Ast_412.Parsetree.Ppat_interval (copy_constant x0, copy_constant x1) + | Ast_411.Parsetree.Ppat_tuple x0 -> + Ast_412.Parsetree.Ppat_tuple (List.map copy_pattern x0) + | Ast_411.Parsetree.Ppat_construct (x0, x1) -> + Ast_412.Parsetree.Ppat_construct + (copy_loc copy_Longident_t x0, Option.map copy_pattern x1) + | Ast_411.Parsetree.Ppat_variant (x0, x1) -> + Ast_412.Parsetree.Ppat_variant (copy_label x0, Option.map copy_pattern x1) + | Ast_411.Parsetree.Ppat_record (x0, x1) -> + Ast_412.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_411.Parsetree.Ppat_array x0 -> + Ast_412.Parsetree.Ppat_array (List.map copy_pattern x0) + | Ast_411.Parsetree.Ppat_or (x0, x1) -> + Ast_412.Parsetree.Ppat_or (copy_pattern x0, copy_pattern x1) + | Ast_411.Parsetree.Ppat_constraint (x0, x1) -> + Ast_412.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1) + | Ast_411.Parsetree.Ppat_type x0 -> + Ast_412.Parsetree.Ppat_type (copy_loc copy_Longident_t x0) + | Ast_411.Parsetree.Ppat_lazy x0 -> + Ast_412.Parsetree.Ppat_lazy (copy_pattern x0) + | Ast_411.Parsetree.Ppat_unpack x0 -> + Ast_412.Parsetree.Ppat_unpack + (copy_loc (fun x -> Option.map (fun x -> x) x) x0) + | Ast_411.Parsetree.Ppat_exception x0 -> + Ast_412.Parsetree.Ppat_exception (copy_pattern x0) + | Ast_411.Parsetree.Ppat_extension x0 -> + Ast_412.Parsetree.Ppat_extension (copy_extension x0) + | Ast_411.Parsetree.Ppat_open (x0, x1) -> + Ast_412.Parsetree.Ppat_open (copy_loc copy_Longident_t x0, copy_pattern x1) + +and copy_core_type : Ast_411.Parsetree.core_type -> Ast_412.Parsetree.core_type + = + fun { + Ast_411.Parsetree.ptyp_desc; + Ast_411.Parsetree.ptyp_loc; + Ast_411.Parsetree.ptyp_loc_stack; + Ast_411.Parsetree.ptyp_attributes; + } -> + { + Ast_412.Parsetree.ptyp_desc = copy_core_type_desc ptyp_desc; + Ast_412.Parsetree.ptyp_loc = copy_location ptyp_loc; + Ast_412.Parsetree.ptyp_loc_stack = copy_location_stack ptyp_loc_stack; + Ast_412.Parsetree.ptyp_attributes = copy_attributes ptyp_attributes; + } + +and copy_location_stack : + Ast_411.Parsetree.location_stack -> Ast_412.Parsetree.location_stack = + fun x -> x + +and copy_core_type_desc : + Ast_411.Parsetree.core_type_desc -> Ast_412.Parsetree.core_type_desc = + function + | Ast_411.Parsetree.Ptyp_any -> Ast_412.Parsetree.Ptyp_any + | Ast_411.Parsetree.Ptyp_var x0 -> Ast_412.Parsetree.Ptyp_var x0 + | Ast_411.Parsetree.Ptyp_arrow (x0, x1, x2) -> + Ast_412.Parsetree.Ptyp_arrow + (copy_arg_label x0, copy_core_type x1, copy_core_type x2) + | Ast_411.Parsetree.Ptyp_tuple x0 -> + Ast_412.Parsetree.Ptyp_tuple (List.map copy_core_type x0) + | Ast_411.Parsetree.Ptyp_constr (x0, x1) -> + Ast_412.Parsetree.Ptyp_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_411.Parsetree.Ptyp_object (x0, x1) -> + Ast_412.Parsetree.Ptyp_object + (List.map copy_object_field x0, copy_closed_flag x1) + | Ast_411.Parsetree.Ptyp_class (x0, x1) -> + Ast_412.Parsetree.Ptyp_class + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_411.Parsetree.Ptyp_alias (x0, x1) -> + Ast_412.Parsetree.Ptyp_alias (copy_core_type x0, x1) + | Ast_411.Parsetree.Ptyp_variant (x0, x1, x2) -> + Ast_412.Parsetree.Ptyp_variant + ( List.map copy_row_field x0, + copy_closed_flag x1, + Option.map (fun x -> List.map copy_label x) x2 ) + | Ast_411.Parsetree.Ptyp_poly (x0, x1) -> + Ast_412.Parsetree.Ptyp_poly + (List.map (fun x -> copy_loc (fun x -> x) x) x0, copy_core_type x1) + | Ast_411.Parsetree.Ptyp_package x0 -> + Ast_412.Parsetree.Ptyp_package (copy_package_type x0) + | Ast_411.Parsetree.Ptyp_extension x0 -> + Ast_412.Parsetree.Ptyp_extension (copy_extension x0) + +and copy_package_type : + Ast_411.Parsetree.package_type -> Ast_412.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_411.Parsetree.row_field -> Ast_412.Parsetree.row_field + = + fun { + Ast_411.Parsetree.prf_desc; + Ast_411.Parsetree.prf_loc; + Ast_411.Parsetree.prf_attributes; + } -> + { + Ast_412.Parsetree.prf_desc = copy_row_field_desc prf_desc; + Ast_412.Parsetree.prf_loc = copy_location prf_loc; + Ast_412.Parsetree.prf_attributes = copy_attributes prf_attributes; + } + +and copy_row_field_desc : + Ast_411.Parsetree.row_field_desc -> Ast_412.Parsetree.row_field_desc = + function + | Ast_411.Parsetree.Rtag (x0, x1, x2) -> + Ast_412.Parsetree.Rtag + (copy_loc copy_label x0, x1, List.map copy_core_type x2) + | Ast_411.Parsetree.Rinherit x0 -> + Ast_412.Parsetree.Rinherit (copy_core_type x0) + +and copy_object_field : + Ast_411.Parsetree.object_field -> Ast_412.Parsetree.object_field = + fun { + Ast_411.Parsetree.pof_desc; + Ast_411.Parsetree.pof_loc; + Ast_411.Parsetree.pof_attributes; + } -> + { + Ast_412.Parsetree.pof_desc = copy_object_field_desc pof_desc; + Ast_412.Parsetree.pof_loc = copy_location pof_loc; + Ast_412.Parsetree.pof_attributes = copy_attributes pof_attributes; + } + +and copy_attributes : + Ast_411.Parsetree.attributes -> Ast_412.Parsetree.attributes = + fun x -> List.map copy_attribute x + +and copy_attribute : Ast_411.Parsetree.attribute -> Ast_412.Parsetree.attribute + = + fun { + Ast_411.Parsetree.attr_name; + Ast_411.Parsetree.attr_payload; + Ast_411.Parsetree.attr_loc; + } -> + { + Ast_412.Parsetree.attr_name = copy_loc (fun x -> x) attr_name; + Ast_412.Parsetree.attr_payload = copy_payload attr_payload; + Ast_412.Parsetree.attr_loc = copy_location attr_loc; + } + +and copy_payload : Ast_411.Parsetree.payload -> Ast_412.Parsetree.payload = + function + | Ast_411.Parsetree.PStr x0 -> Ast_412.Parsetree.PStr (copy_structure x0) + | Ast_411.Parsetree.PSig x0 -> Ast_412.Parsetree.PSig (copy_signature x0) + | Ast_411.Parsetree.PTyp x0 -> Ast_412.Parsetree.PTyp (copy_core_type x0) + | Ast_411.Parsetree.PPat (x0, x1) -> + Ast_412.Parsetree.PPat (copy_pattern x0, Option.map copy_expression x1) + +and copy_structure : Ast_411.Parsetree.structure -> Ast_412.Parsetree.structure + = + fun x -> List.map copy_structure_item x + +and copy_structure_item : + Ast_411.Parsetree.structure_item -> Ast_412.Parsetree.structure_item = + fun { Ast_411.Parsetree.pstr_desc; Ast_411.Parsetree.pstr_loc } -> + { + Ast_412.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc; + Ast_412.Parsetree.pstr_loc = copy_location pstr_loc; + } + +and copy_structure_item_desc : + Ast_411.Parsetree.structure_item_desc -> + Ast_412.Parsetree.structure_item_desc = function + | Ast_411.Parsetree.Pstr_eval (x0, x1) -> + Ast_412.Parsetree.Pstr_eval (copy_expression x0, copy_attributes x1) + | Ast_411.Parsetree.Pstr_value (x0, x1) -> + Ast_412.Parsetree.Pstr_value + (copy_rec_flag x0, List.map copy_value_binding x1) + | Ast_411.Parsetree.Pstr_primitive x0 -> + Ast_412.Parsetree.Pstr_primitive (copy_value_description x0) + | Ast_411.Parsetree.Pstr_type (x0, x1) -> + Ast_412.Parsetree.Pstr_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | Ast_411.Parsetree.Pstr_typext x0 -> + Ast_412.Parsetree.Pstr_typext (copy_type_extension x0) + | Ast_411.Parsetree.Pstr_exception x0 -> + Ast_412.Parsetree.Pstr_exception (copy_type_exception x0) + | Ast_411.Parsetree.Pstr_module x0 -> + Ast_412.Parsetree.Pstr_module (copy_module_binding x0) + | Ast_411.Parsetree.Pstr_recmodule x0 -> + Ast_412.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) + | Ast_411.Parsetree.Pstr_modtype x0 -> + Ast_412.Parsetree.Pstr_modtype (copy_module_type_declaration x0) + | Ast_411.Parsetree.Pstr_open x0 -> + Ast_412.Parsetree.Pstr_open (copy_open_declaration x0) + | Ast_411.Parsetree.Pstr_class x0 -> + Ast_412.Parsetree.Pstr_class (List.map copy_class_declaration x0) + | Ast_411.Parsetree.Pstr_class_type x0 -> + Ast_412.Parsetree.Pstr_class_type + (List.map copy_class_type_declaration x0) + | Ast_411.Parsetree.Pstr_include x0 -> + Ast_412.Parsetree.Pstr_include (copy_include_declaration x0) + | Ast_411.Parsetree.Pstr_attribute x0 -> + Ast_412.Parsetree.Pstr_attribute (copy_attribute x0) + | Ast_411.Parsetree.Pstr_extension (x0, x1) -> + Ast_412.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1) + +and copy_include_declaration : + Ast_411.Parsetree.include_declaration -> + Ast_412.Parsetree.include_declaration = + fun x -> copy_include_infos copy_module_expr x + +and copy_class_declaration : + Ast_411.Parsetree.class_declaration -> Ast_412.Parsetree.class_declaration = + fun x -> copy_class_infos copy_class_expr x + +and copy_class_expr : + Ast_411.Parsetree.class_expr -> Ast_412.Parsetree.class_expr = + fun { + Ast_411.Parsetree.pcl_desc; + Ast_411.Parsetree.pcl_loc; + Ast_411.Parsetree.pcl_attributes; + } -> + { + Ast_412.Parsetree.pcl_desc = copy_class_expr_desc pcl_desc; + Ast_412.Parsetree.pcl_loc = copy_location pcl_loc; + Ast_412.Parsetree.pcl_attributes = copy_attributes pcl_attributes; + } + +and copy_class_expr_desc : + Ast_411.Parsetree.class_expr_desc -> Ast_412.Parsetree.class_expr_desc = + function + | Ast_411.Parsetree.Pcl_constr (x0, x1) -> + Ast_412.Parsetree.Pcl_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_411.Parsetree.Pcl_structure x0 -> + Ast_412.Parsetree.Pcl_structure (copy_class_structure x0) + | Ast_411.Parsetree.Pcl_fun (x0, x1, x2, x3) -> + Ast_412.Parsetree.Pcl_fun + ( copy_arg_label x0, + Option.map copy_expression x1, + copy_pattern x2, + copy_class_expr x3 ) + | Ast_411.Parsetree.Pcl_apply (x0, x1) -> + Ast_412.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_411.Parsetree.Pcl_let (x0, x1, x2) -> + Ast_412.Parsetree.Pcl_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_class_expr x2) + | Ast_411.Parsetree.Pcl_constraint (x0, x1) -> + Ast_412.Parsetree.Pcl_constraint (copy_class_expr x0, copy_class_type x1) + | Ast_411.Parsetree.Pcl_extension x0 -> + Ast_412.Parsetree.Pcl_extension (copy_extension x0) + | Ast_411.Parsetree.Pcl_open (x0, x1) -> + Ast_412.Parsetree.Pcl_open (copy_open_description x0, copy_class_expr x1) + +and copy_class_structure : + Ast_411.Parsetree.class_structure -> Ast_412.Parsetree.class_structure = + fun { Ast_411.Parsetree.pcstr_self; Ast_411.Parsetree.pcstr_fields } -> + { + Ast_412.Parsetree.pcstr_self = copy_pattern pcstr_self; + Ast_412.Parsetree.pcstr_fields = List.map copy_class_field pcstr_fields; + } + +and copy_class_field : + Ast_411.Parsetree.class_field -> Ast_412.Parsetree.class_field = + fun { + Ast_411.Parsetree.pcf_desc; + Ast_411.Parsetree.pcf_loc; + Ast_411.Parsetree.pcf_attributes; + } -> + { + Ast_412.Parsetree.pcf_desc = copy_class_field_desc pcf_desc; + Ast_412.Parsetree.pcf_loc = copy_location pcf_loc; + Ast_412.Parsetree.pcf_attributes = copy_attributes pcf_attributes; + } + +and copy_class_field_desc : + Ast_411.Parsetree.class_field_desc -> Ast_412.Parsetree.class_field_desc = + function + | Ast_411.Parsetree.Pcf_inherit (x0, x1, x2) -> + Ast_412.Parsetree.Pcf_inherit + ( copy_override_flag x0, + copy_class_expr x1, + Option.map (fun x -> copy_loc (fun x -> x) x) x2 ) + | Ast_411.Parsetree.Pcf_val x0 -> + Ast_412.Parsetree.Pcf_val + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_mutable_flag x1, copy_class_field_kind x2)) + | Ast_411.Parsetree.Pcf_method x0 -> + Ast_412.Parsetree.Pcf_method + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_private_flag x1, copy_class_field_kind x2)) + | Ast_411.Parsetree.Pcf_constraint x0 -> + Ast_412.Parsetree.Pcf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | Ast_411.Parsetree.Pcf_initializer x0 -> + Ast_412.Parsetree.Pcf_initializer (copy_expression x0) + | Ast_411.Parsetree.Pcf_attribute x0 -> + Ast_412.Parsetree.Pcf_attribute (copy_attribute x0) + | Ast_411.Parsetree.Pcf_extension x0 -> + Ast_412.Parsetree.Pcf_extension (copy_extension x0) + +and copy_class_field_kind : + Ast_411.Parsetree.class_field_kind -> Ast_412.Parsetree.class_field_kind = + function + | Ast_411.Parsetree.Cfk_virtual x0 -> + Ast_412.Parsetree.Cfk_virtual (copy_core_type x0) + | Ast_411.Parsetree.Cfk_concrete (x0, x1) -> + Ast_412.Parsetree.Cfk_concrete (copy_override_flag x0, copy_expression x1) + +and copy_open_declaration : + Ast_411.Parsetree.open_declaration -> Ast_412.Parsetree.open_declaration = + fun x -> copy_open_infos copy_module_expr x + +and copy_module_binding : + Ast_411.Parsetree.module_binding -> Ast_412.Parsetree.module_binding = + fun { + Ast_411.Parsetree.pmb_name; + Ast_411.Parsetree.pmb_expr; + Ast_411.Parsetree.pmb_attributes; + Ast_411.Parsetree.pmb_loc; + } -> + { + Ast_412.Parsetree.pmb_name = + copy_loc (fun x -> Option.map (fun x -> x) x) pmb_name; + Ast_412.Parsetree.pmb_expr = copy_module_expr pmb_expr; + Ast_412.Parsetree.pmb_attributes = copy_attributes pmb_attributes; + Ast_412.Parsetree.pmb_loc = copy_location pmb_loc; + } + +and copy_module_expr : + Ast_411.Parsetree.module_expr -> Ast_412.Parsetree.module_expr = + fun { + Ast_411.Parsetree.pmod_desc; + Ast_411.Parsetree.pmod_loc; + Ast_411.Parsetree.pmod_attributes; + } -> + { + Ast_412.Parsetree.pmod_desc = copy_module_expr_desc pmod_desc; + Ast_412.Parsetree.pmod_loc = copy_location pmod_loc; + Ast_412.Parsetree.pmod_attributes = copy_attributes pmod_attributes; + } + +and copy_module_expr_desc : + Ast_411.Parsetree.module_expr_desc -> Ast_412.Parsetree.module_expr_desc = + function + | Ast_411.Parsetree.Pmod_ident x0 -> + Ast_412.Parsetree.Pmod_ident (copy_loc copy_Longident_t x0) + | Ast_411.Parsetree.Pmod_structure x0 -> + Ast_412.Parsetree.Pmod_structure (copy_structure x0) + | Ast_411.Parsetree.Pmod_functor (x0, x1) -> + Ast_412.Parsetree.Pmod_functor + (copy_functor_parameter x0, copy_module_expr x1) + | Ast_411.Parsetree.Pmod_apply (x0, x1) -> + Ast_412.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) + | Ast_411.Parsetree.Pmod_constraint (x0, x1) -> + Ast_412.Parsetree.Pmod_constraint + (copy_module_expr x0, copy_module_type x1) + | Ast_411.Parsetree.Pmod_unpack x0 -> + Ast_412.Parsetree.Pmod_unpack (copy_expression x0) + | Ast_411.Parsetree.Pmod_extension x0 -> + Ast_412.Parsetree.Pmod_extension (copy_extension x0) + +and copy_functor_parameter : + Ast_411.Parsetree.functor_parameter -> Ast_412.Parsetree.functor_parameter = + function + | Ast_411.Parsetree.Unit -> Ast_412.Parsetree.Unit + | Ast_411.Parsetree.Named (x0, x1) -> + Ast_412.Parsetree.Named + (copy_loc (fun x -> Option.map (fun x -> x) x) x0, copy_module_type x1) + +and copy_module_type : + Ast_411.Parsetree.module_type -> Ast_412.Parsetree.module_type = + fun { + Ast_411.Parsetree.pmty_desc; + Ast_411.Parsetree.pmty_loc; + Ast_411.Parsetree.pmty_attributes; + } -> + { + Ast_412.Parsetree.pmty_desc = copy_module_type_desc pmty_desc; + Ast_412.Parsetree.pmty_loc = copy_location pmty_loc; + Ast_412.Parsetree.pmty_attributes = copy_attributes pmty_attributes; + } + +and copy_module_type_desc : + Ast_411.Parsetree.module_type_desc -> Ast_412.Parsetree.module_type_desc = + function + | Ast_411.Parsetree.Pmty_ident x0 -> + Ast_412.Parsetree.Pmty_ident (copy_loc copy_Longident_t x0) + | Ast_411.Parsetree.Pmty_signature x0 -> + Ast_412.Parsetree.Pmty_signature (copy_signature x0) + | Ast_411.Parsetree.Pmty_functor (x0, x1) -> + Ast_412.Parsetree.Pmty_functor + (copy_functor_parameter x0, copy_module_type x1) + | Ast_411.Parsetree.Pmty_with (x0, x1) -> + Ast_412.Parsetree.Pmty_with + (copy_module_type x0, List.map copy_with_constraint x1) + | Ast_411.Parsetree.Pmty_typeof x0 -> + Ast_412.Parsetree.Pmty_typeof (copy_module_expr x0) + | Ast_411.Parsetree.Pmty_extension x0 -> + Ast_412.Parsetree.Pmty_extension (copy_extension x0) + | Ast_411.Parsetree.Pmty_alias x0 -> + Ast_412.Parsetree.Pmty_alias (copy_loc copy_Longident_t x0) + +and copy_with_constraint : + Ast_411.Parsetree.with_constraint -> Ast_412.Parsetree.with_constraint = + function + | Ast_411.Parsetree.Pwith_type (x0, x1) -> + Ast_412.Parsetree.Pwith_type + (copy_loc copy_Longident_t x0, copy_type_declaration x1) + | Ast_411.Parsetree.Pwith_module (x0, x1) -> + Ast_412.Parsetree.Pwith_module + (copy_loc copy_Longident_t x0, copy_loc copy_Longident_t x1) + | Ast_411.Parsetree.Pwith_typesubst (x0, x1) -> + Ast_412.Parsetree.Pwith_typesubst + (copy_loc copy_Longident_t x0, copy_type_declaration x1) + | Ast_411.Parsetree.Pwith_modsubst (x0, x1) -> + Ast_412.Parsetree.Pwith_modsubst + (copy_loc copy_Longident_t x0, copy_loc copy_Longident_t x1) + +and copy_signature : Ast_411.Parsetree.signature -> Ast_412.Parsetree.signature + = + fun x -> List.map copy_signature_item x + +and copy_signature_item : + Ast_411.Parsetree.signature_item -> Ast_412.Parsetree.signature_item = + fun { Ast_411.Parsetree.psig_desc; Ast_411.Parsetree.psig_loc } -> + { + Ast_412.Parsetree.psig_desc = copy_signature_item_desc psig_desc; + Ast_412.Parsetree.psig_loc = copy_location psig_loc; + } + +and copy_signature_item_desc : + Ast_411.Parsetree.signature_item_desc -> + Ast_412.Parsetree.signature_item_desc = function + | Ast_411.Parsetree.Psig_value x0 -> + Ast_412.Parsetree.Psig_value (copy_value_description x0) + | Ast_411.Parsetree.Psig_type (x0, x1) -> + Ast_412.Parsetree.Psig_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | Ast_411.Parsetree.Psig_typesubst x0 -> + Ast_412.Parsetree.Psig_typesubst (List.map copy_type_declaration x0) + | Ast_411.Parsetree.Psig_typext x0 -> + Ast_412.Parsetree.Psig_typext (copy_type_extension x0) + | Ast_411.Parsetree.Psig_exception x0 -> + Ast_412.Parsetree.Psig_exception (copy_type_exception x0) + | Ast_411.Parsetree.Psig_module x0 -> + Ast_412.Parsetree.Psig_module (copy_module_declaration x0) + | Ast_411.Parsetree.Psig_modsubst x0 -> + Ast_412.Parsetree.Psig_modsubst (copy_module_substitution x0) + | Ast_411.Parsetree.Psig_recmodule x0 -> + Ast_412.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) + | Ast_411.Parsetree.Psig_modtype x0 -> + Ast_412.Parsetree.Psig_modtype (copy_module_type_declaration x0) + | Ast_411.Parsetree.Psig_open x0 -> + Ast_412.Parsetree.Psig_open (copy_open_description x0) + | Ast_411.Parsetree.Psig_include x0 -> + Ast_412.Parsetree.Psig_include (copy_include_description x0) + | Ast_411.Parsetree.Psig_class x0 -> + Ast_412.Parsetree.Psig_class (List.map copy_class_description x0) + | Ast_411.Parsetree.Psig_class_type x0 -> + Ast_412.Parsetree.Psig_class_type + (List.map copy_class_type_declaration x0) + | Ast_411.Parsetree.Psig_attribute x0 -> + Ast_412.Parsetree.Psig_attribute (copy_attribute x0) + | Ast_411.Parsetree.Psig_extension (x0, x1) -> + Ast_412.Parsetree.Psig_extension (copy_extension x0, copy_attributes x1) + +and copy_class_type_declaration : + Ast_411.Parsetree.class_type_declaration -> + Ast_412.Parsetree.class_type_declaration = + fun x -> copy_class_infos copy_class_type x + +and copy_class_description : + Ast_411.Parsetree.class_description -> Ast_412.Parsetree.class_description = + fun x -> copy_class_infos copy_class_type x + +and copy_class_type : + Ast_411.Parsetree.class_type -> Ast_412.Parsetree.class_type = + fun { + Ast_411.Parsetree.pcty_desc; + Ast_411.Parsetree.pcty_loc; + Ast_411.Parsetree.pcty_attributes; + } -> + { + Ast_412.Parsetree.pcty_desc = copy_class_type_desc pcty_desc; + Ast_412.Parsetree.pcty_loc = copy_location pcty_loc; + Ast_412.Parsetree.pcty_attributes = copy_attributes pcty_attributes; + } + +and copy_class_type_desc : + Ast_411.Parsetree.class_type_desc -> Ast_412.Parsetree.class_type_desc = + function + | Ast_411.Parsetree.Pcty_constr (x0, x1) -> + Ast_412.Parsetree.Pcty_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_411.Parsetree.Pcty_signature x0 -> + Ast_412.Parsetree.Pcty_signature (copy_class_signature x0) + | Ast_411.Parsetree.Pcty_arrow (x0, x1, x2) -> + Ast_412.Parsetree.Pcty_arrow + (copy_arg_label x0, copy_core_type x1, copy_class_type x2) + | Ast_411.Parsetree.Pcty_extension x0 -> + Ast_412.Parsetree.Pcty_extension (copy_extension x0) + | Ast_411.Parsetree.Pcty_open (x0, x1) -> + Ast_412.Parsetree.Pcty_open (copy_open_description x0, copy_class_type x1) + +and copy_class_signature : + Ast_411.Parsetree.class_signature -> Ast_412.Parsetree.class_signature = + fun { Ast_411.Parsetree.pcsig_self; Ast_411.Parsetree.pcsig_fields } -> + { + Ast_412.Parsetree.pcsig_self = copy_core_type pcsig_self; + Ast_412.Parsetree.pcsig_fields = List.map copy_class_type_field pcsig_fields; + } + +and copy_class_type_field : + Ast_411.Parsetree.class_type_field -> Ast_412.Parsetree.class_type_field = + fun { + Ast_411.Parsetree.pctf_desc; + Ast_411.Parsetree.pctf_loc; + Ast_411.Parsetree.pctf_attributes; + } -> + { + Ast_412.Parsetree.pctf_desc = copy_class_type_field_desc pctf_desc; + Ast_412.Parsetree.pctf_loc = copy_location pctf_loc; + Ast_412.Parsetree.pctf_attributes = copy_attributes pctf_attributes; + } + +and copy_class_type_field_desc : + Ast_411.Parsetree.class_type_field_desc -> + Ast_412.Parsetree.class_type_field_desc = function + | Ast_411.Parsetree.Pctf_inherit x0 -> + Ast_412.Parsetree.Pctf_inherit (copy_class_type x0) + | Ast_411.Parsetree.Pctf_val x0 -> + Ast_412.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_411.Parsetree.Pctf_method x0 -> + Ast_412.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_411.Parsetree.Pctf_constraint x0 -> + Ast_412.Parsetree.Pctf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | Ast_411.Parsetree.Pctf_attribute x0 -> + Ast_412.Parsetree.Pctf_attribute (copy_attribute x0) + | Ast_411.Parsetree.Pctf_extension x0 -> + Ast_412.Parsetree.Pctf_extension (copy_extension x0) + +and copy_extension : Ast_411.Parsetree.extension -> Ast_412.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_411.Parsetree.class_infos -> + 'g0 Ast_412.Parsetree.class_infos = + fun f0 + { + Ast_411.Parsetree.pci_virt; + Ast_411.Parsetree.pci_params; + Ast_411.Parsetree.pci_name; + Ast_411.Parsetree.pci_expr; + Ast_411.Parsetree.pci_loc; + Ast_411.Parsetree.pci_attributes; + } -> + { + Ast_412.Parsetree.pci_virt = copy_virtual_flag pci_virt; + Ast_412.Parsetree.pci_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, (copy_variance x1, Ast_412.Asttypes.NoInjectivity))) + pci_params; + Ast_412.Parsetree.pci_name = copy_loc (fun x -> x) pci_name; + Ast_412.Parsetree.pci_expr = f0 pci_expr; + Ast_412.Parsetree.pci_loc = copy_location pci_loc; + Ast_412.Parsetree.pci_attributes = copy_attributes pci_attributes; + } + +and copy_virtual_flag : + Ast_411.Asttypes.virtual_flag -> Ast_412.Asttypes.virtual_flag = function + | Ast_411.Asttypes.Virtual -> Ast_412.Asttypes.Virtual + | Ast_411.Asttypes.Concrete -> Ast_412.Asttypes.Concrete + +and copy_include_description : + Ast_411.Parsetree.include_description -> + Ast_412.Parsetree.include_description = + fun x -> copy_include_infos copy_module_type x + +and copy_include_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 Ast_411.Parsetree.include_infos -> + 'g0 Ast_412.Parsetree.include_infos = + fun f0 + { + Ast_411.Parsetree.pincl_mod; + Ast_411.Parsetree.pincl_loc; + Ast_411.Parsetree.pincl_attributes; + } -> + { + Ast_412.Parsetree.pincl_mod = f0 pincl_mod; + Ast_412.Parsetree.pincl_loc = copy_location pincl_loc; + Ast_412.Parsetree.pincl_attributes = copy_attributes pincl_attributes; + } + +and copy_open_description : + Ast_411.Parsetree.open_description -> Ast_412.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_411.Parsetree.open_infos -> + 'g0 Ast_412.Parsetree.open_infos = + fun f0 + { + Ast_411.Parsetree.popen_expr; + Ast_411.Parsetree.popen_override; + Ast_411.Parsetree.popen_loc; + Ast_411.Parsetree.popen_attributes; + } -> + { + Ast_412.Parsetree.popen_expr = f0 popen_expr; + Ast_412.Parsetree.popen_override = copy_override_flag popen_override; + Ast_412.Parsetree.popen_loc = copy_location popen_loc; + Ast_412.Parsetree.popen_attributes = copy_attributes popen_attributes; + } + +and copy_override_flag : + Ast_411.Asttypes.override_flag -> Ast_412.Asttypes.override_flag = function + | Ast_411.Asttypes.Override -> Ast_412.Asttypes.Override + | Ast_411.Asttypes.Fresh -> Ast_412.Asttypes.Fresh + +and copy_module_type_declaration : + Ast_411.Parsetree.module_type_declaration -> + Ast_412.Parsetree.module_type_declaration = + fun { + Ast_411.Parsetree.pmtd_name; + Ast_411.Parsetree.pmtd_type; + Ast_411.Parsetree.pmtd_attributes; + Ast_411.Parsetree.pmtd_loc; + } -> + { + Ast_412.Parsetree.pmtd_name = copy_loc (fun x -> x) pmtd_name; + Ast_412.Parsetree.pmtd_type = Option.map copy_module_type pmtd_type; + Ast_412.Parsetree.pmtd_attributes = copy_attributes pmtd_attributes; + Ast_412.Parsetree.pmtd_loc = copy_location pmtd_loc; + } + +and copy_module_substitution : + Ast_411.Parsetree.module_substitution -> + Ast_412.Parsetree.module_substitution = + fun { + Ast_411.Parsetree.pms_name; + Ast_411.Parsetree.pms_manifest; + Ast_411.Parsetree.pms_attributes; + Ast_411.Parsetree.pms_loc; + } -> + { + Ast_412.Parsetree.pms_name = copy_loc (fun x -> x) pms_name; + Ast_412.Parsetree.pms_manifest = copy_loc copy_Longident_t pms_manifest; + Ast_412.Parsetree.pms_attributes = copy_attributes pms_attributes; + Ast_412.Parsetree.pms_loc = copy_location pms_loc; + } + +and copy_module_declaration : + Ast_411.Parsetree.module_declaration -> Ast_412.Parsetree.module_declaration + = + fun { + Ast_411.Parsetree.pmd_name; + Ast_411.Parsetree.pmd_type; + Ast_411.Parsetree.pmd_attributes; + Ast_411.Parsetree.pmd_loc; + } -> + { + Ast_412.Parsetree.pmd_name = + copy_loc (fun x -> Option.map (fun x -> x) x) pmd_name; + Ast_412.Parsetree.pmd_type = copy_module_type pmd_type; + Ast_412.Parsetree.pmd_attributes = copy_attributes pmd_attributes; + Ast_412.Parsetree.pmd_loc = copy_location pmd_loc; + } + +and copy_type_exception : + Ast_411.Parsetree.type_exception -> Ast_412.Parsetree.type_exception = + fun { + Ast_411.Parsetree.ptyexn_constructor; + Ast_411.Parsetree.ptyexn_loc; + Ast_411.Parsetree.ptyexn_attributes; + } -> + { + Ast_412.Parsetree.ptyexn_constructor = + copy_extension_constructor ptyexn_constructor; + Ast_412.Parsetree.ptyexn_loc = copy_location ptyexn_loc; + Ast_412.Parsetree.ptyexn_attributes = copy_attributes ptyexn_attributes; + } + +and copy_type_extension : + Ast_411.Parsetree.type_extension -> Ast_412.Parsetree.type_extension = + fun { + Ast_411.Parsetree.ptyext_path; + Ast_411.Parsetree.ptyext_params; + Ast_411.Parsetree.ptyext_constructors; + Ast_411.Parsetree.ptyext_private; + Ast_411.Parsetree.ptyext_loc; + Ast_411.Parsetree.ptyext_attributes; + } -> + { + Ast_412.Parsetree.ptyext_path = copy_loc copy_Longident_t ptyext_path; + Ast_412.Parsetree.ptyext_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, (copy_variance x1, Ast_412.Asttypes.NoInjectivity))) + ptyext_params; + Ast_412.Parsetree.ptyext_constructors = + List.map copy_extension_constructor ptyext_constructors; + Ast_412.Parsetree.ptyext_private = copy_private_flag ptyext_private; + Ast_412.Parsetree.ptyext_loc = copy_location ptyext_loc; + Ast_412.Parsetree.ptyext_attributes = copy_attributes ptyext_attributes; + } + +and copy_extension_constructor : + Ast_411.Parsetree.extension_constructor -> + Ast_412.Parsetree.extension_constructor = + fun { + Ast_411.Parsetree.pext_name; + Ast_411.Parsetree.pext_kind; + Ast_411.Parsetree.pext_loc; + Ast_411.Parsetree.pext_attributes; + } -> + { + Ast_412.Parsetree.pext_name = copy_loc (fun x -> x) pext_name; + Ast_412.Parsetree.pext_kind = copy_extension_constructor_kind pext_kind; + Ast_412.Parsetree.pext_loc = copy_location pext_loc; + Ast_412.Parsetree.pext_attributes = copy_attributes pext_attributes; + } + +and copy_extension_constructor_kind : + Ast_411.Parsetree.extension_constructor_kind -> + Ast_412.Parsetree.extension_constructor_kind = function + | Ast_411.Parsetree.Pext_decl (x0, x1) -> + Ast_412.Parsetree.Pext_decl + (copy_constructor_arguments x0, Option.map copy_core_type x1) + | Ast_411.Parsetree.Pext_rebind x0 -> + Ast_412.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0) + +and copy_type_declaration : + Ast_411.Parsetree.type_declaration -> Ast_412.Parsetree.type_declaration = + fun { + Ast_411.Parsetree.ptype_name; + Ast_411.Parsetree.ptype_params; + Ast_411.Parsetree.ptype_cstrs; + Ast_411.Parsetree.ptype_kind; + Ast_411.Parsetree.ptype_private; + Ast_411.Parsetree.ptype_manifest; + Ast_411.Parsetree.ptype_attributes; + Ast_411.Parsetree.ptype_loc; + } -> + { + Ast_412.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name; + Ast_412.Parsetree.ptype_params = + List.map + (fun x -> + let x0, x1 = x in + (copy_core_type x0, (copy_variance x1, Ast_412.Asttypes.NoInjectivity))) + ptype_params; + Ast_412.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_412.Parsetree.ptype_kind = copy_type_kind ptype_kind; + Ast_412.Parsetree.ptype_private = copy_private_flag ptype_private; + Ast_412.Parsetree.ptype_manifest = Option.map copy_core_type ptype_manifest; + Ast_412.Parsetree.ptype_attributes = copy_attributes ptype_attributes; + Ast_412.Parsetree.ptype_loc = copy_location ptype_loc; + } + +and copy_private_flag : + Ast_411.Asttypes.private_flag -> Ast_412.Asttypes.private_flag = function + | Ast_411.Asttypes.Private -> Ast_412.Asttypes.Private + | Ast_411.Asttypes.Public -> Ast_412.Asttypes.Public + +and copy_type_kind : Ast_411.Parsetree.type_kind -> Ast_412.Parsetree.type_kind + = function + | Ast_411.Parsetree.Ptype_abstract -> Ast_412.Parsetree.Ptype_abstract + | Ast_411.Parsetree.Ptype_variant x0 -> + Ast_412.Parsetree.Ptype_variant (List.map copy_constructor_declaration x0) + | Ast_411.Parsetree.Ptype_record x0 -> + Ast_412.Parsetree.Ptype_record (List.map copy_label_declaration x0) + | Ast_411.Parsetree.Ptype_open -> Ast_412.Parsetree.Ptype_open + +and copy_constructor_declaration : + Ast_411.Parsetree.constructor_declaration -> + Ast_412.Parsetree.constructor_declaration = + fun { + Ast_411.Parsetree.pcd_name; + Ast_411.Parsetree.pcd_args; + Ast_411.Parsetree.pcd_res; + Ast_411.Parsetree.pcd_loc; + Ast_411.Parsetree.pcd_attributes; + } -> + { + Ast_412.Parsetree.pcd_name = copy_loc (fun x -> x) pcd_name; + Ast_412.Parsetree.pcd_args = copy_constructor_arguments pcd_args; + Ast_412.Parsetree.pcd_res = Option.map copy_core_type pcd_res; + Ast_412.Parsetree.pcd_loc = copy_location pcd_loc; + Ast_412.Parsetree.pcd_attributes = copy_attributes pcd_attributes; + } + +and copy_constructor_arguments : + Ast_411.Parsetree.constructor_arguments -> + Ast_412.Parsetree.constructor_arguments = function + | Ast_411.Parsetree.Pcstr_tuple x0 -> + Ast_412.Parsetree.Pcstr_tuple (List.map copy_core_type x0) + | Ast_411.Parsetree.Pcstr_record x0 -> + Ast_412.Parsetree.Pcstr_record (List.map copy_label_declaration x0) + +and copy_label_declaration : + Ast_411.Parsetree.label_declaration -> Ast_412.Parsetree.label_declaration = + fun { + Ast_411.Parsetree.pld_name; + Ast_411.Parsetree.pld_mutable; + Ast_411.Parsetree.pld_type; + Ast_411.Parsetree.pld_loc; + Ast_411.Parsetree.pld_attributes; + } -> + { + Ast_412.Parsetree.pld_name = copy_loc (fun x -> x) pld_name; + Ast_412.Parsetree.pld_mutable = copy_mutable_flag pld_mutable; + Ast_412.Parsetree.pld_type = copy_core_type pld_type; + Ast_412.Parsetree.pld_loc = copy_location pld_loc; + Ast_412.Parsetree.pld_attributes = copy_attributes pld_attributes; + } + +and copy_mutable_flag : + Ast_411.Asttypes.mutable_flag -> Ast_412.Asttypes.mutable_flag = function + | Ast_411.Asttypes.Immutable -> Ast_412.Asttypes.Immutable + | Ast_411.Asttypes.Mutable -> Ast_412.Asttypes.Mutable + +and copy_variance : Ast_411.Asttypes.variance -> Ast_412.Asttypes.variance = + function + | Ast_411.Asttypes.Covariant -> Ast_412.Asttypes.Covariant + | Ast_411.Asttypes.Contravariant -> Ast_412.Asttypes.Contravariant + | Ast_411.Asttypes.Invariant -> Ast_412.Asttypes.NoVariance + +and copy_value_description : + Ast_411.Parsetree.value_description -> Ast_412.Parsetree.value_description = + fun { + Ast_411.Parsetree.pval_name; + Ast_411.Parsetree.pval_type; + Ast_411.Parsetree.pval_prim; + Ast_411.Parsetree.pval_attributes; + Ast_411.Parsetree.pval_loc; + } -> + { + Ast_412.Parsetree.pval_name = copy_loc (fun x -> x) pval_name; + Ast_412.Parsetree.pval_type = copy_core_type pval_type; + Ast_412.Parsetree.pval_prim = List.map (fun x -> x) pval_prim; + Ast_412.Parsetree.pval_attributes = copy_attributes pval_attributes; + Ast_412.Parsetree.pval_loc = copy_location pval_loc; + } + +and copy_object_field_desc : + Ast_411.Parsetree.object_field_desc -> Ast_412.Parsetree.object_field_desc = + function + | Ast_411.Parsetree.Otag (x0, x1) -> + Ast_412.Parsetree.Otag (copy_loc copy_label x0, copy_core_type x1) + | Ast_411.Parsetree.Oinherit x0 -> + Ast_412.Parsetree.Oinherit (copy_core_type x0) + +and copy_arg_label : Ast_411.Asttypes.arg_label -> Ast_412.Asttypes.arg_label = + function + | Ast_411.Asttypes.Nolabel -> Ast_412.Asttypes.Nolabel + | Ast_411.Asttypes.Labelled x0 -> Ast_412.Asttypes.Labelled x0 + | Ast_411.Asttypes.Optional x0 -> Ast_412.Asttypes.Optional x0 + +and copy_closed_flag : + Ast_411.Asttypes.closed_flag -> Ast_412.Asttypes.closed_flag = function + | Ast_411.Asttypes.Closed -> Ast_412.Asttypes.Closed + | Ast_411.Asttypes.Open -> Ast_412.Asttypes.Open + +and copy_label : Ast_411.Asttypes.label -> Ast_412.Asttypes.label = fun x -> x + +and copy_rec_flag : Ast_411.Asttypes.rec_flag -> Ast_412.Asttypes.rec_flag = + function + | Ast_411.Asttypes.Nonrecursive -> Ast_412.Asttypes.Nonrecursive + | Ast_411.Asttypes.Recursive -> Ast_412.Asttypes.Recursive + +and copy_constant : Ast_411.Parsetree.constant -> Ast_412.Parsetree.constant = + function + | Ast_411.Parsetree.Pconst_integer (x0, x1) -> + Ast_412.Parsetree.Pconst_integer (x0, Option.map (fun x -> x) x1) + | Ast_411.Parsetree.Pconst_char x0 -> Ast_412.Parsetree.Pconst_char x0 + | Ast_411.Parsetree.Pconst_string (x0, x1, x2) -> + Ast_412.Parsetree.Pconst_string + (x0, copy_location x1, Option.map (fun x -> x) x2) + | Ast_411.Parsetree.Pconst_float (x0, x1) -> + Ast_412.Parsetree.Pconst_float (x0, Option.map (fun x -> x) x1) + +and copy_Longident_t : Longident.t -> Longident.t = fun x -> x + +and copy_loc : + 'f0 'g0. + ('f0 -> 'g0) -> 'f0 Ast_411.Asttypes.loc -> 'g0 Ast_412.Asttypes.loc = + fun f0 { Ast_411.Asttypes.txt; Ast_411.Asttypes.loc } -> + { Ast_412.Asttypes.txt = f0 txt; Ast_412.Asttypes.loc = copy_location loc } + +and copy_location : Location.t -> Location.t = fun x -> x diff -Nru ppxlib-0.15.0/astlib/migrate_412_411.ml ppxlib-0.24.0/astlib/migrate_412_411.ml --- ppxlib-0.15.0/astlib/migrate_412_411.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/migrate_412_411.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1193 @@ +open Stdlib0 +module From = Ast_412 +module To = Ast_411 + +let rec copy_toplevel_phrase : + Ast_412.Parsetree.toplevel_phrase -> Ast_411.Parsetree.toplevel_phrase = + function + | Ast_412.Parsetree.Ptop_def x0 -> + Ast_411.Parsetree.Ptop_def (copy_structure x0) + | Ast_412.Parsetree.Ptop_dir x0 -> + Ast_411.Parsetree.Ptop_dir (copy_toplevel_directive x0) + +and copy_toplevel_directive : + Ast_412.Parsetree.toplevel_directive -> Ast_411.Parsetree.toplevel_directive + = + fun { + Ast_412.Parsetree.pdir_name; + Ast_412.Parsetree.pdir_arg; + Ast_412.Parsetree.pdir_loc; + } -> + { + Ast_411.Parsetree.pdir_name = copy_loc (fun x -> x) pdir_name; + Ast_411.Parsetree.pdir_arg = Option.map copy_directive_argument pdir_arg; + Ast_411.Parsetree.pdir_loc = copy_location pdir_loc; + } + +and copy_directive_argument : + Ast_412.Parsetree.directive_argument -> Ast_411.Parsetree.directive_argument + = + fun { Ast_412.Parsetree.pdira_desc; Ast_412.Parsetree.pdira_loc } -> + { + Ast_411.Parsetree.pdira_desc = copy_directive_argument_desc pdira_desc; + Ast_411.Parsetree.pdira_loc = copy_location pdira_loc; + } + +and copy_directive_argument_desc : + Ast_412.Parsetree.directive_argument_desc -> + Ast_411.Parsetree.directive_argument_desc = function + | Ast_412.Parsetree.Pdir_string x0 -> Ast_411.Parsetree.Pdir_string x0 + | Ast_412.Parsetree.Pdir_int (x0, x1) -> + Ast_411.Parsetree.Pdir_int (x0, Option.map (fun x -> x) x1) + | Ast_412.Parsetree.Pdir_ident x0 -> + Ast_411.Parsetree.Pdir_ident (copy_Longident_t x0) + | Ast_412.Parsetree.Pdir_bool x0 -> Ast_411.Parsetree.Pdir_bool x0 + +and copy_expression : + Ast_412.Parsetree.expression -> Ast_411.Parsetree.expression = + fun { + Ast_412.Parsetree.pexp_desc; + Ast_412.Parsetree.pexp_loc; + Ast_412.Parsetree.pexp_loc_stack; + Ast_412.Parsetree.pexp_attributes; + } -> + { + Ast_411.Parsetree.pexp_desc = copy_expression_desc pexp_desc; + Ast_411.Parsetree.pexp_loc = copy_location pexp_loc; + Ast_411.Parsetree.pexp_loc_stack = copy_location_stack pexp_loc_stack; + Ast_411.Parsetree.pexp_attributes = copy_attributes pexp_attributes; + } + +and copy_expression_desc : + Ast_412.Parsetree.expression_desc -> Ast_411.Parsetree.expression_desc = + function + | Ast_412.Parsetree.Pexp_ident x0 -> + Ast_411.Parsetree.Pexp_ident (copy_loc copy_Longident_t x0) + | Ast_412.Parsetree.Pexp_constant x0 -> + Ast_411.Parsetree.Pexp_constant (copy_constant x0) + | Ast_412.Parsetree.Pexp_let (x0, x1, x2) -> + Ast_411.Parsetree.Pexp_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_expression x2) + | Ast_412.Parsetree.Pexp_function x0 -> + Ast_411.Parsetree.Pexp_function (List.map copy_case x0) + | Ast_412.Parsetree.Pexp_fun (x0, x1, x2, x3) -> + Ast_411.Parsetree.Pexp_fun + ( copy_arg_label x0, + Option.map copy_expression x1, + copy_pattern x2, + copy_expression x3 ) + | Ast_412.Parsetree.Pexp_apply (x0, x1) -> + Ast_411.Parsetree.Pexp_apply + ( copy_expression x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | Ast_412.Parsetree.Pexp_match (x0, x1) -> + Ast_411.Parsetree.Pexp_match (copy_expression x0, List.map copy_case x1) + | Ast_412.Parsetree.Pexp_try (x0, x1) -> + Ast_411.Parsetree.Pexp_try (copy_expression x0, List.map copy_case x1) + | Ast_412.Parsetree.Pexp_tuple x0 -> + Ast_411.Parsetree.Pexp_tuple (List.map copy_expression x0) + | Ast_412.Parsetree.Pexp_construct (x0, x1) -> + Ast_411.Parsetree.Pexp_construct + (copy_loc copy_Longident_t x0, Option.map copy_expression x1) + | Ast_412.Parsetree.Pexp_variant (x0, x1) -> + Ast_411.Parsetree.Pexp_variant + (copy_label x0, Option.map copy_expression x1) + | Ast_412.Parsetree.Pexp_record (x0, x1) -> + Ast_411.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_412.Parsetree.Pexp_field (x0, x1) -> + Ast_411.Parsetree.Pexp_field + (copy_expression x0, copy_loc copy_Longident_t x1) + | Ast_412.Parsetree.Pexp_setfield (x0, x1, x2) -> + Ast_411.Parsetree.Pexp_setfield + (copy_expression x0, copy_loc copy_Longident_t x1, copy_expression x2) + | Ast_412.Parsetree.Pexp_array x0 -> + Ast_411.Parsetree.Pexp_array (List.map copy_expression x0) + | Ast_412.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> + Ast_411.Parsetree.Pexp_ifthenelse + (copy_expression x0, copy_expression x1, Option.map copy_expression x2) + | Ast_412.Parsetree.Pexp_sequence (x0, x1) -> + Ast_411.Parsetree.Pexp_sequence (copy_expression x0, copy_expression x1) + | Ast_412.Parsetree.Pexp_while (x0, x1) -> + Ast_411.Parsetree.Pexp_while (copy_expression x0, copy_expression x1) + | Ast_412.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> + Ast_411.Parsetree.Pexp_for + ( copy_pattern x0, + copy_expression x1, + copy_expression x2, + copy_direction_flag x3, + copy_expression x4 ) + | Ast_412.Parsetree.Pexp_constraint (x0, x1) -> + Ast_411.Parsetree.Pexp_constraint (copy_expression x0, copy_core_type x1) + | Ast_412.Parsetree.Pexp_coerce (x0, x1, x2) -> + Ast_411.Parsetree.Pexp_coerce + (copy_expression x0, Option.map copy_core_type x1, copy_core_type x2) + | Ast_412.Parsetree.Pexp_send (x0, x1) -> + Ast_411.Parsetree.Pexp_send (copy_expression x0, copy_loc copy_label x1) + | Ast_412.Parsetree.Pexp_new x0 -> + Ast_411.Parsetree.Pexp_new (copy_loc copy_Longident_t x0) + | Ast_412.Parsetree.Pexp_setinstvar (x0, x1) -> + Ast_411.Parsetree.Pexp_setinstvar + (copy_loc copy_label x0, copy_expression x1) + | Ast_412.Parsetree.Pexp_override x0 -> + Ast_411.Parsetree.Pexp_override + (List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_label x0, copy_expression x1)) + x0) + | Ast_412.Parsetree.Pexp_letmodule (x0, x1, x2) -> + Ast_411.Parsetree.Pexp_letmodule + ( copy_loc (fun x -> Option.map (fun x -> x) x) x0, + copy_module_expr x1, + copy_expression x2 ) + | Ast_412.Parsetree.Pexp_letexception (x0, x1) -> + Ast_411.Parsetree.Pexp_letexception + (copy_extension_constructor x0, copy_expression x1) + | Ast_412.Parsetree.Pexp_assert x0 -> + Ast_411.Parsetree.Pexp_assert (copy_expression x0) + | Ast_412.Parsetree.Pexp_lazy x0 -> + Ast_411.Parsetree.Pexp_lazy (copy_expression x0) + | Ast_412.Parsetree.Pexp_poly (x0, x1) -> + Ast_411.Parsetree.Pexp_poly + (copy_expression x0, Option.map copy_core_type x1) + | Ast_412.Parsetree.Pexp_object x0 -> + Ast_411.Parsetree.Pexp_object (copy_class_structure x0) + | Ast_412.Parsetree.Pexp_newtype (x0, x1) -> + Ast_411.Parsetree.Pexp_newtype + (copy_loc (fun x -> x) x0, copy_expression x1) + | Ast_412.Parsetree.Pexp_pack x0 -> + Ast_411.Parsetree.Pexp_pack (copy_module_expr x0) + | Ast_412.Parsetree.Pexp_open (x0, x1) -> + Ast_411.Parsetree.Pexp_open (copy_open_declaration x0, copy_expression x1) + | Ast_412.Parsetree.Pexp_letop x0 -> + Ast_411.Parsetree.Pexp_letop (copy_letop x0) + | Ast_412.Parsetree.Pexp_extension x0 -> + Ast_411.Parsetree.Pexp_extension (copy_extension x0) + | Ast_412.Parsetree.Pexp_unreachable -> Ast_411.Parsetree.Pexp_unreachable + +and copy_letop : Ast_412.Parsetree.letop -> Ast_411.Parsetree.letop = + fun { Ast_412.Parsetree.let_; Ast_412.Parsetree.ands; Ast_412.Parsetree.body } -> + { + Ast_411.Parsetree.let_ = copy_binding_op let_; + Ast_411.Parsetree.ands = List.map copy_binding_op ands; + Ast_411.Parsetree.body = copy_expression body; + } + +and copy_binding_op : + Ast_412.Parsetree.binding_op -> Ast_411.Parsetree.binding_op = + fun { + Ast_412.Parsetree.pbop_op; + Ast_412.Parsetree.pbop_pat; + Ast_412.Parsetree.pbop_exp; + Ast_412.Parsetree.pbop_loc; + } -> + { + Ast_411.Parsetree.pbop_op = copy_loc (fun x -> x) pbop_op; + Ast_411.Parsetree.pbop_pat = copy_pattern pbop_pat; + Ast_411.Parsetree.pbop_exp = copy_expression pbop_exp; + Ast_411.Parsetree.pbop_loc = copy_location pbop_loc; + } + +and copy_direction_flag : + Ast_412.Asttypes.direction_flag -> Ast_411.Asttypes.direction_flag = + function + | Ast_412.Asttypes.Upto -> Ast_411.Asttypes.Upto + | Ast_412.Asttypes.Downto -> Ast_411.Asttypes.Downto + +and copy_case : Ast_412.Parsetree.case -> Ast_411.Parsetree.case = + fun { + Ast_412.Parsetree.pc_lhs; + Ast_412.Parsetree.pc_guard; + Ast_412.Parsetree.pc_rhs; + } -> + { + Ast_411.Parsetree.pc_lhs = copy_pattern pc_lhs; + Ast_411.Parsetree.pc_guard = Option.map copy_expression pc_guard; + Ast_411.Parsetree.pc_rhs = copy_expression pc_rhs; + } + +and copy_value_binding : + Ast_412.Parsetree.value_binding -> Ast_411.Parsetree.value_binding = + fun { + Ast_412.Parsetree.pvb_pat; + Ast_412.Parsetree.pvb_expr; + Ast_412.Parsetree.pvb_attributes; + Ast_412.Parsetree.pvb_loc; + } -> + { + Ast_411.Parsetree.pvb_pat = copy_pattern pvb_pat; + Ast_411.Parsetree.pvb_expr = copy_expression pvb_expr; + Ast_411.Parsetree.pvb_attributes = copy_attributes pvb_attributes; + Ast_411.Parsetree.pvb_loc = copy_location pvb_loc; + } + +and copy_pattern : Ast_412.Parsetree.pattern -> Ast_411.Parsetree.pattern = + fun { + Ast_412.Parsetree.ppat_desc; + Ast_412.Parsetree.ppat_loc; + Ast_412.Parsetree.ppat_loc_stack; + Ast_412.Parsetree.ppat_attributes; + } -> + { + Ast_411.Parsetree.ppat_desc = copy_pattern_desc ppat_desc; + Ast_411.Parsetree.ppat_loc = copy_location ppat_loc; + Ast_411.Parsetree.ppat_loc_stack = copy_location_stack ppat_loc_stack; + Ast_411.Parsetree.ppat_attributes = copy_attributes ppat_attributes; + } + +and copy_pattern_desc : + Ast_412.Parsetree.pattern_desc -> Ast_411.Parsetree.pattern_desc = function + | Ast_412.Parsetree.Ppat_any -> Ast_411.Parsetree.Ppat_any + | Ast_412.Parsetree.Ppat_var x0 -> + Ast_411.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) + | Ast_412.Parsetree.Ppat_alias (x0, x1) -> + Ast_411.Parsetree.Ppat_alias (copy_pattern x0, copy_loc (fun x -> x) x1) + | Ast_412.Parsetree.Ppat_constant x0 -> + Ast_411.Parsetree.Ppat_constant (copy_constant x0) + | Ast_412.Parsetree.Ppat_interval (x0, x1) -> + Ast_411.Parsetree.Ppat_interval (copy_constant x0, copy_constant x1) + | Ast_412.Parsetree.Ppat_tuple x0 -> + Ast_411.Parsetree.Ppat_tuple (List.map copy_pattern x0) + | Ast_412.Parsetree.Ppat_construct (x0, x1) -> + Ast_411.Parsetree.Ppat_construct + (copy_loc copy_Longident_t x0, Option.map copy_pattern x1) + | Ast_412.Parsetree.Ppat_variant (x0, x1) -> + Ast_411.Parsetree.Ppat_variant (copy_label x0, Option.map copy_pattern x1) + | Ast_412.Parsetree.Ppat_record (x0, x1) -> + Ast_411.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_412.Parsetree.Ppat_array x0 -> + Ast_411.Parsetree.Ppat_array (List.map copy_pattern x0) + | Ast_412.Parsetree.Ppat_or (x0, x1) -> + Ast_411.Parsetree.Ppat_or (copy_pattern x0, copy_pattern x1) + | Ast_412.Parsetree.Ppat_constraint (x0, x1) -> + Ast_411.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1) + | Ast_412.Parsetree.Ppat_type x0 -> + Ast_411.Parsetree.Ppat_type (copy_loc copy_Longident_t x0) + | Ast_412.Parsetree.Ppat_lazy x0 -> + Ast_411.Parsetree.Ppat_lazy (copy_pattern x0) + | Ast_412.Parsetree.Ppat_unpack x0 -> + Ast_411.Parsetree.Ppat_unpack + (copy_loc (fun x -> Option.map (fun x -> x) x) x0) + | Ast_412.Parsetree.Ppat_exception x0 -> + Ast_411.Parsetree.Ppat_exception (copy_pattern x0) + | Ast_412.Parsetree.Ppat_extension x0 -> + Ast_411.Parsetree.Ppat_extension (copy_extension x0) + | Ast_412.Parsetree.Ppat_open (x0, x1) -> + Ast_411.Parsetree.Ppat_open (copy_loc copy_Longident_t x0, copy_pattern x1) + +and copy_core_type : Ast_412.Parsetree.core_type -> Ast_411.Parsetree.core_type + = + fun { + Ast_412.Parsetree.ptyp_desc; + Ast_412.Parsetree.ptyp_loc; + Ast_412.Parsetree.ptyp_loc_stack; + Ast_412.Parsetree.ptyp_attributes; + } -> + { + Ast_411.Parsetree.ptyp_desc = copy_core_type_desc ptyp_desc; + Ast_411.Parsetree.ptyp_loc = copy_location ptyp_loc; + Ast_411.Parsetree.ptyp_loc_stack = copy_location_stack ptyp_loc_stack; + Ast_411.Parsetree.ptyp_attributes = copy_attributes ptyp_attributes; + } + +and copy_location_stack : + Ast_412.Parsetree.location_stack -> Ast_411.Parsetree.location_stack = + fun x -> x + +and copy_core_type_desc : + Ast_412.Parsetree.core_type_desc -> Ast_411.Parsetree.core_type_desc = + function + | Ast_412.Parsetree.Ptyp_any -> Ast_411.Parsetree.Ptyp_any + | Ast_412.Parsetree.Ptyp_var x0 -> Ast_411.Parsetree.Ptyp_var x0 + | Ast_412.Parsetree.Ptyp_arrow (x0, x1, x2) -> + Ast_411.Parsetree.Ptyp_arrow + (copy_arg_label x0, copy_core_type x1, copy_core_type x2) + | Ast_412.Parsetree.Ptyp_tuple x0 -> + Ast_411.Parsetree.Ptyp_tuple (List.map copy_core_type x0) + | Ast_412.Parsetree.Ptyp_constr (x0, x1) -> + Ast_411.Parsetree.Ptyp_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_412.Parsetree.Ptyp_object (x0, x1) -> + Ast_411.Parsetree.Ptyp_object + (List.map copy_object_field x0, copy_closed_flag x1) + | Ast_412.Parsetree.Ptyp_class (x0, x1) -> + Ast_411.Parsetree.Ptyp_class + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_412.Parsetree.Ptyp_alias (x0, x1) -> + Ast_411.Parsetree.Ptyp_alias (copy_core_type x0, x1) + | Ast_412.Parsetree.Ptyp_variant (x0, x1, x2) -> + Ast_411.Parsetree.Ptyp_variant + ( List.map copy_row_field x0, + copy_closed_flag x1, + Option.map (fun x -> List.map copy_label x) x2 ) + | Ast_412.Parsetree.Ptyp_poly (x0, x1) -> + Ast_411.Parsetree.Ptyp_poly + (List.map (fun x -> copy_loc (fun x -> x) x) x0, copy_core_type x1) + | Ast_412.Parsetree.Ptyp_package x0 -> + Ast_411.Parsetree.Ptyp_package (copy_package_type x0) + | Ast_412.Parsetree.Ptyp_extension x0 -> + Ast_411.Parsetree.Ptyp_extension (copy_extension x0) + +and copy_package_type : + Ast_412.Parsetree.package_type -> Ast_411.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_412.Parsetree.row_field -> Ast_411.Parsetree.row_field + = + fun { + Ast_412.Parsetree.prf_desc; + Ast_412.Parsetree.prf_loc; + Ast_412.Parsetree.prf_attributes; + } -> + { + Ast_411.Parsetree.prf_desc = copy_row_field_desc prf_desc; + Ast_411.Parsetree.prf_loc = copy_location prf_loc; + Ast_411.Parsetree.prf_attributes = copy_attributes prf_attributes; + } + +and copy_row_field_desc : + Ast_412.Parsetree.row_field_desc -> Ast_411.Parsetree.row_field_desc = + function + | Ast_412.Parsetree.Rtag (x0, x1, x2) -> + Ast_411.Parsetree.Rtag + (copy_loc copy_label x0, x1, List.map copy_core_type x2) + | Ast_412.Parsetree.Rinherit x0 -> + Ast_411.Parsetree.Rinherit (copy_core_type x0) + +and copy_object_field : + Ast_412.Parsetree.object_field -> Ast_411.Parsetree.object_field = + fun { + Ast_412.Parsetree.pof_desc; + Ast_412.Parsetree.pof_loc; + Ast_412.Parsetree.pof_attributes; + } -> + { + Ast_411.Parsetree.pof_desc = copy_object_field_desc pof_desc; + Ast_411.Parsetree.pof_loc = copy_location pof_loc; + Ast_411.Parsetree.pof_attributes = copy_attributes pof_attributes; + } + +and copy_attributes : + Ast_412.Parsetree.attributes -> Ast_411.Parsetree.attributes = + fun x -> List.map copy_attribute x + +and copy_attribute : Ast_412.Parsetree.attribute -> Ast_411.Parsetree.attribute + = + fun { + Ast_412.Parsetree.attr_name; + Ast_412.Parsetree.attr_payload; + Ast_412.Parsetree.attr_loc; + } -> + { + Ast_411.Parsetree.attr_name = copy_loc (fun x -> x) attr_name; + Ast_411.Parsetree.attr_payload = copy_payload attr_payload; + Ast_411.Parsetree.attr_loc = copy_location attr_loc; + } + +and copy_payload : Ast_412.Parsetree.payload -> Ast_411.Parsetree.payload = + function + | Ast_412.Parsetree.PStr x0 -> Ast_411.Parsetree.PStr (copy_structure x0) + | Ast_412.Parsetree.PSig x0 -> Ast_411.Parsetree.PSig (copy_signature x0) + | Ast_412.Parsetree.PTyp x0 -> Ast_411.Parsetree.PTyp (copy_core_type x0) + | Ast_412.Parsetree.PPat (x0, x1) -> + Ast_411.Parsetree.PPat (copy_pattern x0, Option.map copy_expression x1) + +and copy_structure : Ast_412.Parsetree.structure -> Ast_411.Parsetree.structure + = + fun x -> List.map copy_structure_item x + +and copy_structure_item : + Ast_412.Parsetree.structure_item -> Ast_411.Parsetree.structure_item = + fun { Ast_412.Parsetree.pstr_desc; Ast_412.Parsetree.pstr_loc } -> + { + Ast_411.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc; + Ast_411.Parsetree.pstr_loc = copy_location pstr_loc; + } + +and copy_structure_item_desc : + Ast_412.Parsetree.structure_item_desc -> + Ast_411.Parsetree.structure_item_desc = function + | Ast_412.Parsetree.Pstr_eval (x0, x1) -> + Ast_411.Parsetree.Pstr_eval (copy_expression x0, copy_attributes x1) + | Ast_412.Parsetree.Pstr_value (x0, x1) -> + Ast_411.Parsetree.Pstr_value + (copy_rec_flag x0, List.map copy_value_binding x1) + | Ast_412.Parsetree.Pstr_primitive x0 -> + Ast_411.Parsetree.Pstr_primitive (copy_value_description x0) + | Ast_412.Parsetree.Pstr_type (x0, x1) -> + Ast_411.Parsetree.Pstr_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | Ast_412.Parsetree.Pstr_typext x0 -> + Ast_411.Parsetree.Pstr_typext (copy_type_extension x0) + | Ast_412.Parsetree.Pstr_exception x0 -> + Ast_411.Parsetree.Pstr_exception (copy_type_exception x0) + | Ast_412.Parsetree.Pstr_module x0 -> + Ast_411.Parsetree.Pstr_module (copy_module_binding x0) + | Ast_412.Parsetree.Pstr_recmodule x0 -> + Ast_411.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) + | Ast_412.Parsetree.Pstr_modtype x0 -> + Ast_411.Parsetree.Pstr_modtype (copy_module_type_declaration x0) + | Ast_412.Parsetree.Pstr_open x0 -> + Ast_411.Parsetree.Pstr_open (copy_open_declaration x0) + | Ast_412.Parsetree.Pstr_class x0 -> + Ast_411.Parsetree.Pstr_class (List.map copy_class_declaration x0) + | Ast_412.Parsetree.Pstr_class_type x0 -> + Ast_411.Parsetree.Pstr_class_type + (List.map copy_class_type_declaration x0) + | Ast_412.Parsetree.Pstr_include x0 -> + Ast_411.Parsetree.Pstr_include (copy_include_declaration x0) + | Ast_412.Parsetree.Pstr_attribute x0 -> + Ast_411.Parsetree.Pstr_attribute (copy_attribute x0) + | Ast_412.Parsetree.Pstr_extension (x0, x1) -> + Ast_411.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1) + +and copy_include_declaration : + Ast_412.Parsetree.include_declaration -> + Ast_411.Parsetree.include_declaration = + fun x -> copy_include_infos copy_module_expr x + +and copy_class_declaration : + Ast_412.Parsetree.class_declaration -> Ast_411.Parsetree.class_declaration = + fun x -> copy_class_infos copy_class_expr x + +and copy_class_expr : + Ast_412.Parsetree.class_expr -> Ast_411.Parsetree.class_expr = + fun { + Ast_412.Parsetree.pcl_desc; + Ast_412.Parsetree.pcl_loc; + Ast_412.Parsetree.pcl_attributes; + } -> + { + Ast_411.Parsetree.pcl_desc = copy_class_expr_desc pcl_desc; + Ast_411.Parsetree.pcl_loc = copy_location pcl_loc; + Ast_411.Parsetree.pcl_attributes = copy_attributes pcl_attributes; + } + +and copy_class_expr_desc : + Ast_412.Parsetree.class_expr_desc -> Ast_411.Parsetree.class_expr_desc = + function + | Ast_412.Parsetree.Pcl_constr (x0, x1) -> + Ast_411.Parsetree.Pcl_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_412.Parsetree.Pcl_structure x0 -> + Ast_411.Parsetree.Pcl_structure (copy_class_structure x0) + | Ast_412.Parsetree.Pcl_fun (x0, x1, x2, x3) -> + Ast_411.Parsetree.Pcl_fun + ( copy_arg_label x0, + Option.map copy_expression x1, + copy_pattern x2, + copy_class_expr x3 ) + | Ast_412.Parsetree.Pcl_apply (x0, x1) -> + Ast_411.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_412.Parsetree.Pcl_let (x0, x1, x2) -> + Ast_411.Parsetree.Pcl_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_class_expr x2) + | Ast_412.Parsetree.Pcl_constraint (x0, x1) -> + Ast_411.Parsetree.Pcl_constraint (copy_class_expr x0, copy_class_type x1) + | Ast_412.Parsetree.Pcl_extension x0 -> + Ast_411.Parsetree.Pcl_extension (copy_extension x0) + | Ast_412.Parsetree.Pcl_open (x0, x1) -> + Ast_411.Parsetree.Pcl_open (copy_open_description x0, copy_class_expr x1) + +and copy_class_structure : + Ast_412.Parsetree.class_structure -> Ast_411.Parsetree.class_structure = + fun { Ast_412.Parsetree.pcstr_self; Ast_412.Parsetree.pcstr_fields } -> + { + Ast_411.Parsetree.pcstr_self = copy_pattern pcstr_self; + Ast_411.Parsetree.pcstr_fields = List.map copy_class_field pcstr_fields; + } + +and copy_class_field : + Ast_412.Parsetree.class_field -> Ast_411.Parsetree.class_field = + fun { + Ast_412.Parsetree.pcf_desc; + Ast_412.Parsetree.pcf_loc; + Ast_412.Parsetree.pcf_attributes; + } -> + { + Ast_411.Parsetree.pcf_desc = copy_class_field_desc pcf_desc; + Ast_411.Parsetree.pcf_loc = copy_location pcf_loc; + Ast_411.Parsetree.pcf_attributes = copy_attributes pcf_attributes; + } + +and copy_class_field_desc : + Ast_412.Parsetree.class_field_desc -> Ast_411.Parsetree.class_field_desc = + function + | Ast_412.Parsetree.Pcf_inherit (x0, x1, x2) -> + Ast_411.Parsetree.Pcf_inherit + ( copy_override_flag x0, + copy_class_expr x1, + Option.map (fun x -> copy_loc (fun x -> x) x) x2 ) + | Ast_412.Parsetree.Pcf_val x0 -> + Ast_411.Parsetree.Pcf_val + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_mutable_flag x1, copy_class_field_kind x2)) + | Ast_412.Parsetree.Pcf_method x0 -> + Ast_411.Parsetree.Pcf_method + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_private_flag x1, copy_class_field_kind x2)) + | Ast_412.Parsetree.Pcf_constraint x0 -> + Ast_411.Parsetree.Pcf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | Ast_412.Parsetree.Pcf_initializer x0 -> + Ast_411.Parsetree.Pcf_initializer (copy_expression x0) + | Ast_412.Parsetree.Pcf_attribute x0 -> + Ast_411.Parsetree.Pcf_attribute (copy_attribute x0) + | Ast_412.Parsetree.Pcf_extension x0 -> + Ast_411.Parsetree.Pcf_extension (copy_extension x0) + +and copy_class_field_kind : + Ast_412.Parsetree.class_field_kind -> Ast_411.Parsetree.class_field_kind = + function + | Ast_412.Parsetree.Cfk_virtual x0 -> + Ast_411.Parsetree.Cfk_virtual (copy_core_type x0) + | Ast_412.Parsetree.Cfk_concrete (x0, x1) -> + Ast_411.Parsetree.Cfk_concrete (copy_override_flag x0, copy_expression x1) + +and copy_open_declaration : + Ast_412.Parsetree.open_declaration -> Ast_411.Parsetree.open_declaration = + fun x -> copy_open_infos copy_module_expr x + +and copy_module_binding : + Ast_412.Parsetree.module_binding -> Ast_411.Parsetree.module_binding = + fun { + Ast_412.Parsetree.pmb_name; + Ast_412.Parsetree.pmb_expr; + Ast_412.Parsetree.pmb_attributes; + Ast_412.Parsetree.pmb_loc; + } -> + { + Ast_411.Parsetree.pmb_name = + copy_loc (fun x -> Option.map (fun x -> x) x) pmb_name; + Ast_411.Parsetree.pmb_expr = copy_module_expr pmb_expr; + Ast_411.Parsetree.pmb_attributes = copy_attributes pmb_attributes; + Ast_411.Parsetree.pmb_loc = copy_location pmb_loc; + } + +and copy_module_expr : + Ast_412.Parsetree.module_expr -> Ast_411.Parsetree.module_expr = + fun { + Ast_412.Parsetree.pmod_desc; + Ast_412.Parsetree.pmod_loc; + Ast_412.Parsetree.pmod_attributes; + } -> + { + Ast_411.Parsetree.pmod_desc = copy_module_expr_desc pmod_desc; + Ast_411.Parsetree.pmod_loc = copy_location pmod_loc; + Ast_411.Parsetree.pmod_attributes = copy_attributes pmod_attributes; + } + +and copy_module_expr_desc : + Ast_412.Parsetree.module_expr_desc -> Ast_411.Parsetree.module_expr_desc = + function + | Ast_412.Parsetree.Pmod_ident x0 -> + Ast_411.Parsetree.Pmod_ident (copy_loc copy_Longident_t x0) + | Ast_412.Parsetree.Pmod_structure x0 -> + Ast_411.Parsetree.Pmod_structure (copy_structure x0) + | Ast_412.Parsetree.Pmod_functor (x0, x1) -> + Ast_411.Parsetree.Pmod_functor + (copy_functor_parameter x0, copy_module_expr x1) + | Ast_412.Parsetree.Pmod_apply (x0, x1) -> + Ast_411.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) + | Ast_412.Parsetree.Pmod_constraint (x0, x1) -> + Ast_411.Parsetree.Pmod_constraint + (copy_module_expr x0, copy_module_type x1) + | Ast_412.Parsetree.Pmod_unpack x0 -> + Ast_411.Parsetree.Pmod_unpack (copy_expression x0) + | Ast_412.Parsetree.Pmod_extension x0 -> + Ast_411.Parsetree.Pmod_extension (copy_extension x0) + +and copy_functor_parameter : + Ast_412.Parsetree.functor_parameter -> Ast_411.Parsetree.functor_parameter = + function + | Ast_412.Parsetree.Unit -> Ast_411.Parsetree.Unit + | Ast_412.Parsetree.Named (x0, x1) -> + Ast_411.Parsetree.Named + (copy_loc (fun x -> Option.map (fun x -> x) x) x0, copy_module_type x1) + +and copy_module_type : + Ast_412.Parsetree.module_type -> Ast_411.Parsetree.module_type = + fun { + Ast_412.Parsetree.pmty_desc; + Ast_412.Parsetree.pmty_loc; + Ast_412.Parsetree.pmty_attributes; + } -> + { + Ast_411.Parsetree.pmty_desc = copy_module_type_desc pmty_desc; + Ast_411.Parsetree.pmty_loc = copy_location pmty_loc; + Ast_411.Parsetree.pmty_attributes = copy_attributes pmty_attributes; + } + +and copy_module_type_desc : + Ast_412.Parsetree.module_type_desc -> Ast_411.Parsetree.module_type_desc = + function + | Ast_412.Parsetree.Pmty_ident x0 -> + Ast_411.Parsetree.Pmty_ident (copy_loc copy_Longident_t x0) + | Ast_412.Parsetree.Pmty_signature x0 -> + Ast_411.Parsetree.Pmty_signature (copy_signature x0) + | Ast_412.Parsetree.Pmty_functor (x0, x1) -> + Ast_411.Parsetree.Pmty_functor + (copy_functor_parameter x0, copy_module_type x1) + | Ast_412.Parsetree.Pmty_with (x0, x1) -> + Ast_411.Parsetree.Pmty_with + (copy_module_type x0, List.map copy_with_constraint x1) + | Ast_412.Parsetree.Pmty_typeof x0 -> + Ast_411.Parsetree.Pmty_typeof (copy_module_expr x0) + | Ast_412.Parsetree.Pmty_extension x0 -> + Ast_411.Parsetree.Pmty_extension (copy_extension x0) + | Ast_412.Parsetree.Pmty_alias x0 -> + Ast_411.Parsetree.Pmty_alias (copy_loc copy_Longident_t x0) + +and copy_with_constraint : + Ast_412.Parsetree.with_constraint -> Ast_411.Parsetree.with_constraint = + function + | Ast_412.Parsetree.Pwith_type (x0, x1) -> + Ast_411.Parsetree.Pwith_type + (copy_loc copy_Longident_t x0, copy_type_declaration x1) + | Ast_412.Parsetree.Pwith_module (x0, x1) -> + Ast_411.Parsetree.Pwith_module + (copy_loc copy_Longident_t x0, copy_loc copy_Longident_t x1) + | Ast_412.Parsetree.Pwith_typesubst (x0, x1) -> + Ast_411.Parsetree.Pwith_typesubst + (copy_loc copy_Longident_t x0, copy_type_declaration x1) + | Ast_412.Parsetree.Pwith_modsubst (x0, x1) -> + Ast_411.Parsetree.Pwith_modsubst + (copy_loc copy_Longident_t x0, copy_loc copy_Longident_t x1) + +and copy_signature : Ast_412.Parsetree.signature -> Ast_411.Parsetree.signature + = + fun x -> List.map copy_signature_item x + +and copy_signature_item : + Ast_412.Parsetree.signature_item -> Ast_411.Parsetree.signature_item = + fun { Ast_412.Parsetree.psig_desc; Ast_412.Parsetree.psig_loc } -> + { + Ast_411.Parsetree.psig_desc = copy_signature_item_desc psig_desc; + Ast_411.Parsetree.psig_loc = copy_location psig_loc; + } + +and copy_signature_item_desc : + Ast_412.Parsetree.signature_item_desc -> + Ast_411.Parsetree.signature_item_desc = function + | Ast_412.Parsetree.Psig_value x0 -> + Ast_411.Parsetree.Psig_value (copy_value_description x0) + | Ast_412.Parsetree.Psig_type (x0, x1) -> + Ast_411.Parsetree.Psig_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | Ast_412.Parsetree.Psig_typesubst x0 -> + Ast_411.Parsetree.Psig_typesubst (List.map copy_type_declaration x0) + | Ast_412.Parsetree.Psig_typext x0 -> + Ast_411.Parsetree.Psig_typext (copy_type_extension x0) + | Ast_412.Parsetree.Psig_exception x0 -> + Ast_411.Parsetree.Psig_exception (copy_type_exception x0) + | Ast_412.Parsetree.Psig_module x0 -> + Ast_411.Parsetree.Psig_module (copy_module_declaration x0) + | Ast_412.Parsetree.Psig_modsubst x0 -> + Ast_411.Parsetree.Psig_modsubst (copy_module_substitution x0) + | Ast_412.Parsetree.Psig_recmodule x0 -> + Ast_411.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) + | Ast_412.Parsetree.Psig_modtype x0 -> + Ast_411.Parsetree.Psig_modtype (copy_module_type_declaration x0) + | Ast_412.Parsetree.Psig_open x0 -> + Ast_411.Parsetree.Psig_open (copy_open_description x0) + | Ast_412.Parsetree.Psig_include x0 -> + Ast_411.Parsetree.Psig_include (copy_include_description x0) + | Ast_412.Parsetree.Psig_class x0 -> + Ast_411.Parsetree.Psig_class (List.map copy_class_description x0) + | Ast_412.Parsetree.Psig_class_type x0 -> + Ast_411.Parsetree.Psig_class_type + (List.map copy_class_type_declaration x0) + | Ast_412.Parsetree.Psig_attribute x0 -> + Ast_411.Parsetree.Psig_attribute (copy_attribute x0) + | Ast_412.Parsetree.Psig_extension (x0, x1) -> + Ast_411.Parsetree.Psig_extension (copy_extension x0, copy_attributes x1) + +and copy_class_type_declaration : + Ast_412.Parsetree.class_type_declaration -> + Ast_411.Parsetree.class_type_declaration = + fun x -> copy_class_infos copy_class_type x + +and copy_class_description : + Ast_412.Parsetree.class_description -> Ast_411.Parsetree.class_description = + fun x -> copy_class_infos copy_class_type x + +and copy_class_type : + Ast_412.Parsetree.class_type -> Ast_411.Parsetree.class_type = + fun { + Ast_412.Parsetree.pcty_desc; + Ast_412.Parsetree.pcty_loc; + Ast_412.Parsetree.pcty_attributes; + } -> + { + Ast_411.Parsetree.pcty_desc = copy_class_type_desc pcty_desc; + Ast_411.Parsetree.pcty_loc = copy_location pcty_loc; + Ast_411.Parsetree.pcty_attributes = copy_attributes pcty_attributes; + } + +and copy_class_type_desc : + Ast_412.Parsetree.class_type_desc -> Ast_411.Parsetree.class_type_desc = + function + | Ast_412.Parsetree.Pcty_constr (x0, x1) -> + Ast_411.Parsetree.Pcty_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_412.Parsetree.Pcty_signature x0 -> + Ast_411.Parsetree.Pcty_signature (copy_class_signature x0) + | Ast_412.Parsetree.Pcty_arrow (x0, x1, x2) -> + Ast_411.Parsetree.Pcty_arrow + (copy_arg_label x0, copy_core_type x1, copy_class_type x2) + | Ast_412.Parsetree.Pcty_extension x0 -> + Ast_411.Parsetree.Pcty_extension (copy_extension x0) + | Ast_412.Parsetree.Pcty_open (x0, x1) -> + Ast_411.Parsetree.Pcty_open (copy_open_description x0, copy_class_type x1) + +and copy_class_signature : + Ast_412.Parsetree.class_signature -> Ast_411.Parsetree.class_signature = + fun { Ast_412.Parsetree.pcsig_self; Ast_412.Parsetree.pcsig_fields } -> + { + Ast_411.Parsetree.pcsig_self = copy_core_type pcsig_self; + Ast_411.Parsetree.pcsig_fields = List.map copy_class_type_field pcsig_fields; + } + +and copy_class_type_field : + Ast_412.Parsetree.class_type_field -> Ast_411.Parsetree.class_type_field = + fun { + Ast_412.Parsetree.pctf_desc; + Ast_412.Parsetree.pctf_loc; + Ast_412.Parsetree.pctf_attributes; + } -> + { + Ast_411.Parsetree.pctf_desc = copy_class_type_field_desc pctf_desc; + Ast_411.Parsetree.pctf_loc = copy_location pctf_loc; + Ast_411.Parsetree.pctf_attributes = copy_attributes pctf_attributes; + } + +and copy_class_type_field_desc : + Ast_412.Parsetree.class_type_field_desc -> + Ast_411.Parsetree.class_type_field_desc = function + | Ast_412.Parsetree.Pctf_inherit x0 -> + Ast_411.Parsetree.Pctf_inherit (copy_class_type x0) + | Ast_412.Parsetree.Pctf_val x0 -> + Ast_411.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_412.Parsetree.Pctf_method x0 -> + Ast_411.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_412.Parsetree.Pctf_constraint x0 -> + Ast_411.Parsetree.Pctf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | Ast_412.Parsetree.Pctf_attribute x0 -> + Ast_411.Parsetree.Pctf_attribute (copy_attribute x0) + | Ast_412.Parsetree.Pctf_extension x0 -> + Ast_411.Parsetree.Pctf_extension (copy_extension x0) + +and copy_extension : Ast_412.Parsetree.extension -> Ast_411.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_412.Parsetree.class_infos -> + 'g0 Ast_411.Parsetree.class_infos = + fun f0 + { + Ast_412.Parsetree.pci_virt; + Ast_412.Parsetree.pci_params; + Ast_412.Parsetree.pci_name; + Ast_412.Parsetree.pci_expr; + Ast_412.Parsetree.pci_loc; + Ast_412.Parsetree.pci_attributes; + } -> + { + Ast_411.Parsetree.pci_virt = copy_virtual_flag pci_virt; + Ast_411.Parsetree.pci_params = + List.map + (fun x -> + let x0, x1 = x in + ( copy_core_type x0, + let x0, _ = x1 in + copy_variance x0 )) + pci_params; + Ast_411.Parsetree.pci_name = copy_loc (fun x -> x) pci_name; + Ast_411.Parsetree.pci_expr = f0 pci_expr; + Ast_411.Parsetree.pci_loc = copy_location pci_loc; + Ast_411.Parsetree.pci_attributes = copy_attributes pci_attributes; + } + +and copy_virtual_flag : + Ast_412.Asttypes.virtual_flag -> Ast_411.Asttypes.virtual_flag = function + | Ast_412.Asttypes.Virtual -> Ast_411.Asttypes.Virtual + | Ast_412.Asttypes.Concrete -> Ast_411.Asttypes.Concrete + +and copy_include_description : + Ast_412.Parsetree.include_description -> + Ast_411.Parsetree.include_description = + fun x -> copy_include_infos copy_module_type x + +and copy_include_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 Ast_412.Parsetree.include_infos -> + 'g0 Ast_411.Parsetree.include_infos = + fun f0 + { + Ast_412.Parsetree.pincl_mod; + Ast_412.Parsetree.pincl_loc; + Ast_412.Parsetree.pincl_attributes; + } -> + { + Ast_411.Parsetree.pincl_mod = f0 pincl_mod; + Ast_411.Parsetree.pincl_loc = copy_location pincl_loc; + Ast_411.Parsetree.pincl_attributes = copy_attributes pincl_attributes; + } + +and copy_open_description : + Ast_412.Parsetree.open_description -> Ast_411.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_412.Parsetree.open_infos -> + 'g0 Ast_411.Parsetree.open_infos = + fun f0 + { + Ast_412.Parsetree.popen_expr; + Ast_412.Parsetree.popen_override; + Ast_412.Parsetree.popen_loc; + Ast_412.Parsetree.popen_attributes; + } -> + { + Ast_411.Parsetree.popen_expr = f0 popen_expr; + Ast_411.Parsetree.popen_override = copy_override_flag popen_override; + Ast_411.Parsetree.popen_loc = copy_location popen_loc; + Ast_411.Parsetree.popen_attributes = copy_attributes popen_attributes; + } + +and copy_override_flag : + Ast_412.Asttypes.override_flag -> Ast_411.Asttypes.override_flag = function + | Ast_412.Asttypes.Override -> Ast_411.Asttypes.Override + | Ast_412.Asttypes.Fresh -> Ast_411.Asttypes.Fresh + +and copy_module_type_declaration : + Ast_412.Parsetree.module_type_declaration -> + Ast_411.Parsetree.module_type_declaration = + fun { + Ast_412.Parsetree.pmtd_name; + Ast_412.Parsetree.pmtd_type; + Ast_412.Parsetree.pmtd_attributes; + Ast_412.Parsetree.pmtd_loc; + } -> + { + Ast_411.Parsetree.pmtd_name = copy_loc (fun x -> x) pmtd_name; + Ast_411.Parsetree.pmtd_type = Option.map copy_module_type pmtd_type; + Ast_411.Parsetree.pmtd_attributes = copy_attributes pmtd_attributes; + Ast_411.Parsetree.pmtd_loc = copy_location pmtd_loc; + } + +and copy_module_substitution : + Ast_412.Parsetree.module_substitution -> + Ast_411.Parsetree.module_substitution = + fun { + Ast_412.Parsetree.pms_name; + Ast_412.Parsetree.pms_manifest; + Ast_412.Parsetree.pms_attributes; + Ast_412.Parsetree.pms_loc; + } -> + { + Ast_411.Parsetree.pms_name = copy_loc (fun x -> x) pms_name; + Ast_411.Parsetree.pms_manifest = copy_loc copy_Longident_t pms_manifest; + Ast_411.Parsetree.pms_attributes = copy_attributes pms_attributes; + Ast_411.Parsetree.pms_loc = copy_location pms_loc; + } + +and copy_module_declaration : + Ast_412.Parsetree.module_declaration -> Ast_411.Parsetree.module_declaration + = + fun { + Ast_412.Parsetree.pmd_name; + Ast_412.Parsetree.pmd_type; + Ast_412.Parsetree.pmd_attributes; + Ast_412.Parsetree.pmd_loc; + } -> + { + Ast_411.Parsetree.pmd_name = + copy_loc (fun x -> Option.map (fun x -> x) x) pmd_name; + Ast_411.Parsetree.pmd_type = copy_module_type pmd_type; + Ast_411.Parsetree.pmd_attributes = copy_attributes pmd_attributes; + Ast_411.Parsetree.pmd_loc = copy_location pmd_loc; + } + +and copy_type_exception : + Ast_412.Parsetree.type_exception -> Ast_411.Parsetree.type_exception = + fun { + Ast_412.Parsetree.ptyexn_constructor; + Ast_412.Parsetree.ptyexn_loc; + Ast_412.Parsetree.ptyexn_attributes; + } -> + { + Ast_411.Parsetree.ptyexn_constructor = + copy_extension_constructor ptyexn_constructor; + Ast_411.Parsetree.ptyexn_loc = copy_location ptyexn_loc; + Ast_411.Parsetree.ptyexn_attributes = copy_attributes ptyexn_attributes; + } + +and copy_type_extension : + Ast_412.Parsetree.type_extension -> Ast_411.Parsetree.type_extension = + fun { + Ast_412.Parsetree.ptyext_path; + Ast_412.Parsetree.ptyext_params; + Ast_412.Parsetree.ptyext_constructors; + Ast_412.Parsetree.ptyext_private; + Ast_412.Parsetree.ptyext_loc; + Ast_412.Parsetree.ptyext_attributes; + } -> + { + Ast_411.Parsetree.ptyext_path = copy_loc copy_Longident_t ptyext_path; + Ast_411.Parsetree.ptyext_params = + List.map + (fun x -> + let x0, x1 = x in + ( copy_core_type x0, + let x0, _ = x1 in + copy_variance x0 )) + ptyext_params; + Ast_411.Parsetree.ptyext_constructors = + List.map copy_extension_constructor ptyext_constructors; + Ast_411.Parsetree.ptyext_private = copy_private_flag ptyext_private; + Ast_411.Parsetree.ptyext_loc = copy_location ptyext_loc; + Ast_411.Parsetree.ptyext_attributes = copy_attributes ptyext_attributes; + } + +and copy_extension_constructor : + Ast_412.Parsetree.extension_constructor -> + Ast_411.Parsetree.extension_constructor = + fun { + Ast_412.Parsetree.pext_name; + Ast_412.Parsetree.pext_kind; + Ast_412.Parsetree.pext_loc; + Ast_412.Parsetree.pext_attributes; + } -> + { + Ast_411.Parsetree.pext_name = copy_loc (fun x -> x) pext_name; + Ast_411.Parsetree.pext_kind = copy_extension_constructor_kind pext_kind; + Ast_411.Parsetree.pext_loc = copy_location pext_loc; + Ast_411.Parsetree.pext_attributes = copy_attributes pext_attributes; + } + +and copy_extension_constructor_kind : + Ast_412.Parsetree.extension_constructor_kind -> + Ast_411.Parsetree.extension_constructor_kind = function + | Ast_412.Parsetree.Pext_decl (x0, x1) -> + Ast_411.Parsetree.Pext_decl + (copy_constructor_arguments x0, Option.map copy_core_type x1) + | Ast_412.Parsetree.Pext_rebind x0 -> + Ast_411.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0) + +and copy_type_declaration : + Ast_412.Parsetree.type_declaration -> Ast_411.Parsetree.type_declaration = + fun { + Ast_412.Parsetree.ptype_name; + Ast_412.Parsetree.ptype_params; + Ast_412.Parsetree.ptype_cstrs; + Ast_412.Parsetree.ptype_kind; + Ast_412.Parsetree.ptype_private; + Ast_412.Parsetree.ptype_manifest; + Ast_412.Parsetree.ptype_attributes; + Ast_412.Parsetree.ptype_loc; + } -> + { + Ast_411.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name; + Ast_411.Parsetree.ptype_params = + List.map + (fun x -> + let x0, x1 = x in + ( copy_core_type x0, + let x0, _ = x1 in + copy_variance x0 )) + ptype_params; + Ast_411.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_411.Parsetree.ptype_kind = copy_type_kind ptype_kind; + Ast_411.Parsetree.ptype_private = copy_private_flag ptype_private; + Ast_411.Parsetree.ptype_manifest = Option.map copy_core_type ptype_manifest; + Ast_411.Parsetree.ptype_attributes = copy_attributes ptype_attributes; + Ast_411.Parsetree.ptype_loc = copy_location ptype_loc; + } + +and copy_private_flag : + Ast_412.Asttypes.private_flag -> Ast_411.Asttypes.private_flag = function + | Ast_412.Asttypes.Private -> Ast_411.Asttypes.Private + | Ast_412.Asttypes.Public -> Ast_411.Asttypes.Public + +and copy_type_kind : Ast_412.Parsetree.type_kind -> Ast_411.Parsetree.type_kind + = function + | Ast_412.Parsetree.Ptype_abstract -> Ast_411.Parsetree.Ptype_abstract + | Ast_412.Parsetree.Ptype_variant x0 -> + Ast_411.Parsetree.Ptype_variant (List.map copy_constructor_declaration x0) + | Ast_412.Parsetree.Ptype_record x0 -> + Ast_411.Parsetree.Ptype_record (List.map copy_label_declaration x0) + | Ast_412.Parsetree.Ptype_open -> Ast_411.Parsetree.Ptype_open + +and copy_constructor_declaration : + Ast_412.Parsetree.constructor_declaration -> + Ast_411.Parsetree.constructor_declaration = + fun { + Ast_412.Parsetree.pcd_name; + Ast_412.Parsetree.pcd_args; + Ast_412.Parsetree.pcd_res; + Ast_412.Parsetree.pcd_loc; + Ast_412.Parsetree.pcd_attributes; + } -> + { + Ast_411.Parsetree.pcd_name = copy_loc (fun x -> x) pcd_name; + Ast_411.Parsetree.pcd_args = copy_constructor_arguments pcd_args; + Ast_411.Parsetree.pcd_res = Option.map copy_core_type pcd_res; + Ast_411.Parsetree.pcd_loc = copy_location pcd_loc; + Ast_411.Parsetree.pcd_attributes = copy_attributes pcd_attributes; + } + +and copy_constructor_arguments : + Ast_412.Parsetree.constructor_arguments -> + Ast_411.Parsetree.constructor_arguments = function + | Ast_412.Parsetree.Pcstr_tuple x0 -> + Ast_411.Parsetree.Pcstr_tuple (List.map copy_core_type x0) + | Ast_412.Parsetree.Pcstr_record x0 -> + Ast_411.Parsetree.Pcstr_record (List.map copy_label_declaration x0) + +and copy_label_declaration : + Ast_412.Parsetree.label_declaration -> Ast_411.Parsetree.label_declaration = + fun { + Ast_412.Parsetree.pld_name; + Ast_412.Parsetree.pld_mutable; + Ast_412.Parsetree.pld_type; + Ast_412.Parsetree.pld_loc; + Ast_412.Parsetree.pld_attributes; + } -> + { + Ast_411.Parsetree.pld_name = copy_loc (fun x -> x) pld_name; + Ast_411.Parsetree.pld_mutable = copy_mutable_flag pld_mutable; + Ast_411.Parsetree.pld_type = copy_core_type pld_type; + Ast_411.Parsetree.pld_loc = copy_location pld_loc; + Ast_411.Parsetree.pld_attributes = copy_attributes pld_attributes; + } + +and copy_mutable_flag : + Ast_412.Asttypes.mutable_flag -> Ast_411.Asttypes.mutable_flag = function + | Ast_412.Asttypes.Immutable -> Ast_411.Asttypes.Immutable + | Ast_412.Asttypes.Mutable -> Ast_411.Asttypes.Mutable + +and copy_variance : Ast_412.Asttypes.variance -> Ast_411.Asttypes.variance = + function + | Ast_412.Asttypes.Covariant -> Ast_411.Asttypes.Covariant + | Ast_412.Asttypes.Contravariant -> Ast_411.Asttypes.Contravariant + | Ast_412.Asttypes.NoVariance -> Ast_411.Asttypes.Invariant + +and copy_value_description : + Ast_412.Parsetree.value_description -> Ast_411.Parsetree.value_description = + fun { + Ast_412.Parsetree.pval_name; + Ast_412.Parsetree.pval_type; + Ast_412.Parsetree.pval_prim; + Ast_412.Parsetree.pval_attributes; + Ast_412.Parsetree.pval_loc; + } -> + { + Ast_411.Parsetree.pval_name = copy_loc (fun x -> x) pval_name; + Ast_411.Parsetree.pval_type = copy_core_type pval_type; + Ast_411.Parsetree.pval_prim = List.map (fun x -> x) pval_prim; + Ast_411.Parsetree.pval_attributes = copy_attributes pval_attributes; + Ast_411.Parsetree.pval_loc = copy_location pval_loc; + } + +and copy_object_field_desc : + Ast_412.Parsetree.object_field_desc -> Ast_411.Parsetree.object_field_desc = + function + | Ast_412.Parsetree.Otag (x0, x1) -> + Ast_411.Parsetree.Otag (copy_loc copy_label x0, copy_core_type x1) + | Ast_412.Parsetree.Oinherit x0 -> + Ast_411.Parsetree.Oinherit (copy_core_type x0) + +and copy_arg_label : Ast_412.Asttypes.arg_label -> Ast_411.Asttypes.arg_label = + function + | Ast_412.Asttypes.Nolabel -> Ast_411.Asttypes.Nolabel + | Ast_412.Asttypes.Labelled x0 -> Ast_411.Asttypes.Labelled x0 + | Ast_412.Asttypes.Optional x0 -> Ast_411.Asttypes.Optional x0 + +and copy_closed_flag : + Ast_412.Asttypes.closed_flag -> Ast_411.Asttypes.closed_flag = function + | Ast_412.Asttypes.Closed -> Ast_411.Asttypes.Closed + | Ast_412.Asttypes.Open -> Ast_411.Asttypes.Open + +and copy_label : Ast_412.Asttypes.label -> Ast_411.Asttypes.label = fun x -> x + +and copy_rec_flag : Ast_412.Asttypes.rec_flag -> Ast_411.Asttypes.rec_flag = + function + | Ast_412.Asttypes.Nonrecursive -> Ast_411.Asttypes.Nonrecursive + | Ast_412.Asttypes.Recursive -> Ast_411.Asttypes.Recursive + +and copy_constant : Ast_412.Parsetree.constant -> Ast_411.Parsetree.constant = + function + | Ast_412.Parsetree.Pconst_integer (x0, x1) -> + Ast_411.Parsetree.Pconst_integer (x0, Option.map (fun x -> x) x1) + | Ast_412.Parsetree.Pconst_char x0 -> Ast_411.Parsetree.Pconst_char x0 + | Ast_412.Parsetree.Pconst_string (x0, x1, x2) -> + Ast_411.Parsetree.Pconst_string + (x0, copy_location x1, Option.map (fun x -> x) x2) + | Ast_412.Parsetree.Pconst_float (x0, x1) -> + Ast_411.Parsetree.Pconst_float (x0, Option.map (fun x -> x) x1) + +and copy_Longident_t : Longident.t -> Longident.t = fun x -> x + +and copy_loc : + 'f0 'g0. + ('f0 -> 'g0) -> 'f0 Ast_412.Asttypes.loc -> 'g0 Ast_411.Asttypes.loc = + fun f0 { Ast_412.Asttypes.txt; Ast_412.Asttypes.loc } -> + { Ast_411.Asttypes.txt = f0 txt; Ast_411.Asttypes.loc = copy_location loc } + +and copy_location : Location.t -> Location.t = fun x -> x diff -Nru ppxlib-0.15.0/astlib/migrate_412_413.ml ppxlib-0.24.0/astlib/migrate_412_413.ml --- ppxlib-0.15.0/astlib/migrate_412_413.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/migrate_412_413.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1199 @@ +open Stdlib0 +module From = Ast_412 +module To = Ast_413 + +let rec copy_toplevel_phrase : + Ast_412.Parsetree.toplevel_phrase -> Ast_413.Parsetree.toplevel_phrase = + function + | Ast_412.Parsetree.Ptop_def x0 -> + Ast_413.Parsetree.Ptop_def (copy_structure x0) + | Ast_412.Parsetree.Ptop_dir x0 -> + Ast_413.Parsetree.Ptop_dir (copy_toplevel_directive x0) + +and copy_toplevel_directive : + Ast_412.Parsetree.toplevel_directive -> Ast_413.Parsetree.toplevel_directive + = + fun { + Ast_412.Parsetree.pdir_name; + Ast_412.Parsetree.pdir_arg; + Ast_412.Parsetree.pdir_loc; + } -> + { + Ast_413.Parsetree.pdir_name = copy_loc (fun x -> x) pdir_name; + Ast_413.Parsetree.pdir_arg = Option.map copy_directive_argument pdir_arg; + Ast_413.Parsetree.pdir_loc = copy_location pdir_loc; + } + +and copy_directive_argument : + Ast_412.Parsetree.directive_argument -> Ast_413.Parsetree.directive_argument + = + fun { Ast_412.Parsetree.pdira_desc; Ast_412.Parsetree.pdira_loc } -> + { + Ast_413.Parsetree.pdira_desc = copy_directive_argument_desc pdira_desc; + Ast_413.Parsetree.pdira_loc = copy_location pdira_loc; + } + +and copy_directive_argument_desc : + Ast_412.Parsetree.directive_argument_desc -> + Ast_413.Parsetree.directive_argument_desc = function + | Ast_412.Parsetree.Pdir_string x0 -> Ast_413.Parsetree.Pdir_string x0 + | Ast_412.Parsetree.Pdir_int (x0, x1) -> + Ast_413.Parsetree.Pdir_int (x0, Option.map (fun x -> x) x1) + | Ast_412.Parsetree.Pdir_ident x0 -> + Ast_413.Parsetree.Pdir_ident (copy_Longident_t x0) + | Ast_412.Parsetree.Pdir_bool x0 -> Ast_413.Parsetree.Pdir_bool x0 + +and copy_expression : + Ast_412.Parsetree.expression -> Ast_413.Parsetree.expression = + fun { + Ast_412.Parsetree.pexp_desc; + Ast_412.Parsetree.pexp_loc; + Ast_412.Parsetree.pexp_loc_stack; + Ast_412.Parsetree.pexp_attributes; + } -> + { + Ast_413.Parsetree.pexp_desc = copy_expression_desc pexp_desc; + Ast_413.Parsetree.pexp_loc = copy_location pexp_loc; + Ast_413.Parsetree.pexp_loc_stack = copy_location_stack pexp_loc_stack; + Ast_413.Parsetree.pexp_attributes = copy_attributes pexp_attributes; + } + +and copy_expression_desc : + Ast_412.Parsetree.expression_desc -> Ast_413.Parsetree.expression_desc = + function + | Ast_412.Parsetree.Pexp_ident x0 -> + Ast_413.Parsetree.Pexp_ident (copy_loc copy_Longident_t x0) + | Ast_412.Parsetree.Pexp_constant x0 -> + Ast_413.Parsetree.Pexp_constant (copy_constant x0) + | Ast_412.Parsetree.Pexp_let (x0, x1, x2) -> + Ast_413.Parsetree.Pexp_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_expression x2) + | Ast_412.Parsetree.Pexp_function x0 -> + Ast_413.Parsetree.Pexp_function (List.map copy_case x0) + | Ast_412.Parsetree.Pexp_fun (x0, x1, x2, x3) -> + Ast_413.Parsetree.Pexp_fun + ( copy_arg_label x0, + Option.map copy_expression x1, + copy_pattern x2, + copy_expression x3 ) + | Ast_412.Parsetree.Pexp_apply (x0, x1) -> + Ast_413.Parsetree.Pexp_apply + ( copy_expression x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | Ast_412.Parsetree.Pexp_match (x0, x1) -> + Ast_413.Parsetree.Pexp_match (copy_expression x0, List.map copy_case x1) + | Ast_412.Parsetree.Pexp_try (x0, x1) -> + Ast_413.Parsetree.Pexp_try (copy_expression x0, List.map copy_case x1) + | Ast_412.Parsetree.Pexp_tuple x0 -> + Ast_413.Parsetree.Pexp_tuple (List.map copy_expression x0) + | Ast_412.Parsetree.Pexp_construct (x0, x1) -> + Ast_413.Parsetree.Pexp_construct + (copy_loc copy_Longident_t x0, Option.map copy_expression x1) + | Ast_412.Parsetree.Pexp_variant (x0, x1) -> + Ast_413.Parsetree.Pexp_variant + (copy_label x0, Option.map copy_expression x1) + | Ast_412.Parsetree.Pexp_record (x0, x1) -> + Ast_413.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_412.Parsetree.Pexp_field (x0, x1) -> + Ast_413.Parsetree.Pexp_field + (copy_expression x0, copy_loc copy_Longident_t x1) + | Ast_412.Parsetree.Pexp_setfield (x0, x1, x2) -> + Ast_413.Parsetree.Pexp_setfield + (copy_expression x0, copy_loc copy_Longident_t x1, copy_expression x2) + | Ast_412.Parsetree.Pexp_array x0 -> + Ast_413.Parsetree.Pexp_array (List.map copy_expression x0) + | Ast_412.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> + Ast_413.Parsetree.Pexp_ifthenelse + (copy_expression x0, copy_expression x1, Option.map copy_expression x2) + | Ast_412.Parsetree.Pexp_sequence (x0, x1) -> + Ast_413.Parsetree.Pexp_sequence (copy_expression x0, copy_expression x1) + | Ast_412.Parsetree.Pexp_while (x0, x1) -> + Ast_413.Parsetree.Pexp_while (copy_expression x0, copy_expression x1) + | Ast_412.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> + Ast_413.Parsetree.Pexp_for + ( copy_pattern x0, + copy_expression x1, + copy_expression x2, + copy_direction_flag x3, + copy_expression x4 ) + | Ast_412.Parsetree.Pexp_constraint (x0, x1) -> + Ast_413.Parsetree.Pexp_constraint (copy_expression x0, copy_core_type x1) + | Ast_412.Parsetree.Pexp_coerce (x0, x1, x2) -> + Ast_413.Parsetree.Pexp_coerce + (copy_expression x0, Option.map copy_core_type x1, copy_core_type x2) + | Ast_412.Parsetree.Pexp_send (x0, x1) -> + Ast_413.Parsetree.Pexp_send (copy_expression x0, copy_loc copy_label x1) + | Ast_412.Parsetree.Pexp_new x0 -> + Ast_413.Parsetree.Pexp_new (copy_loc copy_Longident_t x0) + | Ast_412.Parsetree.Pexp_setinstvar (x0, x1) -> + Ast_413.Parsetree.Pexp_setinstvar + (copy_loc copy_label x0, copy_expression x1) + | Ast_412.Parsetree.Pexp_override x0 -> + Ast_413.Parsetree.Pexp_override + (List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_label x0, copy_expression x1)) + x0) + | Ast_412.Parsetree.Pexp_letmodule (x0, x1, x2) -> + Ast_413.Parsetree.Pexp_letmodule + ( copy_loc (fun x -> Option.map (fun x -> x) x) x0, + copy_module_expr x1, + copy_expression x2 ) + | Ast_412.Parsetree.Pexp_letexception (x0, x1) -> + Ast_413.Parsetree.Pexp_letexception + (copy_extension_constructor x0, copy_expression x1) + | Ast_412.Parsetree.Pexp_assert x0 -> + Ast_413.Parsetree.Pexp_assert (copy_expression x0) + | Ast_412.Parsetree.Pexp_lazy x0 -> + Ast_413.Parsetree.Pexp_lazy (copy_expression x0) + | Ast_412.Parsetree.Pexp_poly (x0, x1) -> + Ast_413.Parsetree.Pexp_poly + (copy_expression x0, Option.map copy_core_type x1) + | Ast_412.Parsetree.Pexp_object x0 -> + Ast_413.Parsetree.Pexp_object (copy_class_structure x0) + | Ast_412.Parsetree.Pexp_newtype (x0, x1) -> + Ast_413.Parsetree.Pexp_newtype + (copy_loc (fun x -> x) x0, copy_expression x1) + | Ast_412.Parsetree.Pexp_pack x0 -> + Ast_413.Parsetree.Pexp_pack (copy_module_expr x0) + | Ast_412.Parsetree.Pexp_open (x0, x1) -> + Ast_413.Parsetree.Pexp_open (copy_open_declaration x0, copy_expression x1) + | Ast_412.Parsetree.Pexp_letop x0 -> + Ast_413.Parsetree.Pexp_letop (copy_letop x0) + | Ast_412.Parsetree.Pexp_extension x0 -> + Ast_413.Parsetree.Pexp_extension (copy_extension x0) + | Ast_412.Parsetree.Pexp_unreachable -> Ast_413.Parsetree.Pexp_unreachable + +and copy_letop : Ast_412.Parsetree.letop -> Ast_413.Parsetree.letop = + fun { Ast_412.Parsetree.let_; Ast_412.Parsetree.ands; Ast_412.Parsetree.body } -> + { + Ast_413.Parsetree.let_ = copy_binding_op let_; + Ast_413.Parsetree.ands = List.map copy_binding_op ands; + Ast_413.Parsetree.body = copy_expression body; + } + +and copy_binding_op : + Ast_412.Parsetree.binding_op -> Ast_413.Parsetree.binding_op = + fun { + Ast_412.Parsetree.pbop_op; + Ast_412.Parsetree.pbop_pat; + Ast_412.Parsetree.pbop_exp; + Ast_412.Parsetree.pbop_loc; + } -> + { + Ast_413.Parsetree.pbop_op = copy_loc (fun x -> x) pbop_op; + Ast_413.Parsetree.pbop_pat = copy_pattern pbop_pat; + Ast_413.Parsetree.pbop_exp = copy_expression pbop_exp; + Ast_413.Parsetree.pbop_loc = copy_location pbop_loc; + } + +and copy_direction_flag : + Ast_412.Asttypes.direction_flag -> Ast_413.Asttypes.direction_flag = + function + | Ast_412.Asttypes.Upto -> Ast_413.Asttypes.Upto + | Ast_412.Asttypes.Downto -> Ast_413.Asttypes.Downto + +and copy_case : Ast_412.Parsetree.case -> Ast_413.Parsetree.case = + fun { + Ast_412.Parsetree.pc_lhs; + Ast_412.Parsetree.pc_guard; + Ast_412.Parsetree.pc_rhs; + } -> + { + Ast_413.Parsetree.pc_lhs = copy_pattern pc_lhs; + Ast_413.Parsetree.pc_guard = Option.map copy_expression pc_guard; + Ast_413.Parsetree.pc_rhs = copy_expression pc_rhs; + } + +and copy_value_binding : + Ast_412.Parsetree.value_binding -> Ast_413.Parsetree.value_binding = + fun { + Ast_412.Parsetree.pvb_pat; + Ast_412.Parsetree.pvb_expr; + Ast_412.Parsetree.pvb_attributes; + Ast_412.Parsetree.pvb_loc; + } -> + { + Ast_413.Parsetree.pvb_pat = copy_pattern pvb_pat; + Ast_413.Parsetree.pvb_expr = copy_expression pvb_expr; + Ast_413.Parsetree.pvb_attributes = copy_attributes pvb_attributes; + Ast_413.Parsetree.pvb_loc = copy_location pvb_loc; + } + +and copy_pattern : Ast_412.Parsetree.pattern -> Ast_413.Parsetree.pattern = + fun { + Ast_412.Parsetree.ppat_desc; + Ast_412.Parsetree.ppat_loc; + Ast_412.Parsetree.ppat_loc_stack; + Ast_412.Parsetree.ppat_attributes; + } -> + { + Ast_413.Parsetree.ppat_desc = copy_pattern_desc ppat_desc; + Ast_413.Parsetree.ppat_loc = copy_location ppat_loc; + Ast_413.Parsetree.ppat_loc_stack = copy_location_stack ppat_loc_stack; + Ast_413.Parsetree.ppat_attributes = copy_attributes ppat_attributes; + } + +and copy_pattern_desc : + Ast_412.Parsetree.pattern_desc -> Ast_413.Parsetree.pattern_desc = function + | Ast_412.Parsetree.Ppat_any -> Ast_413.Parsetree.Ppat_any + | Ast_412.Parsetree.Ppat_var x0 -> + Ast_413.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) + | Ast_412.Parsetree.Ppat_alias (x0, x1) -> + Ast_413.Parsetree.Ppat_alias (copy_pattern x0, copy_loc (fun x -> x) x1) + | Ast_412.Parsetree.Ppat_constant x0 -> + Ast_413.Parsetree.Ppat_constant (copy_constant x0) + | Ast_412.Parsetree.Ppat_interval (x0, x1) -> + Ast_413.Parsetree.Ppat_interval (copy_constant x0, copy_constant x1) + | Ast_412.Parsetree.Ppat_tuple x0 -> + Ast_413.Parsetree.Ppat_tuple (List.map copy_pattern x0) + | Ast_412.Parsetree.Ppat_construct (x0, x1) -> + Ast_413.Parsetree.Ppat_construct + ( copy_loc copy_Longident_t x0, + Option.map (fun x -> ([], copy_pattern x)) x1 ) + | Ast_412.Parsetree.Ppat_variant (x0, x1) -> + Ast_413.Parsetree.Ppat_variant (copy_label x0, Option.map copy_pattern x1) + | Ast_412.Parsetree.Ppat_record (x0, x1) -> + Ast_413.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_412.Parsetree.Ppat_array x0 -> + Ast_413.Parsetree.Ppat_array (List.map copy_pattern x0) + | Ast_412.Parsetree.Ppat_or (x0, x1) -> + Ast_413.Parsetree.Ppat_or (copy_pattern x0, copy_pattern x1) + | Ast_412.Parsetree.Ppat_constraint (x0, x1) -> + Ast_413.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1) + | Ast_412.Parsetree.Ppat_type x0 -> + Ast_413.Parsetree.Ppat_type (copy_loc copy_Longident_t x0) + | Ast_412.Parsetree.Ppat_lazy x0 -> + Ast_413.Parsetree.Ppat_lazy (copy_pattern x0) + | Ast_412.Parsetree.Ppat_unpack x0 -> + Ast_413.Parsetree.Ppat_unpack + (copy_loc (fun x -> Option.map (fun x -> x) x) x0) + | Ast_412.Parsetree.Ppat_exception x0 -> + Ast_413.Parsetree.Ppat_exception (copy_pattern x0) + | Ast_412.Parsetree.Ppat_extension x0 -> + Ast_413.Parsetree.Ppat_extension (copy_extension x0) + | Ast_412.Parsetree.Ppat_open (x0, x1) -> + Ast_413.Parsetree.Ppat_open (copy_loc copy_Longident_t x0, copy_pattern x1) + +and copy_core_type : Ast_412.Parsetree.core_type -> Ast_413.Parsetree.core_type + = + fun { + Ast_412.Parsetree.ptyp_desc; + Ast_412.Parsetree.ptyp_loc; + Ast_412.Parsetree.ptyp_loc_stack; + Ast_412.Parsetree.ptyp_attributes; + } -> + { + Ast_413.Parsetree.ptyp_desc = copy_core_type_desc ptyp_desc; + Ast_413.Parsetree.ptyp_loc = copy_location ptyp_loc; + Ast_413.Parsetree.ptyp_loc_stack = copy_location_stack ptyp_loc_stack; + Ast_413.Parsetree.ptyp_attributes = copy_attributes ptyp_attributes; + } + +and copy_location_stack : + Ast_412.Parsetree.location_stack -> Ast_413.Parsetree.location_stack = + fun x -> List.map copy_location x + +and copy_core_type_desc : + Ast_412.Parsetree.core_type_desc -> Ast_413.Parsetree.core_type_desc = + function + | Ast_412.Parsetree.Ptyp_any -> Ast_413.Parsetree.Ptyp_any + | Ast_412.Parsetree.Ptyp_var x0 -> Ast_413.Parsetree.Ptyp_var x0 + | Ast_412.Parsetree.Ptyp_arrow (x0, x1, x2) -> + Ast_413.Parsetree.Ptyp_arrow + (copy_arg_label x0, copy_core_type x1, copy_core_type x2) + | Ast_412.Parsetree.Ptyp_tuple x0 -> + Ast_413.Parsetree.Ptyp_tuple (List.map copy_core_type x0) + | Ast_412.Parsetree.Ptyp_constr (x0, x1) -> + Ast_413.Parsetree.Ptyp_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_412.Parsetree.Ptyp_object (x0, x1) -> + Ast_413.Parsetree.Ptyp_object + (List.map copy_object_field x0, copy_closed_flag x1) + | Ast_412.Parsetree.Ptyp_class (x0, x1) -> + Ast_413.Parsetree.Ptyp_class + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_412.Parsetree.Ptyp_alias (x0, x1) -> + Ast_413.Parsetree.Ptyp_alias (copy_core_type x0, x1) + | Ast_412.Parsetree.Ptyp_variant (x0, x1, x2) -> + Ast_413.Parsetree.Ptyp_variant + ( List.map copy_row_field x0, + copy_closed_flag x1, + Option.map (fun x -> List.map copy_label x) x2 ) + | Ast_412.Parsetree.Ptyp_poly (x0, x1) -> + Ast_413.Parsetree.Ptyp_poly + (List.map (fun x -> copy_loc (fun x -> x) x) x0, copy_core_type x1) + | Ast_412.Parsetree.Ptyp_package x0 -> + Ast_413.Parsetree.Ptyp_package (copy_package_type x0) + | Ast_412.Parsetree.Ptyp_extension x0 -> + Ast_413.Parsetree.Ptyp_extension (copy_extension x0) + +and copy_package_type : + Ast_412.Parsetree.package_type -> Ast_413.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_412.Parsetree.row_field -> Ast_413.Parsetree.row_field + = + fun { + Ast_412.Parsetree.prf_desc; + Ast_412.Parsetree.prf_loc; + Ast_412.Parsetree.prf_attributes; + } -> + { + Ast_413.Parsetree.prf_desc = copy_row_field_desc prf_desc; + Ast_413.Parsetree.prf_loc = copy_location prf_loc; + Ast_413.Parsetree.prf_attributes = copy_attributes prf_attributes; + } + +and copy_row_field_desc : + Ast_412.Parsetree.row_field_desc -> Ast_413.Parsetree.row_field_desc = + function + | Ast_412.Parsetree.Rtag (x0, x1, x2) -> + Ast_413.Parsetree.Rtag + (copy_loc copy_label x0, x1, List.map copy_core_type x2) + | Ast_412.Parsetree.Rinherit x0 -> + Ast_413.Parsetree.Rinherit (copy_core_type x0) + +and copy_object_field : + Ast_412.Parsetree.object_field -> Ast_413.Parsetree.object_field = + fun { + Ast_412.Parsetree.pof_desc; + Ast_412.Parsetree.pof_loc; + Ast_412.Parsetree.pof_attributes; + } -> + { + Ast_413.Parsetree.pof_desc = copy_object_field_desc pof_desc; + Ast_413.Parsetree.pof_loc = copy_location pof_loc; + Ast_413.Parsetree.pof_attributes = copy_attributes pof_attributes; + } + +and copy_attributes : + Ast_412.Parsetree.attributes -> Ast_413.Parsetree.attributes = + fun x -> List.map copy_attribute x + +and copy_attribute : Ast_412.Parsetree.attribute -> Ast_413.Parsetree.attribute + = + fun { + Ast_412.Parsetree.attr_name; + Ast_412.Parsetree.attr_payload; + Ast_412.Parsetree.attr_loc; + } -> + { + Ast_413.Parsetree.attr_name = copy_loc (fun x -> x) attr_name; + Ast_413.Parsetree.attr_payload = copy_payload attr_payload; + Ast_413.Parsetree.attr_loc = copy_location attr_loc; + } + +and copy_payload : Ast_412.Parsetree.payload -> Ast_413.Parsetree.payload = + function + | Ast_412.Parsetree.PStr x0 -> Ast_413.Parsetree.PStr (copy_structure x0) + | Ast_412.Parsetree.PSig x0 -> Ast_413.Parsetree.PSig (copy_signature x0) + | Ast_412.Parsetree.PTyp x0 -> Ast_413.Parsetree.PTyp (copy_core_type x0) + | Ast_412.Parsetree.PPat (x0, x1) -> + Ast_413.Parsetree.PPat (copy_pattern x0, Option.map copy_expression x1) + +and copy_structure : Ast_412.Parsetree.structure -> Ast_413.Parsetree.structure + = + fun x -> List.map copy_structure_item x + +and copy_structure_item : + Ast_412.Parsetree.structure_item -> Ast_413.Parsetree.structure_item = + fun { Ast_412.Parsetree.pstr_desc; Ast_412.Parsetree.pstr_loc } -> + { + Ast_413.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc; + Ast_413.Parsetree.pstr_loc = copy_location pstr_loc; + } + +and copy_structure_item_desc : + Ast_412.Parsetree.structure_item_desc -> + Ast_413.Parsetree.structure_item_desc = function + | Ast_412.Parsetree.Pstr_eval (x0, x1) -> + Ast_413.Parsetree.Pstr_eval (copy_expression x0, copy_attributes x1) + | Ast_412.Parsetree.Pstr_value (x0, x1) -> + Ast_413.Parsetree.Pstr_value + (copy_rec_flag x0, List.map copy_value_binding x1) + | Ast_412.Parsetree.Pstr_primitive x0 -> + Ast_413.Parsetree.Pstr_primitive (copy_value_description x0) + | Ast_412.Parsetree.Pstr_type (x0, x1) -> + Ast_413.Parsetree.Pstr_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | Ast_412.Parsetree.Pstr_typext x0 -> + Ast_413.Parsetree.Pstr_typext (copy_type_extension x0) + | Ast_412.Parsetree.Pstr_exception x0 -> + Ast_413.Parsetree.Pstr_exception (copy_type_exception x0) + | Ast_412.Parsetree.Pstr_module x0 -> + Ast_413.Parsetree.Pstr_module (copy_module_binding x0) + | Ast_412.Parsetree.Pstr_recmodule x0 -> + Ast_413.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) + | Ast_412.Parsetree.Pstr_modtype x0 -> + Ast_413.Parsetree.Pstr_modtype (copy_module_type_declaration x0) + | Ast_412.Parsetree.Pstr_open x0 -> + Ast_413.Parsetree.Pstr_open (copy_open_declaration x0) + | Ast_412.Parsetree.Pstr_class x0 -> + Ast_413.Parsetree.Pstr_class (List.map copy_class_declaration x0) + | Ast_412.Parsetree.Pstr_class_type x0 -> + Ast_413.Parsetree.Pstr_class_type + (List.map copy_class_type_declaration x0) + | Ast_412.Parsetree.Pstr_include x0 -> + Ast_413.Parsetree.Pstr_include (copy_include_declaration x0) + | Ast_412.Parsetree.Pstr_attribute x0 -> + Ast_413.Parsetree.Pstr_attribute (copy_attribute x0) + | Ast_412.Parsetree.Pstr_extension (x0, x1) -> + Ast_413.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1) + +and copy_include_declaration : + Ast_412.Parsetree.include_declaration -> + Ast_413.Parsetree.include_declaration = + fun x -> copy_include_infos copy_module_expr x + +and copy_class_declaration : + Ast_412.Parsetree.class_declaration -> Ast_413.Parsetree.class_declaration = + fun x -> copy_class_infos copy_class_expr x + +and copy_class_expr : + Ast_412.Parsetree.class_expr -> Ast_413.Parsetree.class_expr = + fun { + Ast_412.Parsetree.pcl_desc; + Ast_412.Parsetree.pcl_loc; + Ast_412.Parsetree.pcl_attributes; + } -> + { + Ast_413.Parsetree.pcl_desc = copy_class_expr_desc pcl_desc; + Ast_413.Parsetree.pcl_loc = copy_location pcl_loc; + Ast_413.Parsetree.pcl_attributes = copy_attributes pcl_attributes; + } + +and copy_class_expr_desc : + Ast_412.Parsetree.class_expr_desc -> Ast_413.Parsetree.class_expr_desc = + function + | Ast_412.Parsetree.Pcl_constr (x0, x1) -> + Ast_413.Parsetree.Pcl_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_412.Parsetree.Pcl_structure x0 -> + Ast_413.Parsetree.Pcl_structure (copy_class_structure x0) + | Ast_412.Parsetree.Pcl_fun (x0, x1, x2, x3) -> + Ast_413.Parsetree.Pcl_fun + ( copy_arg_label x0, + Option.map copy_expression x1, + copy_pattern x2, + copy_class_expr x3 ) + | Ast_412.Parsetree.Pcl_apply (x0, x1) -> + Ast_413.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_412.Parsetree.Pcl_let (x0, x1, x2) -> + Ast_413.Parsetree.Pcl_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_class_expr x2) + | Ast_412.Parsetree.Pcl_constraint (x0, x1) -> + Ast_413.Parsetree.Pcl_constraint (copy_class_expr x0, copy_class_type x1) + | Ast_412.Parsetree.Pcl_extension x0 -> + Ast_413.Parsetree.Pcl_extension (copy_extension x0) + | Ast_412.Parsetree.Pcl_open (x0, x1) -> + Ast_413.Parsetree.Pcl_open (copy_open_description x0, copy_class_expr x1) + +and copy_class_structure : + Ast_412.Parsetree.class_structure -> Ast_413.Parsetree.class_structure = + fun { Ast_412.Parsetree.pcstr_self; Ast_412.Parsetree.pcstr_fields } -> + { + Ast_413.Parsetree.pcstr_self = copy_pattern pcstr_self; + Ast_413.Parsetree.pcstr_fields = List.map copy_class_field pcstr_fields; + } + +and copy_class_field : + Ast_412.Parsetree.class_field -> Ast_413.Parsetree.class_field = + fun { + Ast_412.Parsetree.pcf_desc; + Ast_412.Parsetree.pcf_loc; + Ast_412.Parsetree.pcf_attributes; + } -> + { + Ast_413.Parsetree.pcf_desc = copy_class_field_desc pcf_desc; + Ast_413.Parsetree.pcf_loc = copy_location pcf_loc; + Ast_413.Parsetree.pcf_attributes = copy_attributes pcf_attributes; + } + +and copy_class_field_desc : + Ast_412.Parsetree.class_field_desc -> Ast_413.Parsetree.class_field_desc = + function + | Ast_412.Parsetree.Pcf_inherit (x0, x1, x2) -> + Ast_413.Parsetree.Pcf_inherit + ( copy_override_flag x0, + copy_class_expr x1, + Option.map (fun x -> copy_loc (fun x -> x) x) x2 ) + | Ast_412.Parsetree.Pcf_val x0 -> + Ast_413.Parsetree.Pcf_val + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_mutable_flag x1, copy_class_field_kind x2)) + | Ast_412.Parsetree.Pcf_method x0 -> + Ast_413.Parsetree.Pcf_method + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_private_flag x1, copy_class_field_kind x2)) + | Ast_412.Parsetree.Pcf_constraint x0 -> + Ast_413.Parsetree.Pcf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | Ast_412.Parsetree.Pcf_initializer x0 -> + Ast_413.Parsetree.Pcf_initializer (copy_expression x0) + | Ast_412.Parsetree.Pcf_attribute x0 -> + Ast_413.Parsetree.Pcf_attribute (copy_attribute x0) + | Ast_412.Parsetree.Pcf_extension x0 -> + Ast_413.Parsetree.Pcf_extension (copy_extension x0) + +and copy_class_field_kind : + Ast_412.Parsetree.class_field_kind -> Ast_413.Parsetree.class_field_kind = + function + | Ast_412.Parsetree.Cfk_virtual x0 -> + Ast_413.Parsetree.Cfk_virtual (copy_core_type x0) + | Ast_412.Parsetree.Cfk_concrete (x0, x1) -> + Ast_413.Parsetree.Cfk_concrete (copy_override_flag x0, copy_expression x1) + +and copy_open_declaration : + Ast_412.Parsetree.open_declaration -> Ast_413.Parsetree.open_declaration = + fun x -> copy_open_infos copy_module_expr x + +and copy_module_binding : + Ast_412.Parsetree.module_binding -> Ast_413.Parsetree.module_binding = + fun { + Ast_412.Parsetree.pmb_name; + Ast_412.Parsetree.pmb_expr; + Ast_412.Parsetree.pmb_attributes; + Ast_412.Parsetree.pmb_loc; + } -> + { + Ast_413.Parsetree.pmb_name = + copy_loc (fun x -> Option.map (fun x -> x) x) pmb_name; + Ast_413.Parsetree.pmb_expr = copy_module_expr pmb_expr; + Ast_413.Parsetree.pmb_attributes = copy_attributes pmb_attributes; + Ast_413.Parsetree.pmb_loc = copy_location pmb_loc; + } + +and copy_module_expr : + Ast_412.Parsetree.module_expr -> Ast_413.Parsetree.module_expr = + fun { + Ast_412.Parsetree.pmod_desc; + Ast_412.Parsetree.pmod_loc; + Ast_412.Parsetree.pmod_attributes; + } -> + { + Ast_413.Parsetree.pmod_desc = copy_module_expr_desc pmod_desc; + Ast_413.Parsetree.pmod_loc = copy_location pmod_loc; + Ast_413.Parsetree.pmod_attributes = copy_attributes pmod_attributes; + } + +and copy_module_expr_desc : + Ast_412.Parsetree.module_expr_desc -> Ast_413.Parsetree.module_expr_desc = + function + | Ast_412.Parsetree.Pmod_ident x0 -> + Ast_413.Parsetree.Pmod_ident (copy_loc copy_Longident_t x0) + | Ast_412.Parsetree.Pmod_structure x0 -> + Ast_413.Parsetree.Pmod_structure (copy_structure x0) + | Ast_412.Parsetree.Pmod_functor (x0, x1) -> + Ast_413.Parsetree.Pmod_functor + (copy_functor_parameter x0, copy_module_expr x1) + | Ast_412.Parsetree.Pmod_apply (x0, x1) -> + Ast_413.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) + | Ast_412.Parsetree.Pmod_constraint (x0, x1) -> + Ast_413.Parsetree.Pmod_constraint + (copy_module_expr x0, copy_module_type x1) + | Ast_412.Parsetree.Pmod_unpack x0 -> + Ast_413.Parsetree.Pmod_unpack (copy_expression x0) + | Ast_412.Parsetree.Pmod_extension x0 -> + Ast_413.Parsetree.Pmod_extension (copy_extension x0) + +and copy_functor_parameter : + Ast_412.Parsetree.functor_parameter -> Ast_413.Parsetree.functor_parameter = + function + | Ast_412.Parsetree.Unit -> Ast_413.Parsetree.Unit + | Ast_412.Parsetree.Named (x0, x1) -> + Ast_413.Parsetree.Named + (copy_loc (fun x -> Option.map (fun x -> x) x) x0, copy_module_type x1) + +and copy_module_type : + Ast_412.Parsetree.module_type -> Ast_413.Parsetree.module_type = + fun { + Ast_412.Parsetree.pmty_desc; + Ast_412.Parsetree.pmty_loc; + Ast_412.Parsetree.pmty_attributes; + } -> + { + Ast_413.Parsetree.pmty_desc = copy_module_type_desc pmty_desc; + Ast_413.Parsetree.pmty_loc = copy_location pmty_loc; + Ast_413.Parsetree.pmty_attributes = copy_attributes pmty_attributes; + } + +and copy_module_type_desc : + Ast_412.Parsetree.module_type_desc -> Ast_413.Parsetree.module_type_desc = + function + | Ast_412.Parsetree.Pmty_ident x0 -> + Ast_413.Parsetree.Pmty_ident (copy_loc copy_Longident_t x0) + | Ast_412.Parsetree.Pmty_signature x0 -> + Ast_413.Parsetree.Pmty_signature (copy_signature x0) + | Ast_412.Parsetree.Pmty_functor (x0, x1) -> + Ast_413.Parsetree.Pmty_functor + (copy_functor_parameter x0, copy_module_type x1) + | Ast_412.Parsetree.Pmty_with (x0, x1) -> + Ast_413.Parsetree.Pmty_with + (copy_module_type x0, List.map copy_with_constraint x1) + | Ast_412.Parsetree.Pmty_typeof x0 -> + Ast_413.Parsetree.Pmty_typeof (copy_module_expr x0) + | Ast_412.Parsetree.Pmty_extension x0 -> + Ast_413.Parsetree.Pmty_extension (copy_extension x0) + | Ast_412.Parsetree.Pmty_alias x0 -> + Ast_413.Parsetree.Pmty_alias (copy_loc copy_Longident_t x0) + +and copy_with_constraint : + Ast_412.Parsetree.with_constraint -> Ast_413.Parsetree.with_constraint = + function + | Ast_412.Parsetree.Pwith_type (x0, x1) -> + Ast_413.Parsetree.Pwith_type + (copy_loc copy_Longident_t x0, copy_type_declaration x1) + | Ast_412.Parsetree.Pwith_module (x0, x1) -> + Ast_413.Parsetree.Pwith_module + (copy_loc copy_Longident_t x0, copy_loc copy_Longident_t x1) + | Ast_412.Parsetree.Pwith_typesubst (x0, x1) -> + Ast_413.Parsetree.Pwith_typesubst + (copy_loc copy_Longident_t x0, copy_type_declaration x1) + | Ast_412.Parsetree.Pwith_modsubst (x0, x1) -> + Ast_413.Parsetree.Pwith_modsubst + (copy_loc copy_Longident_t x0, copy_loc copy_Longident_t x1) + +and copy_signature : Ast_412.Parsetree.signature -> Ast_413.Parsetree.signature + = + fun x -> List.map copy_signature_item x + +and copy_signature_item : + Ast_412.Parsetree.signature_item -> Ast_413.Parsetree.signature_item = + fun { Ast_412.Parsetree.psig_desc; Ast_412.Parsetree.psig_loc } -> + { + Ast_413.Parsetree.psig_desc = copy_signature_item_desc psig_desc; + Ast_413.Parsetree.psig_loc = copy_location psig_loc; + } + +and copy_signature_item_desc : + Ast_412.Parsetree.signature_item_desc -> + Ast_413.Parsetree.signature_item_desc = function + | Ast_412.Parsetree.Psig_value x0 -> + Ast_413.Parsetree.Psig_value (copy_value_description x0) + | Ast_412.Parsetree.Psig_type (x0, x1) -> + Ast_413.Parsetree.Psig_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | Ast_412.Parsetree.Psig_typesubst x0 -> + Ast_413.Parsetree.Psig_typesubst (List.map copy_type_declaration x0) + | Ast_412.Parsetree.Psig_typext x0 -> + Ast_413.Parsetree.Psig_typext (copy_type_extension x0) + | Ast_412.Parsetree.Psig_exception x0 -> + Ast_413.Parsetree.Psig_exception (copy_type_exception x0) + | Ast_412.Parsetree.Psig_module x0 -> + Ast_413.Parsetree.Psig_module (copy_module_declaration x0) + | Ast_412.Parsetree.Psig_modsubst x0 -> + Ast_413.Parsetree.Psig_modsubst (copy_module_substitution x0) + | Ast_412.Parsetree.Psig_recmodule x0 -> + Ast_413.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) + | Ast_412.Parsetree.Psig_modtype x0 -> + Ast_413.Parsetree.Psig_modtype (copy_module_type_declaration x0) + | Ast_412.Parsetree.Psig_open x0 -> + Ast_413.Parsetree.Psig_open (copy_open_description x0) + | Ast_412.Parsetree.Psig_include x0 -> + Ast_413.Parsetree.Psig_include (copy_include_description x0) + | Ast_412.Parsetree.Psig_class x0 -> + Ast_413.Parsetree.Psig_class (List.map copy_class_description x0) + | Ast_412.Parsetree.Psig_class_type x0 -> + Ast_413.Parsetree.Psig_class_type + (List.map copy_class_type_declaration x0) + | Ast_412.Parsetree.Psig_attribute x0 -> + Ast_413.Parsetree.Psig_attribute (copy_attribute x0) + | Ast_412.Parsetree.Psig_extension (x0, x1) -> + Ast_413.Parsetree.Psig_extension (copy_extension x0, copy_attributes x1) + +and copy_class_type_declaration : + Ast_412.Parsetree.class_type_declaration -> + Ast_413.Parsetree.class_type_declaration = + fun x -> copy_class_infos copy_class_type x + +and copy_class_description : + Ast_412.Parsetree.class_description -> Ast_413.Parsetree.class_description = + fun x -> copy_class_infos copy_class_type x + +and copy_class_type : + Ast_412.Parsetree.class_type -> Ast_413.Parsetree.class_type = + fun { + Ast_412.Parsetree.pcty_desc; + Ast_412.Parsetree.pcty_loc; + Ast_412.Parsetree.pcty_attributes; + } -> + { + Ast_413.Parsetree.pcty_desc = copy_class_type_desc pcty_desc; + Ast_413.Parsetree.pcty_loc = copy_location pcty_loc; + Ast_413.Parsetree.pcty_attributes = copy_attributes pcty_attributes; + } + +and copy_class_type_desc : + Ast_412.Parsetree.class_type_desc -> Ast_413.Parsetree.class_type_desc = + function + | Ast_412.Parsetree.Pcty_constr (x0, x1) -> + Ast_413.Parsetree.Pcty_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_412.Parsetree.Pcty_signature x0 -> + Ast_413.Parsetree.Pcty_signature (copy_class_signature x0) + | Ast_412.Parsetree.Pcty_arrow (x0, x1, x2) -> + Ast_413.Parsetree.Pcty_arrow + (copy_arg_label x0, copy_core_type x1, copy_class_type x2) + | Ast_412.Parsetree.Pcty_extension x0 -> + Ast_413.Parsetree.Pcty_extension (copy_extension x0) + | Ast_412.Parsetree.Pcty_open (x0, x1) -> + Ast_413.Parsetree.Pcty_open (copy_open_description x0, copy_class_type x1) + +and copy_class_signature : + Ast_412.Parsetree.class_signature -> Ast_413.Parsetree.class_signature = + fun { Ast_412.Parsetree.pcsig_self; Ast_412.Parsetree.pcsig_fields } -> + { + Ast_413.Parsetree.pcsig_self = copy_core_type pcsig_self; + Ast_413.Parsetree.pcsig_fields = List.map copy_class_type_field pcsig_fields; + } + +and copy_class_type_field : + Ast_412.Parsetree.class_type_field -> Ast_413.Parsetree.class_type_field = + fun { + Ast_412.Parsetree.pctf_desc; + Ast_412.Parsetree.pctf_loc; + Ast_412.Parsetree.pctf_attributes; + } -> + { + Ast_413.Parsetree.pctf_desc = copy_class_type_field_desc pctf_desc; + Ast_413.Parsetree.pctf_loc = copy_location pctf_loc; + Ast_413.Parsetree.pctf_attributes = copy_attributes pctf_attributes; + } + +and copy_class_type_field_desc : + Ast_412.Parsetree.class_type_field_desc -> + Ast_413.Parsetree.class_type_field_desc = function + | Ast_412.Parsetree.Pctf_inherit x0 -> + Ast_413.Parsetree.Pctf_inherit (copy_class_type x0) + | Ast_412.Parsetree.Pctf_val x0 -> + Ast_413.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_412.Parsetree.Pctf_method x0 -> + Ast_413.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_412.Parsetree.Pctf_constraint x0 -> + Ast_413.Parsetree.Pctf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | Ast_412.Parsetree.Pctf_attribute x0 -> + Ast_413.Parsetree.Pctf_attribute (copy_attribute x0) + | Ast_412.Parsetree.Pctf_extension x0 -> + Ast_413.Parsetree.Pctf_extension (copy_extension x0) + +and copy_extension : Ast_412.Parsetree.extension -> Ast_413.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_412.Parsetree.class_infos -> + 'g0 Ast_413.Parsetree.class_infos = + fun f0 + { + Ast_412.Parsetree.pci_virt; + Ast_412.Parsetree.pci_params; + Ast_412.Parsetree.pci_name; + Ast_412.Parsetree.pci_expr; + Ast_412.Parsetree.pci_loc; + Ast_412.Parsetree.pci_attributes; + } -> + { + Ast_413.Parsetree.pci_virt = copy_virtual_flag pci_virt; + Ast_413.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_413.Parsetree.pci_name = copy_loc (fun x -> x) pci_name; + Ast_413.Parsetree.pci_expr = f0 pci_expr; + Ast_413.Parsetree.pci_loc = copy_location pci_loc; + Ast_413.Parsetree.pci_attributes = copy_attributes pci_attributes; + } + +and copy_virtual_flag : + Ast_412.Asttypes.virtual_flag -> Ast_413.Asttypes.virtual_flag = function + | Ast_412.Asttypes.Virtual -> Ast_413.Asttypes.Virtual + | Ast_412.Asttypes.Concrete -> Ast_413.Asttypes.Concrete + +and copy_include_description : + Ast_412.Parsetree.include_description -> + Ast_413.Parsetree.include_description = + fun x -> copy_include_infos copy_module_type x + +and copy_include_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 Ast_412.Parsetree.include_infos -> + 'g0 Ast_413.Parsetree.include_infos = + fun f0 + { + Ast_412.Parsetree.pincl_mod; + Ast_412.Parsetree.pincl_loc; + Ast_412.Parsetree.pincl_attributes; + } -> + { + Ast_413.Parsetree.pincl_mod = f0 pincl_mod; + Ast_413.Parsetree.pincl_loc = copy_location pincl_loc; + Ast_413.Parsetree.pincl_attributes = copy_attributes pincl_attributes; + } + +and copy_open_description : + Ast_412.Parsetree.open_description -> Ast_413.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_412.Parsetree.open_infos -> + 'g0 Ast_413.Parsetree.open_infos = + fun f0 + { + Ast_412.Parsetree.popen_expr; + Ast_412.Parsetree.popen_override; + Ast_412.Parsetree.popen_loc; + Ast_412.Parsetree.popen_attributes; + } -> + { + Ast_413.Parsetree.popen_expr = f0 popen_expr; + Ast_413.Parsetree.popen_override = copy_override_flag popen_override; + Ast_413.Parsetree.popen_loc = copy_location popen_loc; + Ast_413.Parsetree.popen_attributes = copy_attributes popen_attributes; + } + +and copy_override_flag : + Ast_412.Asttypes.override_flag -> Ast_413.Asttypes.override_flag = function + | Ast_412.Asttypes.Override -> Ast_413.Asttypes.Override + | Ast_412.Asttypes.Fresh -> Ast_413.Asttypes.Fresh + +and copy_module_type_declaration : + Ast_412.Parsetree.module_type_declaration -> + Ast_413.Parsetree.module_type_declaration = + fun { + Ast_412.Parsetree.pmtd_name; + Ast_412.Parsetree.pmtd_type; + Ast_412.Parsetree.pmtd_attributes; + Ast_412.Parsetree.pmtd_loc; + } -> + { + Ast_413.Parsetree.pmtd_name = copy_loc (fun x -> x) pmtd_name; + Ast_413.Parsetree.pmtd_type = Option.map copy_module_type pmtd_type; + Ast_413.Parsetree.pmtd_attributes = copy_attributes pmtd_attributes; + Ast_413.Parsetree.pmtd_loc = copy_location pmtd_loc; + } + +and copy_module_substitution : + Ast_412.Parsetree.module_substitution -> + Ast_413.Parsetree.module_substitution = + fun { + Ast_412.Parsetree.pms_name; + Ast_412.Parsetree.pms_manifest; + Ast_412.Parsetree.pms_attributes; + Ast_412.Parsetree.pms_loc; + } -> + { + Ast_413.Parsetree.pms_name = copy_loc (fun x -> x) pms_name; + Ast_413.Parsetree.pms_manifest = copy_loc copy_Longident_t pms_manifest; + Ast_413.Parsetree.pms_attributes = copy_attributes pms_attributes; + Ast_413.Parsetree.pms_loc = copy_location pms_loc; + } + +and copy_module_declaration : + Ast_412.Parsetree.module_declaration -> Ast_413.Parsetree.module_declaration + = + fun { + Ast_412.Parsetree.pmd_name; + Ast_412.Parsetree.pmd_type; + Ast_412.Parsetree.pmd_attributes; + Ast_412.Parsetree.pmd_loc; + } -> + { + Ast_413.Parsetree.pmd_name = + copy_loc (fun x -> Option.map (fun x -> x) x) pmd_name; + Ast_413.Parsetree.pmd_type = copy_module_type pmd_type; + Ast_413.Parsetree.pmd_attributes = copy_attributes pmd_attributes; + Ast_413.Parsetree.pmd_loc = copy_location pmd_loc; + } + +and copy_type_exception : + Ast_412.Parsetree.type_exception -> Ast_413.Parsetree.type_exception = + fun { + Ast_412.Parsetree.ptyexn_constructor; + Ast_412.Parsetree.ptyexn_loc; + Ast_412.Parsetree.ptyexn_attributes; + } -> + { + Ast_413.Parsetree.ptyexn_constructor = + copy_extension_constructor ptyexn_constructor; + Ast_413.Parsetree.ptyexn_loc = copy_location ptyexn_loc; + Ast_413.Parsetree.ptyexn_attributes = copy_attributes ptyexn_attributes; + } + +and copy_type_extension : + Ast_412.Parsetree.type_extension -> Ast_413.Parsetree.type_extension = + fun { + Ast_412.Parsetree.ptyext_path; + Ast_412.Parsetree.ptyext_params; + Ast_412.Parsetree.ptyext_constructors; + Ast_412.Parsetree.ptyext_private; + Ast_412.Parsetree.ptyext_loc; + Ast_412.Parsetree.ptyext_attributes; + } -> + { + Ast_413.Parsetree.ptyext_path = copy_loc copy_Longident_t ptyext_path; + Ast_413.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_413.Parsetree.ptyext_constructors = + List.map copy_extension_constructor ptyext_constructors; + Ast_413.Parsetree.ptyext_private = copy_private_flag ptyext_private; + Ast_413.Parsetree.ptyext_loc = copy_location ptyext_loc; + Ast_413.Parsetree.ptyext_attributes = copy_attributes ptyext_attributes; + } + +and copy_extension_constructor : + Ast_412.Parsetree.extension_constructor -> + Ast_413.Parsetree.extension_constructor = + fun { + Ast_412.Parsetree.pext_name; + Ast_412.Parsetree.pext_kind; + Ast_412.Parsetree.pext_loc; + Ast_412.Parsetree.pext_attributes; + } -> + { + Ast_413.Parsetree.pext_name = copy_loc (fun x -> x) pext_name; + Ast_413.Parsetree.pext_kind = copy_extension_constructor_kind pext_kind; + Ast_413.Parsetree.pext_loc = copy_location pext_loc; + Ast_413.Parsetree.pext_attributes = copy_attributes pext_attributes; + } + +and copy_extension_constructor_kind : + Ast_412.Parsetree.extension_constructor_kind -> + Ast_413.Parsetree.extension_constructor_kind = function + | Ast_412.Parsetree.Pext_decl (x0, x1) -> + Ast_413.Parsetree.Pext_decl + (copy_constructor_arguments x0, Option.map copy_core_type x1) + | Ast_412.Parsetree.Pext_rebind x0 -> + Ast_413.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0) + +and copy_type_declaration : + Ast_412.Parsetree.type_declaration -> Ast_413.Parsetree.type_declaration = + fun { + Ast_412.Parsetree.ptype_name; + Ast_412.Parsetree.ptype_params; + Ast_412.Parsetree.ptype_cstrs; + Ast_412.Parsetree.ptype_kind; + Ast_412.Parsetree.ptype_private; + Ast_412.Parsetree.ptype_manifest; + Ast_412.Parsetree.ptype_attributes; + Ast_412.Parsetree.ptype_loc; + } -> + { + Ast_413.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name; + Ast_413.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_413.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_413.Parsetree.ptype_kind = copy_type_kind ptype_kind; + Ast_413.Parsetree.ptype_private = copy_private_flag ptype_private; + Ast_413.Parsetree.ptype_manifest = Option.map copy_core_type ptype_manifest; + Ast_413.Parsetree.ptype_attributes = copy_attributes ptype_attributes; + Ast_413.Parsetree.ptype_loc = copy_location ptype_loc; + } + +and copy_private_flag : + Ast_412.Asttypes.private_flag -> Ast_413.Asttypes.private_flag = function + | Ast_412.Asttypes.Private -> Ast_413.Asttypes.Private + | Ast_412.Asttypes.Public -> Ast_413.Asttypes.Public + +and copy_type_kind : Ast_412.Parsetree.type_kind -> Ast_413.Parsetree.type_kind + = function + | Ast_412.Parsetree.Ptype_abstract -> Ast_413.Parsetree.Ptype_abstract + | Ast_412.Parsetree.Ptype_variant x0 -> + Ast_413.Parsetree.Ptype_variant (List.map copy_constructor_declaration x0) + | Ast_412.Parsetree.Ptype_record x0 -> + Ast_413.Parsetree.Ptype_record (List.map copy_label_declaration x0) + | Ast_412.Parsetree.Ptype_open -> Ast_413.Parsetree.Ptype_open + +and copy_constructor_declaration : + Ast_412.Parsetree.constructor_declaration -> + Ast_413.Parsetree.constructor_declaration = + fun { + Ast_412.Parsetree.pcd_name; + Ast_412.Parsetree.pcd_args; + Ast_412.Parsetree.pcd_res; + Ast_412.Parsetree.pcd_loc; + Ast_412.Parsetree.pcd_attributes; + } -> + { + Ast_413.Parsetree.pcd_name = copy_loc (fun x -> x) pcd_name; + Ast_413.Parsetree.pcd_args = copy_constructor_arguments pcd_args; + Ast_413.Parsetree.pcd_res = Option.map copy_core_type pcd_res; + Ast_413.Parsetree.pcd_loc = copy_location pcd_loc; + Ast_413.Parsetree.pcd_attributes = copy_attributes pcd_attributes; + } + +and copy_constructor_arguments : + Ast_412.Parsetree.constructor_arguments -> + Ast_413.Parsetree.constructor_arguments = function + | Ast_412.Parsetree.Pcstr_tuple x0 -> + Ast_413.Parsetree.Pcstr_tuple (List.map copy_core_type x0) + | Ast_412.Parsetree.Pcstr_record x0 -> + Ast_413.Parsetree.Pcstr_record (List.map copy_label_declaration x0) + +and copy_label_declaration : + Ast_412.Parsetree.label_declaration -> Ast_413.Parsetree.label_declaration = + fun { + Ast_412.Parsetree.pld_name; + Ast_412.Parsetree.pld_mutable; + Ast_412.Parsetree.pld_type; + Ast_412.Parsetree.pld_loc; + Ast_412.Parsetree.pld_attributes; + } -> + { + Ast_413.Parsetree.pld_name = copy_loc (fun x -> x) pld_name; + Ast_413.Parsetree.pld_mutable = copy_mutable_flag pld_mutable; + Ast_413.Parsetree.pld_type = copy_core_type pld_type; + Ast_413.Parsetree.pld_loc = copy_location pld_loc; + Ast_413.Parsetree.pld_attributes = copy_attributes pld_attributes; + } + +and copy_mutable_flag : + Ast_412.Asttypes.mutable_flag -> Ast_413.Asttypes.mutable_flag = function + | Ast_412.Asttypes.Immutable -> Ast_413.Asttypes.Immutable + | Ast_412.Asttypes.Mutable -> Ast_413.Asttypes.Mutable + +and copy_injectivity : + Ast_412.Asttypes.injectivity -> Ast_413.Asttypes.injectivity = function + | Ast_412.Asttypes.Injective -> Ast_413.Asttypes.Injective + | Ast_412.Asttypes.NoInjectivity -> Ast_413.Asttypes.NoInjectivity + +and copy_variance : Ast_412.Asttypes.variance -> Ast_413.Asttypes.variance = + function + | Ast_412.Asttypes.Covariant -> Ast_413.Asttypes.Covariant + | Ast_412.Asttypes.Contravariant -> Ast_413.Asttypes.Contravariant + | Ast_412.Asttypes.NoVariance -> Ast_413.Asttypes.NoVariance + +and copy_value_description : + Ast_412.Parsetree.value_description -> Ast_413.Parsetree.value_description = + fun { + Ast_412.Parsetree.pval_name; + Ast_412.Parsetree.pval_type; + Ast_412.Parsetree.pval_prim; + Ast_412.Parsetree.pval_attributes; + Ast_412.Parsetree.pval_loc; + } -> + { + Ast_413.Parsetree.pval_name = copy_loc (fun x -> x) pval_name; + Ast_413.Parsetree.pval_type = copy_core_type pval_type; + Ast_413.Parsetree.pval_prim = List.map (fun x -> x) pval_prim; + Ast_413.Parsetree.pval_attributes = copy_attributes pval_attributes; + Ast_413.Parsetree.pval_loc = copy_location pval_loc; + } + +and copy_object_field_desc : + Ast_412.Parsetree.object_field_desc -> Ast_413.Parsetree.object_field_desc = + function + | Ast_412.Parsetree.Otag (x0, x1) -> + Ast_413.Parsetree.Otag (copy_loc copy_label x0, copy_core_type x1) + | Ast_412.Parsetree.Oinherit x0 -> + Ast_413.Parsetree.Oinherit (copy_core_type x0) + +and copy_arg_label : Ast_412.Asttypes.arg_label -> Ast_413.Asttypes.arg_label = + function + | Ast_412.Asttypes.Nolabel -> Ast_413.Asttypes.Nolabel + | Ast_412.Asttypes.Labelled x0 -> Ast_413.Asttypes.Labelled x0 + | Ast_412.Asttypes.Optional x0 -> Ast_413.Asttypes.Optional x0 + +and copy_closed_flag : + Ast_412.Asttypes.closed_flag -> Ast_413.Asttypes.closed_flag = function + | Ast_412.Asttypes.Closed -> Ast_413.Asttypes.Closed + | Ast_412.Asttypes.Open -> Ast_413.Asttypes.Open + +and copy_label : Ast_412.Asttypes.label -> Ast_413.Asttypes.label = fun x -> x + +and copy_rec_flag : Ast_412.Asttypes.rec_flag -> Ast_413.Asttypes.rec_flag = + function + | Ast_412.Asttypes.Nonrecursive -> Ast_413.Asttypes.Nonrecursive + | Ast_412.Asttypes.Recursive -> Ast_413.Asttypes.Recursive + +and copy_constant : Ast_412.Parsetree.constant -> Ast_413.Parsetree.constant = + function + | Ast_412.Parsetree.Pconst_integer (x0, x1) -> + Ast_413.Parsetree.Pconst_integer (x0, Option.map (fun x -> x) x1) + | Ast_412.Parsetree.Pconst_char x0 -> Ast_413.Parsetree.Pconst_char x0 + | Ast_412.Parsetree.Pconst_string (x0, x1, x2) -> + Ast_413.Parsetree.Pconst_string + (x0, copy_location x1, Option.map (fun x -> x) x2) + | Ast_412.Parsetree.Pconst_float (x0, x1) -> + Ast_413.Parsetree.Pconst_float (x0, Option.map (fun x -> x) x1) + +and copy_Longident_t : Longident.t -> Longident.t = fun x -> x + +and copy_loc : + 'f0 'g0. + ('f0 -> 'g0) -> 'f0 Ast_412.Asttypes.loc -> 'g0 Ast_413.Asttypes.loc = + fun f0 { Ast_412.Asttypes.txt; Ast_412.Asttypes.loc } -> + { Ast_413.Asttypes.txt = f0 txt; Ast_413.Asttypes.loc = copy_location loc } + +and copy_location : Location.t -> Location.t = fun x -> x diff -Nru ppxlib-0.15.0/astlib/migrate_413_412.ml ppxlib-0.24.0/astlib/migrate_413_412.ml --- ppxlib-0.15.0/astlib/migrate_413_412.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/migrate_413_412.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1220 @@ +open Stdlib0 +module From = Ast_413 +module To = Ast_412 + +let migration_error loc missing_feature = + Location.raise_errorf ~loc + "migration error: %s is not supported before OCaml 4.13" missing_feature + +let rec copy_toplevel_phrase : + Ast_413.Parsetree.toplevel_phrase -> Ast_412.Parsetree.toplevel_phrase = + function + | Ast_413.Parsetree.Ptop_def x0 -> + Ast_412.Parsetree.Ptop_def (copy_structure x0) + | Ast_413.Parsetree.Ptop_dir x0 -> + Ast_412.Parsetree.Ptop_dir (copy_toplevel_directive x0) + +and copy_toplevel_directive : + Ast_413.Parsetree.toplevel_directive -> Ast_412.Parsetree.toplevel_directive + = + fun { + Ast_413.Parsetree.pdir_name; + Ast_413.Parsetree.pdir_arg; + Ast_413.Parsetree.pdir_loc; + } -> + { + Ast_412.Parsetree.pdir_name = copy_loc (fun x -> x) pdir_name; + Ast_412.Parsetree.pdir_arg = Option.map copy_directive_argument pdir_arg; + Ast_412.Parsetree.pdir_loc = copy_location pdir_loc; + } + +and copy_directive_argument : + Ast_413.Parsetree.directive_argument -> Ast_412.Parsetree.directive_argument + = + fun { Ast_413.Parsetree.pdira_desc; Ast_413.Parsetree.pdira_loc } -> + { + Ast_412.Parsetree.pdira_desc = copy_directive_argument_desc pdira_desc; + Ast_412.Parsetree.pdira_loc = copy_location pdira_loc; + } + +and copy_directive_argument_desc : + Ast_413.Parsetree.directive_argument_desc -> + Ast_412.Parsetree.directive_argument_desc = function + | Ast_413.Parsetree.Pdir_string x0 -> Ast_412.Parsetree.Pdir_string x0 + | Ast_413.Parsetree.Pdir_int (x0, x1) -> + Ast_412.Parsetree.Pdir_int (x0, Option.map (fun x -> x) x1) + | Ast_413.Parsetree.Pdir_ident x0 -> + Ast_412.Parsetree.Pdir_ident (copy_Longident_t x0) + | Ast_413.Parsetree.Pdir_bool x0 -> Ast_412.Parsetree.Pdir_bool x0 + +and copy_expression : + Ast_413.Parsetree.expression -> Ast_412.Parsetree.expression = + fun { + Ast_413.Parsetree.pexp_desc; + Ast_413.Parsetree.pexp_loc; + Ast_413.Parsetree.pexp_loc_stack; + Ast_413.Parsetree.pexp_attributes; + } -> + { + Ast_412.Parsetree.pexp_desc = copy_expression_desc pexp_desc; + Ast_412.Parsetree.pexp_loc = copy_location pexp_loc; + Ast_412.Parsetree.pexp_loc_stack = copy_location_stack pexp_loc_stack; + Ast_412.Parsetree.pexp_attributes = copy_attributes pexp_attributes; + } + +and copy_expression_desc : + Ast_413.Parsetree.expression_desc -> Ast_412.Parsetree.expression_desc = + function + | Ast_413.Parsetree.Pexp_ident x0 -> + Ast_412.Parsetree.Pexp_ident (copy_loc copy_Longident_t x0) + | Ast_413.Parsetree.Pexp_constant x0 -> + Ast_412.Parsetree.Pexp_constant (copy_constant x0) + | Ast_413.Parsetree.Pexp_let (x0, x1, x2) -> + Ast_412.Parsetree.Pexp_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_expression x2) + | Ast_413.Parsetree.Pexp_function x0 -> + Ast_412.Parsetree.Pexp_function (List.map copy_case x0) + | Ast_413.Parsetree.Pexp_fun (x0, x1, x2, x3) -> + Ast_412.Parsetree.Pexp_fun + ( copy_arg_label x0, + Option.map copy_expression x1, + copy_pattern x2, + copy_expression x3 ) + | Ast_413.Parsetree.Pexp_apply (x0, x1) -> + Ast_412.Parsetree.Pexp_apply + ( copy_expression x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | Ast_413.Parsetree.Pexp_match (x0, x1) -> + Ast_412.Parsetree.Pexp_match (copy_expression x0, List.map copy_case x1) + | Ast_413.Parsetree.Pexp_try (x0, x1) -> + Ast_412.Parsetree.Pexp_try (copy_expression x0, List.map copy_case x1) + | Ast_413.Parsetree.Pexp_tuple x0 -> + Ast_412.Parsetree.Pexp_tuple (List.map copy_expression x0) + | Ast_413.Parsetree.Pexp_construct (x0, x1) -> + Ast_412.Parsetree.Pexp_construct + (copy_loc copy_Longident_t x0, Option.map copy_expression x1) + | Ast_413.Parsetree.Pexp_variant (x0, x1) -> + Ast_412.Parsetree.Pexp_variant + (copy_label x0, Option.map copy_expression x1) + | Ast_413.Parsetree.Pexp_record (x0, x1) -> + Ast_412.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_413.Parsetree.Pexp_field (x0, x1) -> + Ast_412.Parsetree.Pexp_field + (copy_expression x0, copy_loc copy_Longident_t x1) + | Ast_413.Parsetree.Pexp_setfield (x0, x1, x2) -> + Ast_412.Parsetree.Pexp_setfield + (copy_expression x0, copy_loc copy_Longident_t x1, copy_expression x2) + | Ast_413.Parsetree.Pexp_array x0 -> + Ast_412.Parsetree.Pexp_array (List.map copy_expression x0) + | Ast_413.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> + Ast_412.Parsetree.Pexp_ifthenelse + (copy_expression x0, copy_expression x1, Option.map copy_expression x2) + | Ast_413.Parsetree.Pexp_sequence (x0, x1) -> + Ast_412.Parsetree.Pexp_sequence (copy_expression x0, copy_expression x1) + | Ast_413.Parsetree.Pexp_while (x0, x1) -> + Ast_412.Parsetree.Pexp_while (copy_expression x0, copy_expression x1) + | Ast_413.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> + Ast_412.Parsetree.Pexp_for + ( copy_pattern x0, + copy_expression x1, + copy_expression x2, + copy_direction_flag x3, + copy_expression x4 ) + | Ast_413.Parsetree.Pexp_constraint (x0, x1) -> + Ast_412.Parsetree.Pexp_constraint (copy_expression x0, copy_core_type x1) + | Ast_413.Parsetree.Pexp_coerce (x0, x1, x2) -> + Ast_412.Parsetree.Pexp_coerce + (copy_expression x0, Option.map copy_core_type x1, copy_core_type x2) + | Ast_413.Parsetree.Pexp_send (x0, x1) -> + Ast_412.Parsetree.Pexp_send (copy_expression x0, copy_loc copy_label x1) + | Ast_413.Parsetree.Pexp_new x0 -> + Ast_412.Parsetree.Pexp_new (copy_loc copy_Longident_t x0) + | Ast_413.Parsetree.Pexp_setinstvar (x0, x1) -> + Ast_412.Parsetree.Pexp_setinstvar + (copy_loc copy_label x0, copy_expression x1) + | Ast_413.Parsetree.Pexp_override x0 -> + Ast_412.Parsetree.Pexp_override + (List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_label x0, copy_expression x1)) + x0) + | Ast_413.Parsetree.Pexp_letmodule (x0, x1, x2) -> + Ast_412.Parsetree.Pexp_letmodule + ( copy_loc (fun x -> Option.map (fun x -> x) x) x0, + copy_module_expr x1, + copy_expression x2 ) + | Ast_413.Parsetree.Pexp_letexception (x0, x1) -> + Ast_412.Parsetree.Pexp_letexception + (copy_extension_constructor x0, copy_expression x1) + | Ast_413.Parsetree.Pexp_assert x0 -> + Ast_412.Parsetree.Pexp_assert (copy_expression x0) + | Ast_413.Parsetree.Pexp_lazy x0 -> + Ast_412.Parsetree.Pexp_lazy (copy_expression x0) + | Ast_413.Parsetree.Pexp_poly (x0, x1) -> + Ast_412.Parsetree.Pexp_poly + (copy_expression x0, Option.map copy_core_type x1) + | Ast_413.Parsetree.Pexp_object x0 -> + Ast_412.Parsetree.Pexp_object (copy_class_structure x0) + | Ast_413.Parsetree.Pexp_newtype (x0, x1) -> + Ast_412.Parsetree.Pexp_newtype + (copy_loc (fun x -> x) x0, copy_expression x1) + | Ast_413.Parsetree.Pexp_pack x0 -> + Ast_412.Parsetree.Pexp_pack (copy_module_expr x0) + | Ast_413.Parsetree.Pexp_open (x0, x1) -> + Ast_412.Parsetree.Pexp_open (copy_open_declaration x0, copy_expression x1) + | Ast_413.Parsetree.Pexp_letop x0 -> + Ast_412.Parsetree.Pexp_letop (copy_letop x0) + | Ast_413.Parsetree.Pexp_extension x0 -> + Ast_412.Parsetree.Pexp_extension (copy_extension x0) + | Ast_413.Parsetree.Pexp_unreachable -> Ast_412.Parsetree.Pexp_unreachable + +and copy_letop : Ast_413.Parsetree.letop -> Ast_412.Parsetree.letop = + fun { Ast_413.Parsetree.let_; Ast_413.Parsetree.ands; Ast_413.Parsetree.body } -> + { + Ast_412.Parsetree.let_ = copy_binding_op let_; + Ast_412.Parsetree.ands = List.map copy_binding_op ands; + Ast_412.Parsetree.body = copy_expression body; + } + +and copy_binding_op : + Ast_413.Parsetree.binding_op -> Ast_412.Parsetree.binding_op = + fun { + Ast_413.Parsetree.pbop_op; + Ast_413.Parsetree.pbop_pat; + Ast_413.Parsetree.pbop_exp; + Ast_413.Parsetree.pbop_loc; + } -> + { + Ast_412.Parsetree.pbop_op = copy_loc (fun x -> x) pbop_op; + Ast_412.Parsetree.pbop_pat = copy_pattern pbop_pat; + Ast_412.Parsetree.pbop_exp = copy_expression pbop_exp; + Ast_412.Parsetree.pbop_loc = copy_location pbop_loc; + } + +and copy_direction_flag : + Ast_413.Asttypes.direction_flag -> Ast_412.Asttypes.direction_flag = + function + | Ast_413.Asttypes.Upto -> Ast_412.Asttypes.Upto + | Ast_413.Asttypes.Downto -> Ast_412.Asttypes.Downto + +and copy_case : Ast_413.Parsetree.case -> Ast_412.Parsetree.case = + fun { + Ast_413.Parsetree.pc_lhs; + Ast_413.Parsetree.pc_guard; + Ast_413.Parsetree.pc_rhs; + } -> + { + Ast_412.Parsetree.pc_lhs = copy_pattern pc_lhs; + Ast_412.Parsetree.pc_guard = Option.map copy_expression pc_guard; + Ast_412.Parsetree.pc_rhs = copy_expression pc_rhs; + } + +and copy_value_binding : + Ast_413.Parsetree.value_binding -> Ast_412.Parsetree.value_binding = + fun { + Ast_413.Parsetree.pvb_pat; + Ast_413.Parsetree.pvb_expr; + Ast_413.Parsetree.pvb_attributes; + Ast_413.Parsetree.pvb_loc; + } -> + { + Ast_412.Parsetree.pvb_pat = copy_pattern pvb_pat; + Ast_412.Parsetree.pvb_expr = copy_expression pvb_expr; + Ast_412.Parsetree.pvb_attributes = copy_attributes pvb_attributes; + Ast_412.Parsetree.pvb_loc = copy_location pvb_loc; + } + +and copy_pattern : Ast_413.Parsetree.pattern -> Ast_412.Parsetree.pattern = + fun { + Ast_413.Parsetree.ppat_desc; + Ast_413.Parsetree.ppat_loc; + Ast_413.Parsetree.ppat_loc_stack; + Ast_413.Parsetree.ppat_attributes; + } -> + { + Ast_412.Parsetree.ppat_desc = copy_pattern_desc ppat_desc; + Ast_412.Parsetree.ppat_loc = copy_location ppat_loc; + Ast_412.Parsetree.ppat_loc_stack = copy_location_stack ppat_loc_stack; + Ast_412.Parsetree.ppat_attributes = copy_attributes ppat_attributes; + } + +and copy_pattern_desc : + Ast_413.Parsetree.pattern_desc -> Ast_412.Parsetree.pattern_desc = function + | Ast_413.Parsetree.Ppat_any -> Ast_412.Parsetree.Ppat_any + | Ast_413.Parsetree.Ppat_var x0 -> + Ast_412.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) + | Ast_413.Parsetree.Ppat_alias (x0, x1) -> + Ast_412.Parsetree.Ppat_alias (copy_pattern x0, copy_loc (fun x -> x) x1) + | Ast_413.Parsetree.Ppat_constant x0 -> + Ast_412.Parsetree.Ppat_constant (copy_constant x0) + | Ast_413.Parsetree.Ppat_interval (x0, x1) -> + Ast_412.Parsetree.Ppat_interval (copy_constant x0, copy_constant x1) + | Ast_413.Parsetree.Ppat_tuple x0 -> + Ast_412.Parsetree.Ppat_tuple (List.map copy_pattern x0) + | Ast_413.Parsetree.Ppat_construct (x0, x1) -> + Ast_412.Parsetree.Ppat_construct + ( copy_loc copy_Longident_t x0, + Option.map + (fun x -> + let x0, x1 = x in + (match x0 with + | [] -> () + | ty :: _ -> + migration_error ty.Ast_413.Asttypes.loc + "existentials in pattern-matching"); + copy_pattern x1) + x1 ) + | Ast_413.Parsetree.Ppat_variant (x0, x1) -> + Ast_412.Parsetree.Ppat_variant (copy_label x0, Option.map copy_pattern x1) + | Ast_413.Parsetree.Ppat_record (x0, x1) -> + Ast_412.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_413.Parsetree.Ppat_array x0 -> + Ast_412.Parsetree.Ppat_array (List.map copy_pattern x0) + | Ast_413.Parsetree.Ppat_or (x0, x1) -> + Ast_412.Parsetree.Ppat_or (copy_pattern x0, copy_pattern x1) + | Ast_413.Parsetree.Ppat_constraint (x0, x1) -> + Ast_412.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1) + | Ast_413.Parsetree.Ppat_type x0 -> + Ast_412.Parsetree.Ppat_type (copy_loc copy_Longident_t x0) + | Ast_413.Parsetree.Ppat_lazy x0 -> + Ast_412.Parsetree.Ppat_lazy (copy_pattern x0) + | Ast_413.Parsetree.Ppat_unpack x0 -> + Ast_412.Parsetree.Ppat_unpack + (copy_loc (fun x -> Option.map (fun x -> x) x) x0) + | Ast_413.Parsetree.Ppat_exception x0 -> + Ast_412.Parsetree.Ppat_exception (copy_pattern x0) + | Ast_413.Parsetree.Ppat_extension x0 -> + Ast_412.Parsetree.Ppat_extension (copy_extension x0) + | Ast_413.Parsetree.Ppat_open (x0, x1) -> + Ast_412.Parsetree.Ppat_open (copy_loc copy_Longident_t x0, copy_pattern x1) + +and copy_core_type : Ast_413.Parsetree.core_type -> Ast_412.Parsetree.core_type + = + fun { + Ast_413.Parsetree.ptyp_desc; + Ast_413.Parsetree.ptyp_loc; + Ast_413.Parsetree.ptyp_loc_stack; + Ast_413.Parsetree.ptyp_attributes; + } -> + { + Ast_412.Parsetree.ptyp_desc = copy_core_type_desc ptyp_desc; + Ast_412.Parsetree.ptyp_loc = copy_location ptyp_loc; + Ast_412.Parsetree.ptyp_loc_stack = copy_location_stack ptyp_loc_stack; + Ast_412.Parsetree.ptyp_attributes = copy_attributes ptyp_attributes; + } + +and copy_location_stack : + Ast_413.Parsetree.location_stack -> Ast_412.Parsetree.location_stack = + fun x -> List.map copy_location x + +and copy_core_type_desc : + Ast_413.Parsetree.core_type_desc -> Ast_412.Parsetree.core_type_desc = + function + | Ast_413.Parsetree.Ptyp_any -> Ast_412.Parsetree.Ptyp_any + | Ast_413.Parsetree.Ptyp_var x0 -> Ast_412.Parsetree.Ptyp_var x0 + | Ast_413.Parsetree.Ptyp_arrow (x0, x1, x2) -> + Ast_412.Parsetree.Ptyp_arrow + (copy_arg_label x0, copy_core_type x1, copy_core_type x2) + | Ast_413.Parsetree.Ptyp_tuple x0 -> + Ast_412.Parsetree.Ptyp_tuple (List.map copy_core_type x0) + | Ast_413.Parsetree.Ptyp_constr (x0, x1) -> + Ast_412.Parsetree.Ptyp_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_413.Parsetree.Ptyp_object (x0, x1) -> + Ast_412.Parsetree.Ptyp_object + (List.map copy_object_field x0, copy_closed_flag x1) + | Ast_413.Parsetree.Ptyp_class (x0, x1) -> + Ast_412.Parsetree.Ptyp_class + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_413.Parsetree.Ptyp_alias (x0, x1) -> + Ast_412.Parsetree.Ptyp_alias (copy_core_type x0, x1) + | Ast_413.Parsetree.Ptyp_variant (x0, x1, x2) -> + Ast_412.Parsetree.Ptyp_variant + ( List.map copy_row_field x0, + copy_closed_flag x1, + Option.map (fun x -> List.map copy_label x) x2 ) + | Ast_413.Parsetree.Ptyp_poly (x0, x1) -> + Ast_412.Parsetree.Ptyp_poly + (List.map (fun x -> copy_loc (fun x -> x) x) x0, copy_core_type x1) + | Ast_413.Parsetree.Ptyp_package x0 -> + Ast_412.Parsetree.Ptyp_package (copy_package_type x0) + | Ast_413.Parsetree.Ptyp_extension x0 -> + Ast_412.Parsetree.Ptyp_extension (copy_extension x0) + +and copy_package_type : + Ast_413.Parsetree.package_type -> Ast_412.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_413.Parsetree.row_field -> Ast_412.Parsetree.row_field + = + fun { + Ast_413.Parsetree.prf_desc; + Ast_413.Parsetree.prf_loc; + Ast_413.Parsetree.prf_attributes; + } -> + { + Ast_412.Parsetree.prf_desc = copy_row_field_desc prf_desc; + Ast_412.Parsetree.prf_loc = copy_location prf_loc; + Ast_412.Parsetree.prf_attributes = copy_attributes prf_attributes; + } + +and copy_row_field_desc : + Ast_413.Parsetree.row_field_desc -> Ast_412.Parsetree.row_field_desc = + function + | Ast_413.Parsetree.Rtag (x0, x1, x2) -> + Ast_412.Parsetree.Rtag + (copy_loc copy_label x0, x1, List.map copy_core_type x2) + | Ast_413.Parsetree.Rinherit x0 -> + Ast_412.Parsetree.Rinherit (copy_core_type x0) + +and copy_object_field : + Ast_413.Parsetree.object_field -> Ast_412.Parsetree.object_field = + fun { + Ast_413.Parsetree.pof_desc; + Ast_413.Parsetree.pof_loc; + Ast_413.Parsetree.pof_attributes; + } -> + { + Ast_412.Parsetree.pof_desc = copy_object_field_desc pof_desc; + Ast_412.Parsetree.pof_loc = copy_location pof_loc; + Ast_412.Parsetree.pof_attributes = copy_attributes pof_attributes; + } + +and copy_attributes : + Ast_413.Parsetree.attributes -> Ast_412.Parsetree.attributes = + fun x -> List.map copy_attribute x + +and copy_attribute : Ast_413.Parsetree.attribute -> Ast_412.Parsetree.attribute + = + fun { + Ast_413.Parsetree.attr_name; + Ast_413.Parsetree.attr_payload; + Ast_413.Parsetree.attr_loc; + } -> + { + Ast_412.Parsetree.attr_name = copy_loc (fun x -> x) attr_name; + Ast_412.Parsetree.attr_payload = copy_payload attr_payload; + Ast_412.Parsetree.attr_loc = copy_location attr_loc; + } + +and copy_payload : Ast_413.Parsetree.payload -> Ast_412.Parsetree.payload = + function + | Ast_413.Parsetree.PStr x0 -> Ast_412.Parsetree.PStr (copy_structure x0) + | Ast_413.Parsetree.PSig x0 -> Ast_412.Parsetree.PSig (copy_signature x0) + | Ast_413.Parsetree.PTyp x0 -> Ast_412.Parsetree.PTyp (copy_core_type x0) + | Ast_413.Parsetree.PPat (x0, x1) -> + Ast_412.Parsetree.PPat (copy_pattern x0, Option.map copy_expression x1) + +and copy_structure : Ast_413.Parsetree.structure -> Ast_412.Parsetree.structure + = + fun x -> List.map copy_structure_item x + +and copy_structure_item : + Ast_413.Parsetree.structure_item -> Ast_412.Parsetree.structure_item = + fun { Ast_413.Parsetree.pstr_desc; Ast_413.Parsetree.pstr_loc } -> + { + Ast_412.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc; + Ast_412.Parsetree.pstr_loc = copy_location pstr_loc; + } + +and copy_structure_item_desc : + Ast_413.Parsetree.structure_item_desc -> + Ast_412.Parsetree.structure_item_desc = function + | Ast_413.Parsetree.Pstr_eval (x0, x1) -> + Ast_412.Parsetree.Pstr_eval (copy_expression x0, copy_attributes x1) + | Ast_413.Parsetree.Pstr_value (x0, x1) -> + Ast_412.Parsetree.Pstr_value + (copy_rec_flag x0, List.map copy_value_binding x1) + | Ast_413.Parsetree.Pstr_primitive x0 -> + Ast_412.Parsetree.Pstr_primitive (copy_value_description x0) + | Ast_413.Parsetree.Pstr_type (x0, x1) -> + Ast_412.Parsetree.Pstr_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | Ast_413.Parsetree.Pstr_typext x0 -> + Ast_412.Parsetree.Pstr_typext (copy_type_extension x0) + | Ast_413.Parsetree.Pstr_exception x0 -> + Ast_412.Parsetree.Pstr_exception (copy_type_exception x0) + | Ast_413.Parsetree.Pstr_module x0 -> + Ast_412.Parsetree.Pstr_module (copy_module_binding x0) + | Ast_413.Parsetree.Pstr_recmodule x0 -> + Ast_412.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) + | Ast_413.Parsetree.Pstr_modtype x0 -> + Ast_412.Parsetree.Pstr_modtype (copy_module_type_declaration x0) + | Ast_413.Parsetree.Pstr_open x0 -> + Ast_412.Parsetree.Pstr_open (copy_open_declaration x0) + | Ast_413.Parsetree.Pstr_class x0 -> + Ast_412.Parsetree.Pstr_class (List.map copy_class_declaration x0) + | Ast_413.Parsetree.Pstr_class_type x0 -> + Ast_412.Parsetree.Pstr_class_type + (List.map copy_class_type_declaration x0) + | Ast_413.Parsetree.Pstr_include x0 -> + Ast_412.Parsetree.Pstr_include (copy_include_declaration x0) + | Ast_413.Parsetree.Pstr_attribute x0 -> + Ast_412.Parsetree.Pstr_attribute (copy_attribute x0) + | Ast_413.Parsetree.Pstr_extension (x0, x1) -> + Ast_412.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1) + +and copy_include_declaration : + Ast_413.Parsetree.include_declaration -> + Ast_412.Parsetree.include_declaration = + fun x -> copy_include_infos copy_module_expr x + +and copy_class_declaration : + Ast_413.Parsetree.class_declaration -> Ast_412.Parsetree.class_declaration = + fun x -> copy_class_infos copy_class_expr x + +and copy_class_expr : + Ast_413.Parsetree.class_expr -> Ast_412.Parsetree.class_expr = + fun { + Ast_413.Parsetree.pcl_desc; + Ast_413.Parsetree.pcl_loc; + Ast_413.Parsetree.pcl_attributes; + } -> + { + Ast_412.Parsetree.pcl_desc = copy_class_expr_desc pcl_desc; + Ast_412.Parsetree.pcl_loc = copy_location pcl_loc; + Ast_412.Parsetree.pcl_attributes = copy_attributes pcl_attributes; + } + +and copy_class_expr_desc : + Ast_413.Parsetree.class_expr_desc -> Ast_412.Parsetree.class_expr_desc = + function + | Ast_413.Parsetree.Pcl_constr (x0, x1) -> + Ast_412.Parsetree.Pcl_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_413.Parsetree.Pcl_structure x0 -> + Ast_412.Parsetree.Pcl_structure (copy_class_structure x0) + | Ast_413.Parsetree.Pcl_fun (x0, x1, x2, x3) -> + Ast_412.Parsetree.Pcl_fun + ( copy_arg_label x0, + Option.map copy_expression x1, + copy_pattern x2, + copy_class_expr x3 ) + | Ast_413.Parsetree.Pcl_apply (x0, x1) -> + Ast_412.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_413.Parsetree.Pcl_let (x0, x1, x2) -> + Ast_412.Parsetree.Pcl_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_class_expr x2) + | Ast_413.Parsetree.Pcl_constraint (x0, x1) -> + Ast_412.Parsetree.Pcl_constraint (copy_class_expr x0, copy_class_type x1) + | Ast_413.Parsetree.Pcl_extension x0 -> + Ast_412.Parsetree.Pcl_extension (copy_extension x0) + | Ast_413.Parsetree.Pcl_open (x0, x1) -> + Ast_412.Parsetree.Pcl_open (copy_open_description x0, copy_class_expr x1) + +and copy_class_structure : + Ast_413.Parsetree.class_structure -> Ast_412.Parsetree.class_structure = + fun { Ast_413.Parsetree.pcstr_self; Ast_413.Parsetree.pcstr_fields } -> + { + Ast_412.Parsetree.pcstr_self = copy_pattern pcstr_self; + Ast_412.Parsetree.pcstr_fields = List.map copy_class_field pcstr_fields; + } + +and copy_class_field : + Ast_413.Parsetree.class_field -> Ast_412.Parsetree.class_field = + fun { + Ast_413.Parsetree.pcf_desc; + Ast_413.Parsetree.pcf_loc; + Ast_413.Parsetree.pcf_attributes; + } -> + { + Ast_412.Parsetree.pcf_desc = copy_class_field_desc pcf_desc; + Ast_412.Parsetree.pcf_loc = copy_location pcf_loc; + Ast_412.Parsetree.pcf_attributes = copy_attributes pcf_attributes; + } + +and copy_class_field_desc : + Ast_413.Parsetree.class_field_desc -> Ast_412.Parsetree.class_field_desc = + function + | Ast_413.Parsetree.Pcf_inherit (x0, x1, x2) -> + Ast_412.Parsetree.Pcf_inherit + ( copy_override_flag x0, + copy_class_expr x1, + Option.map (fun x -> copy_loc (fun x -> x) x) x2 ) + | Ast_413.Parsetree.Pcf_val x0 -> + Ast_412.Parsetree.Pcf_val + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_mutable_flag x1, copy_class_field_kind x2)) + | Ast_413.Parsetree.Pcf_method x0 -> + Ast_412.Parsetree.Pcf_method + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_private_flag x1, copy_class_field_kind x2)) + | Ast_413.Parsetree.Pcf_constraint x0 -> + Ast_412.Parsetree.Pcf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | Ast_413.Parsetree.Pcf_initializer x0 -> + Ast_412.Parsetree.Pcf_initializer (copy_expression x0) + | Ast_413.Parsetree.Pcf_attribute x0 -> + Ast_412.Parsetree.Pcf_attribute (copy_attribute x0) + | Ast_413.Parsetree.Pcf_extension x0 -> + Ast_412.Parsetree.Pcf_extension (copy_extension x0) + +and copy_class_field_kind : + Ast_413.Parsetree.class_field_kind -> Ast_412.Parsetree.class_field_kind = + function + | Ast_413.Parsetree.Cfk_virtual x0 -> + Ast_412.Parsetree.Cfk_virtual (copy_core_type x0) + | Ast_413.Parsetree.Cfk_concrete (x0, x1) -> + Ast_412.Parsetree.Cfk_concrete (copy_override_flag x0, copy_expression x1) + +and copy_open_declaration : + Ast_413.Parsetree.open_declaration -> Ast_412.Parsetree.open_declaration = + fun x -> copy_open_infos copy_module_expr x + +and copy_module_binding : + Ast_413.Parsetree.module_binding -> Ast_412.Parsetree.module_binding = + fun { + Ast_413.Parsetree.pmb_name; + Ast_413.Parsetree.pmb_expr; + Ast_413.Parsetree.pmb_attributes; + Ast_413.Parsetree.pmb_loc; + } -> + { + Ast_412.Parsetree.pmb_name = + copy_loc (fun x -> Option.map (fun x -> x) x) pmb_name; + Ast_412.Parsetree.pmb_expr = copy_module_expr pmb_expr; + Ast_412.Parsetree.pmb_attributes = copy_attributes pmb_attributes; + Ast_412.Parsetree.pmb_loc = copy_location pmb_loc; + } + +and copy_module_expr : + Ast_413.Parsetree.module_expr -> Ast_412.Parsetree.module_expr = + fun { + Ast_413.Parsetree.pmod_desc; + Ast_413.Parsetree.pmod_loc; + Ast_413.Parsetree.pmod_attributes; + } -> + { + Ast_412.Parsetree.pmod_desc = copy_module_expr_desc pmod_desc; + Ast_412.Parsetree.pmod_loc = copy_location pmod_loc; + Ast_412.Parsetree.pmod_attributes = copy_attributes pmod_attributes; + } + +and copy_module_expr_desc : + Ast_413.Parsetree.module_expr_desc -> Ast_412.Parsetree.module_expr_desc = + function + | Ast_413.Parsetree.Pmod_ident x0 -> + Ast_412.Parsetree.Pmod_ident (copy_loc copy_Longident_t x0) + | Ast_413.Parsetree.Pmod_structure x0 -> + Ast_412.Parsetree.Pmod_structure (copy_structure x0) + | Ast_413.Parsetree.Pmod_functor (x0, x1) -> + Ast_412.Parsetree.Pmod_functor + (copy_functor_parameter x0, copy_module_expr x1) + | Ast_413.Parsetree.Pmod_apply (x0, x1) -> + Ast_412.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) + | Ast_413.Parsetree.Pmod_constraint (x0, x1) -> + Ast_412.Parsetree.Pmod_constraint + (copy_module_expr x0, copy_module_type x1) + | Ast_413.Parsetree.Pmod_unpack x0 -> + Ast_412.Parsetree.Pmod_unpack (copy_expression x0) + | Ast_413.Parsetree.Pmod_extension x0 -> + Ast_412.Parsetree.Pmod_extension (copy_extension x0) + +and copy_functor_parameter : + Ast_413.Parsetree.functor_parameter -> Ast_412.Parsetree.functor_parameter = + function + | Ast_413.Parsetree.Unit -> Ast_412.Parsetree.Unit + | Ast_413.Parsetree.Named (x0, x1) -> + Ast_412.Parsetree.Named + (copy_loc (fun x -> Option.map (fun x -> x) x) x0, copy_module_type x1) + +and copy_module_type : + Ast_413.Parsetree.module_type -> Ast_412.Parsetree.module_type = + fun { + Ast_413.Parsetree.pmty_desc; + Ast_413.Parsetree.pmty_loc; + Ast_413.Parsetree.pmty_attributes; + } -> + { + Ast_412.Parsetree.pmty_desc = copy_module_type_desc pmty_desc; + Ast_412.Parsetree.pmty_loc = copy_location pmty_loc; + Ast_412.Parsetree.pmty_attributes = copy_attributes pmty_attributes; + } + +and copy_module_type_desc : + Ast_413.Parsetree.module_type_desc -> Ast_412.Parsetree.module_type_desc = + function + | Ast_413.Parsetree.Pmty_ident x0 -> + Ast_412.Parsetree.Pmty_ident (copy_loc copy_Longident_t x0) + | Ast_413.Parsetree.Pmty_signature x0 -> + Ast_412.Parsetree.Pmty_signature (copy_signature x0) + | Ast_413.Parsetree.Pmty_functor (x0, x1) -> + Ast_412.Parsetree.Pmty_functor + (copy_functor_parameter x0, copy_module_type x1) + | Ast_413.Parsetree.Pmty_with (x0, x1) -> + Ast_412.Parsetree.Pmty_with + (copy_module_type x0, List.map copy_with_constraint x1) + | Ast_413.Parsetree.Pmty_typeof x0 -> + Ast_412.Parsetree.Pmty_typeof (copy_module_expr x0) + | Ast_413.Parsetree.Pmty_extension x0 -> + Ast_412.Parsetree.Pmty_extension (copy_extension x0) + | Ast_413.Parsetree.Pmty_alias x0 -> + Ast_412.Parsetree.Pmty_alias (copy_loc copy_Longident_t x0) + +and copy_with_constraint : + Ast_413.Parsetree.with_constraint -> Ast_412.Parsetree.with_constraint = + function + | Ast_413.Parsetree.Pwith_type (x0, x1) -> + Ast_412.Parsetree.Pwith_type + (copy_loc copy_Longident_t x0, copy_type_declaration x1) + | Ast_413.Parsetree.Pwith_module (x0, x1) -> + Ast_412.Parsetree.Pwith_module + (copy_loc copy_Longident_t x0, copy_loc copy_Longident_t x1) + | Ast_413.Parsetree.Pwith_modtype (_x0, x1) -> + migration_error x1.Ast_413.Parsetree.pmty_loc "module type substitution" + | Ast_413.Parsetree.Pwith_modtypesubst (_x0, x1) -> + migration_error x1.Ast_413.Parsetree.pmty_loc + "destructive module type substitution" + | Ast_413.Parsetree.Pwith_typesubst (x0, x1) -> + Ast_412.Parsetree.Pwith_typesubst + (copy_loc copy_Longident_t x0, copy_type_declaration x1) + | Ast_413.Parsetree.Pwith_modsubst (x0, x1) -> + Ast_412.Parsetree.Pwith_modsubst + (copy_loc copy_Longident_t x0, copy_loc copy_Longident_t x1) + +and copy_signature : Ast_413.Parsetree.signature -> Ast_412.Parsetree.signature + = + fun x -> List.map copy_signature_item x + +and copy_signature_item : + Ast_413.Parsetree.signature_item -> Ast_412.Parsetree.signature_item = + fun { Ast_413.Parsetree.psig_desc; Ast_413.Parsetree.psig_loc } -> + { + Ast_412.Parsetree.psig_desc = copy_signature_item_desc psig_desc; + Ast_412.Parsetree.psig_loc = copy_location psig_loc; + } + +and copy_signature_item_desc : + Ast_413.Parsetree.signature_item_desc -> + Ast_412.Parsetree.signature_item_desc = function + | Ast_413.Parsetree.Psig_value x0 -> + Ast_412.Parsetree.Psig_value (copy_value_description x0) + | Ast_413.Parsetree.Psig_type (x0, x1) -> + Ast_412.Parsetree.Psig_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | Ast_413.Parsetree.Psig_typesubst x0 -> + Ast_412.Parsetree.Psig_typesubst (List.map copy_type_declaration x0) + | Ast_413.Parsetree.Psig_typext x0 -> + Ast_412.Parsetree.Psig_typext (copy_type_extension x0) + | Ast_413.Parsetree.Psig_exception x0 -> + Ast_412.Parsetree.Psig_exception (copy_type_exception x0) + | Ast_413.Parsetree.Psig_module x0 -> + Ast_412.Parsetree.Psig_module (copy_module_declaration x0) + | Ast_413.Parsetree.Psig_modsubst x0 -> + Ast_412.Parsetree.Psig_modsubst (copy_module_substitution x0) + | Ast_413.Parsetree.Psig_recmodule x0 -> + Ast_412.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) + | Ast_413.Parsetree.Psig_modtype x0 -> + Ast_412.Parsetree.Psig_modtype (copy_module_type_declaration x0) + | Ast_413.Parsetree.Psig_modtypesubst x0 -> + migration_error x0.Ast_413.Parsetree.pmtd_loc + "local module type substitution" + | Ast_413.Parsetree.Psig_open x0 -> + Ast_412.Parsetree.Psig_open (copy_open_description x0) + | Ast_413.Parsetree.Psig_include x0 -> + Ast_412.Parsetree.Psig_include (copy_include_description x0) + | Ast_413.Parsetree.Psig_class x0 -> + Ast_412.Parsetree.Psig_class (List.map copy_class_description x0) + | Ast_413.Parsetree.Psig_class_type x0 -> + Ast_412.Parsetree.Psig_class_type + (List.map copy_class_type_declaration x0) + | Ast_413.Parsetree.Psig_attribute x0 -> + Ast_412.Parsetree.Psig_attribute (copy_attribute x0) + | Ast_413.Parsetree.Psig_extension (x0, x1) -> + Ast_412.Parsetree.Psig_extension (copy_extension x0, copy_attributes x1) + +and copy_class_type_declaration : + Ast_413.Parsetree.class_type_declaration -> + Ast_412.Parsetree.class_type_declaration = + fun x -> copy_class_infos copy_class_type x + +and copy_class_description : + Ast_413.Parsetree.class_description -> Ast_412.Parsetree.class_description = + fun x -> copy_class_infos copy_class_type x + +and copy_class_type : + Ast_413.Parsetree.class_type -> Ast_412.Parsetree.class_type = + fun { + Ast_413.Parsetree.pcty_desc; + Ast_413.Parsetree.pcty_loc; + Ast_413.Parsetree.pcty_attributes; + } -> + { + Ast_412.Parsetree.pcty_desc = copy_class_type_desc pcty_desc; + Ast_412.Parsetree.pcty_loc = copy_location pcty_loc; + Ast_412.Parsetree.pcty_attributes = copy_attributes pcty_attributes; + } + +and copy_class_type_desc : + Ast_413.Parsetree.class_type_desc -> Ast_412.Parsetree.class_type_desc = + function + | Ast_413.Parsetree.Pcty_constr (x0, x1) -> + Ast_412.Parsetree.Pcty_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_413.Parsetree.Pcty_signature x0 -> + Ast_412.Parsetree.Pcty_signature (copy_class_signature x0) + | Ast_413.Parsetree.Pcty_arrow (x0, x1, x2) -> + Ast_412.Parsetree.Pcty_arrow + (copy_arg_label x0, copy_core_type x1, copy_class_type x2) + | Ast_413.Parsetree.Pcty_extension x0 -> + Ast_412.Parsetree.Pcty_extension (copy_extension x0) + | Ast_413.Parsetree.Pcty_open (x0, x1) -> + Ast_412.Parsetree.Pcty_open (copy_open_description x0, copy_class_type x1) + +and copy_class_signature : + Ast_413.Parsetree.class_signature -> Ast_412.Parsetree.class_signature = + fun { Ast_413.Parsetree.pcsig_self; Ast_413.Parsetree.pcsig_fields } -> + { + Ast_412.Parsetree.pcsig_self = copy_core_type pcsig_self; + Ast_412.Parsetree.pcsig_fields = List.map copy_class_type_field pcsig_fields; + } + +and copy_class_type_field : + Ast_413.Parsetree.class_type_field -> Ast_412.Parsetree.class_type_field = + fun { + Ast_413.Parsetree.pctf_desc; + Ast_413.Parsetree.pctf_loc; + Ast_413.Parsetree.pctf_attributes; + } -> + { + Ast_412.Parsetree.pctf_desc = copy_class_type_field_desc pctf_desc; + Ast_412.Parsetree.pctf_loc = copy_location pctf_loc; + Ast_412.Parsetree.pctf_attributes = copy_attributes pctf_attributes; + } + +and copy_class_type_field_desc : + Ast_413.Parsetree.class_type_field_desc -> + Ast_412.Parsetree.class_type_field_desc = function + | Ast_413.Parsetree.Pctf_inherit x0 -> + Ast_412.Parsetree.Pctf_inherit (copy_class_type x0) + | Ast_413.Parsetree.Pctf_val x0 -> + Ast_412.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_413.Parsetree.Pctf_method x0 -> + Ast_412.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_413.Parsetree.Pctf_constraint x0 -> + Ast_412.Parsetree.Pctf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | Ast_413.Parsetree.Pctf_attribute x0 -> + Ast_412.Parsetree.Pctf_attribute (copy_attribute x0) + | Ast_413.Parsetree.Pctf_extension x0 -> + Ast_412.Parsetree.Pctf_extension (copy_extension x0) + +and copy_extension : Ast_413.Parsetree.extension -> Ast_412.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_413.Parsetree.class_infos -> + 'g0 Ast_412.Parsetree.class_infos = + fun f0 + { + Ast_413.Parsetree.pci_virt; + Ast_413.Parsetree.pci_params; + Ast_413.Parsetree.pci_name; + Ast_413.Parsetree.pci_expr; + Ast_413.Parsetree.pci_loc; + Ast_413.Parsetree.pci_attributes; + } -> + { + Ast_412.Parsetree.pci_virt = copy_virtual_flag pci_virt; + Ast_412.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_412.Parsetree.pci_name = copy_loc (fun x -> x) pci_name; + Ast_412.Parsetree.pci_expr = f0 pci_expr; + Ast_412.Parsetree.pci_loc = copy_location pci_loc; + Ast_412.Parsetree.pci_attributes = copy_attributes pci_attributes; + } + +and copy_virtual_flag : + Ast_413.Asttypes.virtual_flag -> Ast_412.Asttypes.virtual_flag = function + | Ast_413.Asttypes.Virtual -> Ast_412.Asttypes.Virtual + | Ast_413.Asttypes.Concrete -> Ast_412.Asttypes.Concrete + +and copy_include_description : + Ast_413.Parsetree.include_description -> + Ast_412.Parsetree.include_description = + fun x -> copy_include_infos copy_module_type x + +and copy_include_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 Ast_413.Parsetree.include_infos -> + 'g0 Ast_412.Parsetree.include_infos = + fun f0 + { + Ast_413.Parsetree.pincl_mod; + Ast_413.Parsetree.pincl_loc; + Ast_413.Parsetree.pincl_attributes; + } -> + { + Ast_412.Parsetree.pincl_mod = f0 pincl_mod; + Ast_412.Parsetree.pincl_loc = copy_location pincl_loc; + Ast_412.Parsetree.pincl_attributes = copy_attributes pincl_attributes; + } + +and copy_open_description : + Ast_413.Parsetree.open_description -> Ast_412.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_413.Parsetree.open_infos -> + 'g0 Ast_412.Parsetree.open_infos = + fun f0 + { + Ast_413.Parsetree.popen_expr; + Ast_413.Parsetree.popen_override; + Ast_413.Parsetree.popen_loc; + Ast_413.Parsetree.popen_attributes; + } -> + { + Ast_412.Parsetree.popen_expr = f0 popen_expr; + Ast_412.Parsetree.popen_override = copy_override_flag popen_override; + Ast_412.Parsetree.popen_loc = copy_location popen_loc; + Ast_412.Parsetree.popen_attributes = copy_attributes popen_attributes; + } + +and copy_override_flag : + Ast_413.Asttypes.override_flag -> Ast_412.Asttypes.override_flag = function + | Ast_413.Asttypes.Override -> Ast_412.Asttypes.Override + | Ast_413.Asttypes.Fresh -> Ast_412.Asttypes.Fresh + +and copy_module_type_declaration : + Ast_413.Parsetree.module_type_declaration -> + Ast_412.Parsetree.module_type_declaration = + fun { + Ast_413.Parsetree.pmtd_name; + Ast_413.Parsetree.pmtd_type; + Ast_413.Parsetree.pmtd_attributes; + Ast_413.Parsetree.pmtd_loc; + } -> + { + Ast_412.Parsetree.pmtd_name = copy_loc (fun x -> x) pmtd_name; + Ast_412.Parsetree.pmtd_type = Option.map copy_module_type pmtd_type; + Ast_412.Parsetree.pmtd_attributes = copy_attributes pmtd_attributes; + Ast_412.Parsetree.pmtd_loc = copy_location pmtd_loc; + } + +and copy_module_substitution : + Ast_413.Parsetree.module_substitution -> + Ast_412.Parsetree.module_substitution = + fun { + Ast_413.Parsetree.pms_name; + Ast_413.Parsetree.pms_manifest; + Ast_413.Parsetree.pms_attributes; + Ast_413.Parsetree.pms_loc; + } -> + { + Ast_412.Parsetree.pms_name = copy_loc (fun x -> x) pms_name; + Ast_412.Parsetree.pms_manifest = copy_loc copy_Longident_t pms_manifest; + Ast_412.Parsetree.pms_attributes = copy_attributes pms_attributes; + Ast_412.Parsetree.pms_loc = copy_location pms_loc; + } + +and copy_module_declaration : + Ast_413.Parsetree.module_declaration -> Ast_412.Parsetree.module_declaration + = + fun { + Ast_413.Parsetree.pmd_name; + Ast_413.Parsetree.pmd_type; + Ast_413.Parsetree.pmd_attributes; + Ast_413.Parsetree.pmd_loc; + } -> + { + Ast_412.Parsetree.pmd_name = + copy_loc (fun x -> Option.map (fun x -> x) x) pmd_name; + Ast_412.Parsetree.pmd_type = copy_module_type pmd_type; + Ast_412.Parsetree.pmd_attributes = copy_attributes pmd_attributes; + Ast_412.Parsetree.pmd_loc = copy_location pmd_loc; + } + +and copy_type_exception : + Ast_413.Parsetree.type_exception -> Ast_412.Parsetree.type_exception = + fun { + Ast_413.Parsetree.ptyexn_constructor; + Ast_413.Parsetree.ptyexn_loc; + Ast_413.Parsetree.ptyexn_attributes; + } -> + { + Ast_412.Parsetree.ptyexn_constructor = + copy_extension_constructor ptyexn_constructor; + Ast_412.Parsetree.ptyexn_loc = copy_location ptyexn_loc; + Ast_412.Parsetree.ptyexn_attributes = copy_attributes ptyexn_attributes; + } + +and copy_type_extension : + Ast_413.Parsetree.type_extension -> Ast_412.Parsetree.type_extension = + fun { + Ast_413.Parsetree.ptyext_path; + Ast_413.Parsetree.ptyext_params; + Ast_413.Parsetree.ptyext_constructors; + Ast_413.Parsetree.ptyext_private; + Ast_413.Parsetree.ptyext_loc; + Ast_413.Parsetree.ptyext_attributes; + } -> + { + Ast_412.Parsetree.ptyext_path = copy_loc copy_Longident_t ptyext_path; + Ast_412.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_412.Parsetree.ptyext_constructors = + List.map copy_extension_constructor ptyext_constructors; + Ast_412.Parsetree.ptyext_private = copy_private_flag ptyext_private; + Ast_412.Parsetree.ptyext_loc = copy_location ptyext_loc; + Ast_412.Parsetree.ptyext_attributes = copy_attributes ptyext_attributes; + } + +and copy_extension_constructor : + Ast_413.Parsetree.extension_constructor -> + Ast_412.Parsetree.extension_constructor = + fun { + Ast_413.Parsetree.pext_name; + Ast_413.Parsetree.pext_kind; + Ast_413.Parsetree.pext_loc; + Ast_413.Parsetree.pext_attributes; + } -> + { + Ast_412.Parsetree.pext_name = copy_loc (fun x -> x) pext_name; + Ast_412.Parsetree.pext_kind = copy_extension_constructor_kind pext_kind; + Ast_412.Parsetree.pext_loc = copy_location pext_loc; + Ast_412.Parsetree.pext_attributes = copy_attributes pext_attributes; + } + +and copy_extension_constructor_kind : + Ast_413.Parsetree.extension_constructor_kind -> + Ast_412.Parsetree.extension_constructor_kind = function + | Ast_413.Parsetree.Pext_decl (x0, x1) -> + Ast_412.Parsetree.Pext_decl + (copy_constructor_arguments x0, Option.map copy_core_type x1) + | Ast_413.Parsetree.Pext_rebind x0 -> + Ast_412.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0) + +and copy_type_declaration : + Ast_413.Parsetree.type_declaration -> Ast_412.Parsetree.type_declaration = + fun { + Ast_413.Parsetree.ptype_name; + Ast_413.Parsetree.ptype_params; + Ast_413.Parsetree.ptype_cstrs; + Ast_413.Parsetree.ptype_kind; + Ast_413.Parsetree.ptype_private; + Ast_413.Parsetree.ptype_manifest; + Ast_413.Parsetree.ptype_attributes; + Ast_413.Parsetree.ptype_loc; + } -> + { + Ast_412.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name; + Ast_412.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_412.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_412.Parsetree.ptype_kind = copy_type_kind ptype_kind; + Ast_412.Parsetree.ptype_private = copy_private_flag ptype_private; + Ast_412.Parsetree.ptype_manifest = Option.map copy_core_type ptype_manifest; + Ast_412.Parsetree.ptype_attributes = copy_attributes ptype_attributes; + Ast_412.Parsetree.ptype_loc = copy_location ptype_loc; + } + +and copy_private_flag : + Ast_413.Asttypes.private_flag -> Ast_412.Asttypes.private_flag = function + | Ast_413.Asttypes.Private -> Ast_412.Asttypes.Private + | Ast_413.Asttypes.Public -> Ast_412.Asttypes.Public + +and copy_type_kind : Ast_413.Parsetree.type_kind -> Ast_412.Parsetree.type_kind + = function + | Ast_413.Parsetree.Ptype_abstract -> Ast_412.Parsetree.Ptype_abstract + | Ast_413.Parsetree.Ptype_variant x0 -> + Ast_412.Parsetree.Ptype_variant (List.map copy_constructor_declaration x0) + | Ast_413.Parsetree.Ptype_record x0 -> + Ast_412.Parsetree.Ptype_record (List.map copy_label_declaration x0) + | Ast_413.Parsetree.Ptype_open -> Ast_412.Parsetree.Ptype_open + +and copy_constructor_declaration : + Ast_413.Parsetree.constructor_declaration -> + Ast_412.Parsetree.constructor_declaration = + fun { + Ast_413.Parsetree.pcd_name; + Ast_413.Parsetree.pcd_args; + Ast_413.Parsetree.pcd_res; + Ast_413.Parsetree.pcd_loc; + Ast_413.Parsetree.pcd_attributes; + } -> + { + Ast_412.Parsetree.pcd_name = copy_loc (fun x -> x) pcd_name; + Ast_412.Parsetree.pcd_args = copy_constructor_arguments pcd_args; + Ast_412.Parsetree.pcd_res = Option.map copy_core_type pcd_res; + Ast_412.Parsetree.pcd_loc = copy_location pcd_loc; + Ast_412.Parsetree.pcd_attributes = copy_attributes pcd_attributes; + } + +and copy_constructor_arguments : + Ast_413.Parsetree.constructor_arguments -> + Ast_412.Parsetree.constructor_arguments = function + | Ast_413.Parsetree.Pcstr_tuple x0 -> + Ast_412.Parsetree.Pcstr_tuple (List.map copy_core_type x0) + | Ast_413.Parsetree.Pcstr_record x0 -> + Ast_412.Parsetree.Pcstr_record (List.map copy_label_declaration x0) + +and copy_label_declaration : + Ast_413.Parsetree.label_declaration -> Ast_412.Parsetree.label_declaration = + fun { + Ast_413.Parsetree.pld_name; + Ast_413.Parsetree.pld_mutable; + Ast_413.Parsetree.pld_type; + Ast_413.Parsetree.pld_loc; + Ast_413.Parsetree.pld_attributes; + } -> + { + Ast_412.Parsetree.pld_name = copy_loc (fun x -> x) pld_name; + Ast_412.Parsetree.pld_mutable = copy_mutable_flag pld_mutable; + Ast_412.Parsetree.pld_type = copy_core_type pld_type; + Ast_412.Parsetree.pld_loc = copy_location pld_loc; + Ast_412.Parsetree.pld_attributes = copy_attributes pld_attributes; + } + +and copy_mutable_flag : + Ast_413.Asttypes.mutable_flag -> Ast_412.Asttypes.mutable_flag = function + | Ast_413.Asttypes.Immutable -> Ast_412.Asttypes.Immutable + | Ast_413.Asttypes.Mutable -> Ast_412.Asttypes.Mutable + +and copy_injectivity : + Ast_413.Asttypes.injectivity -> Ast_412.Asttypes.injectivity = function + | Ast_413.Asttypes.Injective -> Ast_412.Asttypes.Injective + | Ast_413.Asttypes.NoInjectivity -> Ast_412.Asttypes.NoInjectivity + +and copy_variance : Ast_413.Asttypes.variance -> Ast_412.Asttypes.variance = + function + | Ast_413.Asttypes.Covariant -> Ast_412.Asttypes.Covariant + | Ast_413.Asttypes.Contravariant -> Ast_412.Asttypes.Contravariant + | Ast_413.Asttypes.NoVariance -> Ast_412.Asttypes.NoVariance + +and copy_value_description : + Ast_413.Parsetree.value_description -> Ast_412.Parsetree.value_description = + fun { + Ast_413.Parsetree.pval_name; + Ast_413.Parsetree.pval_type; + Ast_413.Parsetree.pval_prim; + Ast_413.Parsetree.pval_attributes; + Ast_413.Parsetree.pval_loc; + } -> + { + Ast_412.Parsetree.pval_name = copy_loc (fun x -> x) pval_name; + Ast_412.Parsetree.pval_type = copy_core_type pval_type; + Ast_412.Parsetree.pval_prim = List.map (fun x -> x) pval_prim; + Ast_412.Parsetree.pval_attributes = copy_attributes pval_attributes; + Ast_412.Parsetree.pval_loc = copy_location pval_loc; + } + +and copy_object_field_desc : + Ast_413.Parsetree.object_field_desc -> Ast_412.Parsetree.object_field_desc = + function + | Ast_413.Parsetree.Otag (x0, x1) -> + Ast_412.Parsetree.Otag (copy_loc copy_label x0, copy_core_type x1) + | Ast_413.Parsetree.Oinherit x0 -> + Ast_412.Parsetree.Oinherit (copy_core_type x0) + +and copy_arg_label : Ast_413.Asttypes.arg_label -> Ast_412.Asttypes.arg_label = + function + | Ast_413.Asttypes.Nolabel -> Ast_412.Asttypes.Nolabel + | Ast_413.Asttypes.Labelled x0 -> Ast_412.Asttypes.Labelled x0 + | Ast_413.Asttypes.Optional x0 -> Ast_412.Asttypes.Optional x0 + +and copy_closed_flag : + Ast_413.Asttypes.closed_flag -> Ast_412.Asttypes.closed_flag = function + | Ast_413.Asttypes.Closed -> Ast_412.Asttypes.Closed + | Ast_413.Asttypes.Open -> Ast_412.Asttypes.Open + +and copy_label : Ast_413.Asttypes.label -> Ast_412.Asttypes.label = fun x -> x + +and copy_rec_flag : Ast_413.Asttypes.rec_flag -> Ast_412.Asttypes.rec_flag = + function + | Ast_413.Asttypes.Nonrecursive -> Ast_412.Asttypes.Nonrecursive + | Ast_413.Asttypes.Recursive -> Ast_412.Asttypes.Recursive + +and copy_constant : Ast_413.Parsetree.constant -> Ast_412.Parsetree.constant = + function + | Ast_413.Parsetree.Pconst_integer (x0, x1) -> + Ast_412.Parsetree.Pconst_integer (x0, Option.map (fun x -> x) x1) + | Ast_413.Parsetree.Pconst_char x0 -> Ast_412.Parsetree.Pconst_char x0 + | Ast_413.Parsetree.Pconst_string (x0, x1, x2) -> + Ast_412.Parsetree.Pconst_string + (x0, copy_location x1, Option.map (fun x -> x) x2) + | Ast_413.Parsetree.Pconst_float (x0, x1) -> + Ast_412.Parsetree.Pconst_float (x0, Option.map (fun x -> x) x1) + +and copy_Longident_t : Longident.t -> Longident.t = fun x -> x + +and copy_loc : + 'f0 'g0. + ('f0 -> 'g0) -> 'f0 Ast_413.Asttypes.loc -> 'g0 Ast_412.Asttypes.loc = + fun f0 { Ast_413.Asttypes.txt; Ast_413.Asttypes.loc } -> + { Ast_412.Asttypes.txt = f0 txt; Ast_412.Asttypes.loc = copy_location loc } + +and copy_location : Location.t -> Location.t = fun x -> x diff -Nru ppxlib-0.15.0/astlib/migrate_413_414.ml ppxlib-0.24.0/astlib/migrate_413_414.ml --- ppxlib-0.15.0/astlib/migrate_413_414.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/migrate_413_414.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1212 @@ +open Stdlib0 +module From = Ast_413 +module To = Ast_414 + +let rec copy_toplevel_phrase : + Ast_413.Parsetree.toplevel_phrase -> Ast_414.Parsetree.toplevel_phrase = + function + | Ast_413.Parsetree.Ptop_def x0 -> + Ast_414.Parsetree.Ptop_def (copy_structure x0) + | Ast_413.Parsetree.Ptop_dir x0 -> + Ast_414.Parsetree.Ptop_dir (copy_toplevel_directive x0) + +and copy_toplevel_directive : + Ast_413.Parsetree.toplevel_directive -> Ast_414.Parsetree.toplevel_directive + = + fun { + Ast_413.Parsetree.pdir_name; + Ast_413.Parsetree.pdir_arg; + Ast_413.Parsetree.pdir_loc; + } -> + { + Ast_414.Parsetree.pdir_name = copy_loc (fun x -> x) pdir_name; + Ast_414.Parsetree.pdir_arg = Option.map copy_directive_argument pdir_arg; + Ast_414.Parsetree.pdir_loc = copy_location pdir_loc; + } + +and copy_directive_argument : + Ast_413.Parsetree.directive_argument -> Ast_414.Parsetree.directive_argument + = + fun { Ast_413.Parsetree.pdira_desc; Ast_413.Parsetree.pdira_loc } -> + { + Ast_414.Parsetree.pdira_desc = copy_directive_argument_desc pdira_desc; + Ast_414.Parsetree.pdira_loc = copy_location pdira_loc; + } + +and copy_directive_argument_desc : + Ast_413.Parsetree.directive_argument_desc -> + Ast_414.Parsetree.directive_argument_desc = function + | Ast_413.Parsetree.Pdir_string x0 -> Ast_414.Parsetree.Pdir_string x0 + | Ast_413.Parsetree.Pdir_int (x0, x1) -> + Ast_414.Parsetree.Pdir_int (x0, Option.map (fun x -> x) x1) + | Ast_413.Parsetree.Pdir_ident x0 -> + Ast_414.Parsetree.Pdir_ident (copy_Longident_t x0) + | Ast_413.Parsetree.Pdir_bool x0 -> Ast_414.Parsetree.Pdir_bool x0 + +and copy_expression : + Ast_413.Parsetree.expression -> Ast_414.Parsetree.expression = + fun { + Ast_413.Parsetree.pexp_desc; + Ast_413.Parsetree.pexp_loc; + Ast_413.Parsetree.pexp_loc_stack; + Ast_413.Parsetree.pexp_attributes; + } -> + { + Ast_414.Parsetree.pexp_desc = copy_expression_desc pexp_desc; + Ast_414.Parsetree.pexp_loc = copy_location pexp_loc; + Ast_414.Parsetree.pexp_loc_stack = copy_location_stack pexp_loc_stack; + Ast_414.Parsetree.pexp_attributes = copy_attributes pexp_attributes; + } + +and copy_expression_desc : + Ast_413.Parsetree.expression_desc -> Ast_414.Parsetree.expression_desc = + function + | Ast_413.Parsetree.Pexp_ident x0 -> + Ast_414.Parsetree.Pexp_ident (copy_loc copy_Longident_t x0) + | Ast_413.Parsetree.Pexp_constant x0 -> + Ast_414.Parsetree.Pexp_constant (copy_constant x0) + | Ast_413.Parsetree.Pexp_let (x0, x1, x2) -> + Ast_414.Parsetree.Pexp_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_expression x2) + | Ast_413.Parsetree.Pexp_function x0 -> + Ast_414.Parsetree.Pexp_function (List.map copy_case x0) + | Ast_413.Parsetree.Pexp_fun (x0, x1, x2, x3) -> + Ast_414.Parsetree.Pexp_fun + ( copy_arg_label x0, + Option.map copy_expression x1, + copy_pattern x2, + copy_expression x3 ) + | Ast_413.Parsetree.Pexp_apply (x0, x1) -> + Ast_414.Parsetree.Pexp_apply + ( copy_expression x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | Ast_413.Parsetree.Pexp_match (x0, x1) -> + Ast_414.Parsetree.Pexp_match (copy_expression x0, List.map copy_case x1) + | Ast_413.Parsetree.Pexp_try (x0, x1) -> + Ast_414.Parsetree.Pexp_try (copy_expression x0, List.map copy_case x1) + | Ast_413.Parsetree.Pexp_tuple x0 -> + Ast_414.Parsetree.Pexp_tuple (List.map copy_expression x0) + | Ast_413.Parsetree.Pexp_construct (x0, x1) -> + Ast_414.Parsetree.Pexp_construct + (copy_loc copy_Longident_t x0, Option.map copy_expression x1) + | Ast_413.Parsetree.Pexp_variant (x0, x1) -> + Ast_414.Parsetree.Pexp_variant + (copy_label x0, Option.map copy_expression x1) + | Ast_413.Parsetree.Pexp_record (x0, x1) -> + Ast_414.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_413.Parsetree.Pexp_field (x0, x1) -> + Ast_414.Parsetree.Pexp_field + (copy_expression x0, copy_loc copy_Longident_t x1) + | Ast_413.Parsetree.Pexp_setfield (x0, x1, x2) -> + Ast_414.Parsetree.Pexp_setfield + (copy_expression x0, copy_loc copy_Longident_t x1, copy_expression x2) + | Ast_413.Parsetree.Pexp_array x0 -> + Ast_414.Parsetree.Pexp_array (List.map copy_expression x0) + | Ast_413.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> + Ast_414.Parsetree.Pexp_ifthenelse + (copy_expression x0, copy_expression x1, Option.map copy_expression x2) + | Ast_413.Parsetree.Pexp_sequence (x0, x1) -> + Ast_414.Parsetree.Pexp_sequence (copy_expression x0, copy_expression x1) + | Ast_413.Parsetree.Pexp_while (x0, x1) -> + Ast_414.Parsetree.Pexp_while (copy_expression x0, copy_expression x1) + | Ast_413.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> + Ast_414.Parsetree.Pexp_for + ( copy_pattern x0, + copy_expression x1, + copy_expression x2, + copy_direction_flag x3, + copy_expression x4 ) + | Ast_413.Parsetree.Pexp_constraint (x0, x1) -> + Ast_414.Parsetree.Pexp_constraint (copy_expression x0, copy_core_type x1) + | Ast_413.Parsetree.Pexp_coerce (x0, x1, x2) -> + Ast_414.Parsetree.Pexp_coerce + (copy_expression x0, Option.map copy_core_type x1, copy_core_type x2) + | Ast_413.Parsetree.Pexp_send (x0, x1) -> + Ast_414.Parsetree.Pexp_send (copy_expression x0, copy_loc copy_label x1) + | Ast_413.Parsetree.Pexp_new x0 -> + Ast_414.Parsetree.Pexp_new (copy_loc copy_Longident_t x0) + | Ast_413.Parsetree.Pexp_setinstvar (x0, x1) -> + Ast_414.Parsetree.Pexp_setinstvar + (copy_loc copy_label x0, copy_expression x1) + | Ast_413.Parsetree.Pexp_override x0 -> + Ast_414.Parsetree.Pexp_override + (List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_label x0, copy_expression x1)) + x0) + | Ast_413.Parsetree.Pexp_letmodule (x0, x1, x2) -> + Ast_414.Parsetree.Pexp_letmodule + ( copy_loc (fun x -> Option.map (fun x -> x) x) x0, + copy_module_expr x1, + copy_expression x2 ) + | Ast_413.Parsetree.Pexp_letexception (x0, x1) -> + Ast_414.Parsetree.Pexp_letexception + (copy_extension_constructor x0, copy_expression x1) + | Ast_413.Parsetree.Pexp_assert x0 -> + Ast_414.Parsetree.Pexp_assert (copy_expression x0) + | Ast_413.Parsetree.Pexp_lazy x0 -> + Ast_414.Parsetree.Pexp_lazy (copy_expression x0) + | Ast_413.Parsetree.Pexp_poly (x0, x1) -> + Ast_414.Parsetree.Pexp_poly + (copy_expression x0, Option.map copy_core_type x1) + | Ast_413.Parsetree.Pexp_object x0 -> + Ast_414.Parsetree.Pexp_object (copy_class_structure x0) + | Ast_413.Parsetree.Pexp_newtype (x0, x1) -> + Ast_414.Parsetree.Pexp_newtype + (copy_loc (fun x -> x) x0, copy_expression x1) + | Ast_413.Parsetree.Pexp_pack x0 -> + Ast_414.Parsetree.Pexp_pack (copy_module_expr x0) + | Ast_413.Parsetree.Pexp_open (x0, x1) -> + Ast_414.Parsetree.Pexp_open (copy_open_declaration x0, copy_expression x1) + | Ast_413.Parsetree.Pexp_letop x0 -> + Ast_414.Parsetree.Pexp_letop (copy_letop x0) + | Ast_413.Parsetree.Pexp_extension x0 -> + Ast_414.Parsetree.Pexp_extension (copy_extension x0) + | Ast_413.Parsetree.Pexp_unreachable -> Ast_414.Parsetree.Pexp_unreachable + +and copy_letop : Ast_413.Parsetree.letop -> Ast_414.Parsetree.letop = + fun { Ast_413.Parsetree.let_; Ast_413.Parsetree.ands; Ast_413.Parsetree.body } -> + { + Ast_414.Parsetree.let_ = copy_binding_op let_; + Ast_414.Parsetree.ands = List.map copy_binding_op ands; + Ast_414.Parsetree.body = copy_expression body; + } + +and copy_binding_op : + Ast_413.Parsetree.binding_op -> Ast_414.Parsetree.binding_op = + fun { + Ast_413.Parsetree.pbop_op; + Ast_413.Parsetree.pbop_pat; + Ast_413.Parsetree.pbop_exp; + Ast_413.Parsetree.pbop_loc; + } -> + { + Ast_414.Parsetree.pbop_op = copy_loc (fun x -> x) pbop_op; + Ast_414.Parsetree.pbop_pat = copy_pattern pbop_pat; + Ast_414.Parsetree.pbop_exp = copy_expression pbop_exp; + Ast_414.Parsetree.pbop_loc = copy_location pbop_loc; + } + +and copy_direction_flag : + Ast_413.Asttypes.direction_flag -> Ast_414.Asttypes.direction_flag = + function + | Ast_413.Asttypes.Upto -> Ast_414.Asttypes.Upto + | Ast_413.Asttypes.Downto -> Ast_414.Asttypes.Downto + +and copy_case : Ast_413.Parsetree.case -> Ast_414.Parsetree.case = + fun { + Ast_413.Parsetree.pc_lhs; + Ast_413.Parsetree.pc_guard; + Ast_413.Parsetree.pc_rhs; + } -> + { + Ast_414.Parsetree.pc_lhs = copy_pattern pc_lhs; + Ast_414.Parsetree.pc_guard = Option.map copy_expression pc_guard; + Ast_414.Parsetree.pc_rhs = copy_expression pc_rhs; + } + +and copy_value_binding : + Ast_413.Parsetree.value_binding -> Ast_414.Parsetree.value_binding = + fun { + Ast_413.Parsetree.pvb_pat; + Ast_413.Parsetree.pvb_expr; + Ast_413.Parsetree.pvb_attributes; + Ast_413.Parsetree.pvb_loc; + } -> + { + Ast_414.Parsetree.pvb_pat = copy_pattern pvb_pat; + Ast_414.Parsetree.pvb_expr = copy_expression pvb_expr; + Ast_414.Parsetree.pvb_attributes = copy_attributes pvb_attributes; + Ast_414.Parsetree.pvb_loc = copy_location pvb_loc; + } + +and copy_pattern : Ast_413.Parsetree.pattern -> Ast_414.Parsetree.pattern = + fun { + Ast_413.Parsetree.ppat_desc; + Ast_413.Parsetree.ppat_loc; + Ast_413.Parsetree.ppat_loc_stack; + Ast_413.Parsetree.ppat_attributes; + } -> + { + Ast_414.Parsetree.ppat_desc = copy_pattern_desc ppat_desc; + Ast_414.Parsetree.ppat_loc = copy_location ppat_loc; + Ast_414.Parsetree.ppat_loc_stack = copy_location_stack ppat_loc_stack; + Ast_414.Parsetree.ppat_attributes = copy_attributes ppat_attributes; + } + +and copy_pattern_desc : + Ast_413.Parsetree.pattern_desc -> Ast_414.Parsetree.pattern_desc = function + | Ast_413.Parsetree.Ppat_any -> Ast_414.Parsetree.Ppat_any + | Ast_413.Parsetree.Ppat_var x0 -> + Ast_414.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) + | Ast_413.Parsetree.Ppat_alias (x0, x1) -> + Ast_414.Parsetree.Ppat_alias (copy_pattern x0, copy_loc (fun x -> x) x1) + | Ast_413.Parsetree.Ppat_constant x0 -> + Ast_414.Parsetree.Ppat_constant (copy_constant x0) + | Ast_413.Parsetree.Ppat_interval (x0, x1) -> + Ast_414.Parsetree.Ppat_interval (copy_constant x0, copy_constant x1) + | Ast_413.Parsetree.Ppat_tuple x0 -> + Ast_414.Parsetree.Ppat_tuple (List.map copy_pattern x0) + | Ast_413.Parsetree.Ppat_construct (x0, x1) -> + Ast_414.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_413.Parsetree.Ppat_variant (x0, x1) -> + Ast_414.Parsetree.Ppat_variant (copy_label x0, Option.map copy_pattern x1) + | Ast_413.Parsetree.Ppat_record (x0, x1) -> + Ast_414.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_413.Parsetree.Ppat_array x0 -> + Ast_414.Parsetree.Ppat_array (List.map copy_pattern x0) + | Ast_413.Parsetree.Ppat_or (x0, x1) -> + Ast_414.Parsetree.Ppat_or (copy_pattern x0, copy_pattern x1) + | Ast_413.Parsetree.Ppat_constraint (x0, x1) -> + Ast_414.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1) + | Ast_413.Parsetree.Ppat_type x0 -> + Ast_414.Parsetree.Ppat_type (copy_loc copy_Longident_t x0) + | Ast_413.Parsetree.Ppat_lazy x0 -> + Ast_414.Parsetree.Ppat_lazy (copy_pattern x0) + | Ast_413.Parsetree.Ppat_unpack x0 -> + Ast_414.Parsetree.Ppat_unpack + (copy_loc (fun x -> Option.map (fun x -> x) x) x0) + | Ast_413.Parsetree.Ppat_exception x0 -> + Ast_414.Parsetree.Ppat_exception (copy_pattern x0) + | Ast_413.Parsetree.Ppat_extension x0 -> + Ast_414.Parsetree.Ppat_extension (copy_extension x0) + | Ast_413.Parsetree.Ppat_open (x0, x1) -> + Ast_414.Parsetree.Ppat_open (copy_loc copy_Longident_t x0, copy_pattern x1) + +and copy_core_type : Ast_413.Parsetree.core_type -> Ast_414.Parsetree.core_type + = + fun { + Ast_413.Parsetree.ptyp_desc; + Ast_413.Parsetree.ptyp_loc; + Ast_413.Parsetree.ptyp_loc_stack; + Ast_413.Parsetree.ptyp_attributes; + } -> + { + Ast_414.Parsetree.ptyp_desc = copy_core_type_desc ptyp_desc; + Ast_414.Parsetree.ptyp_loc = copy_location ptyp_loc; + Ast_414.Parsetree.ptyp_loc_stack = copy_location_stack ptyp_loc_stack; + Ast_414.Parsetree.ptyp_attributes = copy_attributes ptyp_attributes; + } + +and copy_location_stack : + Ast_413.Parsetree.location_stack -> Ast_414.Parsetree.location_stack = + fun x -> x + +and copy_core_type_desc : + Ast_413.Parsetree.core_type_desc -> Ast_414.Parsetree.core_type_desc = + function + | Ast_413.Parsetree.Ptyp_any -> Ast_414.Parsetree.Ptyp_any + | Ast_413.Parsetree.Ptyp_var x0 -> Ast_414.Parsetree.Ptyp_var x0 + | Ast_413.Parsetree.Ptyp_arrow (x0, x1, x2) -> + Ast_414.Parsetree.Ptyp_arrow + (copy_arg_label x0, copy_core_type x1, copy_core_type x2) + | Ast_413.Parsetree.Ptyp_tuple x0 -> + Ast_414.Parsetree.Ptyp_tuple (List.map copy_core_type x0) + | Ast_413.Parsetree.Ptyp_constr (x0, x1) -> + Ast_414.Parsetree.Ptyp_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_413.Parsetree.Ptyp_object (x0, x1) -> + Ast_414.Parsetree.Ptyp_object + (List.map copy_object_field x0, copy_closed_flag x1) + | Ast_413.Parsetree.Ptyp_class (x0, x1) -> + Ast_414.Parsetree.Ptyp_class + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_413.Parsetree.Ptyp_alias (x0, x1) -> + Ast_414.Parsetree.Ptyp_alias (copy_core_type x0, x1) + | Ast_413.Parsetree.Ptyp_variant (x0, x1, x2) -> + Ast_414.Parsetree.Ptyp_variant + ( List.map copy_row_field x0, + copy_closed_flag x1, + Option.map (fun x -> List.map copy_label x) x2 ) + | Ast_413.Parsetree.Ptyp_poly (x0, x1) -> + Ast_414.Parsetree.Ptyp_poly + (List.map (fun x -> copy_loc (fun x -> x) x) x0, copy_core_type x1) + | Ast_413.Parsetree.Ptyp_package x0 -> + Ast_414.Parsetree.Ptyp_package (copy_package_type x0) + | Ast_413.Parsetree.Ptyp_extension x0 -> + Ast_414.Parsetree.Ptyp_extension (copy_extension x0) + +and copy_package_type : + Ast_413.Parsetree.package_type -> Ast_414.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_413.Parsetree.row_field -> Ast_414.Parsetree.row_field + = + fun { + Ast_413.Parsetree.prf_desc; + Ast_413.Parsetree.prf_loc; + Ast_413.Parsetree.prf_attributes; + } -> + { + Ast_414.Parsetree.prf_desc = copy_row_field_desc prf_desc; + Ast_414.Parsetree.prf_loc = copy_location prf_loc; + Ast_414.Parsetree.prf_attributes = copy_attributes prf_attributes; + } + +and copy_row_field_desc : + Ast_413.Parsetree.row_field_desc -> Ast_414.Parsetree.row_field_desc = + function + | Ast_413.Parsetree.Rtag (x0, x1, x2) -> + Ast_414.Parsetree.Rtag + (copy_loc copy_label x0, x1, List.map copy_core_type x2) + | Ast_413.Parsetree.Rinherit x0 -> + Ast_414.Parsetree.Rinherit (copy_core_type x0) + +and copy_object_field : + Ast_413.Parsetree.object_field -> Ast_414.Parsetree.object_field = + fun { + Ast_413.Parsetree.pof_desc; + Ast_413.Parsetree.pof_loc; + Ast_413.Parsetree.pof_attributes; + } -> + { + Ast_414.Parsetree.pof_desc = copy_object_field_desc pof_desc; + Ast_414.Parsetree.pof_loc = copy_location pof_loc; + Ast_414.Parsetree.pof_attributes = copy_attributes pof_attributes; + } + +and copy_attributes : + Ast_413.Parsetree.attributes -> Ast_414.Parsetree.attributes = + fun x -> List.map copy_attribute x + +and copy_attribute : Ast_413.Parsetree.attribute -> Ast_414.Parsetree.attribute + = + fun { + Ast_413.Parsetree.attr_name; + Ast_413.Parsetree.attr_payload; + Ast_413.Parsetree.attr_loc; + } -> + { + Ast_414.Parsetree.attr_name = copy_loc (fun x -> x) attr_name; + Ast_414.Parsetree.attr_payload = copy_payload attr_payload; + Ast_414.Parsetree.attr_loc = copy_location attr_loc; + } + +and copy_payload : Ast_413.Parsetree.payload -> Ast_414.Parsetree.payload = + function + | Ast_413.Parsetree.PStr x0 -> Ast_414.Parsetree.PStr (copy_structure x0) + | Ast_413.Parsetree.PSig x0 -> Ast_414.Parsetree.PSig (copy_signature x0) + | Ast_413.Parsetree.PTyp x0 -> Ast_414.Parsetree.PTyp (copy_core_type x0) + | Ast_413.Parsetree.PPat (x0, x1) -> + Ast_414.Parsetree.PPat (copy_pattern x0, Option.map copy_expression x1) + +and copy_structure : Ast_413.Parsetree.structure -> Ast_414.Parsetree.structure + = + fun x -> List.map copy_structure_item x + +and copy_structure_item : + Ast_413.Parsetree.structure_item -> Ast_414.Parsetree.structure_item = + fun { Ast_413.Parsetree.pstr_desc; Ast_413.Parsetree.pstr_loc } -> + { + Ast_414.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc; + Ast_414.Parsetree.pstr_loc = copy_location pstr_loc; + } + +and copy_structure_item_desc : + Ast_413.Parsetree.structure_item_desc -> + Ast_414.Parsetree.structure_item_desc = function + | Ast_413.Parsetree.Pstr_eval (x0, x1) -> + Ast_414.Parsetree.Pstr_eval (copy_expression x0, copy_attributes x1) + | Ast_413.Parsetree.Pstr_value (x0, x1) -> + Ast_414.Parsetree.Pstr_value + (copy_rec_flag x0, List.map copy_value_binding x1) + | Ast_413.Parsetree.Pstr_primitive x0 -> + Ast_414.Parsetree.Pstr_primitive (copy_value_description x0) + | Ast_413.Parsetree.Pstr_type (x0, x1) -> + Ast_414.Parsetree.Pstr_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | Ast_413.Parsetree.Pstr_typext x0 -> + Ast_414.Parsetree.Pstr_typext (copy_type_extension x0) + | Ast_413.Parsetree.Pstr_exception x0 -> + Ast_414.Parsetree.Pstr_exception (copy_type_exception x0) + | Ast_413.Parsetree.Pstr_module x0 -> + Ast_414.Parsetree.Pstr_module (copy_module_binding x0) + | Ast_413.Parsetree.Pstr_recmodule x0 -> + Ast_414.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) + | Ast_413.Parsetree.Pstr_modtype x0 -> + Ast_414.Parsetree.Pstr_modtype (copy_module_type_declaration x0) + | Ast_413.Parsetree.Pstr_open x0 -> + Ast_414.Parsetree.Pstr_open (copy_open_declaration x0) + | Ast_413.Parsetree.Pstr_class x0 -> + Ast_414.Parsetree.Pstr_class (List.map copy_class_declaration x0) + | Ast_413.Parsetree.Pstr_class_type x0 -> + Ast_414.Parsetree.Pstr_class_type + (List.map copy_class_type_declaration x0) + | Ast_413.Parsetree.Pstr_include x0 -> + Ast_414.Parsetree.Pstr_include (copy_include_declaration x0) + | Ast_413.Parsetree.Pstr_attribute x0 -> + Ast_414.Parsetree.Pstr_attribute (copy_attribute x0) + | Ast_413.Parsetree.Pstr_extension (x0, x1) -> + Ast_414.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1) + +and copy_include_declaration : + Ast_413.Parsetree.include_declaration -> + Ast_414.Parsetree.include_declaration = + fun x -> copy_include_infos copy_module_expr x + +and copy_class_declaration : + Ast_413.Parsetree.class_declaration -> Ast_414.Parsetree.class_declaration = + fun x -> copy_class_infos copy_class_expr x + +and copy_class_expr : + Ast_413.Parsetree.class_expr -> Ast_414.Parsetree.class_expr = + fun { + Ast_413.Parsetree.pcl_desc; + Ast_413.Parsetree.pcl_loc; + Ast_413.Parsetree.pcl_attributes; + } -> + { + Ast_414.Parsetree.pcl_desc = copy_class_expr_desc pcl_desc; + Ast_414.Parsetree.pcl_loc = copy_location pcl_loc; + Ast_414.Parsetree.pcl_attributes = copy_attributes pcl_attributes; + } + +and copy_class_expr_desc : + Ast_413.Parsetree.class_expr_desc -> Ast_414.Parsetree.class_expr_desc = + function + | Ast_413.Parsetree.Pcl_constr (x0, x1) -> + Ast_414.Parsetree.Pcl_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_413.Parsetree.Pcl_structure x0 -> + Ast_414.Parsetree.Pcl_structure (copy_class_structure x0) + | Ast_413.Parsetree.Pcl_fun (x0, x1, x2, x3) -> + Ast_414.Parsetree.Pcl_fun + ( copy_arg_label x0, + Option.map copy_expression x1, + copy_pattern x2, + copy_class_expr x3 ) + | Ast_413.Parsetree.Pcl_apply (x0, x1) -> + Ast_414.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_413.Parsetree.Pcl_let (x0, x1, x2) -> + Ast_414.Parsetree.Pcl_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_class_expr x2) + | Ast_413.Parsetree.Pcl_constraint (x0, x1) -> + Ast_414.Parsetree.Pcl_constraint (copy_class_expr x0, copy_class_type x1) + | Ast_413.Parsetree.Pcl_extension x0 -> + Ast_414.Parsetree.Pcl_extension (copy_extension x0) + | Ast_413.Parsetree.Pcl_open (x0, x1) -> + Ast_414.Parsetree.Pcl_open (copy_open_description x0, copy_class_expr x1) + +and copy_class_structure : + Ast_413.Parsetree.class_structure -> Ast_414.Parsetree.class_structure = + fun { Ast_413.Parsetree.pcstr_self; Ast_413.Parsetree.pcstr_fields } -> + { + Ast_414.Parsetree.pcstr_self = copy_pattern pcstr_self; + Ast_414.Parsetree.pcstr_fields = List.map copy_class_field pcstr_fields; + } + +and copy_class_field : + Ast_413.Parsetree.class_field -> Ast_414.Parsetree.class_field = + fun { + Ast_413.Parsetree.pcf_desc; + Ast_413.Parsetree.pcf_loc; + Ast_413.Parsetree.pcf_attributes; + } -> + { + Ast_414.Parsetree.pcf_desc = copy_class_field_desc pcf_desc; + Ast_414.Parsetree.pcf_loc = copy_location pcf_loc; + Ast_414.Parsetree.pcf_attributes = copy_attributes pcf_attributes; + } + +and copy_class_field_desc : + Ast_413.Parsetree.class_field_desc -> Ast_414.Parsetree.class_field_desc = + function + | Ast_413.Parsetree.Pcf_inherit (x0, x1, x2) -> + Ast_414.Parsetree.Pcf_inherit + ( copy_override_flag x0, + copy_class_expr x1, + Option.map (fun x -> copy_loc (fun x -> x) x) x2 ) + | Ast_413.Parsetree.Pcf_val x0 -> + Ast_414.Parsetree.Pcf_val + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_mutable_flag x1, copy_class_field_kind x2)) + | Ast_413.Parsetree.Pcf_method x0 -> + Ast_414.Parsetree.Pcf_method + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_private_flag x1, copy_class_field_kind x2)) + | Ast_413.Parsetree.Pcf_constraint x0 -> + Ast_414.Parsetree.Pcf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | Ast_413.Parsetree.Pcf_initializer x0 -> + Ast_414.Parsetree.Pcf_initializer (copy_expression x0) + | Ast_413.Parsetree.Pcf_attribute x0 -> + Ast_414.Parsetree.Pcf_attribute (copy_attribute x0) + | Ast_413.Parsetree.Pcf_extension x0 -> + Ast_414.Parsetree.Pcf_extension (copy_extension x0) + +and copy_class_field_kind : + Ast_413.Parsetree.class_field_kind -> Ast_414.Parsetree.class_field_kind = + function + | Ast_413.Parsetree.Cfk_virtual x0 -> + Ast_414.Parsetree.Cfk_virtual (copy_core_type x0) + | Ast_413.Parsetree.Cfk_concrete (x0, x1) -> + Ast_414.Parsetree.Cfk_concrete (copy_override_flag x0, copy_expression x1) + +and copy_open_declaration : + Ast_413.Parsetree.open_declaration -> Ast_414.Parsetree.open_declaration = + fun x -> copy_open_infos copy_module_expr x + +and copy_module_binding : + Ast_413.Parsetree.module_binding -> Ast_414.Parsetree.module_binding = + fun { + Ast_413.Parsetree.pmb_name; + Ast_413.Parsetree.pmb_expr; + Ast_413.Parsetree.pmb_attributes; + Ast_413.Parsetree.pmb_loc; + } -> + { + Ast_414.Parsetree.pmb_name = + copy_loc (fun x -> Option.map (fun x -> x) x) pmb_name; + Ast_414.Parsetree.pmb_expr = copy_module_expr pmb_expr; + Ast_414.Parsetree.pmb_attributes = copy_attributes pmb_attributes; + Ast_414.Parsetree.pmb_loc = copy_location pmb_loc; + } + +and copy_module_expr : + Ast_413.Parsetree.module_expr -> Ast_414.Parsetree.module_expr = + fun { + Ast_413.Parsetree.pmod_desc; + Ast_413.Parsetree.pmod_loc; + Ast_413.Parsetree.pmod_attributes; + } -> + { + Ast_414.Parsetree.pmod_desc = copy_module_expr_desc pmod_desc; + Ast_414.Parsetree.pmod_loc = copy_location pmod_loc; + Ast_414.Parsetree.pmod_attributes = copy_attributes pmod_attributes; + } + +and copy_module_expr_desc : + Ast_413.Parsetree.module_expr_desc -> Ast_414.Parsetree.module_expr_desc = + function + | Ast_413.Parsetree.Pmod_ident x0 -> + Ast_414.Parsetree.Pmod_ident (copy_loc copy_Longident_t x0) + | Ast_413.Parsetree.Pmod_structure x0 -> + Ast_414.Parsetree.Pmod_structure (copy_structure x0) + | Ast_413.Parsetree.Pmod_functor (x0, x1) -> + Ast_414.Parsetree.Pmod_functor + (copy_functor_parameter x0, copy_module_expr x1) + | Ast_413.Parsetree.Pmod_apply (x0, x1) -> + Ast_414.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) + | Ast_413.Parsetree.Pmod_constraint (x0, x1) -> + Ast_414.Parsetree.Pmod_constraint + (copy_module_expr x0, copy_module_type x1) + | Ast_413.Parsetree.Pmod_unpack x0 -> + Ast_414.Parsetree.Pmod_unpack (copy_expression x0) + | Ast_413.Parsetree.Pmod_extension x0 -> + Ast_414.Parsetree.Pmod_extension (copy_extension x0) + +and copy_functor_parameter : + Ast_413.Parsetree.functor_parameter -> Ast_414.Parsetree.functor_parameter = + function + | Ast_413.Parsetree.Unit -> Ast_414.Parsetree.Unit + | Ast_413.Parsetree.Named (x0, x1) -> + Ast_414.Parsetree.Named + (copy_loc (fun x -> Option.map (fun x -> x) x) x0, copy_module_type x1) + +and copy_module_type : + Ast_413.Parsetree.module_type -> Ast_414.Parsetree.module_type = + fun { + Ast_413.Parsetree.pmty_desc; + Ast_413.Parsetree.pmty_loc; + Ast_413.Parsetree.pmty_attributes; + } -> + { + Ast_414.Parsetree.pmty_desc = copy_module_type_desc pmty_desc; + Ast_414.Parsetree.pmty_loc = copy_location pmty_loc; + Ast_414.Parsetree.pmty_attributes = copy_attributes pmty_attributes; + } + +and copy_module_type_desc : + Ast_413.Parsetree.module_type_desc -> Ast_414.Parsetree.module_type_desc = + function + | Ast_413.Parsetree.Pmty_ident x0 -> + Ast_414.Parsetree.Pmty_ident (copy_loc copy_Longident_t x0) + | Ast_413.Parsetree.Pmty_signature x0 -> + Ast_414.Parsetree.Pmty_signature (copy_signature x0) + | Ast_413.Parsetree.Pmty_functor (x0, x1) -> + Ast_414.Parsetree.Pmty_functor + (copy_functor_parameter x0, copy_module_type x1) + | Ast_413.Parsetree.Pmty_with (x0, x1) -> + Ast_414.Parsetree.Pmty_with + (copy_module_type x0, List.map copy_with_constraint x1) + | Ast_413.Parsetree.Pmty_typeof x0 -> + Ast_414.Parsetree.Pmty_typeof (copy_module_expr x0) + | Ast_413.Parsetree.Pmty_extension x0 -> + Ast_414.Parsetree.Pmty_extension (copy_extension x0) + | Ast_413.Parsetree.Pmty_alias x0 -> + Ast_414.Parsetree.Pmty_alias (copy_loc copy_Longident_t x0) + +and copy_with_constraint : + Ast_413.Parsetree.with_constraint -> Ast_414.Parsetree.with_constraint = + function + | Ast_413.Parsetree.Pwith_type (x0, x1) -> + Ast_414.Parsetree.Pwith_type + (copy_loc copy_Longident_t x0, copy_type_declaration x1) + | Ast_413.Parsetree.Pwith_module (x0, x1) -> + Ast_414.Parsetree.Pwith_module + (copy_loc copy_Longident_t x0, copy_loc copy_Longident_t x1) + | Ast_413.Parsetree.Pwith_modtype (x0, x1) -> + Ast_414.Parsetree.Pwith_modtype + (copy_loc copy_Longident_t x0, copy_module_type x1) + | Ast_413.Parsetree.Pwith_modtypesubst (x0, x1) -> + Ast_414.Parsetree.Pwith_modtypesubst + (copy_loc copy_Longident_t x0, copy_module_type x1) + | Ast_413.Parsetree.Pwith_typesubst (x0, x1) -> + Ast_414.Parsetree.Pwith_typesubst + (copy_loc copy_Longident_t x0, copy_type_declaration x1) + | Ast_413.Parsetree.Pwith_modsubst (x0, x1) -> + Ast_414.Parsetree.Pwith_modsubst + (copy_loc copy_Longident_t x0, copy_loc copy_Longident_t x1) + +and copy_signature : Ast_413.Parsetree.signature -> Ast_414.Parsetree.signature + = + fun x -> List.map copy_signature_item x + +and copy_signature_item : + Ast_413.Parsetree.signature_item -> Ast_414.Parsetree.signature_item = + fun { Ast_413.Parsetree.psig_desc; Ast_413.Parsetree.psig_loc } -> + { + Ast_414.Parsetree.psig_desc = copy_signature_item_desc psig_desc; + Ast_414.Parsetree.psig_loc = copy_location psig_loc; + } + +and copy_signature_item_desc : + Ast_413.Parsetree.signature_item_desc -> + Ast_414.Parsetree.signature_item_desc = function + | Ast_413.Parsetree.Psig_value x0 -> + Ast_414.Parsetree.Psig_value (copy_value_description x0) + | Ast_413.Parsetree.Psig_type (x0, x1) -> + Ast_414.Parsetree.Psig_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | Ast_413.Parsetree.Psig_typesubst x0 -> + Ast_414.Parsetree.Psig_typesubst (List.map copy_type_declaration x0) + | Ast_413.Parsetree.Psig_typext x0 -> + Ast_414.Parsetree.Psig_typext (copy_type_extension x0) + | Ast_413.Parsetree.Psig_exception x0 -> + Ast_414.Parsetree.Psig_exception (copy_type_exception x0) + | Ast_413.Parsetree.Psig_module x0 -> + Ast_414.Parsetree.Psig_module (copy_module_declaration x0) + | Ast_413.Parsetree.Psig_modsubst x0 -> + Ast_414.Parsetree.Psig_modsubst (copy_module_substitution x0) + | Ast_413.Parsetree.Psig_recmodule x0 -> + Ast_414.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) + | Ast_413.Parsetree.Psig_modtype x0 -> + Ast_414.Parsetree.Psig_modtype (copy_module_type_declaration x0) + | Ast_413.Parsetree.Psig_modtypesubst x0 -> + Ast_414.Parsetree.Psig_modtypesubst (copy_module_type_declaration x0) + | Ast_413.Parsetree.Psig_open x0 -> + Ast_414.Parsetree.Psig_open (copy_open_description x0) + | Ast_413.Parsetree.Psig_include x0 -> + Ast_414.Parsetree.Psig_include (copy_include_description x0) + | Ast_413.Parsetree.Psig_class x0 -> + Ast_414.Parsetree.Psig_class (List.map copy_class_description x0) + | Ast_413.Parsetree.Psig_class_type x0 -> + Ast_414.Parsetree.Psig_class_type + (List.map copy_class_type_declaration x0) + | Ast_413.Parsetree.Psig_attribute x0 -> + Ast_414.Parsetree.Psig_attribute (copy_attribute x0) + | Ast_413.Parsetree.Psig_extension (x0, x1) -> + Ast_414.Parsetree.Psig_extension (copy_extension x0, copy_attributes x1) + +and copy_class_type_declaration : + Ast_413.Parsetree.class_type_declaration -> + Ast_414.Parsetree.class_type_declaration = + fun x -> copy_class_infos copy_class_type x + +and copy_class_description : + Ast_413.Parsetree.class_description -> Ast_414.Parsetree.class_description = + fun x -> copy_class_infos copy_class_type x + +and copy_class_type : + Ast_413.Parsetree.class_type -> Ast_414.Parsetree.class_type = + fun { + Ast_413.Parsetree.pcty_desc; + Ast_413.Parsetree.pcty_loc; + Ast_413.Parsetree.pcty_attributes; + } -> + { + Ast_414.Parsetree.pcty_desc = copy_class_type_desc pcty_desc; + Ast_414.Parsetree.pcty_loc = copy_location pcty_loc; + Ast_414.Parsetree.pcty_attributes = copy_attributes pcty_attributes; + } + +and copy_class_type_desc : + Ast_413.Parsetree.class_type_desc -> Ast_414.Parsetree.class_type_desc = + function + | Ast_413.Parsetree.Pcty_constr (x0, x1) -> + Ast_414.Parsetree.Pcty_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_413.Parsetree.Pcty_signature x0 -> + Ast_414.Parsetree.Pcty_signature (copy_class_signature x0) + | Ast_413.Parsetree.Pcty_arrow (x0, x1, x2) -> + Ast_414.Parsetree.Pcty_arrow + (copy_arg_label x0, copy_core_type x1, copy_class_type x2) + | Ast_413.Parsetree.Pcty_extension x0 -> + Ast_414.Parsetree.Pcty_extension (copy_extension x0) + | Ast_413.Parsetree.Pcty_open (x0, x1) -> + Ast_414.Parsetree.Pcty_open (copy_open_description x0, copy_class_type x1) + +and copy_class_signature : + Ast_413.Parsetree.class_signature -> Ast_414.Parsetree.class_signature = + fun { Ast_413.Parsetree.pcsig_self; Ast_413.Parsetree.pcsig_fields } -> + { + Ast_414.Parsetree.pcsig_self = copy_core_type pcsig_self; + Ast_414.Parsetree.pcsig_fields = List.map copy_class_type_field pcsig_fields; + } + +and copy_class_type_field : + Ast_413.Parsetree.class_type_field -> Ast_414.Parsetree.class_type_field = + fun { + Ast_413.Parsetree.pctf_desc; + Ast_413.Parsetree.pctf_loc; + Ast_413.Parsetree.pctf_attributes; + } -> + { + Ast_414.Parsetree.pctf_desc = copy_class_type_field_desc pctf_desc; + Ast_414.Parsetree.pctf_loc = copy_location pctf_loc; + Ast_414.Parsetree.pctf_attributes = copy_attributes pctf_attributes; + } + +and copy_class_type_field_desc : + Ast_413.Parsetree.class_type_field_desc -> + Ast_414.Parsetree.class_type_field_desc = function + | Ast_413.Parsetree.Pctf_inherit x0 -> + Ast_414.Parsetree.Pctf_inherit (copy_class_type x0) + | Ast_413.Parsetree.Pctf_val x0 -> + Ast_414.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_413.Parsetree.Pctf_method x0 -> + Ast_414.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_413.Parsetree.Pctf_constraint x0 -> + Ast_414.Parsetree.Pctf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | Ast_413.Parsetree.Pctf_attribute x0 -> + Ast_414.Parsetree.Pctf_attribute (copy_attribute x0) + | Ast_413.Parsetree.Pctf_extension x0 -> + Ast_414.Parsetree.Pctf_extension (copy_extension x0) + +and copy_extension : Ast_413.Parsetree.extension -> Ast_414.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_413.Parsetree.class_infos -> + 'g0 Ast_414.Parsetree.class_infos = + fun f0 + { + Ast_413.Parsetree.pci_virt; + Ast_413.Parsetree.pci_params; + Ast_413.Parsetree.pci_name; + Ast_413.Parsetree.pci_expr; + Ast_413.Parsetree.pci_loc; + Ast_413.Parsetree.pci_attributes; + } -> + { + Ast_414.Parsetree.pci_virt = copy_virtual_flag pci_virt; + Ast_414.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_414.Parsetree.pci_name = copy_loc (fun x -> x) pci_name; + Ast_414.Parsetree.pci_expr = f0 pci_expr; + Ast_414.Parsetree.pci_loc = copy_location pci_loc; + Ast_414.Parsetree.pci_attributes = copy_attributes pci_attributes; + } + +and copy_virtual_flag : + Ast_413.Asttypes.virtual_flag -> Ast_414.Asttypes.virtual_flag = function + | Ast_413.Asttypes.Virtual -> Ast_414.Asttypes.Virtual + | Ast_413.Asttypes.Concrete -> Ast_414.Asttypes.Concrete + +and copy_include_description : + Ast_413.Parsetree.include_description -> + Ast_414.Parsetree.include_description = + fun x -> copy_include_infos copy_module_type x + +and copy_include_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 Ast_413.Parsetree.include_infos -> + 'g0 Ast_414.Parsetree.include_infos = + fun f0 + { + Ast_413.Parsetree.pincl_mod; + Ast_413.Parsetree.pincl_loc; + Ast_413.Parsetree.pincl_attributes; + } -> + { + Ast_414.Parsetree.pincl_mod = f0 pincl_mod; + Ast_414.Parsetree.pincl_loc = copy_location pincl_loc; + Ast_414.Parsetree.pincl_attributes = copy_attributes pincl_attributes; + } + +and copy_open_description : + Ast_413.Parsetree.open_description -> Ast_414.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_413.Parsetree.open_infos -> + 'g0 Ast_414.Parsetree.open_infos = + fun f0 + { + Ast_413.Parsetree.popen_expr; + Ast_413.Parsetree.popen_override; + Ast_413.Parsetree.popen_loc; + Ast_413.Parsetree.popen_attributes; + } -> + { + Ast_414.Parsetree.popen_expr = f0 popen_expr; + Ast_414.Parsetree.popen_override = copy_override_flag popen_override; + Ast_414.Parsetree.popen_loc = copy_location popen_loc; + Ast_414.Parsetree.popen_attributes = copy_attributes popen_attributes; + } + +and copy_override_flag : + Ast_413.Asttypes.override_flag -> Ast_414.Asttypes.override_flag = function + | Ast_413.Asttypes.Override -> Ast_414.Asttypes.Override + | Ast_413.Asttypes.Fresh -> Ast_414.Asttypes.Fresh + +and copy_module_type_declaration : + Ast_413.Parsetree.module_type_declaration -> + Ast_414.Parsetree.module_type_declaration = + fun { + Ast_413.Parsetree.pmtd_name; + Ast_413.Parsetree.pmtd_type; + Ast_413.Parsetree.pmtd_attributes; + Ast_413.Parsetree.pmtd_loc; + } -> + { + Ast_414.Parsetree.pmtd_name = copy_loc (fun x -> x) pmtd_name; + Ast_414.Parsetree.pmtd_type = Option.map copy_module_type pmtd_type; + Ast_414.Parsetree.pmtd_attributes = copy_attributes pmtd_attributes; + Ast_414.Parsetree.pmtd_loc = copy_location pmtd_loc; + } + +and copy_module_substitution : + Ast_413.Parsetree.module_substitution -> + Ast_414.Parsetree.module_substitution = + fun { + Ast_413.Parsetree.pms_name; + Ast_413.Parsetree.pms_manifest; + Ast_413.Parsetree.pms_attributes; + Ast_413.Parsetree.pms_loc; + } -> + { + Ast_414.Parsetree.pms_name = copy_loc (fun x -> x) pms_name; + Ast_414.Parsetree.pms_manifest = copy_loc copy_Longident_t pms_manifest; + Ast_414.Parsetree.pms_attributes = copy_attributes pms_attributes; + Ast_414.Parsetree.pms_loc = copy_location pms_loc; + } + +and copy_module_declaration : + Ast_413.Parsetree.module_declaration -> Ast_414.Parsetree.module_declaration + = + fun { + Ast_413.Parsetree.pmd_name; + Ast_413.Parsetree.pmd_type; + Ast_413.Parsetree.pmd_attributes; + Ast_413.Parsetree.pmd_loc; + } -> + { + Ast_414.Parsetree.pmd_name = + copy_loc (fun x -> Option.map (fun x -> x) x) pmd_name; + Ast_414.Parsetree.pmd_type = copy_module_type pmd_type; + Ast_414.Parsetree.pmd_attributes = copy_attributes pmd_attributes; + Ast_414.Parsetree.pmd_loc = copy_location pmd_loc; + } + +and copy_type_exception : + Ast_413.Parsetree.type_exception -> Ast_414.Parsetree.type_exception = + fun { + Ast_413.Parsetree.ptyexn_constructor; + Ast_413.Parsetree.ptyexn_loc; + Ast_413.Parsetree.ptyexn_attributes; + } -> + { + Ast_414.Parsetree.ptyexn_constructor = + copy_extension_constructor ptyexn_constructor; + Ast_414.Parsetree.ptyexn_loc = copy_location ptyexn_loc; + Ast_414.Parsetree.ptyexn_attributes = copy_attributes ptyexn_attributes; + } + +and copy_type_extension : + Ast_413.Parsetree.type_extension -> Ast_414.Parsetree.type_extension = + fun { + Ast_413.Parsetree.ptyext_path; + Ast_413.Parsetree.ptyext_params; + Ast_413.Parsetree.ptyext_constructors; + Ast_413.Parsetree.ptyext_private; + Ast_413.Parsetree.ptyext_loc; + Ast_413.Parsetree.ptyext_attributes; + } -> + { + Ast_414.Parsetree.ptyext_path = copy_loc copy_Longident_t ptyext_path; + Ast_414.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_414.Parsetree.ptyext_constructors = + List.map copy_extension_constructor ptyext_constructors; + Ast_414.Parsetree.ptyext_private = copy_private_flag ptyext_private; + Ast_414.Parsetree.ptyext_loc = copy_location ptyext_loc; + Ast_414.Parsetree.ptyext_attributes = copy_attributes ptyext_attributes; + } + +and copy_extension_constructor : + Ast_413.Parsetree.extension_constructor -> + Ast_414.Parsetree.extension_constructor = + fun { + Ast_413.Parsetree.pext_name; + Ast_413.Parsetree.pext_kind; + Ast_413.Parsetree.pext_loc; + Ast_413.Parsetree.pext_attributes; + } -> + { + Ast_414.Parsetree.pext_name = copy_loc (fun x -> x) pext_name; + Ast_414.Parsetree.pext_kind = copy_extension_constructor_kind pext_kind; + Ast_414.Parsetree.pext_loc = copy_location pext_loc; + Ast_414.Parsetree.pext_attributes = copy_attributes pext_attributes; + } + +and copy_extension_constructor_kind : + Ast_413.Parsetree.extension_constructor_kind -> + Ast_414.Parsetree.extension_constructor_kind = function + | Ast_413.Parsetree.Pext_decl (x0, x1) -> + Ast_414.Parsetree.Pext_decl + ([], copy_constructor_arguments x0, Option.map copy_core_type x1) + | Ast_413.Parsetree.Pext_rebind x0 -> + Ast_414.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0) + +and copy_type_declaration : + Ast_413.Parsetree.type_declaration -> Ast_414.Parsetree.type_declaration = + fun { + Ast_413.Parsetree.ptype_name; + Ast_413.Parsetree.ptype_params; + Ast_413.Parsetree.ptype_cstrs; + Ast_413.Parsetree.ptype_kind; + Ast_413.Parsetree.ptype_private; + Ast_413.Parsetree.ptype_manifest; + Ast_413.Parsetree.ptype_attributes; + Ast_413.Parsetree.ptype_loc; + } -> + { + Ast_414.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name; + Ast_414.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_414.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_414.Parsetree.ptype_kind = copy_type_kind ptype_kind; + Ast_414.Parsetree.ptype_private = copy_private_flag ptype_private; + Ast_414.Parsetree.ptype_manifest = Option.map copy_core_type ptype_manifest; + Ast_414.Parsetree.ptype_attributes = copy_attributes ptype_attributes; + Ast_414.Parsetree.ptype_loc = copy_location ptype_loc; + } + +and copy_private_flag : + Ast_413.Asttypes.private_flag -> Ast_414.Asttypes.private_flag = function + | Ast_413.Asttypes.Private -> Ast_414.Asttypes.Private + | Ast_413.Asttypes.Public -> Ast_414.Asttypes.Public + +and copy_type_kind : Ast_413.Parsetree.type_kind -> Ast_414.Parsetree.type_kind + = function + | Ast_413.Parsetree.Ptype_abstract -> Ast_414.Parsetree.Ptype_abstract + | Ast_413.Parsetree.Ptype_variant x0 -> + Ast_414.Parsetree.Ptype_variant (List.map copy_constructor_declaration x0) + | Ast_413.Parsetree.Ptype_record x0 -> + Ast_414.Parsetree.Ptype_record (List.map copy_label_declaration x0) + | Ast_413.Parsetree.Ptype_open -> Ast_414.Parsetree.Ptype_open + +and copy_constructor_declaration : + Ast_413.Parsetree.constructor_declaration -> + Ast_414.Parsetree.constructor_declaration = + fun { + Ast_413.Parsetree.pcd_name; + Ast_413.Parsetree.pcd_args; + Ast_413.Parsetree.pcd_res; + Ast_413.Parsetree.pcd_loc; + Ast_413.Parsetree.pcd_attributes; + } -> + { + Ast_414.Parsetree.pcd_name = copy_loc (fun x -> x) pcd_name; + Ast_414.Parsetree.pcd_vars = []; + Ast_414.Parsetree.pcd_args = copy_constructor_arguments pcd_args; + Ast_414.Parsetree.pcd_res = Option.map copy_core_type pcd_res; + Ast_414.Parsetree.pcd_loc = copy_location pcd_loc; + Ast_414.Parsetree.pcd_attributes = copy_attributes pcd_attributes; + } + +and copy_constructor_arguments : + Ast_413.Parsetree.constructor_arguments -> + Ast_414.Parsetree.constructor_arguments = function + | Ast_413.Parsetree.Pcstr_tuple x0 -> + Ast_414.Parsetree.Pcstr_tuple (List.map copy_core_type x0) + | Ast_413.Parsetree.Pcstr_record x0 -> + Ast_414.Parsetree.Pcstr_record (List.map copy_label_declaration x0) + +and copy_label_declaration : + Ast_413.Parsetree.label_declaration -> Ast_414.Parsetree.label_declaration = + fun { + Ast_413.Parsetree.pld_name; + Ast_413.Parsetree.pld_mutable; + Ast_413.Parsetree.pld_type; + Ast_413.Parsetree.pld_loc; + Ast_413.Parsetree.pld_attributes; + } -> + { + Ast_414.Parsetree.pld_name = copy_loc (fun x -> x) pld_name; + Ast_414.Parsetree.pld_mutable = copy_mutable_flag pld_mutable; + Ast_414.Parsetree.pld_type = copy_core_type pld_type; + Ast_414.Parsetree.pld_loc = copy_location pld_loc; + Ast_414.Parsetree.pld_attributes = copy_attributes pld_attributes; + } + +and copy_mutable_flag : + Ast_413.Asttypes.mutable_flag -> Ast_414.Asttypes.mutable_flag = function + | Ast_413.Asttypes.Immutable -> Ast_414.Asttypes.Immutable + | Ast_413.Asttypes.Mutable -> Ast_414.Asttypes.Mutable + +and copy_injectivity : + Ast_413.Asttypes.injectivity -> Ast_414.Asttypes.injectivity = function + | Ast_413.Asttypes.Injective -> Ast_414.Asttypes.Injective + | Ast_413.Asttypes.NoInjectivity -> Ast_414.Asttypes.NoInjectivity + +and copy_variance : Ast_413.Asttypes.variance -> Ast_414.Asttypes.variance = + function + | Ast_413.Asttypes.Covariant -> Ast_414.Asttypes.Covariant + | Ast_413.Asttypes.Contravariant -> Ast_414.Asttypes.Contravariant + | Ast_413.Asttypes.NoVariance -> Ast_414.Asttypes.NoVariance + +and copy_value_description : + Ast_413.Parsetree.value_description -> Ast_414.Parsetree.value_description = + fun { + Ast_413.Parsetree.pval_name; + Ast_413.Parsetree.pval_type; + Ast_413.Parsetree.pval_prim; + Ast_413.Parsetree.pval_attributes; + Ast_413.Parsetree.pval_loc; + } -> + { + Ast_414.Parsetree.pval_name = copy_loc (fun x -> x) pval_name; + Ast_414.Parsetree.pval_type = copy_core_type pval_type; + Ast_414.Parsetree.pval_prim = List.map (fun x -> x) pval_prim; + Ast_414.Parsetree.pval_attributes = copy_attributes pval_attributes; + Ast_414.Parsetree.pval_loc = copy_location pval_loc; + } + +and copy_object_field_desc : + Ast_413.Parsetree.object_field_desc -> Ast_414.Parsetree.object_field_desc = + function + | Ast_413.Parsetree.Otag (x0, x1) -> + Ast_414.Parsetree.Otag (copy_loc copy_label x0, copy_core_type x1) + | Ast_413.Parsetree.Oinherit x0 -> + Ast_414.Parsetree.Oinherit (copy_core_type x0) + +and copy_arg_label : Ast_413.Asttypes.arg_label -> Ast_414.Asttypes.arg_label = + function + | Ast_413.Asttypes.Nolabel -> Ast_414.Asttypes.Nolabel + | Ast_413.Asttypes.Labelled x0 -> Ast_414.Asttypes.Labelled x0 + | Ast_413.Asttypes.Optional x0 -> Ast_414.Asttypes.Optional x0 + +and copy_closed_flag : + Ast_413.Asttypes.closed_flag -> Ast_414.Asttypes.closed_flag = function + | Ast_413.Asttypes.Closed -> Ast_414.Asttypes.Closed + | Ast_413.Asttypes.Open -> Ast_414.Asttypes.Open + +and copy_label : Ast_413.Asttypes.label -> Ast_414.Asttypes.label = fun x -> x + +and copy_rec_flag : Ast_413.Asttypes.rec_flag -> Ast_414.Asttypes.rec_flag = + function + | Ast_413.Asttypes.Nonrecursive -> Ast_414.Asttypes.Nonrecursive + | Ast_413.Asttypes.Recursive -> Ast_414.Asttypes.Recursive + +and copy_constant : Ast_413.Parsetree.constant -> Ast_414.Parsetree.constant = + function + | Ast_413.Parsetree.Pconst_integer (x0, x1) -> + Ast_414.Parsetree.Pconst_integer (x0, Option.map (fun x -> x) x1) + | Ast_413.Parsetree.Pconst_char x0 -> Ast_414.Parsetree.Pconst_char x0 + | Ast_413.Parsetree.Pconst_string (x0, x1, x2) -> + Ast_414.Parsetree.Pconst_string + (x0, copy_location x1, Option.map (fun x -> x) x2) + | Ast_413.Parsetree.Pconst_float (x0, x1) -> + Ast_414.Parsetree.Pconst_float (x0, Option.map (fun x -> x) x1) + +and copy_Longident_t : Longident.t -> Longident.t = fun x -> x + +and copy_loc : + 'f0 'g0. + ('f0 -> 'g0) -> 'f0 Ast_413.Asttypes.loc -> 'g0 Ast_414.Asttypes.loc = + fun f0 { Ast_413.Asttypes.txt; Ast_413.Asttypes.loc } -> + { Ast_414.Asttypes.txt = f0 txt; Ast_414.Asttypes.loc = copy_location loc } + +and copy_location : Location.t -> Location.t = fun x -> x diff -Nru ppxlib-0.15.0/astlib/migrate_414_413.ml ppxlib-0.24.0/astlib/migrate_414_413.ml --- ppxlib-0.15.0/astlib/migrate_414_413.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/migrate_414_413.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1223 @@ +open Stdlib0 +module From = Ast_414 +module To = Ast_413 + +let migration_error loc missing_feature = + Location.raise_errorf ~loc + "migration error: %s is not supported before OCaml 4.13" missing_feature + +let rec copy_toplevel_phrase : + Ast_414.Parsetree.toplevel_phrase -> Ast_413.Parsetree.toplevel_phrase = + function + | Ast_414.Parsetree.Ptop_def x0 -> + Ast_413.Parsetree.Ptop_def (copy_structure x0) + | Ast_414.Parsetree.Ptop_dir x0 -> + Ast_413.Parsetree.Ptop_dir (copy_toplevel_directive x0) + +and copy_toplevel_directive : + Ast_414.Parsetree.toplevel_directive -> Ast_413.Parsetree.toplevel_directive + = + fun { + Ast_414.Parsetree.pdir_name; + Ast_414.Parsetree.pdir_arg; + Ast_414.Parsetree.pdir_loc; + } -> + { + Ast_413.Parsetree.pdir_name = copy_loc (fun x -> x) pdir_name; + Ast_413.Parsetree.pdir_arg = Option.map copy_directive_argument pdir_arg; + Ast_413.Parsetree.pdir_loc = copy_location pdir_loc; + } + +and copy_directive_argument : + Ast_414.Parsetree.directive_argument -> Ast_413.Parsetree.directive_argument + = + fun { Ast_414.Parsetree.pdira_desc; Ast_414.Parsetree.pdira_loc } -> + { + Ast_413.Parsetree.pdira_desc = copy_directive_argument_desc pdira_desc; + Ast_413.Parsetree.pdira_loc = copy_location pdira_loc; + } + +and copy_directive_argument_desc : + Ast_414.Parsetree.directive_argument_desc -> + Ast_413.Parsetree.directive_argument_desc = function + | Ast_414.Parsetree.Pdir_string x0 -> Ast_413.Parsetree.Pdir_string x0 + | Ast_414.Parsetree.Pdir_int (x0, x1) -> + Ast_413.Parsetree.Pdir_int (x0, Option.map (fun x -> x) x1) + | Ast_414.Parsetree.Pdir_ident x0 -> + Ast_413.Parsetree.Pdir_ident (copy_Longident_t x0) + | Ast_414.Parsetree.Pdir_bool x0 -> Ast_413.Parsetree.Pdir_bool x0 + +and copy_expression : + Ast_414.Parsetree.expression -> Ast_413.Parsetree.expression = + fun { + Ast_414.Parsetree.pexp_desc; + Ast_414.Parsetree.pexp_loc; + Ast_414.Parsetree.pexp_loc_stack; + Ast_414.Parsetree.pexp_attributes; + } -> + { + Ast_413.Parsetree.pexp_desc = copy_expression_desc pexp_desc; + Ast_413.Parsetree.pexp_loc = copy_location pexp_loc; + Ast_413.Parsetree.pexp_loc_stack = copy_location_stack pexp_loc_stack; + Ast_413.Parsetree.pexp_attributes = copy_attributes pexp_attributes; + } + +and copy_expression_desc : + Ast_414.Parsetree.expression_desc -> Ast_413.Parsetree.expression_desc = + function + | Ast_414.Parsetree.Pexp_ident x0 -> + Ast_413.Parsetree.Pexp_ident (copy_loc copy_Longident_t x0) + | Ast_414.Parsetree.Pexp_constant x0 -> + Ast_413.Parsetree.Pexp_constant (copy_constant x0) + | Ast_414.Parsetree.Pexp_let (x0, x1, x2) -> + Ast_413.Parsetree.Pexp_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_expression x2) + | Ast_414.Parsetree.Pexp_function x0 -> + Ast_413.Parsetree.Pexp_function (List.map copy_case x0) + | Ast_414.Parsetree.Pexp_fun (x0, x1, x2, x3) -> + Ast_413.Parsetree.Pexp_fun + ( copy_arg_label x0, + Option.map copy_expression x1, + copy_pattern x2, + copy_expression x3 ) + | Ast_414.Parsetree.Pexp_apply (x0, x1) -> + Ast_413.Parsetree.Pexp_apply + ( copy_expression x0, + List.map + (fun x -> + let x0, x1 = x in + (copy_arg_label x0, copy_expression x1)) + x1 ) + | Ast_414.Parsetree.Pexp_match (x0, x1) -> + Ast_413.Parsetree.Pexp_match (copy_expression x0, List.map copy_case x1) + | Ast_414.Parsetree.Pexp_try (x0, x1) -> + Ast_413.Parsetree.Pexp_try (copy_expression x0, List.map copy_case x1) + | Ast_414.Parsetree.Pexp_tuple x0 -> + Ast_413.Parsetree.Pexp_tuple (List.map copy_expression x0) + | Ast_414.Parsetree.Pexp_construct (x0, x1) -> + Ast_413.Parsetree.Pexp_construct + (copy_loc copy_Longident_t x0, Option.map copy_expression x1) + | Ast_414.Parsetree.Pexp_variant (x0, x1) -> + Ast_413.Parsetree.Pexp_variant + (copy_label x0, Option.map copy_expression x1) + | Ast_414.Parsetree.Pexp_record (x0, x1) -> + Ast_413.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_414.Parsetree.Pexp_field (x0, x1) -> + Ast_413.Parsetree.Pexp_field + (copy_expression x0, copy_loc copy_Longident_t x1) + | Ast_414.Parsetree.Pexp_setfield (x0, x1, x2) -> + Ast_413.Parsetree.Pexp_setfield + (copy_expression x0, copy_loc copy_Longident_t x1, copy_expression x2) + | Ast_414.Parsetree.Pexp_array x0 -> + Ast_413.Parsetree.Pexp_array (List.map copy_expression x0) + | Ast_414.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> + Ast_413.Parsetree.Pexp_ifthenelse + (copy_expression x0, copy_expression x1, Option.map copy_expression x2) + | Ast_414.Parsetree.Pexp_sequence (x0, x1) -> + Ast_413.Parsetree.Pexp_sequence (copy_expression x0, copy_expression x1) + | Ast_414.Parsetree.Pexp_while (x0, x1) -> + Ast_413.Parsetree.Pexp_while (copy_expression x0, copy_expression x1) + | Ast_414.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> + Ast_413.Parsetree.Pexp_for + ( copy_pattern x0, + copy_expression x1, + copy_expression x2, + copy_direction_flag x3, + copy_expression x4 ) + | Ast_414.Parsetree.Pexp_constraint (x0, x1) -> + Ast_413.Parsetree.Pexp_constraint (copy_expression x0, copy_core_type x1) + | Ast_414.Parsetree.Pexp_coerce (x0, x1, x2) -> + Ast_413.Parsetree.Pexp_coerce + (copy_expression x0, Option.map copy_core_type x1, copy_core_type x2) + | Ast_414.Parsetree.Pexp_send (x0, x1) -> + Ast_413.Parsetree.Pexp_send (copy_expression x0, copy_loc copy_label x1) + | Ast_414.Parsetree.Pexp_new x0 -> + Ast_413.Parsetree.Pexp_new (copy_loc copy_Longident_t x0) + | Ast_414.Parsetree.Pexp_setinstvar (x0, x1) -> + Ast_413.Parsetree.Pexp_setinstvar + (copy_loc copy_label x0, copy_expression x1) + | Ast_414.Parsetree.Pexp_override x0 -> + Ast_413.Parsetree.Pexp_override + (List.map + (fun x -> + let x0, x1 = x in + (copy_loc copy_label x0, copy_expression x1)) + x0) + | Ast_414.Parsetree.Pexp_letmodule (x0, x1, x2) -> + Ast_413.Parsetree.Pexp_letmodule + ( copy_loc (fun x -> Option.map (fun x -> x) x) x0, + copy_module_expr x1, + copy_expression x2 ) + | Ast_414.Parsetree.Pexp_letexception (x0, x1) -> + Ast_413.Parsetree.Pexp_letexception + (copy_extension_constructor x0, copy_expression x1) + | Ast_414.Parsetree.Pexp_assert x0 -> + Ast_413.Parsetree.Pexp_assert (copy_expression x0) + | Ast_414.Parsetree.Pexp_lazy x0 -> + Ast_413.Parsetree.Pexp_lazy (copy_expression x0) + | Ast_414.Parsetree.Pexp_poly (x0, x1) -> + Ast_413.Parsetree.Pexp_poly + (copy_expression x0, Option.map copy_core_type x1) + | Ast_414.Parsetree.Pexp_object x0 -> + Ast_413.Parsetree.Pexp_object (copy_class_structure x0) + | Ast_414.Parsetree.Pexp_newtype (x0, x1) -> + Ast_413.Parsetree.Pexp_newtype + (copy_loc (fun x -> x) x0, copy_expression x1) + | Ast_414.Parsetree.Pexp_pack x0 -> + Ast_413.Parsetree.Pexp_pack (copy_module_expr x0) + | Ast_414.Parsetree.Pexp_open (x0, x1) -> + Ast_413.Parsetree.Pexp_open (copy_open_declaration x0, copy_expression x1) + | Ast_414.Parsetree.Pexp_letop x0 -> + Ast_413.Parsetree.Pexp_letop (copy_letop x0) + | Ast_414.Parsetree.Pexp_extension x0 -> + Ast_413.Parsetree.Pexp_extension (copy_extension x0) + | Ast_414.Parsetree.Pexp_unreachable -> Ast_413.Parsetree.Pexp_unreachable + +and copy_letop : Ast_414.Parsetree.letop -> Ast_413.Parsetree.letop = + fun { Ast_414.Parsetree.let_; Ast_414.Parsetree.ands; Ast_414.Parsetree.body } -> + { + Ast_413.Parsetree.let_ = copy_binding_op let_; + Ast_413.Parsetree.ands = List.map copy_binding_op ands; + Ast_413.Parsetree.body = copy_expression body; + } + +and copy_binding_op : + Ast_414.Parsetree.binding_op -> Ast_413.Parsetree.binding_op = + fun { + Ast_414.Parsetree.pbop_op; + Ast_414.Parsetree.pbop_pat; + Ast_414.Parsetree.pbop_exp; + Ast_414.Parsetree.pbop_loc; + } -> + { + Ast_413.Parsetree.pbop_op = copy_loc (fun x -> x) pbop_op; + Ast_413.Parsetree.pbop_pat = copy_pattern pbop_pat; + Ast_413.Parsetree.pbop_exp = copy_expression pbop_exp; + Ast_413.Parsetree.pbop_loc = copy_location pbop_loc; + } + +and copy_direction_flag : + Ast_414.Asttypes.direction_flag -> Ast_413.Asttypes.direction_flag = + function + | Ast_414.Asttypes.Upto -> Ast_413.Asttypes.Upto + | Ast_414.Asttypes.Downto -> Ast_413.Asttypes.Downto + +and copy_case : Ast_414.Parsetree.case -> Ast_413.Parsetree.case = + fun { + Ast_414.Parsetree.pc_lhs; + Ast_414.Parsetree.pc_guard; + Ast_414.Parsetree.pc_rhs; + } -> + { + Ast_413.Parsetree.pc_lhs = copy_pattern pc_lhs; + Ast_413.Parsetree.pc_guard = Option.map copy_expression pc_guard; + Ast_413.Parsetree.pc_rhs = copy_expression pc_rhs; + } + +and copy_value_binding : + Ast_414.Parsetree.value_binding -> Ast_413.Parsetree.value_binding = + fun { + Ast_414.Parsetree.pvb_pat; + Ast_414.Parsetree.pvb_expr; + Ast_414.Parsetree.pvb_attributes; + Ast_414.Parsetree.pvb_loc; + } -> + { + Ast_413.Parsetree.pvb_pat = copy_pattern pvb_pat; + Ast_413.Parsetree.pvb_expr = copy_expression pvb_expr; + Ast_413.Parsetree.pvb_attributes = copy_attributes pvb_attributes; + Ast_413.Parsetree.pvb_loc = copy_location pvb_loc; + } + +and copy_pattern : Ast_414.Parsetree.pattern -> Ast_413.Parsetree.pattern = + fun { + Ast_414.Parsetree.ppat_desc; + Ast_414.Parsetree.ppat_loc; + Ast_414.Parsetree.ppat_loc_stack; + Ast_414.Parsetree.ppat_attributes; + } -> + { + Ast_413.Parsetree.ppat_desc = copy_pattern_desc ppat_desc; + Ast_413.Parsetree.ppat_loc = copy_location ppat_loc; + Ast_413.Parsetree.ppat_loc_stack = copy_location_stack ppat_loc_stack; + Ast_413.Parsetree.ppat_attributes = copy_attributes ppat_attributes; + } + +and copy_pattern_desc : + Ast_414.Parsetree.pattern_desc -> Ast_413.Parsetree.pattern_desc = function + | Ast_414.Parsetree.Ppat_any -> Ast_413.Parsetree.Ppat_any + | Ast_414.Parsetree.Ppat_var x0 -> + Ast_413.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) + | Ast_414.Parsetree.Ppat_alias (x0, x1) -> + Ast_413.Parsetree.Ppat_alias (copy_pattern x0, copy_loc (fun x -> x) x1) + | Ast_414.Parsetree.Ppat_constant x0 -> + Ast_413.Parsetree.Ppat_constant (copy_constant x0) + | Ast_414.Parsetree.Ppat_interval (x0, x1) -> + Ast_413.Parsetree.Ppat_interval (copy_constant x0, copy_constant x1) + | Ast_414.Parsetree.Ppat_tuple x0 -> + Ast_413.Parsetree.Ppat_tuple (List.map copy_pattern x0) + | Ast_414.Parsetree.Ppat_construct (x0, x1) -> + Ast_413.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_414.Parsetree.Ppat_variant (x0, x1) -> + Ast_413.Parsetree.Ppat_variant (copy_label x0, Option.map copy_pattern x1) + | Ast_414.Parsetree.Ppat_record (x0, x1) -> + Ast_413.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_414.Parsetree.Ppat_array x0 -> + Ast_413.Parsetree.Ppat_array (List.map copy_pattern x0) + | Ast_414.Parsetree.Ppat_or (x0, x1) -> + Ast_413.Parsetree.Ppat_or (copy_pattern x0, copy_pattern x1) + | Ast_414.Parsetree.Ppat_constraint (x0, x1) -> + Ast_413.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1) + | Ast_414.Parsetree.Ppat_type x0 -> + Ast_413.Parsetree.Ppat_type (copy_loc copy_Longident_t x0) + | Ast_414.Parsetree.Ppat_lazy x0 -> + Ast_413.Parsetree.Ppat_lazy (copy_pattern x0) + | Ast_414.Parsetree.Ppat_unpack x0 -> + Ast_413.Parsetree.Ppat_unpack + (copy_loc (fun x -> Option.map (fun x -> x) x) x0) + | Ast_414.Parsetree.Ppat_exception x0 -> + Ast_413.Parsetree.Ppat_exception (copy_pattern x0) + | Ast_414.Parsetree.Ppat_extension x0 -> + Ast_413.Parsetree.Ppat_extension (copy_extension x0) + | Ast_414.Parsetree.Ppat_open (x0, x1) -> + Ast_413.Parsetree.Ppat_open (copy_loc copy_Longident_t x0, copy_pattern x1) + +and copy_core_type : Ast_414.Parsetree.core_type -> Ast_413.Parsetree.core_type + = + fun { + Ast_414.Parsetree.ptyp_desc; + Ast_414.Parsetree.ptyp_loc; + Ast_414.Parsetree.ptyp_loc_stack; + Ast_414.Parsetree.ptyp_attributes; + } -> + { + Ast_413.Parsetree.ptyp_desc = copy_core_type_desc ptyp_desc; + Ast_413.Parsetree.ptyp_loc = copy_location ptyp_loc; + Ast_413.Parsetree.ptyp_loc_stack = copy_location_stack ptyp_loc_stack; + Ast_413.Parsetree.ptyp_attributes = copy_attributes ptyp_attributes; + } + +and copy_location_stack : + Ast_414.Parsetree.location_stack -> Ast_413.Parsetree.location_stack = + fun x -> x + +and copy_core_type_desc : + Ast_414.Parsetree.core_type_desc -> Ast_413.Parsetree.core_type_desc = + function + | Ast_414.Parsetree.Ptyp_any -> Ast_413.Parsetree.Ptyp_any + | Ast_414.Parsetree.Ptyp_var x0 -> Ast_413.Parsetree.Ptyp_var x0 + | Ast_414.Parsetree.Ptyp_arrow (x0, x1, x2) -> + Ast_413.Parsetree.Ptyp_arrow + (copy_arg_label x0, copy_core_type x1, copy_core_type x2) + | Ast_414.Parsetree.Ptyp_tuple x0 -> + Ast_413.Parsetree.Ptyp_tuple (List.map copy_core_type x0) + | Ast_414.Parsetree.Ptyp_constr (x0, x1) -> + Ast_413.Parsetree.Ptyp_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_414.Parsetree.Ptyp_object (x0, x1) -> + Ast_413.Parsetree.Ptyp_object + (List.map copy_object_field x0, copy_closed_flag x1) + | Ast_414.Parsetree.Ptyp_class (x0, x1) -> + Ast_413.Parsetree.Ptyp_class + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_414.Parsetree.Ptyp_alias (x0, x1) -> + Ast_413.Parsetree.Ptyp_alias (copy_core_type x0, x1) + | Ast_414.Parsetree.Ptyp_variant (x0, x1, x2) -> + Ast_413.Parsetree.Ptyp_variant + ( List.map copy_row_field x0, + copy_closed_flag x1, + Option.map (fun x -> List.map copy_label x) x2 ) + | Ast_414.Parsetree.Ptyp_poly (x0, x1) -> + Ast_413.Parsetree.Ptyp_poly + (List.map (fun x -> copy_loc (fun x -> x) x) x0, copy_core_type x1) + | Ast_414.Parsetree.Ptyp_package x0 -> + Ast_413.Parsetree.Ptyp_package (copy_package_type x0) + | Ast_414.Parsetree.Ptyp_extension x0 -> + Ast_413.Parsetree.Ptyp_extension (copy_extension x0) + +and copy_package_type : + Ast_414.Parsetree.package_type -> Ast_413.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_414.Parsetree.row_field -> Ast_413.Parsetree.row_field + = + fun { + Ast_414.Parsetree.prf_desc; + Ast_414.Parsetree.prf_loc; + Ast_414.Parsetree.prf_attributes; + } -> + { + Ast_413.Parsetree.prf_desc = copy_row_field_desc prf_desc; + Ast_413.Parsetree.prf_loc = copy_location prf_loc; + Ast_413.Parsetree.prf_attributes = copy_attributes prf_attributes; + } + +and copy_row_field_desc : + Ast_414.Parsetree.row_field_desc -> Ast_413.Parsetree.row_field_desc = + function + | Ast_414.Parsetree.Rtag (x0, x1, x2) -> + Ast_413.Parsetree.Rtag + (copy_loc copy_label x0, x1, List.map copy_core_type x2) + | Ast_414.Parsetree.Rinherit x0 -> + Ast_413.Parsetree.Rinherit (copy_core_type x0) + +and copy_object_field : + Ast_414.Parsetree.object_field -> Ast_413.Parsetree.object_field = + fun { + Ast_414.Parsetree.pof_desc; + Ast_414.Parsetree.pof_loc; + Ast_414.Parsetree.pof_attributes; + } -> + { + Ast_413.Parsetree.pof_desc = copy_object_field_desc pof_desc; + Ast_413.Parsetree.pof_loc = copy_location pof_loc; + Ast_413.Parsetree.pof_attributes = copy_attributes pof_attributes; + } + +and copy_attributes : + Ast_414.Parsetree.attributes -> Ast_413.Parsetree.attributes = + fun x -> List.map copy_attribute x + +and copy_attribute : Ast_414.Parsetree.attribute -> Ast_413.Parsetree.attribute + = + fun { + Ast_414.Parsetree.attr_name; + Ast_414.Parsetree.attr_payload; + Ast_414.Parsetree.attr_loc; + } -> + { + Ast_413.Parsetree.attr_name = copy_loc (fun x -> x) attr_name; + Ast_413.Parsetree.attr_payload = copy_payload attr_payload; + Ast_413.Parsetree.attr_loc = copy_location attr_loc; + } + +and copy_payload : Ast_414.Parsetree.payload -> Ast_413.Parsetree.payload = + function + | Ast_414.Parsetree.PStr x0 -> Ast_413.Parsetree.PStr (copy_structure x0) + | Ast_414.Parsetree.PSig x0 -> Ast_413.Parsetree.PSig (copy_signature x0) + | Ast_414.Parsetree.PTyp x0 -> Ast_413.Parsetree.PTyp (copy_core_type x0) + | Ast_414.Parsetree.PPat (x0, x1) -> + Ast_413.Parsetree.PPat (copy_pattern x0, Option.map copy_expression x1) + +and copy_structure : Ast_414.Parsetree.structure -> Ast_413.Parsetree.structure + = + fun x -> List.map copy_structure_item x + +and copy_structure_item : + Ast_414.Parsetree.structure_item -> Ast_413.Parsetree.structure_item = + fun { Ast_414.Parsetree.pstr_desc; Ast_414.Parsetree.pstr_loc } -> + { + Ast_413.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc; + Ast_413.Parsetree.pstr_loc = copy_location pstr_loc; + } + +and copy_structure_item_desc : + Ast_414.Parsetree.structure_item_desc -> + Ast_413.Parsetree.structure_item_desc = function + | Ast_414.Parsetree.Pstr_eval (x0, x1) -> + Ast_413.Parsetree.Pstr_eval (copy_expression x0, copy_attributes x1) + | Ast_414.Parsetree.Pstr_value (x0, x1) -> + Ast_413.Parsetree.Pstr_value + (copy_rec_flag x0, List.map copy_value_binding x1) + | Ast_414.Parsetree.Pstr_primitive x0 -> + Ast_413.Parsetree.Pstr_primitive (copy_value_description x0) + | Ast_414.Parsetree.Pstr_type (x0, x1) -> + Ast_413.Parsetree.Pstr_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | Ast_414.Parsetree.Pstr_typext x0 -> + Ast_413.Parsetree.Pstr_typext (copy_type_extension x0) + | Ast_414.Parsetree.Pstr_exception x0 -> + Ast_413.Parsetree.Pstr_exception (copy_type_exception x0) + | Ast_414.Parsetree.Pstr_module x0 -> + Ast_413.Parsetree.Pstr_module (copy_module_binding x0) + | Ast_414.Parsetree.Pstr_recmodule x0 -> + Ast_413.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) + | Ast_414.Parsetree.Pstr_modtype x0 -> + Ast_413.Parsetree.Pstr_modtype (copy_module_type_declaration x0) + | Ast_414.Parsetree.Pstr_open x0 -> + Ast_413.Parsetree.Pstr_open (copy_open_declaration x0) + | Ast_414.Parsetree.Pstr_class x0 -> + Ast_413.Parsetree.Pstr_class (List.map copy_class_declaration x0) + | Ast_414.Parsetree.Pstr_class_type x0 -> + Ast_413.Parsetree.Pstr_class_type + (List.map copy_class_type_declaration x0) + | Ast_414.Parsetree.Pstr_include x0 -> + Ast_413.Parsetree.Pstr_include (copy_include_declaration x0) + | Ast_414.Parsetree.Pstr_attribute x0 -> + Ast_413.Parsetree.Pstr_attribute (copy_attribute x0) + | Ast_414.Parsetree.Pstr_extension (x0, x1) -> + Ast_413.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1) + +and copy_include_declaration : + Ast_414.Parsetree.include_declaration -> + Ast_413.Parsetree.include_declaration = + fun x -> copy_include_infos copy_module_expr x + +and copy_class_declaration : + Ast_414.Parsetree.class_declaration -> Ast_413.Parsetree.class_declaration = + fun x -> copy_class_infos copy_class_expr x + +and copy_class_expr : + Ast_414.Parsetree.class_expr -> Ast_413.Parsetree.class_expr = + fun { + Ast_414.Parsetree.pcl_desc; + Ast_414.Parsetree.pcl_loc; + Ast_414.Parsetree.pcl_attributes; + } -> + { + Ast_413.Parsetree.pcl_desc = copy_class_expr_desc pcl_desc; + Ast_413.Parsetree.pcl_loc = copy_location pcl_loc; + Ast_413.Parsetree.pcl_attributes = copy_attributes pcl_attributes; + } + +and copy_class_expr_desc : + Ast_414.Parsetree.class_expr_desc -> Ast_413.Parsetree.class_expr_desc = + function + | Ast_414.Parsetree.Pcl_constr (x0, x1) -> + Ast_413.Parsetree.Pcl_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_414.Parsetree.Pcl_structure x0 -> + Ast_413.Parsetree.Pcl_structure (copy_class_structure x0) + | Ast_414.Parsetree.Pcl_fun (x0, x1, x2, x3) -> + Ast_413.Parsetree.Pcl_fun + ( copy_arg_label x0, + Option.map copy_expression x1, + copy_pattern x2, + copy_class_expr x3 ) + | Ast_414.Parsetree.Pcl_apply (x0, x1) -> + Ast_413.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_414.Parsetree.Pcl_let (x0, x1, x2) -> + Ast_413.Parsetree.Pcl_let + (copy_rec_flag x0, List.map copy_value_binding x1, copy_class_expr x2) + | Ast_414.Parsetree.Pcl_constraint (x0, x1) -> + Ast_413.Parsetree.Pcl_constraint (copy_class_expr x0, copy_class_type x1) + | Ast_414.Parsetree.Pcl_extension x0 -> + Ast_413.Parsetree.Pcl_extension (copy_extension x0) + | Ast_414.Parsetree.Pcl_open (x0, x1) -> + Ast_413.Parsetree.Pcl_open (copy_open_description x0, copy_class_expr x1) + +and copy_class_structure : + Ast_414.Parsetree.class_structure -> Ast_413.Parsetree.class_structure = + fun { Ast_414.Parsetree.pcstr_self; Ast_414.Parsetree.pcstr_fields } -> + { + Ast_413.Parsetree.pcstr_self = copy_pattern pcstr_self; + Ast_413.Parsetree.pcstr_fields = List.map copy_class_field pcstr_fields; + } + +and copy_class_field : + Ast_414.Parsetree.class_field -> Ast_413.Parsetree.class_field = + fun { + Ast_414.Parsetree.pcf_desc; + Ast_414.Parsetree.pcf_loc; + Ast_414.Parsetree.pcf_attributes; + } -> + { + Ast_413.Parsetree.pcf_desc = copy_class_field_desc pcf_desc; + Ast_413.Parsetree.pcf_loc = copy_location pcf_loc; + Ast_413.Parsetree.pcf_attributes = copy_attributes pcf_attributes; + } + +and copy_class_field_desc : + Ast_414.Parsetree.class_field_desc -> Ast_413.Parsetree.class_field_desc = + function + | Ast_414.Parsetree.Pcf_inherit (x0, x1, x2) -> + Ast_413.Parsetree.Pcf_inherit + ( copy_override_flag x0, + copy_class_expr x1, + Option.map (fun x -> copy_loc (fun x -> x) x) x2 ) + | Ast_414.Parsetree.Pcf_val x0 -> + Ast_413.Parsetree.Pcf_val + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_mutable_flag x1, copy_class_field_kind x2)) + | Ast_414.Parsetree.Pcf_method x0 -> + Ast_413.Parsetree.Pcf_method + (let x0, x1, x2 = x0 in + (copy_loc copy_label x0, copy_private_flag x1, copy_class_field_kind x2)) + | Ast_414.Parsetree.Pcf_constraint x0 -> + Ast_413.Parsetree.Pcf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | Ast_414.Parsetree.Pcf_initializer x0 -> + Ast_413.Parsetree.Pcf_initializer (copy_expression x0) + | Ast_414.Parsetree.Pcf_attribute x0 -> + Ast_413.Parsetree.Pcf_attribute (copy_attribute x0) + | Ast_414.Parsetree.Pcf_extension x0 -> + Ast_413.Parsetree.Pcf_extension (copy_extension x0) + +and copy_class_field_kind : + Ast_414.Parsetree.class_field_kind -> Ast_413.Parsetree.class_field_kind = + function + | Ast_414.Parsetree.Cfk_virtual x0 -> + Ast_413.Parsetree.Cfk_virtual (copy_core_type x0) + | Ast_414.Parsetree.Cfk_concrete (x0, x1) -> + Ast_413.Parsetree.Cfk_concrete (copy_override_flag x0, copy_expression x1) + +and copy_open_declaration : + Ast_414.Parsetree.open_declaration -> Ast_413.Parsetree.open_declaration = + fun x -> copy_open_infos copy_module_expr x + +and copy_module_binding : + Ast_414.Parsetree.module_binding -> Ast_413.Parsetree.module_binding = + fun { + Ast_414.Parsetree.pmb_name; + Ast_414.Parsetree.pmb_expr; + Ast_414.Parsetree.pmb_attributes; + Ast_414.Parsetree.pmb_loc; + } -> + { + Ast_413.Parsetree.pmb_name = + copy_loc (fun x -> Option.map (fun x -> x) x) pmb_name; + Ast_413.Parsetree.pmb_expr = copy_module_expr pmb_expr; + Ast_413.Parsetree.pmb_attributes = copy_attributes pmb_attributes; + Ast_413.Parsetree.pmb_loc = copy_location pmb_loc; + } + +and copy_module_expr : + Ast_414.Parsetree.module_expr -> Ast_413.Parsetree.module_expr = + fun { + Ast_414.Parsetree.pmod_desc; + Ast_414.Parsetree.pmod_loc; + Ast_414.Parsetree.pmod_attributes; + } -> + { + Ast_413.Parsetree.pmod_desc = copy_module_expr_desc pmod_desc; + Ast_413.Parsetree.pmod_loc = copy_location pmod_loc; + Ast_413.Parsetree.pmod_attributes = copy_attributes pmod_attributes; + } + +and copy_module_expr_desc : + Ast_414.Parsetree.module_expr_desc -> Ast_413.Parsetree.module_expr_desc = + function + | Ast_414.Parsetree.Pmod_ident x0 -> + Ast_413.Parsetree.Pmod_ident (copy_loc copy_Longident_t x0) + | Ast_414.Parsetree.Pmod_structure x0 -> + Ast_413.Parsetree.Pmod_structure (copy_structure x0) + | Ast_414.Parsetree.Pmod_functor (x0, x1) -> + Ast_413.Parsetree.Pmod_functor + (copy_functor_parameter x0, copy_module_expr x1) + | Ast_414.Parsetree.Pmod_apply (x0, x1) -> + Ast_413.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) + | Ast_414.Parsetree.Pmod_constraint (x0, x1) -> + Ast_413.Parsetree.Pmod_constraint + (copy_module_expr x0, copy_module_type x1) + | Ast_414.Parsetree.Pmod_unpack x0 -> + Ast_413.Parsetree.Pmod_unpack (copy_expression x0) + | Ast_414.Parsetree.Pmod_extension x0 -> + Ast_413.Parsetree.Pmod_extension (copy_extension x0) + +and copy_functor_parameter : + Ast_414.Parsetree.functor_parameter -> Ast_413.Parsetree.functor_parameter = + function + | Ast_414.Parsetree.Unit -> Ast_413.Parsetree.Unit + | Ast_414.Parsetree.Named (x0, x1) -> + Ast_413.Parsetree.Named + (copy_loc (fun x -> Option.map (fun x -> x) x) x0, copy_module_type x1) + +and copy_module_type : + Ast_414.Parsetree.module_type -> Ast_413.Parsetree.module_type = + fun { + Ast_414.Parsetree.pmty_desc; + Ast_414.Parsetree.pmty_loc; + Ast_414.Parsetree.pmty_attributes; + } -> + { + Ast_413.Parsetree.pmty_desc = copy_module_type_desc pmty_desc; + Ast_413.Parsetree.pmty_loc = copy_location pmty_loc; + Ast_413.Parsetree.pmty_attributes = copy_attributes pmty_attributes; + } + +and copy_module_type_desc : + Ast_414.Parsetree.module_type_desc -> Ast_413.Parsetree.module_type_desc = + function + | Ast_414.Parsetree.Pmty_ident x0 -> + Ast_413.Parsetree.Pmty_ident (copy_loc copy_Longident_t x0) + | Ast_414.Parsetree.Pmty_signature x0 -> + Ast_413.Parsetree.Pmty_signature (copy_signature x0) + | Ast_414.Parsetree.Pmty_functor (x0, x1) -> + Ast_413.Parsetree.Pmty_functor + (copy_functor_parameter x0, copy_module_type x1) + | Ast_414.Parsetree.Pmty_with (x0, x1) -> + Ast_413.Parsetree.Pmty_with + (copy_module_type x0, List.map copy_with_constraint x1) + | Ast_414.Parsetree.Pmty_typeof x0 -> + Ast_413.Parsetree.Pmty_typeof (copy_module_expr x0) + | Ast_414.Parsetree.Pmty_extension x0 -> + Ast_413.Parsetree.Pmty_extension (copy_extension x0) + | Ast_414.Parsetree.Pmty_alias x0 -> + Ast_413.Parsetree.Pmty_alias (copy_loc copy_Longident_t x0) + +and copy_with_constraint : + Ast_414.Parsetree.with_constraint -> Ast_413.Parsetree.with_constraint = + function + | Ast_414.Parsetree.Pwith_type (x0, x1) -> + Ast_413.Parsetree.Pwith_type + (copy_loc copy_Longident_t x0, copy_type_declaration x1) + | Ast_414.Parsetree.Pwith_module (x0, x1) -> + Ast_413.Parsetree.Pwith_module + (copy_loc copy_Longident_t x0, copy_loc copy_Longident_t x1) + | Ast_414.Parsetree.Pwith_modtype (x0, x1) -> + Ast_413.Parsetree.Pwith_modtype + (copy_loc copy_Longident_t x0, copy_module_type x1) + | Ast_414.Parsetree.Pwith_modtypesubst (x0, x1) -> + Ast_413.Parsetree.Pwith_modtypesubst + (copy_loc copy_Longident_t x0, copy_module_type x1) + | Ast_414.Parsetree.Pwith_typesubst (x0, x1) -> + Ast_413.Parsetree.Pwith_typesubst + (copy_loc copy_Longident_t x0, copy_type_declaration x1) + | Ast_414.Parsetree.Pwith_modsubst (x0, x1) -> + Ast_413.Parsetree.Pwith_modsubst + (copy_loc copy_Longident_t x0, copy_loc copy_Longident_t x1) + +and copy_signature : Ast_414.Parsetree.signature -> Ast_413.Parsetree.signature + = + fun x -> List.map copy_signature_item x + +and copy_signature_item : + Ast_414.Parsetree.signature_item -> Ast_413.Parsetree.signature_item = + fun { Ast_414.Parsetree.psig_desc; Ast_414.Parsetree.psig_loc } -> + { + Ast_413.Parsetree.psig_desc = copy_signature_item_desc psig_desc; + Ast_413.Parsetree.psig_loc = copy_location psig_loc; + } + +and copy_signature_item_desc : + Ast_414.Parsetree.signature_item_desc -> + Ast_413.Parsetree.signature_item_desc = function + | Ast_414.Parsetree.Psig_value x0 -> + Ast_413.Parsetree.Psig_value (copy_value_description x0) + | Ast_414.Parsetree.Psig_type (x0, x1) -> + Ast_413.Parsetree.Psig_type + (copy_rec_flag x0, List.map copy_type_declaration x1) + | Ast_414.Parsetree.Psig_typesubst x0 -> + Ast_413.Parsetree.Psig_typesubst (List.map copy_type_declaration x0) + | Ast_414.Parsetree.Psig_typext x0 -> + Ast_413.Parsetree.Psig_typext (copy_type_extension x0) + | Ast_414.Parsetree.Psig_exception x0 -> + Ast_413.Parsetree.Psig_exception (copy_type_exception x0) + | Ast_414.Parsetree.Psig_module x0 -> + Ast_413.Parsetree.Psig_module (copy_module_declaration x0) + | Ast_414.Parsetree.Psig_modsubst x0 -> + Ast_413.Parsetree.Psig_modsubst (copy_module_substitution x0) + | Ast_414.Parsetree.Psig_recmodule x0 -> + Ast_413.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) + | Ast_414.Parsetree.Psig_modtype x0 -> + Ast_413.Parsetree.Psig_modtype (copy_module_type_declaration x0) + | Ast_414.Parsetree.Psig_modtypesubst x0 -> + Ast_413.Parsetree.Psig_modtypesubst (copy_module_type_declaration x0) + | Ast_414.Parsetree.Psig_open x0 -> + Ast_413.Parsetree.Psig_open (copy_open_description x0) + | Ast_414.Parsetree.Psig_include x0 -> + Ast_413.Parsetree.Psig_include (copy_include_description x0) + | Ast_414.Parsetree.Psig_class x0 -> + Ast_413.Parsetree.Psig_class (List.map copy_class_description x0) + | Ast_414.Parsetree.Psig_class_type x0 -> + Ast_413.Parsetree.Psig_class_type + (List.map copy_class_type_declaration x0) + | Ast_414.Parsetree.Psig_attribute x0 -> + Ast_413.Parsetree.Psig_attribute (copy_attribute x0) + | Ast_414.Parsetree.Psig_extension (x0, x1) -> + Ast_413.Parsetree.Psig_extension (copy_extension x0, copy_attributes x1) + +and copy_class_type_declaration : + Ast_414.Parsetree.class_type_declaration -> + Ast_413.Parsetree.class_type_declaration = + fun x -> copy_class_infos copy_class_type x + +and copy_class_description : + Ast_414.Parsetree.class_description -> Ast_413.Parsetree.class_description = + fun x -> copy_class_infos copy_class_type x + +and copy_class_type : + Ast_414.Parsetree.class_type -> Ast_413.Parsetree.class_type = + fun { + Ast_414.Parsetree.pcty_desc; + Ast_414.Parsetree.pcty_loc; + Ast_414.Parsetree.pcty_attributes; + } -> + { + Ast_413.Parsetree.pcty_desc = copy_class_type_desc pcty_desc; + Ast_413.Parsetree.pcty_loc = copy_location pcty_loc; + Ast_413.Parsetree.pcty_attributes = copy_attributes pcty_attributes; + } + +and copy_class_type_desc : + Ast_414.Parsetree.class_type_desc -> Ast_413.Parsetree.class_type_desc = + function + | Ast_414.Parsetree.Pcty_constr (x0, x1) -> + Ast_413.Parsetree.Pcty_constr + (copy_loc copy_Longident_t x0, List.map copy_core_type x1) + | Ast_414.Parsetree.Pcty_signature x0 -> + Ast_413.Parsetree.Pcty_signature (copy_class_signature x0) + | Ast_414.Parsetree.Pcty_arrow (x0, x1, x2) -> + Ast_413.Parsetree.Pcty_arrow + (copy_arg_label x0, copy_core_type x1, copy_class_type x2) + | Ast_414.Parsetree.Pcty_extension x0 -> + Ast_413.Parsetree.Pcty_extension (copy_extension x0) + | Ast_414.Parsetree.Pcty_open (x0, x1) -> + Ast_413.Parsetree.Pcty_open (copy_open_description x0, copy_class_type x1) + +and copy_class_signature : + Ast_414.Parsetree.class_signature -> Ast_413.Parsetree.class_signature = + fun { Ast_414.Parsetree.pcsig_self; Ast_414.Parsetree.pcsig_fields } -> + { + Ast_413.Parsetree.pcsig_self = copy_core_type pcsig_self; + Ast_413.Parsetree.pcsig_fields = List.map copy_class_type_field pcsig_fields; + } + +and copy_class_type_field : + Ast_414.Parsetree.class_type_field -> Ast_413.Parsetree.class_type_field = + fun { + Ast_414.Parsetree.pctf_desc; + Ast_414.Parsetree.pctf_loc; + Ast_414.Parsetree.pctf_attributes; + } -> + { + Ast_413.Parsetree.pctf_desc = copy_class_type_field_desc pctf_desc; + Ast_413.Parsetree.pctf_loc = copy_location pctf_loc; + Ast_413.Parsetree.pctf_attributes = copy_attributes pctf_attributes; + } + +and copy_class_type_field_desc : + Ast_414.Parsetree.class_type_field_desc -> + Ast_413.Parsetree.class_type_field_desc = function + | Ast_414.Parsetree.Pctf_inherit x0 -> + Ast_413.Parsetree.Pctf_inherit (copy_class_type x0) + | Ast_414.Parsetree.Pctf_val x0 -> + Ast_413.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_414.Parsetree.Pctf_method x0 -> + Ast_413.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_414.Parsetree.Pctf_constraint x0 -> + Ast_413.Parsetree.Pctf_constraint + (let x0, x1 = x0 in + (copy_core_type x0, copy_core_type x1)) + | Ast_414.Parsetree.Pctf_attribute x0 -> + Ast_413.Parsetree.Pctf_attribute (copy_attribute x0) + | Ast_414.Parsetree.Pctf_extension x0 -> + Ast_413.Parsetree.Pctf_extension (copy_extension x0) + +and copy_extension : Ast_414.Parsetree.extension -> Ast_413.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_414.Parsetree.class_infos -> + 'g0 Ast_413.Parsetree.class_infos = + fun f0 + { + Ast_414.Parsetree.pci_virt; + Ast_414.Parsetree.pci_params; + Ast_414.Parsetree.pci_name; + Ast_414.Parsetree.pci_expr; + Ast_414.Parsetree.pci_loc; + Ast_414.Parsetree.pci_attributes; + } -> + { + Ast_413.Parsetree.pci_virt = copy_virtual_flag pci_virt; + Ast_413.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_413.Parsetree.pci_name = copy_loc (fun x -> x) pci_name; + Ast_413.Parsetree.pci_expr = f0 pci_expr; + Ast_413.Parsetree.pci_loc = copy_location pci_loc; + Ast_413.Parsetree.pci_attributes = copy_attributes pci_attributes; + } + +and copy_virtual_flag : + Ast_414.Asttypes.virtual_flag -> Ast_413.Asttypes.virtual_flag = function + | Ast_414.Asttypes.Virtual -> Ast_413.Asttypes.Virtual + | Ast_414.Asttypes.Concrete -> Ast_413.Asttypes.Concrete + +and copy_include_description : + Ast_414.Parsetree.include_description -> + Ast_413.Parsetree.include_description = + fun x -> copy_include_infos copy_module_type x + +and copy_include_infos : + 'f0 'g0. + ('f0 -> 'g0) -> + 'f0 Ast_414.Parsetree.include_infos -> + 'g0 Ast_413.Parsetree.include_infos = + fun f0 + { + Ast_414.Parsetree.pincl_mod; + Ast_414.Parsetree.pincl_loc; + Ast_414.Parsetree.pincl_attributes; + } -> + { + Ast_413.Parsetree.pincl_mod = f0 pincl_mod; + Ast_413.Parsetree.pincl_loc = copy_location pincl_loc; + Ast_413.Parsetree.pincl_attributes = copy_attributes pincl_attributes; + } + +and copy_open_description : + Ast_414.Parsetree.open_description -> Ast_413.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_414.Parsetree.open_infos -> + 'g0 Ast_413.Parsetree.open_infos = + fun f0 + { + Ast_414.Parsetree.popen_expr; + Ast_414.Parsetree.popen_override; + Ast_414.Parsetree.popen_loc; + Ast_414.Parsetree.popen_attributes; + } -> + { + Ast_413.Parsetree.popen_expr = f0 popen_expr; + Ast_413.Parsetree.popen_override = copy_override_flag popen_override; + Ast_413.Parsetree.popen_loc = copy_location popen_loc; + Ast_413.Parsetree.popen_attributes = copy_attributes popen_attributes; + } + +and copy_override_flag : + Ast_414.Asttypes.override_flag -> Ast_413.Asttypes.override_flag = function + | Ast_414.Asttypes.Override -> Ast_413.Asttypes.Override + | Ast_414.Asttypes.Fresh -> Ast_413.Asttypes.Fresh + +and copy_module_type_declaration : + Ast_414.Parsetree.module_type_declaration -> + Ast_413.Parsetree.module_type_declaration = + fun { + Ast_414.Parsetree.pmtd_name; + Ast_414.Parsetree.pmtd_type; + Ast_414.Parsetree.pmtd_attributes; + Ast_414.Parsetree.pmtd_loc; + } -> + { + Ast_413.Parsetree.pmtd_name = copy_loc (fun x -> x) pmtd_name; + Ast_413.Parsetree.pmtd_type = Option.map copy_module_type pmtd_type; + Ast_413.Parsetree.pmtd_attributes = copy_attributes pmtd_attributes; + Ast_413.Parsetree.pmtd_loc = copy_location pmtd_loc; + } + +and copy_module_substitution : + Ast_414.Parsetree.module_substitution -> + Ast_413.Parsetree.module_substitution = + fun { + Ast_414.Parsetree.pms_name; + Ast_414.Parsetree.pms_manifest; + Ast_414.Parsetree.pms_attributes; + Ast_414.Parsetree.pms_loc; + } -> + { + Ast_413.Parsetree.pms_name = copy_loc (fun x -> x) pms_name; + Ast_413.Parsetree.pms_manifest = copy_loc copy_Longident_t pms_manifest; + Ast_413.Parsetree.pms_attributes = copy_attributes pms_attributes; + Ast_413.Parsetree.pms_loc = copy_location pms_loc; + } + +and copy_module_declaration : + Ast_414.Parsetree.module_declaration -> Ast_413.Parsetree.module_declaration + = + fun { + Ast_414.Parsetree.pmd_name; + Ast_414.Parsetree.pmd_type; + Ast_414.Parsetree.pmd_attributes; + Ast_414.Parsetree.pmd_loc; + } -> + { + Ast_413.Parsetree.pmd_name = + copy_loc (fun x -> Option.map (fun x -> x) x) pmd_name; + Ast_413.Parsetree.pmd_type = copy_module_type pmd_type; + Ast_413.Parsetree.pmd_attributes = copy_attributes pmd_attributes; + Ast_413.Parsetree.pmd_loc = copy_location pmd_loc; + } + +and copy_type_exception : + Ast_414.Parsetree.type_exception -> Ast_413.Parsetree.type_exception = + fun { + Ast_414.Parsetree.ptyexn_constructor; + Ast_414.Parsetree.ptyexn_loc; + Ast_414.Parsetree.ptyexn_attributes; + } -> + { + Ast_413.Parsetree.ptyexn_constructor = + copy_extension_constructor ptyexn_constructor; + Ast_413.Parsetree.ptyexn_loc = copy_location ptyexn_loc; + Ast_413.Parsetree.ptyexn_attributes = copy_attributes ptyexn_attributes; + } + +and copy_type_extension : + Ast_414.Parsetree.type_extension -> Ast_413.Parsetree.type_extension = + fun { + Ast_414.Parsetree.ptyext_path; + Ast_414.Parsetree.ptyext_params; + Ast_414.Parsetree.ptyext_constructors; + Ast_414.Parsetree.ptyext_private; + Ast_414.Parsetree.ptyext_loc; + Ast_414.Parsetree.ptyext_attributes; + } -> + { + Ast_413.Parsetree.ptyext_path = copy_loc copy_Longident_t ptyext_path; + Ast_413.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_413.Parsetree.ptyext_constructors = + List.map copy_extension_constructor ptyext_constructors; + Ast_413.Parsetree.ptyext_private = copy_private_flag ptyext_private; + Ast_413.Parsetree.ptyext_loc = copy_location ptyext_loc; + Ast_413.Parsetree.ptyext_attributes = copy_attributes ptyext_attributes; + } + +and copy_extension_constructor : + Ast_414.Parsetree.extension_constructor -> + Ast_413.Parsetree.extension_constructor = + fun { + Ast_414.Parsetree.pext_name; + Ast_414.Parsetree.pext_kind; + Ast_414.Parsetree.pext_loc; + Ast_414.Parsetree.pext_attributes; + } -> + { + Ast_413.Parsetree.pext_name = copy_loc (fun x -> x) pext_name; + Ast_413.Parsetree.pext_kind = copy_extension_constructor_kind pext_kind; + Ast_413.Parsetree.pext_loc = copy_location pext_loc; + Ast_413.Parsetree.pext_attributes = copy_attributes pext_attributes; + } + +and copy_extension_constructor_kind : + Ast_414.Parsetree.extension_constructor_kind -> + Ast_413.Parsetree.extension_constructor_kind = function + | Ast_414.Parsetree.Pext_decl (x0, x1, x2) -> ( + match x0 with + | [] -> + Ast_413.Parsetree.Pext_decl + (copy_constructor_arguments x1, Option.map copy_core_type x2) + | hd :: _ -> + migration_error hd.loc "type parameters in extension constructors") + | Ast_414.Parsetree.Pext_rebind x0 -> + Ast_413.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0) + +and copy_type_declaration : + Ast_414.Parsetree.type_declaration -> Ast_413.Parsetree.type_declaration = + fun { + Ast_414.Parsetree.ptype_name; + Ast_414.Parsetree.ptype_params; + Ast_414.Parsetree.ptype_cstrs; + Ast_414.Parsetree.ptype_kind; + Ast_414.Parsetree.ptype_private; + Ast_414.Parsetree.ptype_manifest; + Ast_414.Parsetree.ptype_attributes; + Ast_414.Parsetree.ptype_loc; + } -> + { + Ast_413.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name; + Ast_413.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_413.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_413.Parsetree.ptype_kind = copy_type_kind ptype_kind; + Ast_413.Parsetree.ptype_private = copy_private_flag ptype_private; + Ast_413.Parsetree.ptype_manifest = Option.map copy_core_type ptype_manifest; + Ast_413.Parsetree.ptype_attributes = copy_attributes ptype_attributes; + Ast_413.Parsetree.ptype_loc = copy_location ptype_loc; + } + +and copy_private_flag : + Ast_414.Asttypes.private_flag -> Ast_413.Asttypes.private_flag = function + | Ast_414.Asttypes.Private -> Ast_413.Asttypes.Private + | Ast_414.Asttypes.Public -> Ast_413.Asttypes.Public + +and copy_type_kind : Ast_414.Parsetree.type_kind -> Ast_413.Parsetree.type_kind + = function + | Ast_414.Parsetree.Ptype_abstract -> Ast_413.Parsetree.Ptype_abstract + | Ast_414.Parsetree.Ptype_variant x0 -> + Ast_413.Parsetree.Ptype_variant (List.map copy_constructor_declaration x0) + | Ast_414.Parsetree.Ptype_record x0 -> + Ast_413.Parsetree.Ptype_record (List.map copy_label_declaration x0) + | Ast_414.Parsetree.Ptype_open -> Ast_413.Parsetree.Ptype_open + +and copy_constructor_declaration : + Ast_414.Parsetree.constructor_declaration -> + Ast_413.Parsetree.constructor_declaration = + fun { + Ast_414.Parsetree.pcd_name; + Ast_414.Parsetree.pcd_vars; + Ast_414.Parsetree.pcd_args; + Ast_414.Parsetree.pcd_res; + Ast_414.Parsetree.pcd_loc; + Ast_414.Parsetree.pcd_attributes; + } -> + match pcd_vars with + | [] -> + { + Ast_413.Parsetree.pcd_name = copy_loc (fun x -> x) pcd_name; + Ast_413.Parsetree.pcd_args = copy_constructor_arguments pcd_args; + Ast_413.Parsetree.pcd_res = Option.map copy_core_type pcd_res; + Ast_413.Parsetree.pcd_loc = copy_location pcd_loc; + Ast_413.Parsetree.pcd_attributes = copy_attributes pcd_attributes; + } + | hd :: _ -> migration_error hd.loc "pcd_vars in constructor declarations" + +and copy_constructor_arguments : + Ast_414.Parsetree.constructor_arguments -> + Ast_413.Parsetree.constructor_arguments = function + | Ast_414.Parsetree.Pcstr_tuple x0 -> + Ast_413.Parsetree.Pcstr_tuple (List.map copy_core_type x0) + | Ast_414.Parsetree.Pcstr_record x0 -> + Ast_413.Parsetree.Pcstr_record (List.map copy_label_declaration x0) + +and copy_label_declaration : + Ast_414.Parsetree.label_declaration -> Ast_413.Parsetree.label_declaration = + fun { + Ast_414.Parsetree.pld_name; + Ast_414.Parsetree.pld_mutable; + Ast_414.Parsetree.pld_type; + Ast_414.Parsetree.pld_loc; + Ast_414.Parsetree.pld_attributes; + } -> + { + Ast_413.Parsetree.pld_name = copy_loc (fun x -> x) pld_name; + Ast_413.Parsetree.pld_mutable = copy_mutable_flag pld_mutable; + Ast_413.Parsetree.pld_type = copy_core_type pld_type; + Ast_413.Parsetree.pld_loc = copy_location pld_loc; + Ast_413.Parsetree.pld_attributes = copy_attributes pld_attributes; + } + +and copy_mutable_flag : + Ast_414.Asttypes.mutable_flag -> Ast_413.Asttypes.mutable_flag = function + | Ast_414.Asttypes.Immutable -> Ast_413.Asttypes.Immutable + | Ast_414.Asttypes.Mutable -> Ast_413.Asttypes.Mutable + +and copy_injectivity : + Ast_414.Asttypes.injectivity -> Ast_413.Asttypes.injectivity = function + | Ast_414.Asttypes.Injective -> Ast_413.Asttypes.Injective + | Ast_414.Asttypes.NoInjectivity -> Ast_413.Asttypes.NoInjectivity + +and copy_variance : Ast_414.Asttypes.variance -> Ast_413.Asttypes.variance = + function + | Ast_414.Asttypes.Covariant -> Ast_413.Asttypes.Covariant + | Ast_414.Asttypes.Contravariant -> Ast_413.Asttypes.Contravariant + | Ast_414.Asttypes.NoVariance -> Ast_413.Asttypes.NoVariance + +and copy_value_description : + Ast_414.Parsetree.value_description -> Ast_413.Parsetree.value_description = + fun { + Ast_414.Parsetree.pval_name; + Ast_414.Parsetree.pval_type; + Ast_414.Parsetree.pval_prim; + Ast_414.Parsetree.pval_attributes; + Ast_414.Parsetree.pval_loc; + } -> + { + Ast_413.Parsetree.pval_name = copy_loc (fun x -> x) pval_name; + Ast_413.Parsetree.pval_type = copy_core_type pval_type; + Ast_413.Parsetree.pval_prim = List.map (fun x -> x) pval_prim; + Ast_413.Parsetree.pval_attributes = copy_attributes pval_attributes; + Ast_413.Parsetree.pval_loc = copy_location pval_loc; + } + +and copy_object_field_desc : + Ast_414.Parsetree.object_field_desc -> Ast_413.Parsetree.object_field_desc = + function + | Ast_414.Parsetree.Otag (x0, x1) -> + Ast_413.Parsetree.Otag (copy_loc copy_label x0, copy_core_type x1) + | Ast_414.Parsetree.Oinherit x0 -> + Ast_413.Parsetree.Oinherit (copy_core_type x0) + +and copy_arg_label : Ast_414.Asttypes.arg_label -> Ast_413.Asttypes.arg_label = + function + | Ast_414.Asttypes.Nolabel -> Ast_413.Asttypes.Nolabel + | Ast_414.Asttypes.Labelled x0 -> Ast_413.Asttypes.Labelled x0 + | Ast_414.Asttypes.Optional x0 -> Ast_413.Asttypes.Optional x0 + +and copy_closed_flag : + Ast_414.Asttypes.closed_flag -> Ast_413.Asttypes.closed_flag = function + | Ast_414.Asttypes.Closed -> Ast_413.Asttypes.Closed + | Ast_414.Asttypes.Open -> Ast_413.Asttypes.Open + +and copy_label : Ast_414.Asttypes.label -> Ast_413.Asttypes.label = fun x -> x + +and copy_rec_flag : Ast_414.Asttypes.rec_flag -> Ast_413.Asttypes.rec_flag = + function + | Ast_414.Asttypes.Nonrecursive -> Ast_413.Asttypes.Nonrecursive + | Ast_414.Asttypes.Recursive -> Ast_413.Asttypes.Recursive + +and copy_constant : Ast_414.Parsetree.constant -> Ast_413.Parsetree.constant = + function + | Ast_414.Parsetree.Pconst_integer (x0, x1) -> + Ast_413.Parsetree.Pconst_integer (x0, Option.map (fun x -> x) x1) + | Ast_414.Parsetree.Pconst_char x0 -> Ast_413.Parsetree.Pconst_char x0 + | Ast_414.Parsetree.Pconst_string (x0, x1, x2) -> + Ast_413.Parsetree.Pconst_string + (x0, copy_location x1, Option.map (fun x -> x) x2) + | Ast_414.Parsetree.Pconst_float (x0, x1) -> + Ast_413.Parsetree.Pconst_float (x0, Option.map (fun x -> x) x1) + +and copy_Longident_t : Longident.t -> Longident.t = fun x -> x + +and copy_loc : + 'f0 'g0. + ('f0 -> 'g0) -> 'f0 Ast_414.Asttypes.loc -> 'g0 Ast_413.Asttypes.loc = + fun f0 { Ast_414.Asttypes.txt; Ast_414.Asttypes.loc } -> + { Ast_413.Asttypes.txt = f0 txt; Ast_413.Asttypes.loc = copy_location loc } + +and copy_location : Location.t -> Location.t = fun x -> x diff -Nru ppxlib-0.15.0/astlib/parse.ml ppxlib-0.24.0/astlib/parse.ml --- ppxlib-0.15.0/astlib/parse.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/parse.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1 @@ +include Ocaml_common.Parse diff -Nru ppxlib-0.15.0/astlib/parse.mli ppxlib-0.24.0/astlib/parse.mli --- ppxlib-0.15.0/astlib/parse.mli 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/parse.mli 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,22 @@ +(** Entry points in the parser *) + +val implementation : Lexing.lexbuf -> Parsetree.structure_item list +(** Parse a structure *) + +val interface : Lexing.lexbuf -> Parsetree.signature_item list +(** Parse a signature *) + +val toplevel_phrase : Lexing.lexbuf -> Parsetree.toplevel_phrase +(** Parse a toplevel phrase *) + +val use_file : Lexing.lexbuf -> Parsetree.toplevel_phrase list +(** Parse a series of toplevel phrases *) + +val core_type : Lexing.lexbuf -> Parsetree.core_type +(** Parse a core type *) + +val expression : Lexing.lexbuf -> Parsetree.expression +(** Parse an expression *) + +val pattern : Lexing.lexbuf -> Parsetree.pattern +(** Parse a pattern *) diff -Nru ppxlib-0.15.0/astlib/pp/dune ppxlib-0.24.0/astlib/pp/dune --- ppxlib-0.15.0/astlib/pp/dune 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/pp/dune 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,5 @@ +(executables + (names pp) + (flags :standard -w -3)) + +(ocamllex pp_rewrite) diff -Nru ppxlib-0.15.0/astlib/pp/pp.ml ppxlib-0.24.0/astlib/pp/pp.ml --- ppxlib-0.15.0/astlib/pp/pp.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/pp/pp.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,12 @@ +let () = + match Sys.argv with + | [| _; ocaml_version; fname |] -> + let is_current = + Filename.basename fname = Printf.sprintf "ast_%s.ml" ocaml_version + in + let ic = open_in_bin fname in + Printf.printf "# 1 %S\n" fname; + Pp_rewrite.rewrite is_current ocaml_version (Lexing.from_channel ic) + | _ -> + Printf.eprintf "%s: \n" Sys.executable_name; + exit 2 diff -Nru ppxlib-0.15.0/astlib/pp/pp.mli ppxlib-0.24.0/astlib/pp/pp.mli --- ppxlib-0.15.0/astlib/pp/pp.mli 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/pp/pp.mli 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1 @@ +(* empty *) diff -Nru ppxlib-0.15.0/astlib/pp/pp_rewrite.mli ppxlib-0.24.0/astlib/pp/pp_rewrite.mli --- ppxlib-0.15.0/astlib/pp/pp_rewrite.mli 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/pp/pp_rewrite.mli 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1 @@ +val rewrite : bool -> string -> Lexing.lexbuf -> unit diff -Nru ppxlib-0.15.0/astlib/pp/pp_rewrite.mll ppxlib-0.24.0/astlib/pp/pp_rewrite.mll --- ppxlib-0.15.0/astlib/pp/pp_rewrite.mll 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/pp/pp_rewrite.mll 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,32 @@ +rule rewrite is_current ocaml_version = parse + | "(*IF_CURRENT " ([^'*']* as s) "*)" + { let chunk = if is_current + then " " ^ s ^ " " + else Lexing.lexeme lexbuf + in + print_string chunk; + rewrite is_current ocaml_version lexbuf + } + | "(*IF_AT_LEAST " ([^'*' ' ']* as v) " " ([^'*']* as s) "*)" + { let chunk = if (v <= ocaml_version) + then " " ^ String.make (String.length v + 1) ' ' ^ s ^ " " + else Lexing.lexeme lexbuf + in + print_string chunk; + rewrite is_current ocaml_version lexbuf + } + | "(*IF_NOT_AT_LEAST " ([^'*' ' ']* as v) " " ([^'*']* as s) "*)" + { let chunk = if not (v <= ocaml_version) + then " " ^ String.make (String.length v + 1) ' ' ^ s ^ " " + else Lexing.lexeme lexbuf + in + print_string chunk; + rewrite is_current ocaml_version lexbuf + } + | _ as c + { print_char c; + rewrite is_current ocaml_version lexbuf + } + | eof { () } + + diff -Nru ppxlib-0.15.0/astlib/pprintast.ml ppxlib-0.24.0/astlib/pprintast.ml --- ppxlib-0.15.0/astlib/pprintast.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/pprintast.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,1737 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Thomas Gazagnaire, OCamlPro *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* Hongbo Zhang, University of Pennsylvania *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Original Code from Ber-metaocaml, modified for 3.12.0 and fixed *) +(* Printing code expressions *) +(* Authors: Ed Pizzi, Fabrice Le Fessant *) +(* Extensive Rewrite: Hongbo Zhang: University of Pennsylvania *) +(* TODO more fine-grained precedence pretty-printing *) + +open Ast_412 +open Asttypes +open Format +open Location +open Longident +open Parsetree + +let varify_type_constructors var_names t = + let check_variable vl loc v = + if List.mem v vl then + Location.raise_errorf ~loc "variable in scope syntax error: %s" v + in + let var_names = List.map (fun v -> v.txt) var_names in + let rec loop t = + let desc = + match t.ptyp_desc with + | Ptyp_any -> Ptyp_any + | Ptyp_var x -> + check_variable var_names t.ptyp_loc 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) -> + check_variable var_names t.ptyp_loc 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) -> + List.iter + (fun v -> check_variable var_names t.ptyp_loc v.txt) + string_lst; + 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 + | Rtag (label, flag, lst) -> 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 + | Otag (label, t) -> Otag (label, loop t) + | Oinherit t -> Oinherit (loop t) + in + { field with pof_desc } + in + loop t + +let prefix_symbols = [ '!'; '?'; '~' ] + +let infix_symbols = + [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/'; '$'; '%'; '#' ] + +(* type fixity = Infix| Prefix *) +let special_infix_strings = + [ "asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "::" ] + +let letop s = + String.length s > 3 + && s.[0] = 'l' + && s.[1] = 'e' + && s.[2] = 't' + && List.mem s.[3] infix_symbols + +let andop s = + String.length s > 3 + && s.[0] = 'a' + && s.[1] = 'n' + && s.[2] = 'd' + && List.mem s.[3] infix_symbols + +(* determines if the string is an infix string. + checks backwards, first allowing a renaming postfix ("_102") which + may have resulted from Pexp -> Texp -> Pexp translation, then checking + if all the characters in the beginning of the string are valid infix + characters. *) +let fixity_of_string = function + | "" -> `Normal + | s when List.mem s special_infix_strings -> `Infix s + | s when List.mem s.[0] infix_symbols -> `Infix s + | s when List.mem s.[0] prefix_symbols -> `Prefix s + | s when s.[0] = '.' -> `Mixfix s + | s when letop s -> `Letop s + | s when andop s -> `Andop s + | _ -> `Normal + +let view_fixity_of_exp = function + | { pexp_desc = Pexp_ident { txt = Lident l; _ }; pexp_attributes = [] } -> + fixity_of_string l + | _ -> `Normal + +let is_infix = function `Infix _ -> true | _ -> false + +let is_mixfix = function `Mixfix _ -> true | _ -> false + +let is_kwdop = function `Letop _ | `Andop _ -> true | _ -> false + +let first_is c str = str <> "" && str.[0] = c + +let last_is c str = str <> "" && str.[String.length str - 1] = c + +let first_is_in cs str = str <> "" && List.mem str.[0] cs + +(* which identifiers are in fact operators needing parentheses *) +let needs_parens txt = + let fix = fixity_of_string txt in + is_infix fix || is_mixfix fix || is_kwdop fix + || first_is_in prefix_symbols txt + +(* some infixes need spaces around parens to avoid clashes with comment + syntax *) +let needs_spaces txt = first_is '*' txt || last_is '*' txt + +(* add parentheses to binders when they are in fact infix or prefix operators *) +let protect_ident ppf txt = + let format : (_, _, _) format = + if not (needs_parens txt) then "%s" + else if needs_spaces txt then "(@;%s@;)" + else "(%s)" + in + fprintf ppf format txt + +let protect_longident ppf print_longident longprefix txt = + let format : (_, _, _) format = + if not (needs_parens txt) then "%a.%s" + else if needs_spaces txt then "%a.(@;%s@;)" + else "%a.(%s)" + in + fprintf ppf format print_longident longprefix txt + +type space_formatter = (unit, Format.formatter, unit) format + +let override = function Override -> "!" | Fresh -> "" + +(* variance encoding: need to sync up with the [parser.mly] *) +let type_variance = function + | NoVariance -> "" + | Covariant -> "+" + | Contravariant -> "-" + +let type_injectivity = function NoInjectivity -> "" | Injective -> "!" + +type construct = + [ `cons of expression list + | `list of expression list + | `nil + | `normal + | `simple of Longident.t + | `tuple ] + +let view_expr x = + match x.pexp_desc with + | Pexp_construct ({ txt = Lident "()"; _ }, _) -> `tuple + | Pexp_construct ({ txt = Lident "[]"; _ }, _) -> `nil + | Pexp_construct ({ txt = Lident "::"; _ }, Some _) -> + let rec loop exp acc = + match exp with + | { + pexp_desc = Pexp_construct ({ txt = Lident "[]"; _ }, _); + pexp_attributes = []; + } -> + (List.rev acc, true) + | { + pexp_desc = + Pexp_construct + ( { txt = Lident "::"; _ }, + Some { pexp_desc = Pexp_tuple [ e1; e2 ]; pexp_attributes = [] } + ); + pexp_attributes = []; + } -> + loop e2 (e1 :: acc) + | e -> (List.rev (e :: acc), false) + in + let ls, b = loop x [] in + if b then `list ls else `cons ls + | Pexp_construct (x, None) -> `simple x.txt + | _ -> `normal + +let is_simple_construct : construct -> bool = function + | `nil | `tuple | `list _ | `simple _ -> true + | `cons _ | `normal -> false + +let pp = fprintf + +type ctxt = { pipe : bool; semi : bool; ifthenelse : bool } + +let reset_ctxt = { pipe = false; semi = false; ifthenelse = false } + +let under_pipe ctxt = { ctxt with pipe = true } + +let under_semi ctxt = { ctxt with semi = true } + +let under_ifthenelse ctxt = { ctxt with ifthenelse = true } +(* +let reset_semi ctxt = { ctxt with semi=false } +let reset_ifthenelse ctxt = { ctxt with ifthenelse=false } +let reset_pipe ctxt = { ctxt with pipe=false } +*) + +let list : + 'a. + ?sep:space_formatter -> + ?first:space_formatter -> + ?last:space_formatter -> + (Format.formatter -> 'a -> unit) -> + Format.formatter -> + 'a list -> + unit = + fun ?sep ?first ?last fu f xs -> + let first = match first with Some x -> x | None -> ("" : _ format6) + and last = match last with Some x -> x | None -> ("" : _ format6) + and sep = match sep with Some x -> x | None -> ("@ " : _ format6) in + let aux f = function + | [] -> () + | [ x ] -> fu f x + | xs -> + let rec loop f = function + | [ x ] -> fu f x + | x :: xs -> + fu f x; + pp f sep; + loop f xs + | _ -> assert false + in + pp f first; + loop f xs; + pp f last + in + aux f xs + +let option : + 'a. + ?first:space_formatter -> + ?last:space_formatter -> + (Format.formatter -> 'a -> unit) -> + Format.formatter -> + 'a option -> + unit = + fun ?first ?last fu f a -> + let first = match first with Some x -> x | None -> ("" : _ format6) + and last = match last with Some x -> x | None -> ("" : _ format6) in + match a with + | None -> () + | Some x -> + pp f first; + fu f x; + pp f last + +let paren : + 'a. + ?first:space_formatter -> + ?last:space_formatter -> + bool -> + (Format.formatter -> 'a -> unit) -> + Format.formatter -> + 'a -> + unit = + fun ?(first = ("" : _ format6)) ?(last = ("" : _ format6)) b fu f x -> + if b then ( + pp f "("; + pp f first; + fu f x; + pp f last; + pp f ")") + else fu f x + +let rec longident f = function + | Lident s -> protect_ident f s + | Ldot (y, s) -> protect_longident f longident y s + | Lapply (y, s) -> pp f "%a(%a)" longident y longident s + +let longident_loc f x = pp f "%a" longident x.txt + +let constant f = function + | Pconst_char i -> pp f "%C" i + | Pconst_string (i, _, None) -> pp f "%S" i + | Pconst_string (i, _, Some delim) -> pp f "{%s|%s|%s}" delim i delim + | Pconst_integer (i, None) -> paren (first_is '-' i) (fun f -> pp f "%s") f i + | Pconst_integer (i, Some m) -> + paren (first_is '-' i) (fun f (i, m) -> pp f "%s%c" i m) f (i, m) + | Pconst_float (i, None) -> paren (first_is '-' i) (fun f -> pp f "%s") f i + | Pconst_float (i, Some m) -> + paren (first_is '-' i) (fun f (i, m) -> pp f "%s%c" i m) f (i, m) + +(* trailing space*) +let mutable_flag f = function Immutable -> () | Mutable -> pp f "mutable@;" + +let virtual_flag f = function Concrete -> () | Virtual -> pp f "virtual@;" + +(* trailing space added *) +let rec_flag f rf = + match rf with Nonrecursive -> () | Recursive -> pp f "rec " + +let nonrec_flag f rf = + match rf with Nonrecursive -> pp f "nonrec " | Recursive -> () + +let direction_flag f = function + | Upto -> pp f "to@ " + | Downto -> pp f "downto@ " + +let private_flag f = function Public -> () | Private -> pp f "private@ " + +let iter_loc f ctxt { txt; loc = _ } = f ctxt txt + +let constant_string f s = pp f "%S" s + +let tyvar ppf s = + if String.length s >= 2 && s.[1] = '\'' then + (* without the space, this would be parsed as + a character literal *) + Format.fprintf ppf "' %s" s + else Format.fprintf ppf "'%s" s + +let tyvar_loc f str = tyvar f str.txt + +let string_quot f x = pp f "`%s" x + +(* c ['a,'b] *) +let rec class_params_def ctxt f = function + | [] -> () + | l -> pp f "[%a] " (* space *) (list (type_param ctxt) ~sep:",") l + +and type_with_label ctxt f (label, c) = + match label with + | Nolabel -> core_type1 ctxt f c (* otherwise parenthesize *) + | Labelled s -> pp f "%s:%a" s (core_type1 ctxt) c + | Optional s -> pp f "?%s:%a" s (core_type1 ctxt) c + +and core_type ctxt f x = + if x.ptyp_attributes <> [] then + pp f "((%a)%a)" (core_type ctxt) + { x with ptyp_attributes = [] } + (attributes ctxt) x.ptyp_attributes + else + match x.ptyp_desc with + | Ptyp_arrow (l, ct1, ct2) -> + pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) + (type_with_label ctxt) (l, ct1) (core_type ctxt) ct2 + | Ptyp_alias (ct, s) -> + pp f "@[<2>%a@;as@;%a@]" (core_type1 ctxt) ct tyvar s + | Ptyp_poly ([], ct) -> core_type ctxt f ct + | Ptyp_poly (sl, ct) -> + pp f "@[<2>%a%a@]" + (fun f l -> + pp f "%a" + (fun f l -> + match l with + | [] -> () + | _ -> pp f "%a@;.@;" (list tyvar_loc ~sep:"@;") l) + l) + sl (core_type ctxt) ct + | _ -> pp f "@[<2>%a@]" (core_type1 ctxt) x + +and core_type1 ctxt f x = + if x.ptyp_attributes <> [] then core_type ctxt f x + else + match x.ptyp_desc with + | Ptyp_any -> pp f "_" + | Ptyp_var s -> tyvar f s + | Ptyp_tuple l -> pp f "(%a)" (list (core_type1 ctxt) ~sep:"@;*@;") l + | Ptyp_constr (li, l) -> + pp f (* "%a%a@;" *) "%a%a" + (fun f l -> + match l with + | [] -> () + | [ x ] -> pp f "%a@;" (core_type1 ctxt) x + | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:",@;" f l) + l longident_loc li + | Ptyp_variant (l, closed, low) -> + let first_is_inherit = + match l with + | { Parsetree.prf_desc = Rinherit _ } :: _ -> true + | _ -> false + in + let type_variant_helper f x = + match x.prf_desc with + | Rtag (l, _, ctl) -> + pp f "@[<2>%a%a@;%a@]" (iter_loc string_quot) l + (fun f l -> + match l with + | [] -> () + | _ -> pp f "@;of@;%a" (list (core_type ctxt) ~sep:"&") ctl) + ctl (attributes ctxt) x.prf_attributes + | Rinherit ct -> core_type ctxt f ct + in + pp f "@[<2>[%a%a]@]" + (fun f l -> + match (l, closed) with + | [], Closed -> () + | [], Open -> pp f ">" (* Cf #7200: print [>] correctly *) + | _ -> + pp f "%s@;%a" + (match (closed, low) with + | Closed, None -> if first_is_inherit then " |" else "" + | Closed, Some _ -> "<" (* FIXME desugar the syntax sugar*) + | Open, _ -> ">") + (list type_variant_helper ~sep:"@;<1 -2>| ") + l) + l + (fun f low -> + match low with + | Some [] | None -> () + | Some xs -> pp f ">@ %a" (list string_quot) xs) + low + | Ptyp_object (l, o) -> + let core_field_type f x = + match x.pof_desc with + | Otag (l, ct) -> + (* Cf #7200 *) + pp f "@[%s: %a@ %a@ @]" l.txt (core_type ctxt) ct + (attributes ctxt) x.pof_attributes + | Oinherit ct -> pp f "@[%a@ @]" (core_type ctxt) ct + in + let field_var f = function + | Asttypes.Closed -> () + | Asttypes.Open -> ( + match l with [] -> pp f ".." | _ -> pp f " ;..") + in + pp f "@[<@ %a%a@ > @]" + (list core_field_type ~sep:";") + l field_var o + (* Cf #7200 *) + | Ptyp_class (li, l) -> + (*FIXME*) + pp f "@[%a#%a@]" + (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") + l longident_loc li + | Ptyp_package (lid, cstrs) -> ( + let aux f (s, ct) = + pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct + in + match cstrs with + | [] -> pp f "@[(module@ %a)@]" longident_loc lid + | _ -> + pp f "@[(module@ %a@ with@ %a)@]" longident_loc lid + (list aux ~sep:"@ and@ ") cstrs) + | Ptyp_extension e -> extension ctxt f e + | _ -> paren true (core_type ctxt) f x + +(********************pattern********************) +(* be cautious when use [pattern], [pattern1] is preferred *) +and pattern ctxt f x = + let rec list_of_pattern acc = function + (* only consider ((A|B)|C)*) + | { ppat_desc = Ppat_or (p1, p2); ppat_attributes = [] } -> + list_of_pattern (p2 :: acc) p1 + | x -> x :: acc + in + if x.ppat_attributes <> [] then + pp f "((%a)%a)" (pattern ctxt) + { x with ppat_attributes = [] } + (attributes ctxt) x.ppat_attributes + else + match x.ppat_desc with + | Ppat_alias (p, s) -> + pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p protect_ident s.txt (* RA*) + | Ppat_or _ -> + (* *) + pp f "@[%a@]" + (list ~sep:"@,|" (pattern ctxt)) + (list_of_pattern [] x) + | _ -> pattern1 ctxt f x + +and pattern1 ctxt (f : Format.formatter) (x : pattern) : unit = + let rec pattern_list_helper f = function + | { + ppat_desc = + Ppat_construct + ( { txt = Lident "::"; _ }, + Some { ppat_desc = Ppat_tuple [ pat1; pat2 ]; _ } ); + ppat_attributes = []; + } -> + pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*) + | p -> pattern1 ctxt f p + in + if x.ppat_attributes <> [] then pattern ctxt f x + else + match x.ppat_desc with + | Ppat_variant (l, Some p) -> + pp f "@[<2>`%s@;%a@]" l (simple_pattern ctxt) p + | Ppat_construct ({ txt = Lident ("()" | "[]"); _ }, _) -> + simple_pattern ctxt f x + | Ppat_construct (({ txt; _ } as li), po) -> ( + if (* FIXME The third field always false *) + txt = Lident "::" then pp f "%a" pattern_list_helper x + else + match po with + | Some x -> pp f "%a@;%a" longident_loc li (simple_pattern ctxt) x + | None -> pp f "%a" longident_loc li) + | _ -> simple_pattern ctxt f x + +and simple_pattern ctxt (f : Format.formatter) (x : pattern) : unit = + if x.ppat_attributes <> [] then pattern ctxt f x + else + match x.ppat_desc with + | Ppat_construct ({ txt = Lident (("()" | "[]") as x); _ }, _) -> + pp f "%s" x + | Ppat_any -> pp f "_" + | Ppat_var { txt; _ } -> protect_ident f txt + | Ppat_array l -> pp f "@[<2>[|%a|]@]" (list (pattern1 ctxt) ~sep:";") l + | Ppat_unpack { txt = None } -> pp f "(module@ _)@ " + | Ppat_unpack { txt = Some s } -> pp f "(module@ %s)@ " s + | Ppat_type li -> pp f "#%a" longident_loc li + | Ppat_record (l, closed) -> ( + let longident_x_pattern f (li, p) = + match (li, p) with + | ( { txt = Lident s; _ }, + { ppat_desc = Ppat_var { txt; _ }; ppat_attributes = []; _ } ) + when s = txt -> + pp f "@[<2>%a@]" longident_loc li + | _ -> pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p + in + match closed with + | Closed -> + pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l + | _ -> pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l) + | Ppat_tuple l -> + pp f "@[<1>(%a)@]" (list ~sep:",@;" (pattern1 ctxt)) l (* level1*) + | Ppat_constant c -> pp f "%a" constant c + | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2 + | Ppat_variant (l, None) -> pp f "`%s" l + | Ppat_constraint (p, ct) -> + pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct + | Ppat_lazy p -> pp f "@[<2>(lazy@;%a)@]" (pattern1 ctxt) p + | Ppat_exception p -> pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p + | Ppat_extension e -> extension ctxt f e + | Ppat_open (lid, p) -> + let with_paren = + match p.ppat_desc with + | Ppat_array _ | Ppat_record _ + | Ppat_construct ({ txt = Lident ("()" | "[]"); _ }, _) -> + false + | _ -> true + in + pp f "@[<2>%a.%a @]" longident_loc lid + (paren with_paren @@ pattern1 ctxt) + p + | _ -> paren true (pattern ctxt) f x + +and label_exp ctxt f (l, opt, p) = + match l with + | Nolabel -> + (* single case pattern parens needed here *) + pp f "%a@ " (simple_pattern ctxt) p + | Optional rest -> ( + match p with + | { ppat_desc = Ppat_var { txt; _ }; ppat_attributes = [] } + when txt = rest -> ( + match opt with + | Some o -> pp f "?(%s=@;%a)@;" rest (expression ctxt) o + | None -> pp f "?%s@ " rest) + | _ -> ( + match opt with + | Some o -> + pp f "?%s:(%a=@;%a)@;" rest (pattern1 ctxt) p (expression ctxt) o + | None -> pp f "?%s:%a@;" rest (simple_pattern ctxt) p)) + | Labelled l -> ( + match p with + | { ppat_desc = Ppat_var { txt; _ }; ppat_attributes = [] } when txt = l + -> + pp f "~%s@;" l + | _ -> pp f "~%s:%a@;" l (simple_pattern ctxt) p) + +and sugar_expr ctxt f e = + if e.pexp_attributes <> [] then false + else + match e.pexp_desc with + | Pexp_apply + ( { pexp_desc = Pexp_ident { txt = id; _ }; pexp_attributes = []; _ }, + args ) + when List.for_all (fun (lab, _) -> lab = Nolabel) args -> ( + let print_indexop a path_prefix assign left right print_index indices + rem_args = + let print_path ppf = function + | None -> () + | Some m -> pp ppf ".%a" longident m + in + match (assign, rem_args) with + | false, [] -> + pp f "@[%a%a%s%a%s@]" (simple_expr ctxt) a print_path path_prefix + left + (list ~sep:"," print_index) + indices right; + true + | true, [ v ] -> + pp f "@[%a%a%s%a%s@ <-@;<1 2>%a@]" (simple_expr ctxt) a print_path + path_prefix left + (list ~sep:"," print_index) + indices right (simple_expr ctxt) v; + true + | _ -> false + in + match (id, List.map snd args) with + | Lident "!", [ e ] -> + pp f "@[!%a@]" (simple_expr ctxt) e; + true + | Ldot (path, (("get" | "set") as func)), a :: other_args -> ( + let assign = func = "set" in + let print = print_indexop a None assign in + match (path, other_args) with + | Lident "Array", i :: rest -> + print ".(" ")" (expression ctxt) [ i ] rest + | Lident "String", i :: rest -> + print ".[" "]" (expression ctxt) [ i ] rest + | Ldot (Lident "Bigarray", "Array1"), i1 :: rest -> + print ".{" "}" (simple_expr ctxt) [ i1 ] rest + | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest -> + print ".{" "}" (simple_expr ctxt) [ i1; i2 ] rest + | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest -> + print ".{" "}" (simple_expr ctxt) [ i1; i2; i3 ] rest + | ( Ldot (Lident "Bigarray", "Genarray"), + { pexp_desc = Pexp_array indexes; pexp_attributes = [] } :: rest + ) -> + print ".{" "}" (simple_expr ctxt) indexes rest + | _ -> false) + | (Lident s | Ldot (_, s)), a :: i :: rest when first_is '.' s -> + (* extract operator: + assignment operators end with [right_bracket ^ "<-"], + access operators end with [right_bracket] directly + *) + let assign = last_is '-' s in + let kind = + (* extract the right end bracket *) + let n = String.length s in + if assign then s.[n - 3] else s.[n - 1] + in + let left, right = + match kind with + | ')' -> ('(', ")") + | ']' -> ('[', "]") + | '}' -> ('{', "}") + | _ -> assert false + in + let path_prefix = + match id with Ldot (m, _) -> Some m | _ -> None + in + let left = String.sub s 0 (1 + String.index s left) in + print_indexop a path_prefix assign left right (expression ctxt) + [ i ] rest + | _ -> false) + | _ -> false + +and expression ctxt f x = + if x.pexp_attributes <> [] then + pp f "((%a)@,%a)" (expression ctxt) + { x with pexp_attributes = [] } + (attributes ctxt) x.pexp_attributes + else + match x.pexp_desc with + | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _ + when ctxt.pipe || ctxt.semi -> + paren true (expression reset_ctxt) f x + | (Pexp_ifthenelse _ | Pexp_sequence _) when ctxt.ifthenelse -> + paren true (expression reset_ctxt) f x + | Pexp_let _ | Pexp_letmodule _ | Pexp_open _ | Pexp_letexception _ + | Pexp_letop _ + when ctxt.semi -> + paren true (expression reset_ctxt) f x + | Pexp_fun (l, e0, p, e) -> + pp f "@[<2>fun@;%a->@;%a@]" (label_exp ctxt) (l, e0, p) + (expression ctxt) e + | Pexp_function l -> pp f "@[function%a@]" (case_list ctxt) l + | Pexp_match (e, l) -> + pp f "@[@[@[<2>match %a@]@ with@]%a@]" (expression reset_ctxt) + e (case_list ctxt) l + | Pexp_try (e, l) -> + pp f "@[<0>@[try@ %a@]@ @[<0>with%a@]@]" + (* "try@;@[<2>%a@]@\nwith@\n%a"*) + (expression reset_ctxt) + e (case_list ctxt) l + | Pexp_let (rf, l, e) -> + (* pp f "@[<2>let %a%a in@;<1 -2>%a@]" + (*no indentation here, a new line*) *) + (* rec_flag rf *) + pp f "@[<2>%a in@;<1 -2>%a@]" (bindings reset_ctxt) (rf, l) + (expression ctxt) e + | Pexp_apply (e, l) -> ( + if not (sugar_expr ctxt f x) then + match view_fixity_of_exp e with + | `Infix s -> ( + match l with + | [ ((Nolabel, _) as arg1); ((Nolabel, _) as arg2) ] -> + (* FIXME associativity label_x_expression_param *) + pp f "@[<2>%a@;%s@;%a@]" + (label_x_expression_param reset_ctxt) + arg1 s + (label_x_expression_param ctxt) + arg2 + | _ -> + pp f "@[<2>%a %a@]" (simple_expr ctxt) e + (list (label_x_expression_param ctxt)) + l) + | `Prefix s -> ( + let s = + if + List.mem s [ "~+"; "~-"; "~+."; "~-." ] + && + match l with + (* See #7200: avoid turning (~- 1) into (- 1) which is + parsed as an int literal *) + | [ (_, { pexp_desc = Pexp_constant _ }) ] -> false + | _ -> true + then String.sub s 1 (String.length s - 1) + else s + in + match l with + | [ (Nolabel, x) ] -> pp f "@[<2>%s@;%a@]" s (simple_expr ctxt) x + | _ -> + pp f "@[<2>%a %a@]" (simple_expr ctxt) e + (list (label_x_expression_param ctxt)) + l) + | _ -> + pp f "@[%a@]" + (fun f (e, l) -> + pp f "%a@ %a" (expression2 ctxt) e + (list (label_x_expression_param reset_ctxt)) + l + (* reset here only because [function,match,try,sequence] + are lower priority *)) + (e, l)) + | Pexp_construct (li, Some eo) when not (is_simple_construct (view_expr x)) + -> ( + (* Not efficient FIXME*) + match view_expr x with + | `cons ls -> list (simple_expr ctxt) f ls ~sep:"@;::@;" + | `normal -> pp f "@[<2>%a@;%a@]" longident_loc li (simple_expr ctxt) eo + | _ -> assert false) + | Pexp_setfield (e1, li, e2) -> + pp f "@[<2>%a.%a@ <-@ %a@]" (simple_expr ctxt) e1 longident_loc li + (simple_expr ctxt) e2 + | Pexp_ifthenelse (e1, e2, eo) -> + (* @;@[<2>else@ %a@]@] *) + let fmt : (_, _, _) format = + "@[@[<2>if@ %a@]@;@[<2>then@ %a@]%a@]" + in + let expression_under_ifthenelse = expression (under_ifthenelse ctxt) in + pp f fmt expression_under_ifthenelse e1 expression_under_ifthenelse e2 + (fun f eo -> + match eo with + | Some x -> + pp f "@;@[<2>else@;%a@]" (expression (under_semi ctxt)) x + | None -> () + (* pp f "()" *)) + eo + | Pexp_sequence _ -> + let rec sequence_helper acc = function + | { pexp_desc = Pexp_sequence (e1, e2); pexp_attributes = [] } -> + sequence_helper (e1 :: acc) e2 + | v -> List.rev (v :: acc) + in + let lst = sequence_helper [] x in + pp f "@[%a@]" (list (expression (under_semi ctxt)) ~sep:";@;") lst + | Pexp_new li -> pp f "@[new@ %a@]" longident_loc li + | Pexp_setinstvar (s, e) -> + pp f "@[%s@ <-@ %a@]" s.txt (expression ctxt) e + | Pexp_override l -> + (* FIXME *) + let string_x_expression f (s, e) = + pp f "@[%s@ =@ %a@]" s.txt (expression ctxt) e + in + pp f "@[{<%a>}@]" (list string_x_expression ~sep:";") l + | Pexp_letmodule (s, me, e) -> + pp f "@[let@ module@ %s@ =@ %a@ in@ %a@]" + (match s.txt with None -> "_" | Some s -> s) + (module_expr reset_ctxt) me (expression ctxt) e + | Pexp_letexception (cd, e) -> + pp f "@[let@ exception@ %a@ in@ %a@]" + (extension_constructor ctxt) + cd (expression ctxt) e + | Pexp_assert e -> pp f "@[assert@ %a@]" (simple_expr ctxt) e + | Pexp_lazy e -> pp f "@[lazy@ %a@]" (simple_expr ctxt) e + (* Pexp_poly: impossible but we should print it anyway, rather than + assert false *) + | Pexp_poly (e, None) -> pp f "@[!poly!@ %a@]" (simple_expr ctxt) e + | Pexp_poly (e, Some ct) -> + pp f "@[(!poly!@ %a@ : %a)@]" (simple_expr ctxt) e + (core_type ctxt) ct + | Pexp_open (o, e) -> + pp f "@[<2>let open%s %a in@;%a@]" + (override o.popen_override) + (module_expr ctxt) o.popen_expr (expression ctxt) e + | Pexp_variant (l, Some eo) -> pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) eo + | Pexp_letop { let_; ands; body } -> + pp f "@[<2>@[%a@,%a@] in@;<1 -2>%a@]" (binding_op ctxt) let_ + (list ~sep:"@," (binding_op ctxt)) + ands (expression ctxt) body + | Pexp_extension e -> extension ctxt f e + | Pexp_unreachable -> pp f "." + | _ -> expression1 ctxt f x + +and expression1 ctxt f x = + if x.pexp_attributes <> [] then expression ctxt f x + else + match x.pexp_desc with + | Pexp_object cs -> pp f "%a" (class_structure ctxt) cs + | _ -> expression2 ctxt f x +(* used in [Pexp_apply] *) + +and expression2 ctxt f x = + if x.pexp_attributes <> [] then expression ctxt f x + else + match x.pexp_desc with + | Pexp_field (e, li) -> + pp f "@[%a.%a@]" (simple_expr ctxt) e longident_loc li + | Pexp_send (e, s) -> pp f "@[%a#%s@]" (simple_expr ctxt) e s.txt + | _ -> simple_expr ctxt f x + +and simple_expr ctxt f x = + if x.pexp_attributes <> [] then expression ctxt f x + else + match x.pexp_desc with + | Pexp_construct _ when is_simple_construct (view_expr x) -> ( + match view_expr x with + | `nil -> pp f "[]" + | `tuple -> pp f "()" + | `list xs -> + pp f "@[[%a]@]" + (list (expression (under_semi ctxt)) ~sep:";@;") + xs + | `simple x -> longident f x + | _ -> assert false) + | Pexp_ident li -> longident_loc f li + (* (match view_fixity_of_exp x with *) + (* |`Normal -> longident_loc f li *) + (* | `Prefix _ | `Infix _ -> pp f "( %a )" longident_loc li) *) + | Pexp_constant c -> constant f c + | Pexp_pack me -> pp f "(module@;%a)" (module_expr ctxt) me + | Pexp_newtype (lid, e) -> + pp f "fun@;(type@;%s)@;->@;%a" lid.txt (expression ctxt) e + | Pexp_tuple l -> + pp f "@[(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l + | Pexp_constraint (e, ct) -> + pp f "(%a : %a)" (expression ctxt) e (core_type ctxt) ct + | Pexp_coerce (e, cto1, ct) -> + pp f "(%a%a :> %a)" (expression ctxt) e + (option (core_type ctxt) ~first:" : " ~last:" ") + cto1 + (* no sep hint*) (core_type ctxt) + ct + | Pexp_variant (l, None) -> pp f "`%s" l + | Pexp_record (l, eo) -> + let longident_x_expression f (li, e) = + match e with + | { pexp_desc = Pexp_ident { txt; _ }; pexp_attributes = []; _ } + when li.txt = txt -> + pp f "@[%a@]" longident_loc li + | _ -> + pp f "@[%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e + in + pp f "@[@[{@;%a%a@]@;}@]" (* "@[{%a%a}@]" *) + (option ~last:" with@;" (simple_expr ctxt)) + eo + (list longident_x_expression ~sep:";@;") + l + | Pexp_array l -> + pp f "@[<0>@[<2>[|%a|]@]@]" + (list (simple_expr (under_semi ctxt)) ~sep:";") + l + | Pexp_while (e1, e2) -> + let fmt : (_, _, _) format = "@[<2>while@;%a@;do@;%a@;done@]" in + pp f fmt (expression ctxt) e1 (expression ctxt) e2 + | Pexp_for (s, e1, e2, df, e3) -> + let fmt : (_, _, _) format = + "@[@[@[<2>for %a =@;%a@;%a%a@;do@]@;%a@]@;done@]" + in + let expression = expression ctxt in + pp f fmt (pattern ctxt) s expression e1 direction_flag df expression e2 + expression e3 + | _ -> paren true (expression ctxt) f x + +and attributes ctxt f l = List.iter (attribute ctxt f) l + +and item_attributes ctxt f l = List.iter (item_attribute ctxt f) l + +and attribute ctxt f a = + pp f "@[<2>[@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload + +and item_attribute ctxt f a = + pp f "@[<2>[@@@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload + +and floating_attribute ctxt f a = + pp f "@[<2>[@@@@@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload + +and value_description ctxt f x = + (* note: value_description has an attribute field, + but they're already printed by the callers this method *) + pp f "@[%a%a@]" (core_type ctxt) x.pval_type + (fun f x -> + if x.pval_prim <> [] then + pp f "@ =@ %a" (list constant_string) x.pval_prim) + x + +and extension ctxt f (s, e) = pp f "@[<2>[%%%s@ %a]@]" s.txt (payload ctxt) e + +and item_extension ctxt f (s, e) = + pp f "@[<2>[%%%%%s@ %a]@]" s.txt (payload ctxt) e + +and exception_declaration ctxt f x = + pp f "@[exception@ %a@]%a" + (extension_constructor ctxt) + x.ptyexn_constructor (item_attributes ctxt) x.ptyexn_attributes + +and class_type_field ctxt f x = + match x.pctf_desc with + | Pctf_inherit ct -> + pp f "@[<2>inherit@ %a@]%a" (class_type ctxt) ct (item_attributes ctxt) + x.pctf_attributes + | Pctf_val (s, mf, vf, ct) -> + pp f "@[<2>val @ %a%a%s@ :@ %a@]%a" mutable_flag mf virtual_flag vf s.txt + (core_type ctxt) ct (item_attributes ctxt) x.pctf_attributes + | Pctf_method (s, pf, vf, ct) -> + pp f "@[<2>method %a %a%s :@;%a@]%a" private_flag pf virtual_flag vf s.txt + (core_type ctxt) ct (item_attributes ctxt) x.pctf_attributes + | Pctf_constraint (ct1, ct2) -> + pp f "@[<2>constraint@ %a@ =@ %a@]%a" (core_type ctxt) ct1 + (core_type ctxt) ct2 (item_attributes ctxt) x.pctf_attributes + | Pctf_attribute a -> floating_attribute ctxt f a + | Pctf_extension e -> + item_extension ctxt f e; + item_attributes ctxt f x.pctf_attributes + +and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l; _ } = + pp f "@[@[object@[<1>%a@]@ %a@]@ end@]" + (fun f -> function + | { ptyp_desc = Ptyp_any; ptyp_attributes = []; _ } -> () + | ct -> pp f " (%a)" (core_type ctxt) ct) + ct + (list (class_type_field ctxt) ~sep:"@;") + l + +(* call [class_signature] called by [class_signature] *) +and class_type ctxt f x = + match x.pcty_desc with + | Pcty_signature cs -> + class_signature ctxt f cs; + attributes ctxt f x.pcty_attributes + | Pcty_constr (li, l) -> + pp f "%a%a%a" + (fun f l -> + match l with + | [] -> () + | _ -> pp f "[%a]@ " (list (core_type ctxt) ~sep:",") l) + l longident_loc li (attributes ctxt) x.pcty_attributes + | Pcty_arrow (l, co, cl) -> + pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) + (type_with_label ctxt) (l, co) (class_type ctxt) cl + | Pcty_extension e -> + extension ctxt f e; + attributes ctxt f x.pcty_attributes + | Pcty_open (o, e) -> + pp f "@[<2>let open%s %a in@;%a@]" + (override o.popen_override) + longident_loc o.popen_expr (class_type ctxt) e + +(* [class type a = object end] *) +and class_type_declaration_list ctxt f l = + let class_type_declaration kwd f x = + let { pci_params = ls; pci_name = { txt; _ }; _ } = x in + pp f "@[<2>%s %a%a%s@ =@ %a@]%a" kwd virtual_flag x.pci_virt + (class_params_def ctxt) ls txt (class_type ctxt) x.pci_expr + (item_attributes ctxt) x.pci_attributes + in + match l with + | [] -> () + | [ x ] -> class_type_declaration "class type" f x + | x :: xs -> + pp f "@[%a@,%a@]" + (class_type_declaration "class type") + x + (list ~sep:"@," (class_type_declaration "and")) + xs + +and class_field ctxt f x = + match x.pcf_desc with + | Pcf_inherit (ovf, ce, so) -> + pp f "@[<2>inherit@ %s@ %a%a@]%a" (override ovf) (class_expr ctxt) ce + (fun f so -> + match so with None -> () | Some s -> pp f "@ as %s" s.txt) + so (item_attributes ctxt) x.pcf_attributes + | Pcf_val (s, mf, Cfk_concrete (ovf, e)) -> + pp f "@[<2>val%s %a%s =@;%a@]%a" (override ovf) mutable_flag mf s.txt + (expression ctxt) e (item_attributes ctxt) x.pcf_attributes + | Pcf_method (s, pf, Cfk_virtual ct) -> + pp f "@[<2>method virtual %a %s :@;%a@]%a" private_flag pf s.txt + (core_type ctxt) ct (item_attributes ctxt) x.pcf_attributes + | Pcf_val (s, mf, Cfk_virtual ct) -> + pp f "@[<2>val virtual %a%s :@ %a@]%a" mutable_flag mf s.txt + (core_type ctxt) ct (item_attributes ctxt) x.pcf_attributes + | Pcf_method (s, pf, Cfk_concrete (ovf, e)) -> + let bind e = + binding ctxt f + { + pvb_pat = + { + ppat_desc = Ppat_var s; + ppat_loc = Location.none; + ppat_loc_stack = []; + ppat_attributes = []; + }; + pvb_expr = e; + pvb_attributes = []; + pvb_loc = Location.none; + } + in + pp f "@[<2>method%s %a%a@]%a" (override ovf) private_flag pf + (fun f -> function + | { pexp_desc = Pexp_poly (e, Some ct); pexp_attributes = []; _ } -> + pp f "%s :@;%a=@;%a" s.txt (core_type ctxt) ct (expression ctxt) e + | { pexp_desc = Pexp_poly (e, None); pexp_attributes = []; _ } -> + bind e + | _ -> bind e) + e (item_attributes ctxt) x.pcf_attributes + | Pcf_constraint (ct1, ct2) -> + pp f "@[<2>constraint %a =@;%a@]%a" (core_type ctxt) ct1 (core_type ctxt) + ct2 (item_attributes ctxt) x.pcf_attributes + | Pcf_initializer e -> + pp f "@[<2>initializer@ %a@]%a" (expression ctxt) e (item_attributes ctxt) + x.pcf_attributes + | Pcf_attribute a -> floating_attribute ctxt f a + | Pcf_extension e -> + item_extension ctxt f e; + item_attributes ctxt f x.pcf_attributes + +and class_structure ctxt f { pcstr_self = p; pcstr_fields = l } = + pp f "@[@[object%a@;%a@]@;end@]" + (fun f p -> + match p.ppat_desc with + | Ppat_any -> () + | Ppat_constraint _ -> pp f " %a" (pattern ctxt) p + | _ -> pp f " (%a)" (pattern ctxt) p) + p + (list (class_field ctxt)) + l + +and class_expr ctxt f x = + if x.pcl_attributes <> [] then + pp f "((%a)%a)" (class_expr ctxt) + { x with pcl_attributes = [] } + (attributes ctxt) x.pcl_attributes + else + match x.pcl_desc with + | Pcl_structure cs -> class_structure ctxt f cs + | Pcl_fun (l, eo, p, e) -> + pp f "fun@ %a@ ->@ %a" (label_exp ctxt) (l, eo, p) (class_expr ctxt) e + | Pcl_let (rf, l, ce) -> + pp f "%a@ in@ %a" (bindings ctxt) (rf, l) (class_expr ctxt) ce + | Pcl_apply (ce, l) -> + pp f "((%a)@ %a)" + (* Cf: #7200 *) (class_expr ctxt) + ce + (list (label_x_expression_param ctxt)) + l + | Pcl_constr (li, l) -> + pp f "%a%a" + (fun f l -> + if l <> [] then pp f "[%a]@ " (list (core_type ctxt) ~sep:",") l) + l longident_loc li + | Pcl_constraint (ce, ct) -> + pp f "(%a@ :@ %a)" (class_expr ctxt) ce (class_type ctxt) ct + | Pcl_extension e -> extension ctxt f e + | Pcl_open (o, e) -> + pp f "@[<2>let open%s %a in@;%a@]" + (override o.popen_override) + longident_loc o.popen_expr (class_expr ctxt) e + +and module_type ctxt f x = + if x.pmty_attributes <> [] then + pp f "((%a)%a)" (module_type ctxt) + { x with pmty_attributes = [] } + (attributes ctxt) x.pmty_attributes + else + match x.pmty_desc with + | Pmty_functor (Unit, mt2) -> + pp f "@[functor () ->@ %a@]" (module_type ctxt) mt2 + | Pmty_functor (Named (s, mt1), mt2) -> ( + match s.txt with + | None -> + pp f "@[%a@ ->@ %a@]" (module_type1 ctxt) mt1 + (module_type ctxt) mt2 + | Some name -> + pp f "@[functor@ (%s@ :@ %a)@ ->@ %a@]" name + (module_type ctxt) mt1 (module_type ctxt) mt2) + | Pmty_with (mt, []) -> module_type ctxt f mt + | Pmty_with (mt, l) -> + let with_constraint f = function + | Pwith_type (li, ({ ptype_params = ls; _ } as td)) -> + let ls = List.map fst ls in + pp f "type@ %a %a =@ %a" + (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") + ls longident_loc li (type_declaration ctxt) td + | Pwith_module (li, li2) -> + pp f "module %a =@ %a" longident_loc li longident_loc li2 + | Pwith_typesubst (li, ({ ptype_params = ls; _ } as td)) -> + let ls = List.map fst ls in + pp f "type@ %a %a :=@ %a" + (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") + ls longident_loc li (type_declaration ctxt) td + | Pwith_modsubst (li, li2) -> + pp f "module %a :=@ %a" longident_loc li longident_loc li2 + in + pp f "@[%a@ with@ %a@]" (module_type1 ctxt) mt + (list with_constraint ~sep:"@ and@ ") + l + | _ -> module_type1 ctxt f x + +and module_type1 ctxt f x = + if x.pmty_attributes <> [] then module_type ctxt f x + else + match x.pmty_desc with + | Pmty_ident li -> pp f "%a" longident_loc li + | Pmty_alias li -> pp f "(module %a)" longident_loc li + | Pmty_signature s -> + pp f "@[@[sig@ %a@]@ end@]" (* "@[sig@ %a@ end@]" *) + (list (signature_item ctxt)) + s + (* FIXME wrong indentation*) + | Pmty_typeof me -> + pp f "@[module@ type@ of@ %a@]" (module_expr ctxt) me + | Pmty_extension e -> extension ctxt f e + | _ -> paren true (module_type ctxt) f x + +and signature ctxt f x = list ~sep:"@\n" (signature_item ctxt) f x + +and signature_item ctxt f x : unit = + match x.psig_desc with + | Psig_type (rf, l) -> type_def_list ctxt f (rf, true, l) + | Psig_typesubst l -> + (* Psig_typesubst is never recursive, but we specify [Recursive] here to + avoid printing a [nonrec] flag, which would be rejected by the parser. + *) + type_def_list ctxt f (Recursive, false, l) + | Psig_value vd -> + let intro = if vd.pval_prim = [] then "val" else "external" in + pp f "@[<2>%s@ %a@ :@ %a@]%a" intro protect_ident vd.pval_name.txt + (value_description ctxt) vd (item_attributes ctxt) vd.pval_attributes + | Psig_typext te -> type_extension ctxt f te + | Psig_exception ed -> exception_declaration ctxt f ed + | Psig_class l -> ( + let class_description kwd f + ({ pci_params = ls; pci_name = { txt; _ }; _ } as x) = + pp f "@[<2>%s %a%a%s@;:@;%a@]%a" kwd virtual_flag x.pci_virt + (class_params_def ctxt) ls txt (class_type ctxt) x.pci_expr + (item_attributes ctxt) x.pci_attributes + in + match l with + | [] -> () + | [ x ] -> class_description "class" f x + | x :: xs -> + pp f "@[%a@,%a@]" + (class_description "class") + x + (list ~sep:"@," (class_description "and")) + xs) + | Psig_module + ({ + pmd_type = { pmty_desc = Pmty_alias alias; pmty_attributes = []; _ }; + _; + } as pmd) -> + pp f "@[module@ %s@ =@ %a@]%a" + (match pmd.pmd_name.txt with None -> "_" | Some s -> s) + longident_loc alias (item_attributes ctxt) pmd.pmd_attributes + | Psig_module pmd -> + pp f "@[module@ %s@ :@ %a@]%a" + (match pmd.pmd_name.txt with None -> "_" | Some s -> s) + (module_type ctxt) pmd.pmd_type (item_attributes ctxt) + pmd.pmd_attributes + | Psig_modsubst pms -> + pp f "@[module@ %s@ :=@ %a@]%a" pms.pms_name.txt longident_loc + pms.pms_manifest (item_attributes ctxt) pms.pms_attributes + | Psig_open od -> + pp f "@[open%s@ %a@]%a" + (override od.popen_override) + longident_loc od.popen_expr (item_attributes ctxt) od.popen_attributes + | Psig_include incl -> + pp f "@[include@ %a@]%a" (module_type ctxt) incl.pincl_mod + (item_attributes ctxt) incl.pincl_attributes + | Psig_modtype { pmtd_name = s; pmtd_type = md; pmtd_attributes = attrs } -> + pp f "@[module@ type@ %s%a@]%a" s.txt + (fun f md -> + match md with + | None -> () + | Some mt -> + pp_print_space f (); + pp f "@ =@ %a" (module_type ctxt) mt) + md (item_attributes ctxt) attrs + | Psig_class_type l -> class_type_declaration_list ctxt f l + | Psig_recmodule decls -> + let rec string_x_module_type_list f ?(first = true) l = + match l with + | [] -> () + | pmd :: tl -> + if not first then + pp f "@ @[and@ %s:@ %a@]%a" + (match pmd.pmd_name.txt with None -> "_" | Some s -> s) + (module_type1 ctxt) pmd.pmd_type (item_attributes ctxt) + pmd.pmd_attributes + else + pp f "@[module@ rec@ %s:@ %a@]%a" + (match pmd.pmd_name.txt with None -> "_" | Some s -> s) + (module_type1 ctxt) pmd.pmd_type (item_attributes ctxt) + pmd.pmd_attributes; + string_x_module_type_list f ~first:false tl + in + string_x_module_type_list f decls + | Psig_attribute a -> floating_attribute ctxt f a + | Psig_extension (e, a) -> + item_extension ctxt f e; + item_attributes ctxt f a + +and module_expr ctxt f x = + if x.pmod_attributes <> [] then + pp f "((%a)%a)" (module_expr ctxt) + { x with pmod_attributes = [] } + (attributes ctxt) x.pmod_attributes + else + match x.pmod_desc with + | Pmod_structure s -> + pp f "@[struct@;@[<0>%a@]@;<1 -2>end@]" + (list (structure_item ctxt) ~sep:"@\n") + s + | Pmod_constraint (me, mt) -> + pp f "@[(%a@ :@ %a)@]" (module_expr ctxt) me (module_type ctxt) mt + | Pmod_ident li -> pp f "%a" longident_loc li + | Pmod_functor (Unit, me) -> pp f "functor ()@;->@;%a" (module_expr ctxt) me + | Pmod_functor (Named (s, mt), me) -> + pp f "functor@ (%s@ :@ %a)@;->@;%a" + (match s.txt with None -> "_" | Some s -> s) + (module_type ctxt) mt (module_expr ctxt) me + | Pmod_apply (me1, me2) -> + pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2 + (* Cf: #7200 *) + | Pmod_unpack e -> pp f "(val@ %a)" (expression ctxt) e + | Pmod_extension e -> extension ctxt f e + +and structure ctxt f x = list ~sep:"@\n" (structure_item ctxt) f x + +and payload ctxt f = function + | PStr [ { pstr_desc = Pstr_eval (e, attrs) } ] -> + pp f "@[<2>%a@]%a" (expression ctxt) e (item_attributes ctxt) attrs + | PStr x -> structure ctxt f x + | PTyp x -> + pp f ":@ "; + core_type ctxt f x + | PSig x -> + pp f ":@ "; + signature ctxt f x + | PPat (x, None) -> + pp f "?@ "; + pattern ctxt f x + | PPat (x, Some e) -> + pp f "?@ "; + pattern ctxt f x; + pp f " when "; + expression ctxt f e + +(* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *) +and binding ctxt f { pvb_pat = p; pvb_expr = x; _ } = + (* .pvb_attributes have already been printed by the caller, #bindings *) + let rec pp_print_pexp_function f x = + if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x + else + match x.pexp_desc with + | Pexp_fun (label, eo, p, e) -> + if label = Nolabel then + pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function e + else + pp f "%a@ %a" (label_exp ctxt) (label, eo, p) pp_print_pexp_function + e + | Pexp_newtype (str, e) -> + pp f "(type@ %s)@ %a" str.txt pp_print_pexp_function e + | _ -> pp f "=@;%a" (expression ctxt) x + in + let tyvars_str tyvars = List.map (fun v -> v.txt) tyvars in + let is_desugared_gadt p e = + let gadt_pattern = + match p with + | { + ppat_desc = + Ppat_constraint + ( ({ ppat_desc = Ppat_var _ } as pat), + { ptyp_desc = Ptyp_poly (args_tyvars, rt) } ); + ppat_attributes = []; + } -> + Some (pat, args_tyvars, rt) + | _ -> None + in + let rec gadt_exp tyvars e = + match e with + | { pexp_desc = Pexp_newtype (tyvar, e); pexp_attributes = [] } -> + gadt_exp (tyvar :: tyvars) e + | { pexp_desc = Pexp_constraint (e, ct); pexp_attributes = [] } -> + Some (List.rev tyvars, e, ct) + | _ -> None + in + let gadt_exp = gadt_exp [] e in + match (gadt_pattern, gadt_exp) with + | Some (p, pt_tyvars, pt_ct), Some (e_tyvars, e, e_ct) + when tyvars_str pt_tyvars = tyvars_str e_tyvars -> + let ety = varify_type_constructors e_tyvars e_ct in + if ety = pt_ct then Some (p, pt_tyvars, e_ct, e) else None + | _ -> None + in + if x.pexp_attributes <> [] then + match p with + | { + ppat_desc = + Ppat_constraint + ( ({ ppat_desc = Ppat_var _; _ } as pat), + ({ ptyp_desc = Ptyp_poly _; _ } as typ) ); + ppat_attributes = []; + _; + } -> + pp f "%a@;: %a@;=@;%a" (simple_pattern ctxt) pat (core_type ctxt) typ + (expression ctxt) x + | _ -> pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x + else + match is_desugared_gadt p x with + | Some (p, [], ct, e) -> + pp f "%a@;: %a@;=@;%a" (simple_pattern ctxt) p (core_type ctxt) ct + (expression ctxt) e + | Some (p, tyvars, ct, e) -> + pp f "%a@;: type@;%a.@;%a@;=@;%a" (simple_pattern ctxt) p + (list pp_print_string ~sep:"@;") + (tyvars_str tyvars) (core_type ctxt) ct (expression ctxt) e + | None -> ( + match p with + | { ppat_desc = Ppat_constraint (p, ty); ppat_attributes = [] } -> ( + (* special case for the first*) + match ty with + | { ptyp_desc = Ptyp_poly _; ptyp_attributes = [] } -> + pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p (core_type ctxt) + ty (expression ctxt) x + | _ -> + pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p + (core_type ctxt) ty (expression ctxt) x) + | { ppat_desc = Ppat_var _; ppat_attributes = [] } -> + pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x + | _ -> pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x) + +(* [in] is not printed *) +and bindings ctxt f (rf, l) = + let binding kwd rf f x = + pp f "@[<2>%s %a%a@]%a" kwd rec_flag rf (binding ctxt) x + (item_attributes ctxt) x.pvb_attributes + in + match l with + | [] -> () + | [ x ] -> binding "let" rf f x + | x :: xs -> + pp f "@[%a@,%a@]" (binding "let" rf) x + (list ~sep:"@," (binding "and" Nonrecursive)) + xs + +and binding_op ctxt f x = + pp f "@[<2>%s %a@;=@;%a@]" x.pbop_op.txt (pattern ctxt) x.pbop_pat + (expression ctxt) x.pbop_exp + +and structure_item ctxt f x = + match x.pstr_desc with + | Pstr_eval (e, attrs) -> + pp f "@[;;%a@]%a" (expression ctxt) e (item_attributes ctxt) attrs + | Pstr_type (_, []) -> assert false + | Pstr_type (rf, l) -> type_def_list ctxt f (rf, true, l) + | Pstr_value (rf, l) -> + (* pp f "@[let %a%a@]" rec_flag rf bindings l *) + pp f "@[<2>%a@]" (bindings ctxt) (rf, l) + | Pstr_typext te -> type_extension ctxt f te + | Pstr_exception ed -> exception_declaration ctxt f ed + | Pstr_module x -> + let rec module_helper = function + | { pmod_desc = Pmod_functor (arg_opt, me'); pmod_attributes = [] } -> + (match arg_opt with + | Unit -> pp f "()" + | Named (s, mt) -> + pp f "(%s:%a)" + (match s.txt with None -> "_" | Some s -> s) + (module_type ctxt) mt); + module_helper me' + | me -> me + in + pp f "@[module %s%a@]%a" + (match x.pmb_name.txt with None -> "_" | Some s -> s) + (fun f me -> + let me = module_helper me in + match me with + | { + pmod_desc = + Pmod_constraint + (me', ({ pmty_desc = Pmty_ident _ | Pmty_signature _; _ } as mt)); + pmod_attributes = []; + } -> + pp f " :@;%a@;=@;%a@;" (module_type ctxt) mt (module_expr ctxt) + me' + | _ -> pp f " =@ %a" (module_expr ctxt) me) + x.pmb_expr (item_attributes ctxt) x.pmb_attributes + | Pstr_open od -> + pp f "@[<2>open%s@;%a@]%a" + (override od.popen_override) + (module_expr ctxt) od.popen_expr (item_attributes ctxt) + od.popen_attributes + | Pstr_modtype { pmtd_name = s; pmtd_type = md; pmtd_attributes = attrs } -> + pp f "@[module@ type@ %s%a@]%a" s.txt + (fun f md -> + match md with + | None -> () + | Some mt -> + pp_print_space f (); + pp f "@ =@ %a" (module_type ctxt) mt) + md (item_attributes ctxt) attrs + | Pstr_class l -> ( + let extract_class_args cl = + let rec loop acc = function + | { pcl_desc = Pcl_fun (l, eo, p, cl'); pcl_attributes = [] } -> + loop ((l, eo, p) :: acc) cl' + | cl -> (List.rev acc, cl) + in + let args, cl = loop [] cl in + let constr, cl = + match cl with + | { pcl_desc = Pcl_constraint (cl', ct); pcl_attributes = [] } -> + (Some ct, cl') + | _ -> (None, cl) + in + (args, constr, cl) + in + let class_constraint f ct = pp f ": @[%a@] " (class_type ctxt) ct in + let class_declaration kwd f + ({ pci_params = ls; pci_name = { txt; _ }; _ } as x) = + let args, constr, cl = extract_class_args x.pci_expr in + pp f "@[<2>%s %a%a%s %a%a=@;%a@]%a" kwd virtual_flag x.pci_virt + (class_params_def ctxt) ls txt + (list (label_exp ctxt)) + args (option class_constraint) constr (class_expr ctxt) cl + (item_attributes ctxt) x.pci_attributes + in + match l with + | [] -> () + | [ x ] -> class_declaration "class" f x + | x :: xs -> + pp f "@[%a@,%a@]" + (class_declaration "class") + x + (list ~sep:"@," (class_declaration "and")) + xs) + | Pstr_class_type l -> class_type_declaration_list ctxt f l + | Pstr_primitive vd -> + pp f "@[external@ %a@ :@ %a@]%a" protect_ident vd.pval_name.txt + (value_description ctxt) vd (item_attributes ctxt) vd.pval_attributes + | Pstr_include incl -> + pp f "@[include@ %a@]%a" (module_expr ctxt) incl.pincl_mod + (item_attributes ctxt) incl.pincl_attributes + | Pstr_recmodule decls -> ( + (* 3.07 *) + let aux f = function + | { pmb_expr = { pmod_desc = Pmod_constraint (expr, typ) } } as pmb -> + pp f "@[@ and@ %s:%a@ =@ %a@]%a" + (match pmb.pmb_name.txt with None -> "_" | Some s -> s) + (module_type ctxt) typ (module_expr ctxt) expr + (item_attributes ctxt) pmb.pmb_attributes + | pmb -> + pp f "@[@ and@ %s@ =@ %a@]%a" + (match pmb.pmb_name.txt with None -> "_" | Some s -> s) + (module_expr ctxt) pmb.pmb_expr (item_attributes ctxt) + pmb.pmb_attributes + in + match decls with + | ({ pmb_expr = { pmod_desc = Pmod_constraint (expr, typ) } } as pmb) + :: l2 -> + pp f "@[@[module@ rec@ %s:%a@ =@ %a@]%a@ %a@]" + (match pmb.pmb_name.txt with None -> "_" | Some s -> s) + (module_type ctxt) typ (module_expr ctxt) expr + (item_attributes ctxt) pmb.pmb_attributes + (fun f l2 -> List.iter (aux f) l2) + l2 + | pmb :: l2 -> + pp f "@[@[module@ rec@ %s@ =@ %a@]%a@ %a@]" + (match pmb.pmb_name.txt with None -> "_" | Some s -> s) + (module_expr ctxt) pmb.pmb_expr (item_attributes ctxt) + pmb.pmb_attributes + (fun f l2 -> List.iter (aux f) l2) + l2 + | _ -> assert false) + | Pstr_attribute a -> floating_attribute ctxt f a + | Pstr_extension (e, a) -> + item_extension ctxt f e; + item_attributes ctxt f a + +and type_param ctxt f (ct, (a, b)) = + pp f "%s%s%a" (type_variance a) (type_injectivity b) (core_type ctxt) ct + +and type_params ctxt f = function + | [] -> () + | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",@;") l + +and type_def_list ctxt f (rf, exported, l) = + let type_decl kwd rf f x = + let eq = + if x.ptype_kind = Ptype_abstract && x.ptype_manifest = None then "" + else if exported then " =" + else " :=" + in + pp f "@[<2>%s %a%a%s%s%a@]%a" kwd nonrec_flag rf (type_params ctxt) + x.ptype_params x.ptype_name.txt eq (type_declaration ctxt) x + (item_attributes ctxt) x.ptype_attributes + in + match l with + | [] -> assert false + | [ x ] -> type_decl "type" rf f x + | x :: xs -> + pp f "@[%a@,%a@]" (type_decl "type" rf) x + (list ~sep:"@," (type_decl "and" Recursive)) + xs + +and record_declaration ctxt f lbls = + let type_record_field f pld = + pp f "@[<2>%a%s:@;%a@;%a@]" mutable_flag pld.pld_mutable pld.pld_name.txt + (core_type ctxt) pld.pld_type (attributes ctxt) pld.pld_attributes + in + pp f "{@\n%a}" (list type_record_field ~sep:";@\n") lbls + +and type_declaration ctxt f x = + (* type_declaration has an attribute field, + but it's been printed by the caller of this method *) + let priv f = + match x.ptype_private with Public -> () | Private -> pp f "@;private" + in + let manifest f = + match x.ptype_manifest with + | None -> () + | Some y -> + if x.ptype_kind = Ptype_abstract then + pp f "%t@;%a" priv (core_type ctxt) y + else pp f "@;%a" (core_type ctxt) y + in + let constructor_declaration f pcd = + pp f "|@;"; + constructor_declaration ctxt f + (pcd.pcd_name.txt, pcd.pcd_args, pcd.pcd_res, pcd.pcd_attributes) + in + let repr f = + let intro f = if x.ptype_manifest = None then () else pp f "@;=" in + match x.ptype_kind with + | Ptype_variant xs -> + let variants fmt xs = + if xs = [] then pp fmt " |" + else pp fmt "@\n%a" (list ~sep:"@\n" constructor_declaration) xs + in + pp f "%t%t%a" intro priv variants xs + | Ptype_abstract -> () + | Ptype_record l -> pp f "%t%t@;%a" intro priv (record_declaration ctxt) l + | Ptype_open -> pp f "%t%t@;.." intro priv + in + let constraints f = + List.iter + (fun (ct1, ct2, _) -> + pp f "@[@ constraint@ %a@ =@ %a@]" (core_type ctxt) ct1 + (core_type ctxt) ct2) + x.ptype_cstrs + in + pp f "%t%t%t" manifest repr constraints + +and type_extension ctxt f x = + let extension_constructor f x = + pp f "@\n|@;%a" (extension_constructor ctxt) x + in + pp f "@[<2>type %a%a += %a@ %a@]%a" + (fun f -> function + | [] -> () + | l -> + pp f "%a@;" (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l) + x.ptyext_params longident_loc x.ptyext_path private_flag + x.ptyext_private (* Cf: #7200 *) + (list ~sep:"" extension_constructor) + x.ptyext_constructors (item_attributes ctxt) x.ptyext_attributes + +and constructor_declaration ctxt f (name, args, res, attrs) = + let name = match name with "::" -> "(::)" | s -> s in + match res with + | None -> + pp f "%s%a@;%a" name + (fun f -> function + | Pcstr_tuple [] -> () + | Pcstr_tuple l -> + pp f "@;of@;%a" (list (core_type1 ctxt) ~sep:"@;*@;") l + | Pcstr_record l -> pp f "@;of@;%a" (record_declaration ctxt) l) + args (attributes ctxt) attrs + | Some r -> + pp f "%s:@;%a@;%a" name + (fun f -> function + | Pcstr_tuple [] -> core_type1 ctxt f r + | Pcstr_tuple l -> + pp f "%a@;->@;%a" + (list (core_type1 ctxt) ~sep:"@;*@;") + l (core_type1 ctxt) r + | Pcstr_record l -> + pp f "%a@;->@;%a" (record_declaration ctxt) l (core_type1 ctxt) r) + args (attributes ctxt) attrs + +and extension_constructor ctxt f x = + (* Cf: #7200 *) + match x.pext_kind with + | Pext_decl (l, r) -> + constructor_declaration ctxt f (x.pext_name.txt, l, r, x.pext_attributes) + | Pext_rebind li -> + pp f "%s@;=@;%a%a" x.pext_name.txt longident_loc li (attributes ctxt) + x.pext_attributes + +and case_list ctxt f l : unit = + let aux f { pc_lhs; pc_guard; pc_rhs } = + pp f "@;| @[<2>%a%a@;->@;%a@]" (pattern ctxt) pc_lhs + (option (expression ctxt) ~first:"@;when@;") + pc_guard + (expression (under_pipe ctxt)) + pc_rhs + in + list aux f l ~sep:"" + +and label_x_expression_param ctxt f (l, e) = + let simple_name = + match e with + | { pexp_desc = Pexp_ident { txt = Lident l; _ }; pexp_attributes = [] } -> + Some l + | _ -> None + in + match l with + | Nolabel -> expression2 ctxt f e (* level 2*) + | Optional str -> + if Some str = simple_name then pp f "?%s" str + else pp f "?%s:%a" str (simple_expr ctxt) e + | Labelled lbl -> + if Some lbl = simple_name then pp f "~%s" lbl + else pp f "~%s:%a" lbl (simple_expr ctxt) e + +and directive_argument f x = + match x.pdira_desc with + | Pdir_string s -> pp f "@ %S" s + | Pdir_int (n, None) -> pp f "@ %s" n + | Pdir_int (n, Some m) -> pp f "@ %s%c" n m + | Pdir_ident li -> pp f "@ %a" longident li + | Pdir_bool b -> pp f "@ %s" (string_of_bool b) + +let toplevel_phrase f x = + match x with + | Ptop_def s -> pp f "@[%a@]" (list (structure_item reset_ctxt)) s + (* pp_open_hvbox f 0; *) + (* pp_print_list structure_item f s ; *) + (* pp_close_box f (); *) + | Ptop_dir { pdir_name; pdir_arg = None; _ } -> + pp f "@[#%s@]" pdir_name.txt + | Ptop_dir { pdir_name; pdir_arg = Some pdir_arg; _ } -> + pp f "@[#%s@ %a@]" pdir_name.txt directive_argument pdir_arg + +let expression f x = pp f "@[%a@]" (expression reset_ctxt) x + +let string_of_expression x = + ignore (flush_str_formatter ()); + let f = str_formatter in + expression f x; + flush_str_formatter () + +let string_of_structure x = + ignore (flush_str_formatter ()); + let f = str_formatter in + structure reset_ctxt f x; + flush_str_formatter () + +let top_phrase f x = + pp_print_newline f (); + toplevel_phrase f x; + pp f ";;"; + pp_print_newline f () + +let core_type = core_type reset_ctxt + +let pattern = pattern reset_ctxt + +let signature = signature reset_ctxt + +let structure = structure reset_ctxt + +let class_expr = class_expr reset_ctxt + +let class_field = class_field reset_ctxt + +let class_type = class_type reset_ctxt + +let class_signature = class_signature reset_ctxt + +let class_type_field = class_type_field reset_ctxt + +let module_expr = module_expr reset_ctxt + +let module_type = module_type reset_ctxt + +let signature_item = signature_item reset_ctxt + +let structure_item = structure_item reset_ctxt + +let type_declaration = type_declaration reset_ctxt diff -Nru ppxlib-0.15.0/astlib/pprintast.mli ppxlib-0.24.0/astlib/pprintast.mli --- ppxlib-0.15.0/astlib/pprintast.mli 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/pprintast.mli 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,57 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Hongbo Zhang (University of Pennsylvania) *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Ast_412 + +type space_formatter = (unit, Format.formatter, unit) format + +val toplevel_phrase : Format.formatter -> Parsetree.toplevel_phrase -> unit + +val expression : Format.formatter -> Parsetree.expression -> unit + +val string_of_expression : Parsetree.expression -> string + +val top_phrase : Format.formatter -> Parsetree.toplevel_phrase -> unit + +val core_type : Format.formatter -> Parsetree.core_type -> unit + +val pattern : Format.formatter -> Parsetree.pattern -> unit + +val signature : Format.formatter -> Parsetree.signature -> unit + +val structure : Format.formatter -> Parsetree.structure -> unit + +val string_of_structure : Parsetree.structure -> string + +(* Added in the ppxlib copy *) +val class_expr : Format.formatter -> Parsetree.class_expr -> unit + +val class_field : Format.formatter -> Parsetree.class_field -> unit + +val class_type : Format.formatter -> Parsetree.class_type -> unit + +val class_signature : Format.formatter -> Parsetree.class_signature -> unit + +val class_type_field : Format.formatter -> Parsetree.class_type_field -> unit + +val module_expr : Format.formatter -> Parsetree.module_expr -> unit + +val module_type : Format.formatter -> Parsetree.module_type -> unit + +val signature_item : Format.formatter -> Parsetree.signature_item -> unit + +val structure_item : Format.formatter -> Parsetree.structure_item -> unit + +val type_declaration : Format.formatter -> Parsetree.type_declaration -> unit diff -Nru ppxlib-0.15.0/astlib/stdlib0.ml ppxlib-0.24.0/astlib/stdlib0.ml --- ppxlib-0.15.0/astlib/stdlib0.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/astlib/stdlib0.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,7 @@ +module Int = struct + let to_string = string_of_int +end + +module Option = struct + let map f o = match o with None -> None | Some v -> Some (f v) +end diff -Nru ppxlib-0.15.0/CHANGES.md ppxlib-0.24.0/CHANGES.md --- ppxlib-0.15.0/CHANGES.md 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/CHANGES.md 2021-12-08 21:53:37.000000000 +0000 @@ -1,3 +1,150 @@ +0.24.0 (08/12/2021) +------------------- + +- Add support for OCaml 4.14 (#304, @kit-ty-kate) + +- Expand nodes before applying derivers or other inline attributes based + transformation, allowing better interactions between extensions and + derivers (#279, #297, @NathanReb) + +- Add support for registering ppx_import as a pseudo context-free rule (#271, @NathanReb) + +- Add `input_name` to the `Expansion_context.Extension` and `Expansion_context.Deriver` modules (#284, @tatchi) + +- Improve `gen_symbol` to strip previous unique suffix before adding a new one (#285, @ceastlund) + +- Improve `name_type_params_in_td` to use prefixes `a`, `b`, ... instead of `v_x`. (#285, @ceastlund) + +- Fix a bug in `type_is_recursive` and `really_recursive` where they would + consider a type declaration recursive if the type appeared inside an attribute + payload (#299, @NathanReb) + +0.23.0 (31/08/2021) +------------------- + +- Drop `Parser` from the API (#263, @pitag-ha) + +- `Location`: add `set_filename` and `Error.get_location` (#247, @pitag-ha) + +- Drop dependency on OMP2 (#187, @pitag-ha) + +- Make OMP1 a conflict (#255, @kit-ty-kate) + +- Drop `Syntaxerr` from the public API. Doesn't affect any user in the + [ppx universe](https://github.com/ocaml-ppx/ppx_universe) (#244, @pitag-ha) + +- Add a lower-bound constraint for Sexplib0 (#240, @pitag-ha) + +- Fix bug due to which unwanted public binaries got installed when installing + ppxlib (#223, @pitag-ha) + +- Add `Keyword.is_keyword` to check if a string is an OCaml keyword + (#227, @pitag-ha) + +- Remove `Lexer.keyword_table`: use `Keyword.is_keyword` instead + (#227, @pitag-ha) + +- Remove `Lexer` from the API: it was the same as the compiler-libs + `Lexer` (#228, @pitag-ha) + +- Remove the modules `Ast_magic`, `Compiler_version`, `Js`, `Find_version`, + `Convert`, `Extra_warnings`, `Location_error`, `Select_ast` and + `Import_for_core` from the API: they are meant for internal use and + aren't used by any current downstream user in the + [ppx universe](https://github.com/ocaml-ppx/ppx_universe) (#230, @pitag-ha) + +- Remove compiler specific helper functions from `Location`. They aren't used + by any current downstream user in the + [ppx universe](https://github.com/ocaml-ppx/ppx_universe) (#238, @pitag-ha) + +- Allow "%a" when using Location.Error.createf (#239, @mlasson) + +- Fix in `Location`: make `raise_errorf` exception equivalent to exception + `Error` (#242, @pitag-ha) + +- Fix in `Pprintast`: correctly pretty print local type substitutions, e.g. + type t := ... (#261, @matthewelse) + +- Add `Ast_pattern.esequence`, for matching on any number of sequenced + expressions e.g. `do_a (); do_b (); ...`. (#264, @matthewelse) + +- Expose a part of `Ast_io` in order to allow reading AST values from binary + files (#270, @arozovyk) + +0.22.2 (23/06/2021) +------------------- + +- Make ppxlib compatible with 4.13 compiler (#260, @kit-ty-kate) + +0.22.1 (10/06/2021) +------------------- + +- Fix location in parse error reporting (#257, @pitag-ha) + +0.21.1 (09/06/2021) +------------------- + +- Fix location in parse error reporting (#256, @pitag-ha) + +0.22.0 (04/02/2021) +------------------- + +- Bump ppxlib's AST to 4.12 (#193, @NathanReb) + +0.21.0 (22/01/2021) +------------------- + +- Fix ppxlib.traverse declaration and make it a deriver and not a rewriter + (#213, @NathanReb) +- Driver (important for bucklescript): handling binary AST's, accept any + supported version as input; preserve that version (#205, @pitag-ha) + +- `-as-ppx`: take into account the `-loc-filename` argument (#197, @pitag-ha) + +- Add input name to expansion context (#202, @pitag-ha) + +- Add Driver.V2: give access to expansion context in whole file transformation + callbacks of `register_transformation` (#202, @pitag-ha) + +- Driver: take `-cookie` argument into account, also when the input is a + binary AST (@pitag-ha, #209) + +- `run_as_ppx_rewriter`: take into account the arguments + `-loc-filename`, `apply` and `dont-apply` (#205, @pitag-ha) + +- Location.Error: add functions `raise` and `update_loc` + (#205, @pitag-ha) + +0.20.0 (16/11/2020) +------------------- + +- Expose `Ppxlib.Driver.map_signature` (#194, @kit-ty-kate) + +0.19.0 (23/10/2020) +------------------- + +- Make ppxlib compatible with 4.12 compiler (#191, @kit-ty-kate) + +0.18.0 (06/10/2020) +------------------- + +- Bump ppxlib's AST to 4.11 (#180, @NathanReb) + +0.17.0 (17/09/2020) +------------------- + +- Add accessors for `code_path` and `tool_name` to `Expansion_context.Base` + (#173, @jberdine) +- Add `cases` methods to traversal classes in `Ast_traverse` (#183, @pitag-ha) + +0.16.0 (18/08/2020) +------------------- + +- `Driver.register_transformation`: add optional parameter `~instrument` + (#161, @pitag-ha) +- Add missing `Location.init` (#165, @pitag-ha) +- Upgrade to ocaml-migrate-parsetree.2.0.0 (#164, @ceastlund) + 0.15.0 (04/08/2020) ------------------- @@ -104,14 +251,14 @@ - Do not relocate files unless `-loc-filename` is passed (#55, @hhugo) -- Perserve the filename in the output (#56, @hhugo) +- Preserve the filename in the output (#56, @hhugo) 0.3.1 ----- - Add `Attribute.declare_with_name_loc` (#33, @diml) -- Let the tool name pass throught when used as a -ppx (#41, @diml) +- Let the tool name pass thought when used as a -ppx (#41, @diml) - Update the AST to 4.06 (#8, @xclerc) diff -Nru ppxlib-0.15.0/debian/changelog ppxlib-0.24.0/debian/changelog --- ppxlib-0.15.0/debian/changelog 2021-12-09 02:32:31.000000000 +0000 +++ ppxlib-0.24.0/debian/changelog 2022-01-28 15:09:35.000000000 +0000 @@ -1,14 +1,22 @@ -ppxlib (0.15.0-1build2) jammy; urgency=medium +ppxlib (0.24.0-1build2) jammy; urgency=medium - * No-change rebuild for current ocaml ABIs + * No-change rebuild for ocaml abi changes. - -- Steve Langasek Thu, 09 Dec 2021 02:32:31 +0000 + -- Matthias Klose Fri, 28 Jan 2022 16:09:35 +0100 -ppxlib (0.15.0-1build1) hirsute; urgency=medium +ppxlib (0.24.0-1build1) jammy; urgency=medium * No-change rebuild for ocaml abi changes. - -- Matthias Klose Sun, 13 Dec 2020 10:28:55 +0100 + -- Matthias Klose Tue, 25 Jan 2022 10:56:55 +0100 + +ppxlib (0.24.0-1) unstable; urgency=medium + + * New upstream release + * Bump Standards-Version to 4.6.0 + * Bump debian/watch version to 4 + + -- Stéphane Glondu Thu, 20 Jan 2022 16:21:22 +0100 ppxlib (0.15.0-1) unstable; urgency=medium diff -Nru ppxlib-0.15.0/debian/control ppxlib-0.24.0/debian/control --- ppxlib-0.15.0/debian/control 2021-12-09 02:32:31.000000000 +0000 +++ ppxlib-0.24.0/debian/control 2022-01-20 15:21:22.000000000 +0000 @@ -1,19 +1,17 @@ Source: ppxlib Priority: optional -Maintainer: Ubuntu Developers -XSBC-Original-Maintainer: Debian OCaml Maintainers +Maintainer: Debian OCaml Maintainers Uploaders: Stéphane Glondu Build-Depends: debhelper-compat (= 13), - ocaml-nox, + ocaml, ocaml-dune, libocaml-compiler-libs-ocaml-dev, - libmigrate-parsetree-ocaml-dev (>= 1.5.0), libppx-derivers-ocaml-dev, libsexplib0-ocaml-dev, dh-ocaml -Standards-Version: 4.5.0 +Standards-Version: 4.6.0 Rules-Requires-Root: no Section: ocaml Homepage: https://github.com/ocaml-ppx/ppxlib diff -Nru ppxlib-0.15.0/debian/watch ppxlib-0.24.0/debian/watch --- ppxlib-0.15.0/debian/watch 2020-11-08 03:19:05.000000000 +0000 +++ ppxlib-0.24.0/debian/watch 2022-01-20 15:21:22.000000000 +0000 @@ -1,2 +1,2 @@ -version=3 +version=4 https://github.com/ocaml-ppx/ppxlib/releases .*-([0-9.]+)\.tbz diff -Nru ppxlib-0.15.0/dev/README.md ppxlib-0.24.0/dev/README.md --- ppxlib-0.15.0/dev/README.md 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/dev/README.md 2021-12-08 21:53:37.000000000 +0000 @@ -24,19 +24,16 @@ ### Installing their dependencies -You can either install them through opam by running `./dev/rev-deps.sh install-deps opam` or -get the sources locally in the dune-workspace (prefered) by running: -`./dev/rev-deps.sh install-deps duniverse`. - -The opam installation step is very naive and probably won't stand the test of time but might be -better when the rev deps have too strict constraints. The duniverse approach is prefered as it will -work even if some of the rev-deps depend on each other but it requires the rev deps to all be -coninstallable or the duniverse solver will fail. - -To get the duniverse tool, simply clone the duniverse repo at -[https://github.com/ocamllabs/duniverse](https://github.com/ocamllabs/duniverse), build it -and add it to your path. When initially writing this, I used duniverse's master, ie at the time -`47faea8522e8e44ba0dbd04403425970aa5c2662`. +To install the dependencies using opam-monorepo, you can run +`./dev/rev-deps.sh install-deps` + +That gets the sources locally by pulling them into `duniverse/` in your dune-workspace. + +To get the opam monorepo plugin, required to assemble the duniverse with all the dependencies, +simply install it through opam: +``` +opam install opam-monorepo +``` ### Building them @@ -46,3 +43,32 @@ No black magic here, it's just running `dune build -p ppxlib,...` where `...` is the list of rev-deps packages. The `-p` is also helpful to avoid annoying warnings getting in the way. + +### Notes + +This is all very experimental and sometimes a bit of extra work is required. This section contains +note that can hopefully help you with this process. + +A good thing to do is to deal with janestreet packages first because if some non-janestreet rev-deps +depend on a janestreet package you can then simply pin to your patch before running the +`install-deps` step. + +When last assembling the non janestreet rev-deps duniverse I had to remove the following packages: +- `elpi` as it depends on `camlp5` +- `gen_js_api` which depends on `omp.1.x` directly +- `obus` as it depends on `lwt_ppx` which uses `omp.1.x` +- `ppx_import` as it depends on `omp.1.x` directly +- `ppx_show` depends on stdcompat which doesn't build with dune +- `ppx_string_interpolation` depends on `sedlex.ppx` which uses OMP and `ppx_tools_versioned` + +When last assembling the janestreet rev-deps duniverse I had to remove the following packages: +- `memtrace_viewer` as the repo is weirdly maintained, there's no tag for the released versions and + the master branch's opam file depends on packages not available in opam at the time: + `async_rpc_websocket` and `ocaml-embed-file` +- `ppx_python` as it depends on `pyml` which doesn't build with dune + +`opam-monorepo` will pull in `dune-configurator` and if you're using a recent version of dune this +will conflict with the one you have locally so you should probably run: +``` +rm -rf duniverse/dune-configurator* +``` diff -Nru ppxlib-0.15.0/dev/rev-deps.sh ppxlib-0.24.0/dev/rev-deps.sh --- ppxlib-0.15.0/dev/rev-deps.sh 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/dev/rev-deps.sh 2021-12-08 21:53:37.000000000 +0000 @@ -1,7 +1,6 @@ #!/bin/bash set -euo pipefail - pull () { case $1 in janestreet|js) @@ -13,7 +12,7 @@ esac # Get a first list of revdeps candidate - REVDEPS=$(opam list -s --depends-on ppxlib.0.13.0 --coinstallable-with ocaml.4.10.0) + REVDEPS=$(opam list -s --depends-on ppxlib.0.21.0 --coinstallable-with ocaml.4.12.0~beta2) TRUE_REVDEPS="" for d in $REVDEPS @@ -60,7 +59,7 @@ janestreet|js) # To checkout to the latest released version cd $basename - git checkout $ver || git checkout v$ver + git checkout $ver || git checkout v$ver || true cd .. ;; *) @@ -71,47 +70,14 @@ cd .. } -install_deps_opam () { - cd dunireverse - for dir in */ - do - basename=${dir%/} - echo "Installing $basename dependencies" - opam install --deps-only $basename/$basename.opam -y || opam install --deps-only $basename/opam -y - done -} - -install_deps_duniverse () { - # Generate a dummy opam file - echo 'opam-version: "2.0"' > dunireverse.opam - echo "depends: [" >> dunireverse.opam - echo " \"ocaml\" {=\"4.10.0\"}" >> dunireverse.opam - cat dunireverse/.deps | while read line - do - basename=${line%%.*} - ver=${line#*.} - echo " \"$basename\" {=\"$ver\"}" >> dunireverse.opam - done - echo "]" >> dunireverse.opam - duniverse init - duniverse opam-install || true - duniverse pull --no-cache - - cat dunireverse/.deps | while read line - do - rm -r duniverse/$line - done -} - install_deps () { - case $1 in - duniverse) - install_deps_duniverse - ;; - opam|*) - install_deps_opam - ;; - esac + PACKAGES="ppxlib" + while read line + do + PACKAGES="$PACKAGES $line" + done < dunireverse/.deps + opam monorepo lock --build-only $PACKAGES + opam monorepo pull } build () { diff -Nru ppxlib-0.15.0/doc/ppx-for-plugin-authors.rst ppxlib-0.24.0/doc/ppx-for-plugin-authors.rst --- ppxlib-0.15.0/doc/ppx-for-plugin-authors.rst 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/doc/ppx-for-plugin-authors.rst 2021-12-08 21:53:37.000000000 +0000 @@ -4,6 +4,214 @@ This section describes how to use ``ppxlib`` for PPX plugin authors. +Getting started +--------------- + +There are two main kinds of PPX plugins you can write with ``ppxlib``: + +- Extension rewriters i.e. ppx plugins that rewrite extension points such as ``[%my_ext ...]`` + into valid OCaml code. +- Derivers i.e. ppx plugins that generate code from type, module or exception declarations + annotated with ``[@@deriving my_deriver]``. + +It is also possible to write more advanced transformations such as rewriting constants that bear the +right suffix, rewriting function calls based on the function identifier or to generate code from +items annotated with a custom attribute but we won't cover those in this section. + +``ppxlib`` compiles those transformations into rules which allows it to apply them to the right AST +nodes, even recursively in nodes generated by other transformations, in a single AST traversal. + +Note that you can also write arbitrary, whole AST transformations with ppxlib but they don't have a +clear composition semantic since they have to be applied sequentially as opposed to the +other, better defined rewriting rule. You should always prefer the above mentioned transformations +instead when possible. + +The OCaml AST +^^^^^^^^^^^^^ + +As described in :ref:`ppx-overview`, PPX rewriters don't operate at the text level but instead used +the compiler's internal representation of the source code: the Abstract Syntax Tree or AST. + +A lot of the following sections of the manual assume a certain level of familiarity with the OCaml +AST so we'll try to cover the basics here and to give you some pointers to deepen your knowledge on +the subject. + +The types describing the AST are defined in the ``Parsetree`` module of OCaml's compiler-libs. Note +that they vary from one version of the compiler to another so make sure you look at an up to date +version and most importantly to the one corresponding to what ppxlib's using internally. +You can find the module's API documentation online +`here `_. If you're new +to these parts of OCaml it's not always easy to navigate as it just contains the raw type +declarations but no actual documentation. +This documentation is actually written in ``parsetree.mli`` but not in a way that allows it to make +its way to the online doc unfortunately. Until this is fixed in the compiler you can look at the +local copy in one of your opam switches: +``/lib/ocaml/compiler-libs/parsetree.mli``. Here you'll find detailed +explanations as to which part of the concrete syntax the various types correspond to. + +``Parsetree`` is quite a large module and there are plenty of types there, a lot of which you don't +necessarily have to know when writing a rewriter. The two main entry points are the ``structure`` +and ``signature`` types which, amongst other things, describe respectively the content of ``.ml`` +and ``.mli`` files. +Other types you should be familiar with are: + +* ``expression`` which describes anything in OCaml that evaluates to a value, the right hand side + of a let binding or the branches of an if-then-else for instance. +* ``pattern`` which is what you use to deconstruct an OCaml value, the left hand side of a let + binding or a pattern-matching case for example. +* ``core_type`` which describes type expressions ie what you use to explicitly constrain the type + of an expression or describe the type of a value in your ``.mli`` files. Usually it's what comes + after a ``:``. +* ``structure_item`` and ``signature_item`` which describe the top level AST nodes you can find in a + structure or signature such as type definitions, value declarations or module declarations. + +Knowing what these types correspond to puts you in a good position to write a PPX plugin as they are +the parts of the AST you will deal with the most in general. + +Writing an extension rewriter +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +To write your ppx plugin you'll need to add the following stanza in your dune file: + +.. code:: scheme + + (library + (public_name my_ppx_rewriter) + (kind ppx_rewriter) + (libraries ppxlib)) + +You'll note that you have to let dune know this is not a regular library but a ppx_rewriter using +the ``kind`` field. +The public name you chose here is the name your users will refer to your ppx in there ``preprocess`` +field. E.g. here to use this ppx rewriter one would add the ``(preprocess (pps my_ppx_rewriter))`` +to their ``library`` or ``executable`` stanza. + +You will also need the following ``my_ppx_rewriter.ml``: + +.. code:: ocaml + + open Ppxlib + + let expand ~ctxt payload = + ... + + let my_extension = + Extension.V3.declare + "my_ext" + + + expand + + let rule = Ppxlib.Context_free.Rule.extension my_extension + + let () = + Driver.register_transformation + ~rules:[rule] + "my_ext" + +There are a few things to explain here. The last part, i.e. the call to +``Driver.register_transformation`` is common to almost all ppxlib-based PPX plugins and is how +you let ``ppxlib`` know about your transformation. You'll note that here we register a single rule +but it is possible to register several rules for a single logical transformation. + +The above is specific to extension rewriters. You need to declare a ppxlib ``Extension``. +The first argument is the extension name, that's what will appear after the ``%`` in the extension +point when using your rewriter, e.g. here this will transform ``[%my_ext ...]`` nodes. +The ```` argument describes where in OCaml code your this extension can be used. +You can find the full list in the API documentation for ``Extension.Context`` +`here `_. +The ```` argument helps you restrict what users can put into the payload of your +extension, i.e. ``[%my_ext ]``. We cover ``Ast_pattern`` in depths here but the +simplest form it can take is ``Ast_pattern.__`` which allows any payload allowed by the language +and passes it to the expand function which is the last argument here. +The expand function is where the logic for your transformation is implemented. It receives an +``Expansion_context.Extension.t`` argument labelled ``ctxt`` and other arguments whose type and +number depends on the ```` argument. The return type of the function is determined +by the ```` argument, e.g. in the following example: + +.. code:: ocaml + + Extension.V3.declare "my_ext" Extension.Context.expression Ast_pattern.__ expand + +The type of the ``expand`` function is: + +.. code:: ocaml + + val expand : ctxt: Expansion_context.Extension.t -> payload -> expression + + +If you want to look at a concrete example of extension rewriter you can find one in the +``examples/`` folder of the ``ppxlib`` repository +`here `_. + +Writing a deriver +^^^^^^^^^^^^^^^^^ + +Similarly to extension rewriters, derivers must be declared as such to dune. To do so you can use +the following stanza in your dune file: + +.. code:: scheme + + (library + (public_name my_ppx_deriver) + (kind ppx_deriver) + (libraries ppxlib)) + +Same as above, the public name used here determines how users will refer to your ppx deriver in +their dune stanzas. + +You will also need the following ``my_ppx_deriver.ml``: + +.. code:: ocaml + + open Ppxlib + + let generate_impl ~ctxt (rec_flag, type_declarations) = + ... + + let generate_intf ~ctxt (rec_flag, type_declarations) = + ... + + let impl_generator = Deriving.Generator.V2.make_noarg generate_impl + + let intf_generator = Deriving.Generator.V2.make_noarg generate_intf + + let my_deriver = + Deriving.add + "my_deriver" + ~str_type_decl:impl_generator + ~sig_type_decl:intf_generator + + +The call to ``Deriving.add`` is how you'll let ``ppxlib`` know about your deriver. The first string +argument is the name of the deriver as referred to by your users, in the above example one would add +a ``[@@deriving my_deriver]`` annotation to use this plugin. +Here our deriver can be used on type declarations, be it in structures or signatures (i.e. +implementation or interfaces, ``.ml`` or ``.mli``). + +To add a deriver you first have to define a generator. You need one for each node you want to derive +code from. Here we just need one for type declarations in structures and one for type declarations in +signatures. To do that you need the ``Deriving.Generator.V2.make_noarg`` constructor. You'll note +that there exists ``Deriving.Generator.V2.make`` variant if you wish to allow passing arguments to +your deriver but to keep this tutorial simple we won't cover this here. +The only mandatory argument to the constructor is a function which takes a labelled +``Expansion_context.Deriving.t``, an ``'input_ast`` and returns an ``'output_ast`` and that will +give us a ``('output_ast, 'input_ast) Deriving.Generator.t``. Much like the ``expand`` function +described in the section about extension rewriters, this function is where the actual implementation +for your deriver lives. +The ``str_type_decl`` argument of ``Deriving.add`` expects a +``(structure, rec_flag * type_declaration list) Generator.t`` so our ``generate_impl`` function +must take a pair ``(rec_flag, type_declaration list)`` and return a ``structure`` i.e. a +``structure_item list``, for instance a list of function or module declaration. +The same goes for the ``generate_intf`` function except that it must return a ``signature``. +It is often the case that a deriver has a generator for both the structure and signature variants +of a node. That allows users to generate the signature corresponding to the code generated by the +deriver in their ``.ml`` files instead of having to type it and maintain it themselves. + +If you want to look at a concrete example of deriver you can find one in the +``examples/`` folder of the ``ppxlib`` repository +`here `_. + Metaquot -------- @@ -151,4 +359,3 @@ let structure_item = [%stri let [%p some_pat] : [%t some_type] = [%e some_expr]] - diff -Nru ppxlib-0.15.0/doc/what-is-ppx.rst ppxlib-0.24.0/doc/what-is-ppx.rst --- ppxlib-0.15.0/doc/what-is-ppx.rst 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/doc/what-is-ppx.rst 2021-12-08 21:53:37.000000000 +0000 @@ -1,7 +1,10 @@ + ************ What is PPX? ************ +.. _ppx-overview: + Overview -------- diff -Nru ppxlib-0.15.0/dune ppxlib-0.24.0/dune --- ppxlib-0.15.0/dune 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/dune 2021-12-08 21:53:37.000000000 +0000 @@ -2,3 +2,8 @@ (_ (binaries (test/expect/expect_test.exe as expect-test)))) + +(alias + (name runtest) + (deps + (alias_rec lint))) diff -Nru ppxlib-0.15.0/dune-project ppxlib-0.24.0/dune-project --- ppxlib-0.15.0/dune-project 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/dune-project 2021-12-08 21:53:37.000000000 +0000 @@ -1,4 +1,43 @@ -(lang dune 1.11) +(lang dune 2.7) (name ppxlib) -(version 0.15.0) +(version 0.24.0) (using cinaps 1.0) +(allow_approximate_merlin) +(implicit_transitive_deps false) +(cram enable) +(generate_opam_files true) + +(source (github ocaml-ppx/ppxlib)) +(license MIT) +(authors "Jane Street Group, LLC ") +(maintainers "opensource@janestreet.com") +(documentation "https://ocaml-ppx.github.io/ppxlib/") + +(package + (name ppxlib) + (depends + (ocaml (and (>= 4.04.1) (< 4.15))) + (ocaml-compiler-libs (>= v0.11.0)) + (ppx_derivers (>= 1.0)) + (sexplib0 (>= v0.12)) + stdlib-shims + (ocamlfind :with-test) + (re (and :with-test (>= 1.9.0))) + (cinaps (and :with-test (>= v0.12.1))) + (base :with-test) + (stdio :with-test)) + (conflicts + (ocaml-migrate-parsetree (< 2.0.0)) + base-effects) + (synopsis "Standard library for ppx rewriters") + (description "Ppxlib is the standard library for ppx rewriters and other programs +that manipulate the in-memory reprensation of OCaml programs, a.k.a +the \"Parsetree\". + +It also comes bundled with two ppx rewriters that are commonly used to +write tools that manipulate and/or generate Parsetree values; +`ppxlib.metaquot` which allows to construct Parsetree values using the +OCaml syntax directly and `ppxlib.traverse` which provides various +ways of automatically traversing values of a given type, in particular +allowing to inject a complex structured value into generated code. +")) diff -Nru ppxlib-0.15.0/examples/dune ppxlib-0.24.0/examples/dune --- ppxlib-0.15.0/examples/dune 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/examples/dune 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,4 @@ +(alias + (name runtest) + (deps + (alias_rec all))) diff -Nru ppxlib-0.15.0/examples/simple-deriver/dune ppxlib-0.24.0/examples/simple-deriver/dune --- ppxlib-0.15.0/examples/simple-deriver/dune 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/examples/simple-deriver/dune 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,4 @@ +(library + (name ppx_deriving_accessors) + (kind ppx_deriver) + (libraries ppxlib)) diff -Nru ppxlib-0.15.0/examples/simple-deriver/ppx_deriving_accessors.ml ppxlib-0.24.0/examples/simple-deriver/ppx_deriving_accessors.ml --- ppxlib-0.15.0/examples/simple-deriver/ppx_deriving_accessors.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/examples/simple-deriver/ppx_deriving_accessors.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,64 @@ +open Ppxlib +module List = ListLabels +open Ast_builder.Default + +let accessor_impl (ld : label_declaration) = + let loc = ld.pld_loc in + pstr_value ~loc Nonrecursive + [ + { + pvb_pat = ppat_var ~loc ld.pld_name; + pvb_expr = + pexp_fun ~loc Nolabel None + (ppat_var ~loc { loc; txt = "x" }) + (pexp_field ~loc + (pexp_ident ~loc { loc; txt = lident "x" }) + { loc; txt = lident ld.pld_name.txt }); + pvb_attributes = []; + pvb_loc = loc; + }; + ] + +let accessor_intf ~ptype_name (ld : label_declaration) = + let loc = ld.pld_loc in + psig_value ~loc + { + pval_name = ld.pld_name; + pval_type = + ptyp_arrow ~loc Nolabel + (ptyp_constr ~loc { loc; txt = lident ptype_name.txt } []) + ld.pld_type; + pval_attributes = []; + pval_loc = loc; + pval_prim = []; + } + +let generate_impl ~ctxt (_rec_flag, type_declarations) = + let loc = Expansion_context.Deriver.derived_item_loc ctxt in + List.map type_declarations ~f:(fun (td : type_declaration) -> + match td with + | { ptype_kind = Ptype_abstract | Ptype_variant _ | Ptype_open; _ } -> + Location.raise_errorf ~loc + "Cannot derive accessors for non record types" + | { ptype_kind = Ptype_record fields; _ } -> + List.map fields ~f:accessor_impl) + |> List.concat + +let generate_intf ~ctxt (_rec_flag, type_declarations) = + let loc = Expansion_context.Deriver.derived_item_loc ctxt in + List.map type_declarations ~f:(fun (td : type_declaration) -> + match td with + | { ptype_kind = Ptype_abstract | Ptype_variant _ | Ptype_open; _ } -> + Location.raise_errorf ~loc + "Cannot derive accessors for non record types" + | { ptype_kind = Ptype_record fields; ptype_name; _ } -> + List.map fields ~f:(accessor_intf ~ptype_name)) + |> List.concat + +let impl_generator = Deriving.Generator.V2.make_noarg generate_impl + +let intf_generator = Deriving.Generator.V2.make_noarg generate_intf + +let my_deriver = + Deriving.add "accessors" ~str_type_decl:impl_generator + ~sig_type_decl:intf_generator diff -Nru ppxlib-0.15.0/examples/simple-deriver/README.md ppxlib-0.24.0/examples/simple-deriver/README.md --- ppxlib-0.15.0/examples/simple-deriver/README.md 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/examples/simple-deriver/README.md 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,28 @@ +# ppx_deriving_accessors + +This folder contains an example of a very simple ppx deriver that will generate +accessors for record fields from the record type definition. + +E.g. the following: + +```ocaml +type t = + { a : string + ; b : int + } + [@@deriving accessors] +``` + +will generate the following: + +```ocaml +let a x = x.a +let b x = x.b +``` + +It can also be used in `.mli` files to generate the corresponding signatures: + +```ocaml +val a : t -> string +val b : t -> int +``` diff -Nru ppxlib-0.15.0/examples/simple-extension-rewriter/dune ppxlib-0.24.0/examples/simple-extension-rewriter/dune --- ppxlib-0.15.0/examples/simple-extension-rewriter/dune 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/examples/simple-extension-rewriter/dune 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,4 @@ +(library + (name ppx_get_env) + (kind ppx_rewriter) + (libraries ppxlib)) diff -Nru ppxlib-0.15.0/examples/simple-extension-rewriter/ppx_get_env.ml ppxlib-0.24.0/examples/simple-extension-rewriter/ppx_get_env.ml --- ppxlib-0.15.0/examples/simple-extension-rewriter/ppx_get_env.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/examples/simple-extension-rewriter/ppx_get_env.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,18 @@ +open Ppxlib + +let expand ~ctxt env_var = + let loc = Expansion_context.Extension.extension_point_loc ctxt in + match Sys.getenv env_var with + | value -> Ast_builder.Default.estring ~loc value + | exception Not_found -> + Location.raise_errorf ~loc "The environement variable %s is unbound" + env_var + +let my_extension = + Extension.V3.declare "get_env" Extension.Context.expression + Ast_pattern.(single_expr_payload (estring __)) + expand + +let rule = Ppxlib.Context_free.Rule.extension my_extension + +let () = Driver.register_transformation ~rules:[ rule ] "get_env" diff -Nru ppxlib-0.15.0/examples/simple-extension-rewriter/README.md ppxlib-0.24.0/examples/simple-extension-rewriter/README.md --- ppxlib-0.15.0/examples/simple-extension-rewriter/README.md 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/examples/simple-extension-rewriter/README.md 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,24 @@ +# ppx_get_env + +This folder contains an example of a very simple ppx rewriter that will expand +`[%get_env "SOME_ENV_VAR"]` into the value of the env variable `SOME_ENV_VAR` at compile time, +as a string. + +E.g., assuming we set `MY_VAR="foo"`, it will turn: + +```ocaml +let () = print_string [%get_env "foo"] +``` + +into: + +```ocaml +let () = print_string "foo" +``` + +Note that this is just a toy example and we'd actually advise you against this type of ppx +that have side effects or rely heavily on the file system or env variables unless you absolutely +what your doing. + +In particular in this case it won't work well with dune since dune won't know about the dependency +on the env variables specified in the extension's payload. diff -Nru ppxlib-0.15.0/.git-blame-ignore-revs ppxlib-0.24.0/.git-blame-ignore-revs --- ppxlib-0.15.0/.git-blame-ignore-revs 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/.git-blame-ignore-revs 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,2 @@ +# The bulk change commit enabling ocamlformat +427f96e126d306538eb541ac591f71b2c68e5dd4 diff -Nru ppxlib-0.15.0/.github/CODEOWNERS ppxlib-0.24.0/.github/CODEOWNERS --- ppxlib-0.15.0/.github/CODEOWNERS 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/.github/CODEOWNERS 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1 @@ +* @ceastlund @NathanReb @pitag-ha diff -Nru ppxlib-0.15.0/.github/workflows/changelog.yml ppxlib-0.24.0/.github/workflows/changelog.yml --- ppxlib-0.15.0/.github/workflows/changelog.yml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/.github/workflows/changelog.yml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,13 @@ +name: Changelog check + +on: + pull_request: + branches: [ main ] + types: [ opened, synchronize, reopened, labeled, unlabeled ] + +jobs: + Changelog-Entry-Check: + name: Check Changelog Action + runs-on: ubuntu-20.04 + steps: + - uses: tarides/changelog-check-action@v1 diff -Nru ppxlib-0.15.0/.github/workflows/pr-number.yml ppxlib-0.24.0/.github/workflows/pr-number.yml --- ppxlib-0.15.0/.github/workflows/pr-number.yml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/.github/workflows/pr-number.yml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,10 @@ +name: PR number update + +on: [pull_request_target] + +jobs: + PR-Number-Update: + name: Update PR number + runs-on: ubuntu-20.04 + steps: + - uses: tarides/pr-number-action@v1.1 diff -Nru ppxlib-0.15.0/.gitignore ppxlib-0.24.0/.gitignore --- ppxlib-0.15.0/.gitignore 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/.gitignore 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,4 @@ +_build +*.install +*.merlin +_opam diff -Nru ppxlib-0.15.0/HISTORY.md ppxlib-0.24.0/HISTORY.md --- ppxlib-0.15.0/HISTORY.md 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/HISTORY.md 2021-12-08 21:53:37.000000000 +0000 @@ -174,7 +174,7 @@ : ppx(./pp_foo.native --as-ppx) : depends_on_foo -and specifing dependencies in your `myocamlbuild.ml` file using +and specifying dependencies in your `myocamlbuild.ml` file using dep ["compile";"depends_on_foo"] ["ppx_foo.cmxa"; "pp_foo.native"] @@ -421,7 +421,7 @@ [%expr x + 1] ``` -is a value of type `Ppxlib_ast.Ast.expression`, represention the OCaml +is a value of type `Ppxlib_ast.Ast.expression`, representing the OCaml expression `x + 1`. `Ppxlib_metaquot` is similar to [ppx_tools.metaquot](https://github.com/ocaml-ppx/ppx_tools), @@ -518,3 +518,34 @@ end in lift#t t ``` + +Context-free rules +------------------ + +Ppxlib expresses most transformations as context-free rules. Each of these rules +describe how specific AST nodes (extensions points, nodes with particular +attributes attached, numeric literals with specific suffixes, etc...) must be +transformed. + +All those transformation rules are applied in a single AST traversal. They are +also recursively applied to code generated by such rules until they don't apply +anymore. + +It happens that different rules might apply to the same nodes and an order must +be picked. In an effort to document how ppxlib deals with such nodes, I wrote +characterization tests, that you can find +[here](test/extensions_and_deriving/test.ml). Some of those test behaviour that +we believe we should preserve, some act more as documentation of what the +current behaviour is. + +The most debatable behaviour is how it handles attributes based rules. ppxlib +allows one to generate new code based on a node with specific attributes +attached. The most common such rule is the `[@@deriving ...]` one which +generates new structure or signature items based on the value of an item +with that attribute attached. This rule is applied before the item has been +transformed meaning the input of the expander function might contain "wrong" +information. +*Note that this behaviour was changed in +[#279](https://github.com/ocaml-ppx/ppxlib/pull/279) and that nodes are now +expanded before derivers and other attributes-based inline code generation rules +are applied* diff -Nru ppxlib-0.15.0/Makefile ppxlib-0.24.0/Makefile --- ppxlib-0.15.0/Makefile 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/Makefile 2021-12-08 21:53:37.000000000 +0000 @@ -34,5 +34,5 @@ dune-release opam pkg dune-release opam submit -.PHONY: default install uninstall reinstall clean test +.PHONY: default install uninstall reinstall clean test doc .PHONY: all-supported-ocaml-versions opam-release diff -Nru ppxlib-0.15.0/metaquot/dune ppxlib-0.24.0/metaquot/dune --- ppxlib-0.15.0/metaquot/dune 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/metaquot/dune 2021-12-08 21:53:37.000000000 +0000 @@ -1,9 +1,7 @@ (library - (name ppxlib_metaquot) + (name ppxlib_metaquot) (public_name ppxlib.metaquot) (kind ppx_rewriter) - (flags (:standard -safe-string)) - (libraries - ppxlib - ppxlib_traverse_builtins - ppxlib_metaquot_lifters)) + (flags + (:standard -safe-string)) + (libraries ppxlib ppxlib_traverse_builtins ppxlib_metaquot_lifters)) diff -Nru ppxlib-0.15.0/metaquot/ppxlib_metaquot.ml ppxlib-0.24.0/metaquot/ppxlib_metaquot.ml --- ppxlib-0.15.0/metaquot/ppxlib_metaquot.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/metaquot/ppxlib_metaquot.ml 2021-12-08 21:53:37.000000000 +0000 @@ -1,132 +1,154 @@ open Ppxlib open Ast_builder.Default - module E = Extension module A = Ast_pattern -module Make(M : sig - type result - val cast : extension -> result - val location : location -> result - val location_stack : (location -> result) option - val attributes : (location -> result) option - class std_lifters : location -> [result] Ppxlib_traverse_builtins.std_lifters - end) = struct - let lift loc = object - inherit [M.result] Ast_traverse.lift as super - inherit! M.std_lifters loc - - method! attribute x = - Attribute.mark_as_handled_manually x; - super#attribute x - - method! location _ = M.location loc - method! attributes x = - match M.attributes with - | None -> super#attributes x - | Some f -> assert_no_attributes x; f loc - - method! location_stack x = - match M.location_stack with - | None -> super#location_stack x - | Some f -> f loc - - method! expression e = - match e.pexp_desc with - | Pexp_extension ({ txt = "e"; _}, _ as ext)-> M.cast ext - | _ -> super#expression e - - method! pattern p = - match p.ppat_desc with - | Ppat_extension ({ txt = "p"; _}, _ as ext)-> M.cast ext - | _ -> super#pattern p - - method! core_type t = - match t.ptyp_desc with - | Ptyp_extension ({ txt = "t"; _}, _ as ext)-> M.cast ext - | _ -> super#core_type t - - method! module_expr m = - match m.pmod_desc with - | Pmod_extension ({ txt = "m"; _}, _ as ext)-> M.cast ext - | _ -> super#module_expr m - - method! module_type m = - match m.pmty_desc with - | Pmty_extension ({ txt = "m"; _ }, _ as ext)-> M.cast ext - | _ -> super#module_type m - - method! structure_item i = - match i.pstr_desc with - | Pstr_extension (({ txt = "i"; _}, _ as ext), attrs) -> - assert_no_attributes attrs; - M.cast ext - | _ -> super#structure_item i +module Make (M : sig + type result - method! signature_item i = - match i.psig_desc with - | Psig_extension (({ txt = "i"; _}, _ as ext), attrs) -> - assert_no_attributes attrs; - M.cast ext - | _ -> super#signature_item i - end + val cast : extension -> result + + val location : location -> result + + val location_stack : (location -> result) option + + val attributes : (location -> result) option + + class std_lifters : location -> [result] Ppxlib_traverse_builtins.std_lifters +end) = +struct + let lift loc = + object + inherit [M.result] Ast_traverse.lift as super + + inherit! M.std_lifters loc + + method! attribute x = + Attribute.mark_as_handled_manually x; + super#attribute x + + method! location _ = M.location loc + + method! attributes x = + match M.attributes with + | None -> super#attributes x + | Some f -> + assert_no_attributes x; + f loc + + method! location_stack x = + match M.location_stack with + | None -> super#location_stack x + | Some f -> f loc + + method! expression e = + match e.pexp_desc with + | Pexp_extension (({ txt = "e"; _ }, _) as ext) -> M.cast ext + | _ -> super#expression e + + method! pattern p = + match p.ppat_desc with + | Ppat_extension (({ txt = "p"; _ }, _) as ext) -> M.cast ext + | _ -> super#pattern p + + method! core_type t = + match t.ptyp_desc with + | Ptyp_extension (({ txt = "t"; _ }, _) as ext) -> M.cast ext + | _ -> super#core_type t + + method! module_expr m = + match m.pmod_desc with + | Pmod_extension (({ txt = "m"; _ }, _) as ext) -> M.cast ext + | _ -> super#module_expr m + + method! module_type m = + match m.pmty_desc with + | Pmty_extension (({ txt = "m"; _ }, _) as ext) -> M.cast ext + | _ -> super#module_type m + + method! structure_item i = + match i.pstr_desc with + | Pstr_extension ((({ txt = "i"; _ }, _) as ext), attrs) -> + assert_no_attributes attrs; + M.cast ext + | _ -> super#structure_item i + + method! signature_item i = + match i.psig_desc with + | Psig_extension ((({ txt = "i"; _ }, _) as ext), attrs) -> + assert_no_attributes attrs; + M.cast ext + | _ -> super#signature_item i + end end -module Expr = Make(struct - type result = expression - let location loc = evar ~loc:{ loc with loc_ghost = true } "loc" - let location_stack = None - let attributes = None - class std_lifters = Ppxlib_metaquot_lifters.expression_lifters - let cast ext = - match snd ext with - | PStr [{ pstr_desc = Pstr_eval (e, attrs); _}] -> +module Expr = Make (struct + type result = expression + + let location loc = evar ~loc:{ loc with loc_ghost = true } "loc" + + let location_stack = None + + let attributes = None + + class std_lifters = Ppxlib_metaquot_lifters.expression_lifters + + let cast ext = + match snd ext with + | PStr [ { pstr_desc = Pstr_eval (e, attrs); _ } ] -> assert_no_attributes attrs; e - | _ -> - Location.raise_errorf ~loc:(loc_of_extension ext) - "expression expected" - end) - -module Patt = Make(struct - type result = pattern - let location loc = ppat_any ~loc:{ loc with loc_ghost = true } - let location_stack = Some (fun loc -> ppat_any ~loc:{ loc with loc_ghost = true }) - let attributes = Some (fun loc -> ppat_any ~loc:{ loc with loc_ghost = true }) - class std_lifters = Ppxlib_metaquot_lifters.pattern_lifters - let cast ext = - match snd ext with - | PPat (p, None) -> p - | PPat (_, Some e) -> - Location.raise_errorf ~loc:e.pexp_loc - "guard not expected here" - | _ -> - Location.raise_errorf ~loc:(loc_of_extension ext) - "pattern expected" - end) + | _ -> + Location.raise_errorf ~loc:(loc_of_extension ext) "expression expected" +end) + +module Patt = Make (struct + type result = pattern + + let location loc = ppat_any ~loc:{ loc with loc_ghost = true } + + let location_stack = + Some (fun loc -> ppat_any ~loc:{ loc with loc_ghost = true }) + + let attributes = Some (fun loc -> ppat_any ~loc:{ loc with loc_ghost = true }) + + class std_lifters = Ppxlib_metaquot_lifters.pattern_lifters + + let cast ext = + match snd ext with + | PPat (p, None) -> p + | PPat (_, Some e) -> + Location.raise_errorf ~loc:e.pexp_loc "guard not expected here" + | _ -> Location.raise_errorf ~loc:(loc_of_extension ext) "pattern expected" +end) let () = let extensions ctx lifter = - [ E.declare "metaquot.expr" ctx A.(single_expr_payload __) - (fun ~loc ~path:_ e -> (lifter loc)#expression e) - ; E.declare "metaquot.pat" ctx A.(ppat __ none) - (fun ~loc ~path:_ p -> (lifter loc)#pattern p) - ; E.declare "metaquot.str" ctx A.(pstr __) - (fun ~loc ~path:_ s -> (lifter loc)#structure s) - ; E.declare "metaquot.stri" ctx A.(pstr (__ ^:: nil)) - (fun ~loc ~path:_ s -> (lifter loc)#structure_item s) - ; E.declare "metaquot.sig" ctx A.(psig __) - (fun ~loc ~path:_ s -> (lifter loc)#signature s) - ; E.declare "metaquot.sigi" ctx A.(psig (__ ^:: nil)) - (fun ~loc ~path:_ s -> (lifter loc)#signature_item s) - ; E.declare "metaquot.type" ctx A.(ptyp __) - (fun ~loc ~path:_ t -> (lifter loc)#core_type t) + [ + E.declare "metaquot.expr" ctx + A.(single_expr_payload __) + (fun ~loc ~path:_ e -> (lifter loc)#expression e); + E.declare "metaquot.pat" ctx + A.(ppat __ none) + (fun ~loc ~path:_ p -> (lifter loc)#pattern p); + E.declare "metaquot.str" ctx + A.(pstr __) + (fun ~loc ~path:_ s -> (lifter loc)#structure s); + E.declare "metaquot.stri" ctx + A.(pstr (__ ^:: nil)) + (fun ~loc ~path:_ s -> (lifter loc)#structure_item s); + E.declare "metaquot.sig" ctx + A.(psig __) + (fun ~loc ~path:_ s -> (lifter loc)#signature s); + E.declare "metaquot.sigi" ctx + A.(psig (__ ^:: nil)) + (fun ~loc ~path:_ s -> (lifter loc)#signature_item s); + E.declare "metaquot.type" ctx + A.(ptyp __) + (fun ~loc ~path:_ t -> (lifter loc)#core_type t); ] in let extensions = - extensions Expression Expr.lift @ - extensions Pattern Patt.lift + extensions Expression Expr.lift @ extensions Pattern Patt.lift in - Driver.register_transformation - "metaquot" - ~extensions + Driver.register_transformation "metaquot" ~extensions diff -Nru ppxlib-0.15.0/metaquot_lifters/dune ppxlib-0.24.0/metaquot_lifters/dune --- ppxlib-0.15.0/metaquot_lifters/dune 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/metaquot_lifters/dune 2021-12-08 21:53:37.000000000 +0000 @@ -1,5 +1,6 @@ (library - (name ppxlib_metaquot_lifters) + (name ppxlib_metaquot_lifters) (public_name ppxlib.metaquot_lifters) - (flags (:standard -safe-string)) - (libraries ppxlib ppxlib_traverse_builtins)) + (flags + (:standard -safe-string)) + (libraries ppxlib ppxlib_traverse_builtins stdppx stdlib-shims)) diff -Nru ppxlib-0.15.0/metaquot_lifters/ppxlib_metaquot_lifters.ml ppxlib-0.24.0/metaquot_lifters/ppxlib_metaquot_lifters.ml --- ppxlib-0.15.0/metaquot_lifters/ppxlib_metaquot_lifters.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/metaquot_lifters/ppxlib_metaquot_lifters.ml 2021-12-08 21:53:37.000000000 +0000 @@ -6,28 +6,39 @@ let loc = { loc with loc_ghost = true } in object inherit [expression] Ppxlib_traverse_builtins.lift + method record flds = pexp_record ~loc - (List.map flds ~f:(fun (lab, e) -> - ({ loc; txt = Lident lab }, e))) + (List.map flds ~f:(fun (lab, e) -> ({ loc; txt = Lident lab }, e))) None + method constr id args = pexp_construct ~loc { loc; txt = Lident id } - (match args with - | [] -> None - | l -> Some (pexp_tuple ~loc l)) - method tuple l = pexp_tuple ~loc l - method int i = eint ~loc i - method int32 i = eint32 ~loc i - method int64 i = eint64 ~loc i + (match args with [] -> None | l -> Some (pexp_tuple ~loc l)) + + method tuple l = pexp_tuple ~loc l + + method int i = eint ~loc i + + method int32 i = eint32 ~loc i + + method int64 i = eint64 ~loc i + method nativeint i = enativeint ~loc i - method float f = efloat ~loc (Float.to_string f) - method string s = estring ~loc s - method char c = echar ~loc c - method bool b = ebool ~loc b + + method float f = efloat ~loc (Float.to_string f) + + method string s = estring ~loc s + + method char c = echar ~loc c + + method bool b = ebool ~loc b + method array : 'a. ('a -> expression) -> 'a array -> expression = fun f a -> pexp_array ~loc (List.map (Array.to_list a) ~f) + method unit () = eunit ~loc + method other : 'a. 'a -> expression = fun _ -> failwith "not supported" end @@ -35,27 +46,38 @@ let loc = { loc with loc_ghost = true } in object inherit [pattern] Ppxlib_traverse_builtins.lift + method record flds = ppat_record ~loc - (List.map flds ~f:(fun (lab, e) -> - ({ loc; txt = Lident lab }, e))) + (List.map flds ~f:(fun (lab, e) -> ({ loc; txt = Lident lab }, e))) Closed + method constr id args = ppat_construct ~loc { loc; txt = Lident id } - (match args with - | [] -> None - | l -> Some (ppat_tuple ~loc l)) - method tuple l = ppat_tuple ~loc l - method int i = pint ~loc i - method int32 i = pint32 ~loc i - method int64 i = pint64 ~loc i + (match args with [] -> None | l -> Some (ppat_tuple ~loc l)) + + method tuple l = ppat_tuple ~loc l + + method int i = pint ~loc i + + method int32 i = pint32 ~loc i + + method int64 i = pint64 ~loc i + method nativeint i = pnativeint ~loc i - method float f = pfloat ~loc (Float.to_string f) - method string s = pstring ~loc s - method char c = pchar ~loc c - method bool b = pbool ~loc b + + method float f = pfloat ~loc (Float.to_string f) + + method string s = pstring ~loc s + + method char c = pchar ~loc c + + method bool b = pbool ~loc b + method array : 'a. ('a -> pattern) -> 'a array -> pattern = fun f a -> ppat_array ~loc (List.map (Array.to_list a) ~f) + method unit () = punit ~loc + method other : 'a. 'a -> pattern = fun _ -> failwith "not supported" end diff -Nru ppxlib-0.15.0/.ocamlformat ppxlib-0.24.0/.ocamlformat --- ppxlib-0.15.0/.ocamlformat 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/.ocamlformat 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,3 @@ +version=0.19.0 +profile=conventional +parse-docstrings=true diff -Nru ppxlib-0.15.0/.ocamlformat-ignore ppxlib-0.24.0/.ocamlformat-ignore --- ppxlib-0.15.0/.ocamlformat-ignore 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/.ocamlformat-ignore 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,40 @@ +# Files that are preprocessed with pp_rewrite contain invalid syntax +# and therefore must be excluded from the ocamlformat parsing +astlib/location.ml +astlib/longident.ml +astlib/astlib.ml +astlib/ast_402.ml +astlib/ast_403.ml +astlib/ast_404.ml +astlib/ast_405.ml +astlib/ast_406.ml +astlib/ast_407.ml +astlib/ast_408.ml +astlib/ast_409.ml +astlib/ast_410.ml +astlib/ast_411.ml +astlib/ast_412.ml +astlib/ast_413.ml +astlib/ast_414.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 +ast/versions.ml +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/code_path/test.ml +test/deriving/test.ml +test/driver/attributes/test.ml +test/driver/instrument/test.ml +test/driver/non-compressible-suffix/test.ml +test/driver/transformations/test.ml +test/expansion_inside_payloads/test.ml +test/extensions_and_deriving/test.ml +test/location/exception/test.ml +test/ppx_import_support/test.ml +test/quoter/test.ml +test/traverse/test.ml +test/type_is_recursive/test.ml diff -Nru ppxlib-0.15.0/.ocp-indent ppxlib-0.24.0/.ocp-indent --- ppxlib-0.15.0/.ocp-indent 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/.ocp-indent 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1 @@ +JaneStreet diff -Nru ppxlib-0.15.0/ppxlib.opam ppxlib-0.24.0/ppxlib.opam --- ppxlib-0.15.0/ppxlib.opam 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/ppxlib.opam 2021-12-08 21:53:37.000000000 +0000 @@ -1,32 +1,6 @@ -version: "0.15.0" +version: "0.24.0" +# This file is generated by dune, edit dune-project instead opam-version: "2.0" -maintainer: "opensource@janestreet.com" -authors: ["Jane Street Group, LLC "] -homepage: "https://github.com/ocaml-ppx/ppxlib" -bug-reports: "https://github.com/ocaml-ppx/ppxlib/issues" -dev-repo: "git+https://github.com/ocaml-ppx/ppxlib.git" -doc: "https://ocaml-ppx.github.io/ppxlib/" -license: "MIT" -build: [ - ["dune" "subst"] {pinned} - ["dune" "build" "-p" name "-j" jobs] -] -run-test: [ - ["dune" "runtest" "-p" name "-j" jobs] { ocaml:version >= "4.10" } -] -depends: [ - "ocaml" {>= "4.04.1"} - "dune" {>= "1.11"} - "ocaml-compiler-libs" {>= "v0.11.0"} - "ocaml-migrate-parsetree" {>= "1.5.0"} - "ppx_derivers" {>= "1.0"} - "sexplib0" - "stdlib-shims" - "ocamlfind" {with-test} - "cinaps" {with-test & >= "v0.12.1"} - "base" {with-test} - "stdio" {with-test} -] synopsis: "Standard library for ppx rewriters" description: """ Ppxlib is the standard library for ppx rewriters and other programs @@ -39,4 +13,43 @@ OCaml syntax directly and `ppxlib.traverse` which provides various ways of automatically traversing values of a given type, in particular allowing to inject a complex structured value into generated code. -""" \ No newline at end of file +""" +maintainer: ["opensource@janestreet.com"] +authors: ["Jane Street Group, LLC "] +license: "MIT" +homepage: "https://github.com/ocaml-ppx/ppxlib" +doc: "https://ocaml-ppx.github.io/ppxlib/" +bug-reports: "https://github.com/ocaml-ppx/ppxlib/issues" +depends: [ + "dune" {>= "2.7"} + "ocaml" {>= "4.04.1" & < "4.15"} + "ocaml-compiler-libs" {>= "v0.11.0"} + "ppx_derivers" {>= "1.0"} + "sexplib0" {>= "v0.12"} + "stdlib-shims" + "ocamlfind" {with-test} + "re" {with-test & >= "1.9.0"} + "cinaps" {with-test & >= "v0.12.1"} + "base" {with-test} + "stdio" {with-test} + "odoc" {with-doc} +] +conflicts: [ + "ocaml-migrate-parsetree" {< "2.0.0"} + "base-effects" +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/ocaml-ppx/ppxlib.git" \ No newline at end of file diff -Nru ppxlib-0.15.0/print-diff/dune ppxlib-0.24.0/print-diff/dune --- ppxlib-0.15.0/print-diff/dune 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/print-diff/dune 2021-12-08 21:53:37.000000000 +0000 @@ -1,4 +1,5 @@ (library (name ppxlib_print_diff) (public_name ppxlib.print_diff) - (flags (:standard -safe-string))) + (flags + (:standard -safe-string))) diff -Nru ppxlib-0.15.0/print-diff/ppxlib_print_diff.ml ppxlib-0.24.0/print-diff/ppxlib_print_diff.ml --- ppxlib-0.15.0/print-diff/ppxlib_print_diff.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/print-diff/ppxlib_print_diff.ml 2021-12-08 21:53:37.000000000 +0000 @@ -2,20 +2,22 @@ let patdiff_cmd ~use_color ~extra_patdiff_args = let args = - List.concat [ - ["-keep-whitespace"]; - ["-location-style omake"]; - (if use_color then [] else ["-ascii"]); - extra_patdiff_args - ] + List.concat + [ + [ "-keep-whitespace" ]; + [ "-location-style omake" ]; + (if use_color then [] else [ "-ascii" ]); + extra_patdiff_args; + ] in String.concat ~sep:" " ("patdiff" :: args) -;; -let print ?diff_command ?(extra_patdiff_args=[]) ?(use_color=false) ~file1 ~file2 () = +let print ?diff_command ?(extra_patdiff_args = []) ?(use_color = false) ~file1 + ~file2 () = let exec cmd = let cmd = - Printf.sprintf "%s %s %s 1>&2" cmd (Filename.quote file1) (Filename.quote file2) + Printf.sprintf "%s %s %s 1>&2" cmd (Filename.quote file1) + (Filename.quote file2) in match Sys.command cmd with | 0 -> `Same @@ -23,24 +25,25 @@ | n -> `Error (n, cmd) in match diff_command with - | Some s -> ignore (exec s : [> `Same | `Different | `Error of int * string]) - | None -> - begin match exec (patdiff_cmd ~use_color ~extra_patdiff_args) with - | `Same -> - (* patdiff produced no output, fallback to diff -u *) - Printf.eprintf "File \"%s\", line 1, characters 0-0:\n%!" file1; - ignore (exec "diff -u" : [> `Same | `Different | `Error of int * string]) - | `Different -> - (* patdiff successfully found a difference *) - () - | `Error (err_code, cmd) -> - (* patdiff threw an error... perhaps it wasn't installed? fallback to diff -u *) - Printf.eprintf "Error:\n\ - > %S exited with code %d\n\ - > Perhaps patdiff is not installed? Hint, try: opam install patdiff\n\ - > Falling back to diff -u\n\ - \n" cmd err_code; - Printf.eprintf "File \"%s\", line 1, characters 0-0:\n%!" file1; - ignore (exec "diff -u" : [> `Same | `Different | `Error of int * string]) - end -;; + | Some s -> ignore (exec s : [> `Same | `Different | `Error of int * string ]) + | None -> ( + match exec (patdiff_cmd ~use_color ~extra_patdiff_args) with + | `Same -> + (* patdiff produced no output, fallback to diff -u *) + Printf.eprintf "File \"%s\", line 1, characters 0-0:\n%!" file1; + ignore + (exec "diff -u" : [> `Same | `Different | `Error of int * string ]) + | `Different -> + (* patdiff successfully found a difference *) + () + | `Error (err_code, cmd) -> + (* patdiff threw an error... perhaps it wasn't installed? fallback to diff -u *) + Printf.eprintf + "Error:\n\ + > %S exited with code %d\n\ + > Perhaps patdiff is not installed? Hint, try: opam install patdiff\n\ + > Falling back to diff -u\n\n" + cmd err_code; + Printf.eprintf "File \"%s\", line 1, characters 0-0:\n%!" file1; + ignore + (exec "diff -u" : [> `Same | `Different | `Error of int * string ])) diff -Nru ppxlib-0.15.0/print-diff/ppxlib_print_diff.mli ppxlib-0.24.0/print-diff/ppxlib_print_diff.mli --- ppxlib-0.15.0/print-diff/ppxlib_print_diff.mli 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/print-diff/ppxlib_print_diff.mli 2021-12-08 21:53:37.000000000 +0000 @@ -1,11 +1,11 @@ -(** Diff two files. Use [diff_command] to specify what command to use. If not specified - [patdiff] is used, with a fallback to [diff -u] if [patdiff] produces no - differences. *) -val print - : ?diff_command:string - -> ?extra_patdiff_args:string list (** default: [] *) - -> ?use_color:bool (** default: false *) - -> file1:string - -> file2:string - -> unit - -> unit +val print : + ?diff_command:string -> + ?extra_patdiff_args:string list (** default: [] *) -> + ?use_color:bool (** default: false *) -> + file1:string -> + file2:string -> + unit -> + unit +(** Diff two files. Use [diff_command] to specify what command to use. If not + specified [patdiff] is used, with a fallback to [diff -u] if [patdiff] + produces no differences. *) diff -Nru ppxlib-0.15.0/README.md ppxlib-0.24.0/README.md --- ppxlib-0.15.0/README.md 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/README.md 2021-12-08 21:53:37.000000000 +0000 @@ -1,18 +1,19 @@ # Ppxlib - Meta-programming for OCaml -[![Travis status][travis-img]][travis] [![AppVeyor status][appveyor-img]][appveyor] +[![ocaml-ci status][ocaml-ci-img]][ocaml-ci] [![AppVeyor status][appveyor-img]][appveyor] -[travis]: https://travis-ci.org/ocaml-ppx/ppxlib -[travis-img]: https://travis-ci.org/ocaml-ppx/ppxlib.svg?branch=master -[appveyor]: https://ci.appveyor.com/project/diml/ppxlib/branch/master +[ocaml-ci]: https://ci.ocamllabs.io/github/ocaml-ppx/ppxlib +[ocaml-ci-img]: https://img.shields.io/endpoint?url=https%3A%2F%2Fci.ocamllabs.io%2Fbadge%2Focaml-ppx%2Fppxlib%2Fmain&logo=ocaml +[appveyor]: https://ci.appveyor.com/project/diml/ppxlib/branch/main [appveyor-img]: https://ci.appveyor.com/api/projects/status/bogbsm33uvh083jx?svg=true [User manual][man] +[API documentation][api-doc] # Overview Ppxlib is the standard library for ppx rewriters and other programs -that manipulate the in-memory reprensation of OCaml programs, a.k.a +that manipulate the in-memory representation of OCaml programs, a.k.a the "Parsetree". It also comes bundled with two ppx rewriters that are commonly used to @@ -22,7 +23,7 @@ ways of automatically traversing values of a given type, in particular allowing to inject a complex structured value into generated code. -For more information about ppxlib and how to use it, pease consult the +For more information about ppxlib and how to use it, please consult the [user manual][man]. # What is the relation between ppxlib and other ppx libraries? @@ -41,4 +42,5 @@ more details. [man]: http://ppxlib.readthedocs.io/ +[api-doc]: https://ocaml-ppx.github.io/ppxlib/index.html [future-of-ppx]: https://discuss.ocaml.org/t/the-future-of-ppx/3766 diff -Nru ppxlib-0.15.0/runner/dune ppxlib-0.24.0/runner/dune --- ppxlib-0.15.0/runner/dune 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/runner/dune 2021-12-08 21:53:37.000000000 +0000 @@ -2,8 +2,9 @@ ;; be linked after all other libraries and units. (library - (name ppxlib_runner) - (public_name ppxlib.runner) - (flags (:standard -safe-string)) - (libraries ppxlib) + (name ppxlib_runner) + (public_name ppxlib.runner) + (flags + (:standard -safe-string)) + (libraries ppxlib) (library_flags -linkall)) diff -Nru ppxlib-0.15.0/runner_as_ppx/dune ppxlib-0.24.0/runner_as_ppx/dune --- ppxlib-0.15.0/runner_as_ppx/dune 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/runner_as_ppx/dune 2021-12-08 21:53:37.000000000 +0000 @@ -1,8 +1,10 @@ ;; This library just contain the entry point for ppx drivers. It must ;; be linked after all other libraries and units. + (library (name ppxlib_runner_as_ppx) (public_name ppxlib.runner_as_ppx) (library_flags -linkall) - (flags (:standard -safe-string)) + (flags + (:standard -safe-string)) (libraries ppxlib)) diff -Nru ppxlib-0.15.0/src/ast_builder_intf.ml ppxlib-0.24.0/src/ast_builder_intf.ml --- ppxlib-0.15.0/src/ast_builder_intf.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/ast_builder_intf.ml 2021-12-08 21:53:37.000000000 +0000 @@ -7,104 +7,133 @@ module type Additional_helpers = sig type 'a with_loc - val eint : (int -> expression) with_loc - val echar : (char -> expression) with_loc - val estring : (string -> expression) with_loc - val efloat : (string -> expression) with_loc - val eint32 : (int32 -> expression) with_loc - val eint64 : (int64 -> expression) with_loc + val eint : (int -> expression) with_loc + + val echar : (char -> expression) with_loc + + val estring : (string -> expression) with_loc + + val efloat : (string -> expression) with_loc + + val eint32 : (int32 -> expression) with_loc + + val eint64 : (int64 -> expression) with_loc + val enativeint : (nativeint -> expression) with_loc - val ebool : (bool -> expression) with_loc - val pint : (int -> pattern) with_loc - val pchar : (char -> pattern) with_loc - val pstring : (string -> pattern) with_loc - val pfloat : (string -> pattern) with_loc - val pint32 : (int32 -> pattern) with_loc - val pint64 : (int64 -> pattern) with_loc + val ebool : (bool -> expression) with_loc + + val pint : (int -> pattern) with_loc + + val pchar : (char -> pattern) with_loc + + val pstring : (string -> pattern) with_loc + + val pfloat : (string -> pattern) with_loc + + val pint32 : (int32 -> pattern) with_loc + + val pint64 : (int64 -> pattern) with_loc + val pnativeint : (nativeint -> pattern) with_loc - val pbool : (bool -> pattern) with_loc + + val pbool : (bool -> pattern) with_loc val eunit : expression with_loc - val punit : pattern with_loc - (** [evar id] produces a [Pexp_ident _] expression, it parses its input so you can pass - any dot-separated identifier, for instance: [evar ~loc "Foo.bar"]. *) + val punit : pattern with_loc + val evar : (string -> expression) with_loc - val pvar : (string -> pattern ) with_loc + (** [evar id] produces a [Pexp_ident _] expression, it parses its input so you + can pass any dot-separated identifier, for instance: + [evar ~loc "Foo.bar"]. *) + + val pvar : (string -> pattern) with_loc - (** Same as pexp_apply but without labels *) val eapply : (expression -> expression list -> expression) with_loc + (** Same as pexp_apply but without labels *) val eabstract : (pattern list -> expression -> expression) with_loc val esequence : (expression list -> expression) with_loc val ppat_tuple_opt : (pattern list -> pattern option) with_loc + val pexp_tuple_opt : (expression list -> expression option) with_loc - val pconstruct : constructor_declaration -> pattern option -> pattern + val pconstruct : constructor_declaration -> pattern option -> pattern + val econstruct : constructor_declaration -> expression option -> expression val elist : (expression list -> expression) with_loc - val plist : (pattern list -> pattern ) with_loc + + val plist : (pattern list -> pattern) with_loc val pstr_value_list : - loc:Location.t -> Asttypes.rec_flag -> value_binding list -> structure_item list - (** [pstr_value_list ~loc rf vbs] = [pstr_value ~loc rf vbs] if [vbs <> []], [[]] - otherwise. *) + loc:Location.t -> + Asttypes.rec_flag -> + value_binding list -> + structure_item list + (** [pstr_value_list ~loc rf vbs] = [pstr_value ~loc rf vbs] if [vbs <> \[\]], + [\[\]] otherwise. *) val nonrec_type_declaration : - (name:string Loc.t - -> params:(core_type * Asttypes.variance) list - -> cstrs:(core_type * core_type * Location.t) list - -> kind:type_kind - -> private_:Asttypes.private_flag - -> manifest:core_type option - -> type_declaration - ) with_loc - [@@deprecated - "[since 2016-10] use Nonrecursive on the P(str|sig)_type instead"] - - (** [unapplied_type_constr_conv] is the standard way to map identifiers to conversion - fonctions, for preprocessor that creates values that follow the structure of types. - More precisely, [path_conv path (sprintf "sexp_of_%s")] is: - - sexp_of_t if path is "t" - - A.B.sexp_of_foo if path is "A.B.foo" - - A.B.sexp_of_f__foo (module A1) (module A2) if path is "A.B.F(A1)(A2).foo" - [type_constr_conv] also applies it to a list of expression, which both prevents - the compiler from allocating useless closures, and almost always what is needed, - since type constructors are always applied. *) + (name:string Loc.t -> + params:(core_type * Asttypes.variance) list -> + cstrs:(core_type * core_type * Location.t) list -> + kind:type_kind -> + private_:Asttypes.private_flag -> + manifest:core_type option -> + type_declaration) + with_loc + [@@deprecated + "[since 2016-10] use Nonrecursive on the P(str|sig)_type instead"] + val unapplied_type_constr_conv : (Longident.t Loc.t -> f:(string -> string) -> expression) with_loc + (** [unapplied_type_constr_conv] is the standard way to map identifiers to + conversion fonctions, for preprocessor that creates values that follow the + structure of types. More precisely, + [path_conv path (sprintf "sexp_of_%s")] is: + + - sexp_of_t if path is "t" + - A.B.sexp_of_foo if path is "A.B.foo" + - A.B.sexp_of_f__foo (module A1) (module A2) if path is + "A.B.F(A1)(A2).foo" [type_constr_conv] also applies it to a list of + expression, which both prevents the compiler from allocating useless + closures, and almost always what is needed, since type constructors are + always applied. *) + val type_constr_conv : - (Longident.t Loc.t -> f:(string -> string) -> expression list -> expression) with_loc + (Longident.t Loc.t -> f:(string -> string) -> expression list -> expression) + with_loc + + val eta_reduce : expression -> expression option + (** Tries to simplify [fun v1 v2 .. -> f v1 v2 ..] into [f]. Only works when + [f] is a path, not an arbitrary expression as that would change the + meaning of the code. This can be used either for cleaning up the generated + code, or to reduce allocation if [f] is a local variable (the compiler + won't optimize the allocation of the closure). - (** Tries to simplify [fun v1 v2 .. -> f v1 v2 ..] into [f]. Only works when [f] is a - path, not an arbitrary expression as that would change the meaning of - the code. - This can be used either for cleaning up the generated code, or to reduce allocation - if [f] is a local variable (the compiler won't optimize the allocation of the - closure). + Eta-reduction can change the types/behavior in some corner cases that are + unlikely to show up in generated code: - Eta-reduction can change the types/behavior in some corner cases that are unlikely - to show up in generated code: - if [f] has optional arguments, eta-expanding [f] can drop them - - because labels commute, it can change the type of an expression: - $ let f ~x y = x + y - let f2 = fun x -> add x;; - val f : x:int -> int -> int = - val f2 : int -> x:int -> int = - In fact, if [f] does side effects before receiving all its arguments, and if - the eta-expansion is partially applied, eta-reducing could change behavior. - - [eta_reduce_if_possible_and_nonrec] is meant for the case where the resulting - expression is going to be bound in a potentially recursive let-binding, where - we have to keep the eta-expansion when [rec_flag] is [Recursive] to avoid - a compile error. *) - val eta_reduce : expression -> expression option + - because labels commute, it can change the type of an expression: $ let f + ~x y = x + y let f2 = fun x -> add x;; val f : x:int -> int -> int = + val f2 : int -> x:int -> int = In fact, if [f] does side + effects before receiving all its arguments, and if the eta-expansion is + partially applied, eta-reducing could change behavior. + + [eta_reduce_if_possible_and_nonrec] is meant for the case where the + resulting expression is going to be bound in a potentially recursive + let-binding, where we have to keep the eta-expansion when [rec_flag] is + [Recursive] to avoid a compile error. *) + val eta_reduce_if_possible : expression -> expression - val eta_reduce_if_possible_and_nonrec : expression -> rec_flag:rec_flag -> expression + + val eta_reduce_if_possible_and_nonrec : + expression -> rec_flag:rec_flag -> expression end module type Located = sig @@ -116,21 +145,23 @@ val mk : ('a -> 'a t) with_loc - val map : ('a -> 'b) -> 'a t -> 'b t + val map : ('a -> 'b) -> 'a t -> 'b t + val map_lident : string t -> Longident.t t val lident : (string -> Longident.t t) with_loc end type 'a without_location = 'a -type 'a with_location = loc:Location.t -> 'a + +type 'a with_location = loc:Location.t -> 'a module type S = sig - module Located : Located - with type 'a with_loc := 'a without_location + module Located : Located with type 'a with_loc := 'a without_location - include module type of Ast_builder_generated.Make(struct let loc = Location.none end) + include module type of Ast_builder_generated.Make (struct + let loc = Location.none + end) - include Additional_helpers - with type 'a with_loc := 'a without_location + include Additional_helpers with type 'a with_loc := 'a without_location end diff -Nru ppxlib-0.15.0/src/ast_builder.ml ppxlib-0.24.0/src/ast_builder.ml --- ppxlib-0.15.0/src/ast_builder.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/ast_builder.ml 2021-12-08 21:53:37.000000000 +0000 @@ -2,7 +2,6 @@ module Default = struct module Located = struct - type 'a t = 'a Loc.t let loc (x : _ t) = x.loc @@ -10,6 +9,7 @@ let mk ~loc x = { loc; txt = x } let map f t = { t with txt = f t.txt } + let map_lident x = map (fun x -> Longident.Lident x) x let lident ~loc x = mk ~loc (Longident.parse x) @@ -19,182 +19,199 @@ let pstr_value_list ~loc rec_flag = function | [] -> [] - | vbs -> [pstr_value ~loc rec_flag vbs] + | vbs -> [ pstr_value ~loc rec_flag vbs ] - let nonrec_type_declaration ~loc:_ ~name:_ ~params:_ ~cstrs:_ ~kind:_ ~private_:_ - ~manifest:_ = - failwith "Ppxlib.Ast_builder.nonrec_type_declaration: don't use this function" - ;; + let nonrec_type_declaration ~loc:_ ~name:_ ~params:_ ~cstrs:_ ~kind:_ + ~private_:_ ~manifest:_ = + failwith + "Ppxlib.Ast_builder.nonrec_type_declaration: don't use this function" + + let eint ~loc t = pexp_constant ~loc (Pconst_integer (Int.to_string t, None)) - let eint ~loc t = pexp_constant ~loc (Pconst_integer (Int.to_string t, None)) let echar ~loc t = pexp_constant ~loc (Pconst_char t) - let estring ~loc t = pexp_constant ~loc (Pconst_string (t, None)) + + let estring ~loc t = pexp_constant ~loc (Pconst_string (t, loc, None)) + let efloat ~loc t = pexp_constant ~loc (Pconst_float (t, None)) - let eint32 ~loc t = pexp_constant ~loc (Pconst_integer (Int32.to_string t, Some 'l')) - let eint64 ~loc t = pexp_constant ~loc (Pconst_integer (Int64.to_string t, Some 'L')) - let enativeint ~loc t = pexp_constant ~loc (Pconst_integer (Nativeint.to_string t, Some 'n')) + + let eint32 ~loc t = + pexp_constant ~loc (Pconst_integer (Int32.to_string t, Some 'l')) + + let eint64 ~loc t = + pexp_constant ~loc (Pconst_integer (Int64.to_string t, Some 'L')) + + let enativeint ~loc t = + pexp_constant ~loc (Pconst_integer (Nativeint.to_string t, Some 'n')) let pint ~loc t = ppat_constant ~loc (Pconst_integer (Int.to_string t, None)) + let pchar ~loc t = ppat_constant ~loc (Pconst_char t) - let pstring ~loc t = ppat_constant ~loc (Pconst_string (t, None)) + + let pstring ~loc t = ppat_constant ~loc (Pconst_string (t, loc, None)) + let pfloat ~loc t = ppat_constant ~loc (Pconst_float (t, None)) - let pint32 ~loc t = ppat_constant ~loc (Pconst_integer (Int32.to_string t, Some 'l')) - let pint64 ~loc t = ppat_constant ~loc (Pconst_integer (Int64.to_string t, Some 'L')) - let pnativeint ~loc t = ppat_constant ~loc (Pconst_integer (Nativeint.to_string t, Some 'n')) - let ebool ~loc t = pexp_construct ~loc (Located.lident ~loc (Bool.to_string t)) None - let pbool ~loc t = ppat_construct ~loc (Located.lident ~loc (Bool.to_string t)) None + let pint32 ~loc t = + ppat_constant ~loc (Pconst_integer (Int32.to_string t, Some 'l')) + + let pint64 ~loc t = + ppat_constant ~loc (Pconst_integer (Int64.to_string t, Some 'L')) + + let pnativeint ~loc t = + ppat_constant ~loc (Pconst_integer (Nativeint.to_string t, Some 'n')) + + let ebool ~loc t = + pexp_construct ~loc (Located.lident ~loc (Bool.to_string t)) None + + let pbool ~loc t = + ppat_construct ~loc (Located.lident ~loc (Bool.to_string t)) None let evar ~loc v = pexp_ident ~loc (Located.mk ~loc (Longident.parse v)) + let pvar ~loc v = ppat_var ~loc (Located.mk ~loc v) let eunit ~loc = pexp_construct ~loc (Located.lident ~loc "()") None + let punit ~loc = ppat_construct ~loc (Located.lident ~loc "()") None - let pexp_tuple ~loc l = - match l with - | [x] -> x - | _ -> pexp_tuple ~loc l + let pexp_tuple ~loc l = match l with [ x ] -> x | _ -> pexp_tuple ~loc l - let ppat_tuple ~loc l = - match l with - | [x] -> x - | _ -> ppat_tuple ~loc l + let ppat_tuple ~loc l = match l with [ x ] -> x | _ -> ppat_tuple ~loc l - let ptyp_tuple ~loc l = - match l with - | [x] -> x - | _ -> ptyp_tuple ~loc l + let ptyp_tuple ~loc l = match l with [ x ] -> x | _ -> ptyp_tuple ~loc l let pexp_tuple_opt ~loc l = - match l with - | [] -> None - | _ :: _ -> Some (pexp_tuple ~loc l) + match l with [] -> None | _ :: _ -> Some (pexp_tuple ~loc l) let ppat_tuple_opt ~loc l = - match l with - | [] -> None - | _ :: _ -> Some (ppat_tuple ~loc l) + match l with [] -> None | _ :: _ -> Some (ppat_tuple ~loc l) let ptyp_poly ~loc vars ty = - match vars with - | [] -> ty - | _ -> ptyp_poly ~loc vars ty + match vars with [] -> ty | _ -> ptyp_poly ~loc vars ty let pexp_apply ~loc e el = - match e, el with + match (e, el) with | _, [] -> e - | { pexp_desc = Pexp_apply (e, args) - ; pexp_attributes = []; _ }, _ -> - { e with pexp_desc = Pexp_apply (e, args @ el) } + | { pexp_desc = Pexp_apply (e, args); pexp_attributes = []; _ }, _ -> + { e with pexp_desc = Pexp_apply (e, args @ el) } | _ -> pexp_apply ~loc e el - ;; let eapply ~loc e el = pexp_apply ~loc e (List.map el ~f:(fun e -> (Asttypes.Nolabel, e))) let eabstract ~loc ps e = - List.fold_right ps ~init:e ~f:(fun p e -> pexp_fun ~loc Asttypes.Nolabel None p e) - ;; + List.fold_right ps ~init:e ~f:(fun p e -> + pexp_fun ~loc Asttypes.Nolabel None p e) let esequence ~loc el = match el with | [] -> eunit ~loc - | hd :: tl -> List.fold_left tl ~init:hd ~f:(fun acc e -> pexp_sequence ~loc acc e) - ;; + | hd :: tl -> + List.fold_left tl ~init:hd ~f:(fun acc e -> pexp_sequence ~loc acc e) - let pconstruct cd arg = ppat_construct ~loc:cd.pcd_loc (Located.map_lident cd.pcd_name) arg - let econstruct cd arg = pexp_construct ~loc:cd.pcd_loc (Located.map_lident cd.pcd_name) arg + let pconstruct cd arg = + ppat_construct ~loc:cd.pcd_loc (Located.map_lident cd.pcd_name) arg + + let econstruct cd arg = + pexp_construct ~loc:cd.pcd_loc (Located.map_lident cd.pcd_name) arg let rec elist ~loc l = match l with - | [] -> - pexp_construct ~loc (Located.mk ~loc (Longident.Lident "[]")) None + | [] -> pexp_construct ~loc (Located.mk ~loc (Longident.Lident "[]")) None | x :: l -> - pexp_construct ~loc (Located.mk ~loc (Longident.Lident "::")) - (Some (pexp_tuple ~loc [x; elist ~loc l])) - ;; + pexp_construct ~loc + (Located.mk ~loc (Longident.Lident "::")) + (Some (pexp_tuple ~loc [ x; elist ~loc l ])) let rec plist ~loc l = match l with - | [] -> - ppat_construct ~loc (Located.mk ~loc (Longident.Lident "[]")) None + | [] -> ppat_construct ~loc (Located.mk ~loc (Longident.Lident "[]")) None | x :: l -> - ppat_construct ~loc (Located.mk ~loc (Longident.Lident "::")) - (Some (ppat_tuple ~loc [x; plist ~loc l])) - ;; + ppat_construct ~loc + (Located.mk ~loc (Longident.Lident "::")) + (Some (ppat_tuple ~loc [ x; plist ~loc l ])) let unapplied_type_constr_conv_without_apply ~loc (ident : Longident.t) ~f = match ident with | Lident n -> pexp_ident ~loc { txt = Lident (f n); loc } | Ldot (path, n) -> pexp_ident ~loc { txt = Ldot (path, f n); loc } - | Lapply _ -> Location.raise_errorf ~loc "unexpected applicative functor type" + | Lapply _ -> + Location.raise_errorf ~loc "unexpected applicative functor type" let type_constr_conv ~loc:apply_loc { Loc.loc; txt = longident } ~f args = let loc = { loc with loc_ghost = true } in match (longident : Longident.t) with - | Lident _ - | Ldot ((Lident _ | Ldot _), _) - | Lapply _ -> - let ident = unapplied_type_constr_conv_without_apply longident ~loc ~f in - begin match args with - | [] -> ident - | _ :: _ -> eapply ~loc:apply_loc ident args - end - | Ldot (Lapply _ as module_path, n) -> - let suffix_n functor_ = String.uncapitalize_ascii functor_ ^ "__" ^ n in - let rec gather_lapply functor_args : Longident.t -> Longident.t * _ = function - | Lapply (rest, arg) -> - gather_lapply (arg :: functor_args) rest - | Lident functor_ -> - Lident (suffix_n functor_), functor_args - | Ldot (functor_path, functor_) -> - Ldot (functor_path, suffix_n functor_), functor_args - in - let ident, functor_args = gather_lapply [] module_path in - eapply ~loc:apply_loc (unapplied_type_constr_conv_without_apply ident ~loc ~f) - (List.map functor_args ~f:(fun path -> - pexp_pack ~loc (pmod_ident ~loc { txt = path; loc })) - @ args) + | Lident _ | Ldot ((Lident _ | Ldot _), _) | Lapply _ -> ( + let ident = + unapplied_type_constr_conv_without_apply longident ~loc ~f + in + match args with + | [] -> ident + | _ :: _ -> eapply ~loc:apply_loc ident args) + | Ldot ((Lapply _ as module_path), n) -> + let suffix_n functor_ = String.uncapitalize_ascii functor_ ^ "__" ^ n in + let rec gather_lapply functor_args : Longident.t -> Longident.t * _ = + function + | Lapply (rest, arg) -> gather_lapply (arg :: functor_args) rest + | Lident functor_ -> (Lident (suffix_n functor_), functor_args) + | Ldot (functor_path, functor_) -> + (Ldot (functor_path, suffix_n functor_), functor_args) + in + let ident, functor_args = gather_lapply [] module_path in + eapply ~loc:apply_loc + (unapplied_type_constr_conv_without_apply ident ~loc ~f) + (List.map functor_args ~f:(fun path -> + pexp_pack ~loc (pmod_ident ~loc { txt = path; loc })) + @ args) let unapplied_type_constr_conv ~loc longident ~f = type_constr_conv longident ~loc ~f [] - let eta_reduce = let rec gather_params acc expr = match expr with - | { pexp_desc = - Pexp_fun (label, None (* no default expression *), subpat, body) - ; pexp_attributes = [] - ; pexp_loc = _ - ; pexp_loc_stack = _ - } -> - begin match subpat with - | { ppat_desc = Ppat_var name; ppat_attributes = []; ppat_loc = _; ppat_loc_stack = _ } -> - gather_params ((label, name, None) :: acc) body - | { ppat_desc = Ppat_constraint ({ ppat_desc = Ppat_var name - ; ppat_attributes = [] - ; ppat_loc = _ - ; ppat_loc_stack = _ }, ty) - ; ppat_attributes = []; ppat_loc = _; ppat_loc_stack = _ } -> - (* We reduce [fun (x : ty) -> f x] by rewriting it [(f : ty -> _)]. *) - gather_params ((label, name, Some ty) :: acc) body - | _ -> List.rev acc, expr - end - | _ -> List.rev acc, expr + | { + pexp_desc = + Pexp_fun (label, None (* no default expression *), subpat, body); + pexp_attributes = []; + pexp_loc = _; + pexp_loc_stack = _; + } -> ( + match subpat with + | { + ppat_desc = Ppat_var name; + ppat_attributes = []; + ppat_loc = _; + ppat_loc_stack = _; + } -> + gather_params ((label, name, None) :: acc) body + | { + ppat_desc = + Ppat_constraint + ( { + ppat_desc = Ppat_var name; + ppat_attributes = []; + ppat_loc = _; + ppat_loc_stack = _; + }, + ty ); + ppat_attributes = []; + ppat_loc = _; + ppat_loc_stack = _; + } -> + (* We reduce [fun (x : ty) -> f x] by rewriting it [(f : ty -> _)]. *) + gather_params ((label, name, Some ty) :: acc) body + | _ -> (List.rev acc, expr)) + | _ -> (List.rev acc, expr) in let annotate ~loc expr params = - if List.exists params ~f:(fun (_, _, ty) -> Option.is_some ty) - then + if List.exists params ~f:(fun (_, _, ty) -> Option.is_some ty) then let ty = List.fold_right params ~init:(ptyp_any ~loc) ~f:(fun (param_label, param, ty_opt) acc -> let loc = param.loc in let ty = - match ty_opt with - | None -> ptyp_any ~loc - | Some ty -> ty + match ty_opt with None -> ptyp_any ~loc | Some ty -> ty in ptyp_arrow ~loc param_label ty acc) in @@ -203,39 +220,47 @@ in let rec gather_args n x = if n = 0 then Some (x, []) - else match x with - | { pexp_desc = Pexp_apply (body, args) - ; pexp_attributes = []; pexp_loc = _; pexp_loc_stack = _ } -> - if List.length args <= n then - match gather_args (n - List.length args) body with - | None -> None - | Some (body, args') -> - Some (body, args' @ args) - else - None + else + match x with + | { + pexp_desc = Pexp_apply (body, args); + pexp_attributes = []; + pexp_loc = _; + pexp_loc_stack = _; + } -> + if List.length args <= n then + match gather_args (n - List.length args) body with + | None -> None + | Some (body, args') -> Some (body, args' @ args) + else None | _ -> None in fun expr -> let params, body = gather_params [] expr in match gather_args (List.length params) body with | None -> None - | Some (({ pexp_desc = Pexp_ident _; _ } as f_ident), args) -> - begin + | Some (({ pexp_desc = Pexp_ident _; _ } as f_ident), args) -> ( match - List.for_all2 args params ~f:(fun (arg_label, arg) (param_label, param, _) -> - Poly.(=) (arg_label : arg_label) param_label - && match arg with - | { pexp_desc = Pexp_ident { txt = Lident name'; _ }; pexp_attributes = []; pexp_loc = _; pexp_loc_stack = _ } - -> String.(=) name' param.txt - | _ -> false) + List.for_all2 args params + ~f:(fun (arg_label, arg) (param_label, param, _) -> + Poly.( = ) (arg_label : arg_label) param_label + && + match arg with + | { + pexp_desc = Pexp_ident { txt = Lident name'; _ }; + pexp_attributes = []; + pexp_loc = _; + pexp_loc_stack = _; + } -> + String.( = ) name' param.txt + | _ -> false) with | false -> None - | true -> Some (annotate ~loc:expr.pexp_loc f_ident params) - end + | true -> Some (annotate ~loc:expr.pexp_loc f_ident params)) | _ -> None - ;; let eta_reduce_if_possible expr = Option.value (eta_reduce expr) ~default:expr + let eta_reduce_if_possible_and_nonrec expr ~rec_flag = match rec_flag with | Recursive -> expr @@ -243,73 +268,113 @@ end module type Loc = Ast_builder_intf.Loc -module type S = Ast_builder_intf.S -module Make(Loc : sig val loc : Location.t end) : S = struct - include Ast_builder_generated.Make(Loc) +module type S = Ast_builder_intf.S + +module Make (Loc : sig + val loc : Location.t +end) : S = struct + include Ast_builder_generated.Make (Loc) let pstr_value_list = Default.pstr_value_list let nonrec_type_declaration ~name ~params ~cstrs ~kind ~private_ ~manifest = - Default.nonrec_type_declaration ~loc ~name ~params ~cstrs ~kind ~private_ ~manifest - ;; + Default.nonrec_type_declaration ~loc ~name ~params ~cstrs ~kind ~private_ + ~manifest module Located = struct include Default.Located let loc _ = Loc.loc - let mk x = mk ~loc:Loc.loc x + let mk x = mk ~loc:Loc.loc x + let lident x = lident ~loc:Loc.loc x end let pexp_tuple l = Default.pexp_tuple ~loc l + let ppat_tuple l = Default.ppat_tuple ~loc l + let ptyp_tuple l = Default.ptyp_tuple ~loc l + let pexp_tuple_opt l = Default.pexp_tuple_opt ~loc l + let ppat_tuple_opt l = Default.ppat_tuple_opt ~loc l + let ptyp_poly vars ty = Default.ptyp_poly ~loc vars ty let pexp_apply e el = Default.pexp_apply ~loc e el - let eint t = Default.eint ~loc t - let echar t = Default.echar ~loc t - let estring t = Default.estring ~loc t - let efloat t = Default.efloat ~loc t - let eint32 t = Default.eint32 ~loc t - let eint64 t = Default.eint64 ~loc t + let eint t = Default.eint ~loc t + + let echar t = Default.echar ~loc t + + let estring t = Default.estring ~loc t + + let efloat t = Default.efloat ~loc t + + let eint32 t = Default.eint32 ~loc t + + let eint64 t = Default.eint64 ~loc t + let enativeint t = Default.enativeint ~loc t - let ebool t = Default.ebool ~loc t - let evar t = Default.evar ~loc t - let pint t = Default.pint ~loc t - let pchar t = Default.pchar ~loc t - let pstring t = Default.pstring ~loc t - let pfloat t = Default.pfloat ~loc t - let pint32 t = Default.pint32 ~loc t - let pint64 t = Default.pint64 ~loc t + let ebool t = Default.ebool ~loc t + + let evar t = Default.evar ~loc t + + let pint t = Default.pint ~loc t + + let pchar t = Default.pchar ~loc t + + let pstring t = Default.pstring ~loc t + + let pfloat t = Default.pfloat ~loc t + + let pint32 t = Default.pint32 ~loc t + + let pint64 t = Default.pint64 ~loc t + let pnativeint t = Default.pnativeint ~loc t - let pbool t = Default.pbool ~loc t - let pvar t = Default.pvar ~loc t + + let pbool t = Default.pbool ~loc t + + let pvar t = Default.pvar ~loc t let eunit = Default.eunit ~loc + let punit = Default.punit ~loc let econstruct = Default.econstruct + let pconstruct = Default.pconstruct let eapply e el = Default.eapply ~loc e el + let eabstract ps e = Default.eabstract ~loc ps e + let esequence el = Default.esequence ~loc el let elist l = Default.elist ~loc l + let plist l = Default.plist ~loc l - let type_constr_conv ident ~f args = Default.type_constr_conv ~loc ident ~f args - let unapplied_type_constr_conv ident ~f = Default.unapplied_type_constr_conv ~loc ident ~f + let type_constr_conv ident ~f args = + Default.type_constr_conv ~loc ident ~f args + + let unapplied_type_constr_conv ident ~f = + Default.unapplied_type_constr_conv ~loc ident ~f + let eta_reduce = Default.eta_reduce + let eta_reduce_if_possible = Default.eta_reduce_if_possible - let eta_reduce_if_possible_and_nonrec = Default.eta_reduce_if_possible_and_nonrec + + let eta_reduce_if_possible_and_nonrec = + Default.eta_reduce_if_possible_and_nonrec end -let make loc = (module Make(struct let loc = loc end) : S) +let make loc = + (module Make (struct + let loc = loc + end) : S) diff -Nru ppxlib-0.15.0/src/ast_builder.mli ppxlib-0.24.0/src/ast_builder.mli --- ppxlib-0.15.0/src/ast_builder.mli 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/ast_builder.mli 2021-12-08 21:53:37.000000000 +0000 @@ -2,25 +2,26 @@ open! Import -(** This module is similar to the [Ast_helper] module distrubuted with OCaml but uses - different conventions. +(** This module is similar to the [Ast_helper] module distributed with OCaml but + uses different conventions. {3 Locations} - [Ast_helper] uses a global variable for the default locations, we found that to it - makes it quite easy to mess up locations. Instead this modules forces you to provide a - location argument. + [Ast_helper] uses a global variable for the default locations, we found that + to it makes it quite easy to mess up locations. Instead this modules forces + you to provide a location argument. - For building fragment using the same location everywhere, a functor is provided. + For building fragment using the same location everywhere, a functor is + provided. {3 Naming} - The names match the [Parsetree] names closely, which makes it easy to build AST - fragments by just knowing the [Parsetree]. + The names match the [Parsetree] names closely, which makes it easy to build + AST fragments by just knowing the [Parsetree]. - For types of the form a wrapper record with a [_desc] field, helpers are generated for - each constructor constructing the record directly. For instance for the type - [Parsetree.expression]: + For types of the form a wrapper record with a [_desc] field, helpers are + generated for each constructor constructing the record directly. For + instance for the type [Parsetree.expression]: {[ type expression = @@ -45,7 +46,8 @@ ... ]} - For other record types, such as type_declaration, we have the following helper: + For other record types, such as type_declaration, we have the following + helper: {[ type type_declaration = @@ -71,27 +73,30 @@ -> type_declaration ]} - Attributes are always set to the empty list. If you want to set them you have to - override the field with the [{ e with pexp_attributes = ... }] notation. -*) + Attributes are always set to the empty list. If you want to set them you + have to override the field with the [{ e with pexp_attributes = ... }] + notation. *) - -(** Helpers taking a [~loc] argument. This module is meant to be opened or aliased. *) +(** Helpers taking a [~loc] argument. This module is meant to be opened or + aliased. *) module Default : sig - module Located : Ast_builder_intf.Located - with type 'a with_loc := 'a Ast_builder_intf.with_location + module Located : + Ast_builder_intf.Located + with type 'a with_loc := 'a Ast_builder_intf.with_location include module type of Ast_builder_generated.M - include Ast_builder_intf.Additional_helpers - with type 'a with_loc := 'a Ast_builder_intf.with_location + include + Ast_builder_intf.Additional_helpers + with type 'a with_loc := 'a Ast_builder_intf.with_location end module type Loc = Ast_builder_intf.Loc -module type S = Ast_builder_intf.S + +module type S = Ast_builder_intf.S (** Build Ast helpers with the location argument factorized. *) -module Make(Loc : Loc) : S +module Make (Loc : Loc) : S -(** Functional version of [Make]. *) val make : Location.t -> (module S) +(** Functional version of [Make]. *) diff -Nru ppxlib-0.15.0/src/ast_pattern0.ml ppxlib-0.24.0/src/ast_pattern0.ml --- ppxlib-0.15.0/src/ast_pattern0.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/ast_pattern0.ml 2021-12-08 21:53:37.000000000 +0000 @@ -2,19 +2,17 @@ exception Expected of Location.t * string -let fail loc expected = - raise (Expected (loc, expected)) -;; +let fail loc expected = raise (Expected (loc, expected)) -type context = - { (* [matched] counts how many constructors have been matched. This is used to find what - pattern matches the most some piece of ast in [Ast_pattern.alt]. In the case where - all branches fail to match, we report the error from the one that matches the - most. +type context = { + (* [matched] counts how many constructors have been matched. This is used to find what + pattern matches the most some piece of ast in [Ast_pattern.alt]. In the case where + all branches fail to match, we report the error from the one that matches the + most. - This is only incremented by combinators that can fail. *) - mutable matched : int - } + This is only incremented by combinators that can fail. *) + mutable matched : int; +} type ('matched_value, 'k, 'k_result) t = - T of (context -> Location.t -> 'matched_value -> 'k -> 'k_result) + | T of (context -> Location.t -> 'matched_value -> 'k -> 'k_result) diff -Nru ppxlib-0.15.0/src/ast_pattern.ml ppxlib-0.24.0/src/ast_pattern.ml --- ppxlib-0.15.0/src/ast_pattern.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/ast_pattern.ml 2021-12-08 21:53:37.000000000 +0000 @@ -1,224 +1,286 @@ open! Import - include Ast_pattern0 let save_context ctx = ctx.matched + let restore_context ctx backup = ctx.matched <- backup let incr_matched c = c.matched <- c.matched + 1 let parse (T f) loc ?on_error x k = try f { matched = 0 } loc x k - with Expected (loc, expected) -> + with Expected (loc, expected) -> ( match on_error with | None -> Location.raise_errorf ~loc "%s expected" expected - | Some f -> f () + | Some f -> f ()) module Packed = struct type ('a, 'b) t = T : ('a, 'b, 'c) Ast_pattern0.t * 'b -> ('a, 'c) t let create t f = T (t, f) + let parse (T (t, f)) loc x = parse t loc x f end -let __ = T (fun ctx _loc x k -> incr_matched ctx; k x) +let __ = + T + (fun ctx _loc x k -> + incr_matched ctx; + k x) + +let __' = + T + (fun ctx loc x k -> + incr_matched ctx; + k { loc; txt = x }) + +let drop = + T + (fun ctx _loc _ k -> + incr_matched ctx; + k) + +let cst ~to_string ?(equal = Poly.equal) v = + T + (fun ctx loc x k -> + if equal x v then ( + incr_matched ctx; + k) + else fail loc (to_string v)) -let __' = T (fun ctx loc x k -> incr_matched ctx; k { loc; txt = x }) +let int v = cst ~to_string:Int.to_string v -let drop = T (fun ctx _loc _ k -> incr_matched ctx; k) +let char v = cst ~to_string:(Printf.sprintf "%C") v -let cst ~to_string ?(equal=Poly.equal) v = T (fun ctx loc x k -> - if equal x v then begin - incr_matched ctx; - k - end else - fail loc (to_string v) -);; - -let int v = cst ~to_string:Int.to_string v -let char v = cst ~to_string:(Printf.sprintf "%C") v -let string v = cst ~to_string:(Printf.sprintf "%S") v -let float v = cst ~to_string:Float.to_string v -let int32 v = cst ~to_string:Int32.to_string v -let int64 v = cst ~to_string:Int64.to_string v -let nativeint v = cst ~to_string:Nativeint.to_string v -let bool v = cst ~to_string:Bool.to_string v +let string v = cst ~to_string:(Printf.sprintf "%S") v + +let float v = cst ~to_string:Float.to_string v + +let int32 v = cst ~to_string:Int32.to_string v + +let int64 v = cst ~to_string:Int64.to_string v + +let nativeint v = cst ~to_string:Nativeint.to_string v + +let bool v = cst ~to_string:Bool.to_string v let false_ = - T (fun ctx loc x k -> - match x with - | false -> ctx.matched <- ctx.matched + 1; k - | _ -> fail loc "false") -;; + T + (fun ctx loc x k -> + match x with + | false -> + ctx.matched <- ctx.matched + 1; + k + | _ -> fail loc "false") let true_ = - T (fun ctx loc x k -> - match x with - | true -> ctx.matched <- ctx.matched + 1; k - | _ -> fail loc "true") -;; + T + (fun ctx loc x k -> + match x with + | true -> + ctx.matched <- ctx.matched + 1; + k + | _ -> fail loc "true") let nil = - T (fun ctx loc x k -> - match x with - | [] -> ctx.matched <- ctx.matched + 1; k - | _ -> fail loc "[]") -;; + T + (fun ctx loc x k -> + match x with + | [] -> + ctx.matched <- ctx.matched + 1; + k + | _ -> fail loc "[]") let ( ^:: ) (T f0) (T f1) = - T (fun ctx loc x k -> - match x with - | x0::x1 -> - ctx.matched <- ctx.matched + 1; - let k = f0 ctx loc x0 k in - let k = f1 ctx loc x1 k in - k - | _ -> fail loc "::") -;; + T + (fun ctx loc x k -> + match x with + | x0 :: x1 -> + ctx.matched <- ctx.matched + 1; + let k = f0 ctx loc x0 k in + let k = f1 ctx loc x1 k in + k + | _ -> fail loc "::") let none = - T (fun ctx loc x k -> - match x with - | None -> ctx.matched <- ctx.matched + 1; k - | _ -> fail loc "None") -;; + T + (fun ctx loc x k -> + match x with + | None -> + ctx.matched <- ctx.matched + 1; + k + | _ -> fail loc "None") let some (T f0) = - T (fun ctx loc x k -> - match x with - | Some x0 -> - ctx.matched <- ctx.matched + 1; - let k = f0 ctx loc x0 k in - k - | _ -> fail loc "Some") -;; - -let pair (T f1) (T f2) = T (fun ctx loc (x1, x2) k -> - let k = f1 ctx loc x1 k in - let k = f2 ctx loc x2 k in - k -);; + T + (fun ctx loc x k -> + match x with + | Some x0 -> + ctx.matched <- ctx.matched + 1; + let k = f0 ctx loc x0 k in + k + | _ -> fail loc "Some") + +let pair (T f1) (T f2) = + T + (fun ctx loc (x1, x2) k -> + let k = f1 ctx loc x1 k in + let k = f2 ctx loc x2 k in + k) let ( ** ) = pair -let triple (T f1) (T f2) (T f3) = T (fun ctx loc (x1, x2, x3) k -> - let k = f1 ctx loc x1 k in - let k = f2 ctx loc x2 k in - let k = f3 ctx loc x3 k in - k -);; - -let alt (T f1) (T f2) = T (fun ctx loc x k -> - let backup = save_context ctx in - try - f1 ctx loc x k - with e1 -> - let m1 = save_context ctx in - restore_context ctx backup; - try - f2 ctx loc x k - with e2 -> - let m2 = save_context ctx in - if m1 >= m2 then begin - restore_context ctx m1; - raise e1 - end else - raise e2 -);; +let triple (T f1) (T f2) (T f3) = + T + (fun ctx loc (x1, x2, x3) k -> + let k = f1 ctx loc x1 k in + let k = f2 ctx loc x2 k in + let k = f3 ctx loc x3 k in + k) + +let alt (T f1) (T f2) = + T + (fun ctx loc x k -> + let backup = save_context ctx in + try f1 ctx loc x k + with e1 -> ( + let m1 = save_context ctx in + restore_context ctx backup; + try f2 ctx loc x k + with e2 -> + let m2 = save_context ctx in + if m1 >= m2 then ( + restore_context ctx m1; + raise e1) + else raise e2)) let ( ||| ) = alt let map (T func) ~f = T (fun ctx loc x k -> func ctx loc x (f k)) + let map' (T func) ~f = T (fun ctx loc x k -> func ctx loc x (f loc k)) + let map_result (T func) ~f = T (fun ctx loc x k -> f (func ctx loc x k)) let ( >>| ) t f = map t ~f -let map0 (T func) ~f = T (fun ctx loc x k -> func ctx loc x ( k f )) -let map1 (T func) ~f = T (fun ctx loc x k -> func ctx loc x (fun a -> k (f a ))) -let map2 (T func) ~f = T (fun ctx loc x k -> func ctx loc x (fun a b -> k (f a b))) - -let map0' (T func) ~f = T (fun ctx loc x k -> func ctx loc x ( k (f loc ))) -let map1' (T func) ~f = T (fun ctx loc x k -> func ctx loc x (fun a -> k (f loc a ))) -let map2' (T func) ~f = T (fun ctx loc x k -> func ctx loc x (fun a b -> k (f loc a b))) +let map0 (T func) ~f = T (fun ctx loc x k -> func ctx loc x (k f)) + +let map1 (T func) ~f = T (fun ctx loc x k -> func ctx loc x (fun a -> k (f a))) + +let map2 (T func) ~f = + T (fun ctx loc x k -> func ctx loc x (fun a b -> k (f a b))) + +let map0' (T func) ~f = T (fun ctx loc x k -> func ctx loc x (k (f loc))) + +let map1' (T func) ~f = + T (fun ctx loc x k -> func ctx loc x (fun a -> k (f loc a))) + +let map2' (T func) ~f = + T (fun ctx loc x k -> func ctx loc x (fun a b -> k (f loc a b))) let alt_option some none = alt (map1 some ~f:(fun x -> Some x)) (map0 none ~f:None) -let many (T f) = T (fun ctx loc l k -> - k (List.map l ~f:(fun x -> f ctx loc x (fun x -> x)))) -;; - -let loc (T f) = T (fun ctx _loc (x : _ Loc.t) k -> - f ctx x.loc x.txt k) -;; +let many (T f) = + T (fun ctx loc l k -> k (List.map l ~f:(fun x -> f ctx loc x (fun x -> x)))) + +let loc (T f) = T (fun ctx _loc (x : _ Loc.t) k -> f ctx x.loc x.txt k) let pack0 t = map t ~f:(fun f -> f ()) + let pack2 t = map t ~f:(fun f x y -> f (x, y)) + let pack3 t = map t ~f:(fun f x y z -> f (x, y, z)) include Ast_pattern_generated -let echar t = pexp_constant (pconst_char t ) -let estring t = pexp_constant (pconst_string t drop) -let efloat t = pexp_constant (pconst_float t drop) - -let pchar t = ppat_constant (pconst_char t ) -let pstring t = ppat_constant (pconst_string t drop) -let pfloat t = ppat_constant (pconst_float t drop) - -let int' (T f) = T (fun ctx loc x k -> f ctx loc (int_of_string x) k) -let int32' (T f) = T (fun ctx loc x k -> f ctx loc (Int32.of_string x) k) -let int64' (T f) = T (fun ctx loc x k -> f ctx loc (Int64.of_string x) k) -let nativeint' (T f) = T (fun ctx loc x k -> f ctx loc (Nativeint.of_string x) k) - -let const_int t = pconst_integer (int' t) none -let const_int32 t = pconst_integer (int32' t) (some (char 'l')) -let const_int64 t = pconst_integer (int64' t) (some (char 'L')) +let echar t = pexp_constant (pconst_char t) + +let estring t = pexp_constant (pconst_string t drop drop) + +let efloat t = pexp_constant (pconst_float t drop) + +let pchar t = ppat_constant (pconst_char t) + +let pstring t = ppat_constant (pconst_string t drop drop) + +let pfloat t = ppat_constant (pconst_float t drop) + +let int' (T f) = T (fun ctx loc x k -> f ctx loc (int_of_string x) k) + +let int32' (T f) = T (fun ctx loc x k -> f ctx loc (Int32.of_string x) k) + +let int64' (T f) = T (fun ctx loc x k -> f ctx loc (Int64.of_string x) k) + +let nativeint' (T f) = + T (fun ctx loc x k -> f ctx loc (Nativeint.of_string x) k) + +let const_int t = pconst_integer (int' t) none + +let const_int32 t = pconst_integer (int32' t) (some (char 'l')) + +let const_int64 t = pconst_integer (int64' t) (some (char 'L')) + let const_nativeint t = pconst_integer (nativeint' t) (some (char 'n')) -let eint t = pexp_constant (const_int t) -let eint32 t = pexp_constant (const_int32 t) -let eint64 t = pexp_constant (const_int64 t) +let eint t = pexp_constant (const_int t) + +let eint32 t = pexp_constant (const_int32 t) + +let eint64 t = pexp_constant (const_int64 t) + let enativeint t = pexp_constant (const_nativeint t) -let pint t = ppat_constant (const_int t) -let pint32 t = ppat_constant (const_int32 t) -let pint64 t = ppat_constant (const_int64 t) +let pint t = ppat_constant (const_int t) + +let pint32 t = ppat_constant (const_int32 t) + +let pint64 t = ppat_constant (const_int64 t) + let pnativeint t = ppat_constant (const_nativeint t) let single_expr_payload t = pstr (pstr_eval t nil ^:: nil) -let no_label t = (cst Asttypes.Nolabel ~to_string:(fun _ -> "Nolabel")) ** t +let no_label t = cst Asttypes.Nolabel ~to_string:(fun _ -> "Nolabel") ** t -let extension (T f1) (T f2) = T (fun ctx loc ((name : _ Loc.t), payload) k -> - let k = f1 ctx name.loc name.txt k in - let k = f2 ctx loc payload k in - k -) +let extension (T f1) (T f2) = + T + (fun ctx loc ((name : _ Loc.t), payload) k -> + let k = f1 ctx name.loc name.txt k in + let k = f2 ctx loc payload k in + k) let rec parse_elist (e : Parsetree.expression) acc = Common.assert_no_attributes e.pexp_attributes; match e.pexp_desc with - | Pexp_construct ({ txt = Lident "[]"; _ }, None) -> - List.rev acc - | Pexp_construct ({ txt = Lident "::"; _ }, Some arg) -> begin + | Pexp_construct ({ txt = Lident "[]"; _ }, None) -> List.rev acc + | Pexp_construct ({ txt = Lident "::"; _ }, Some arg) -> ( Common.assert_no_attributes arg.pexp_attributes; match arg.pexp_desc with - | Pexp_tuple [hd; tl] -> - parse_elist tl (hd :: acc) - | _ -> - fail arg.pexp_loc "list" - end - | _ -> - fail e.pexp_loc "list" -;; - -let elist (T f) = T (fun ctx _loc e k -> - let l = parse_elist e [] in - incr_matched ctx; - k (List.map l ~f:(fun x -> f ctx x.Parsetree.pexp_loc x (fun x -> x)))) -;; + | Pexp_tuple [ hd; tl ] -> parse_elist tl (hd :: acc) + | _ -> fail arg.pexp_loc "list") + | _ -> fail e.pexp_loc "list" + +let elist (T f) = + T + (fun ctx _loc e k -> + let l = parse_elist e [] in + incr_matched ctx; + k (List.map l ~f:(fun x -> f ctx x.Parsetree.pexp_loc x (fun x -> x)))) + +let esequence (T f) = + T + (fun ctx _loc e k -> + let rec parse_seq expr acc = + match expr.pexp_desc with + | Pexp_sequence (expr, next) -> parse_seq next (expr :: acc) + | _ -> expr :: acc + in + k + (List.rev_map (parse_seq e []) ~f:(fun expr -> + f ctx expr.pexp_loc expr (fun x -> x)))) + +let of_func f = T f -let of_func f = (T f) let to_func (T f) = f diff -Nru ppxlib-0.15.0/src/ast_pattern.mli ppxlib-0.24.0/src/ast_pattern.mli --- ppxlib-0.15.0/src/ast_pattern.mli 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/ast_pattern.mli 2021-12-08 21:53:37.000000000 +0000 @@ -2,28 +2,25 @@ open! Import -(** PPX rewriters often need to recognize fragments the OCaml AST, for instance to parse - the payload of an attribute/expression. You can do that with a pattern matching and - manual error reporting when the input is not what you expect but this has proven to - quickly become extremely verbose and unreadable. +(** PPX rewriters often need to recognize fragments the OCaml AST, for instance + to parse the payload of an attribute/expression. You can do that with a + pattern matching and manual error reporting when the input is not what you + expect but this has proven to quickly become extremely verbose and + unreadable. This module aims to help with that by providing first class AST patterns. - To understand how to use it, let's consider the example of ppx_inline_test. We want to - recognize patterns of the form: + To understand how to use it, let's consider the example of ppx_inline_test. + We want to recognize patterns of the form: - {[ - let%test "name" = expr - ]} + {[ let%test "name" = expr ]} Which is a syntactic sugar for: - {[ - [%%test let "name" = expr] - ]} + {[ [%%test let "name" = expr] ]} - If we wanted to write a function that recognizes the payload of [%%test] using normal - pattern matching we would write: + If we wanted to write a function that recognizes the payload of [%%test] + using normal pattern matching we would write: {[ let match_payload = function @@ -37,189 +34,236 @@ | _ -> Location.raisef ... ]} - This is quite cumbersome, and this is still not right: this function drops all - attributes without notice. + This is quite cumbersome, and this is still not right: this function drops + all attributes without notice. - Now let's imagine we wanted to construct the payload instead, using [Ast_builder] one - would write: + Now let's imagine we wanted to construct the payload instead, using + [Ast_builder] one would write: {[ let build_payload ~loc name expr = let (module B) = Ast_builder.with_loc loc in let open B in - pstr [ pstr_value Nonrecursive (value_binding ~pat:(pstring name) ~expr) ] + pstr + [ pstr_value Nonrecursive (value_binding ~pat:(pstring name) ~expr) ] ]} - Constructing a first class pattern is almost as simple as replacing [Ast_builder] by - [Ast_pattern]: + Constructing a first class pattern is almost as simple as replacing + [Ast_builder] by [Ast_pattern]: {[ let payload_pattern name expr = let open Ast_pattern in - pstr (pstr_value nonrecursive (value_binding ~pat:(pstring __) ~expr:__) ^:: nil) + pstr + (pstr_value nonrecursive (value_binding ~pat:(pstring __) ~expr:__) + ^:: nil) ]} - Notice that the place-holders for [name] and [expr] have been replaced by [__]. The - following pattern with have type: + Notice that the place-holders for [name] and [expr] have been replaced by + [__]. The following pattern with have type: {[ (payload, string -> expression -> 'a, 'a) Ast_pattern.t ]} - which means that it matches values of type [payload] and captures a string and - expression from it. The two captured elements comes from the use of [__]. -*) + which means that it matches values of type [payload] and captures a string + and expression from it. The two captured elements comes from the use of + [__]. *) +type ('a, 'b, 'c) t = ('a, 'b, 'c) Ast_pattern0.t (** Type of a pattern: - ['a] is the type of value matched by the pattern - - ['b] is the continuation, for instance for a pattern that captures an [int] and a - [string], ['b] will be [int -> string -> _] - - ['c] is the result of the continuation. -*) -type ('a, 'b, 'c) t = ('a, 'b, 'c) Ast_pattern0.t + - ['b] is the continuation, for instance for a pattern that captures an + [int] and a [string], ['b] will be [int -> string -> _] + - ['c] is the result of the continuation. *) +val parse : + ('a, 'b, 'c) t -> Location.t -> ?on_error:(unit -> 'c) -> 'a -> 'b -> 'c (** Matches a value against a pattern. *) -val parse : ('a, 'b, 'c) t -> Location.t -> ?on_error:(unit -> 'c) -> 'a -> 'b -> 'c module Packed : sig type ('a, 'b, 'c) pattern = ('a, 'b, 'c) t + type ('a, 'b) t val create : ('a, 'b, 'c) pattern -> 'b -> ('a, 'c) t + val parse : ('a, 'b) t -> Location.t -> 'a -> 'b -end with type ('a, 'b, 'c) pattern := ('a, 'b, 'c) t +end +with type ('a, 'b, 'c) pattern := ('a, 'b, 'c) t -(** Pattern that captures its input. *) val __ : ('a, 'a -> 'b, 'b) t +(** Pattern that captures its input. *) +val __' : ('a, 'a Loc.t -> 'b, 'b) t (** Same as [__] but also captures the location. - Note: this should only be used for types that do not embed a location. For instance - you can use it to capture a string constant: + Note: this should only be used for types that do not embed a location. For + instance you can use it to capture a string constant: - {[ - estring __' - ]} + {[ estring __' ]} but using it to capture an expression would not yield the expected result: - {[ - pair (eint (int 42)) __' - ]} + {[ pair (eint (int 42)) __' ]} - In the latter case you should use the [pexp_loc] field of the captured expression - instead. -*) -val __' : ('a, 'a Loc.t -> 'b, 'b) t + In the latter case you should use the [pexp_loc] field of the captured + expression instead. *) -(** [alt] stands for `alternatives'. It matches either the first pattern or the second - one. *) val alt : ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t +(** [alt] stands for `alternatives'. It matches either the first pattern or the + second one. *) -(** Same as [alt], for the common case where the left-hand-side captures a value but not - the right-hand-side. *) -val alt_option : ('a, 'v -> 'b, 'c) t -> ('a, 'b, 'c) t -> ('a, 'v option -> 'b, 'c) t +val alt_option : + ('a, 'v -> 'b, 'c) t -> ('a, 'b, 'c) t -> ('a, 'v option -> 'b, 'c) t +(** Same as [alt], for the common case where the left-hand-side captures a value + but not the right-hand-side. *) -(** Same as [alt] *) val ( ||| ) : ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t +(** Same as [alt] *) val map : ('a, 'b, 'c) t -> f:('d -> 'b) -> ('a, 'd, 'c) t + val map' : ('a, 'b, 'c) t -> f:(Location.t -> 'd -> 'b) -> ('a, 'd, 'c) t + val map_result : ('a, 'b, 'c) t -> f:('c -> 'd) -> ('a, 'b, 'd) t -(** Same as [map] *) val ( >>| ) : ('a, 'b, 'c) t -> ('d -> 'b) -> ('a, 'd, 'c) t +(** Same as [map] *) + +val map0 : ('a, 'b, 'c) t -> f:'v -> ('a, 'v -> 'b, 'c) t + +val map1 : ('a, 'v1 -> 'b, 'c) t -> f:('v1 -> 'v) -> ('a, 'v -> 'b, 'c) t -val map0 : ('a, 'b, 'c) t -> f: 'v -> ('a, 'v -> 'b, 'c) t -val map1 : ('a, 'v1 -> 'b, 'c) t -> f:('v1 -> 'v) -> ('a, 'v -> 'b, 'c) t -val map2 : ('a, 'v1 -> 'v2 -> 'b, 'c) t -> f:('v1 -> 'v2 -> 'v) -> ('a, 'v -> 'b, 'c) t - -val map0' : ('a, 'b, 'c) t -> f:(Location.t -> 'v) -> ('a, 'v -> 'b, 'c) t -val map1' : ('a, 'v1 -> 'b, 'c) t -> f:(Location.t -> 'v1 -> 'v) -> ('a, 'v -> 'b, 'c) t -val map2' : ('a, 'v1 -> 'v2 -> 'b, 'c) t -> f:(Location.t -> 'v1 -> 'v2 -> 'v) -> ('a, 'v -> 'b, 'c) t +val map2 : + ('a, 'v1 -> 'v2 -> 'b, 'c) t -> f:('v1 -> 'v2 -> 'v) -> ('a, 'v -> 'b, 'c) t + +val map0' : ('a, 'b, 'c) t -> f:(Location.t -> 'v) -> ('a, 'v -> 'b, 'c) t + +val map1' : + ('a, 'v1 -> 'b, 'c) t -> f:(Location.t -> 'v1 -> 'v) -> ('a, 'v -> 'b, 'c) t + +val map2' : + ('a, 'v1 -> 'v2 -> 'b, 'c) t -> + f:(Location.t -> 'v1 -> 'v2 -> 'v) -> + ('a, 'v -> 'b, 'c) t val nil : (_ list, 'a, 'a) t + val ( ^:: ) : ('a, 'b, 'c) t -> ('a list, 'c, 'd) t -> ('a list, 'b, 'd) t + val many : ('a, 'b -> 'b, 'c) t -> ('a list, 'c list -> 'd, 'd) t -val int : int -> (int , 'a, 'a) t -val char : char -> (char , 'a, 'a) t -val string : string -> (string , 'a, 'a) t -val float : float -> (float , 'a, 'a) t -val int32 : int32 -> (int32 , 'a, 'a) t -val int64 : int64 -> (int64 , 'a, 'a) t -val nativeint : nativeint -> (nativeint , 'a, 'a) t -val bool : bool -> (bool , 'a, 'a) t - -val cst - : to_string:('a -> string) - -> ?equal:('a -> 'a -> bool) - -> 'a - -> ('a, 'b, 'b) t +val int : int -> (int, 'a, 'a) t + +val char : char -> (char, 'a, 'a) t + +val string : string -> (string, 'a, 'a) t + +val float : float -> (float, 'a, 'a) t + +val int32 : int32 -> (int32, 'a, 'a) t + +val int64 : int64 -> (int64, 'a, 'a) t + +val nativeint : nativeint -> (nativeint, 'a, 'a) t + +val bool : bool -> (bool, 'a, 'a) t + +val cst : + to_string:('a -> string) -> ?equal:('a -> 'a -> bool) -> 'a -> ('a, 'b, 'b) t val none : (_ option, 'a, 'a) t + val some : ('a, 'b, 'c) t -> ('a option, 'b, 'c) t val pair : ('a1, 'b, 'c) t -> ('a2, 'c, 'd) t -> ('a1 * 'a2, 'b, 'd) t + val ( ** ) : ('a1, 'b, 'c) t -> ('a2, 'c, 'd) t -> ('a1 * 'a2, 'b, 'd) t -val triple - : ('a1, 'b, 'c) t - -> ('a2, 'c, 'd) t - -> ('a3, 'd, 'e) t - -> ('a1 * 'a2 * 'a3, 'b, 'e) t + +val triple : + ('a1, 'b, 'c) t -> + ('a2, 'c, 'd) t -> + ('a3, 'd, 'e) t -> + ('a1 * 'a2 * 'a3, 'b, 'e) t val loc : ('a, 'b, 'c) t -> ('a Loc.t, 'b, 'c) t val pack0 : ('a, 'b, 'c) t -> ('a, unit -> 'b, 'c) t + val pack2 : ('a, 'b -> 'c -> 'd, 'e) t -> ('a, 'b * 'c -> 'd, 'e) t + val pack3 : ('a, 'b -> 'c -> 'd -> 'e, 'f) t -> ('a, 'b * 'c * 'd -> 'e, 'f) t -(** AST patterns for each constructur/record of the parsetree are generated in the same - way AST builders are generated. In addition, for every {it wrapper} we generate a - pattern to match the [loc] and [attributes] fields. For instanct for the [expression] - type: +include module type of Ast_pattern_generated +(** AST patterns for each constructor/record of the parsetree are generated in + the same way AST builders are generated. In addition, for every {i wrapper} + we generate a pattern to match the [loc] and [attributes] fields. For + instance for the [expression] type: {[ - val pexp_loc - : (Location.t, 'a, 'b) t - -> (expression, 'b, 'c) t - -> (expression, 'a, 'c) t - - val pexp_attributes - : (attributes, 'a, 'b) t - -> (expression, 'b, 'c) t - -> (expression, 'a, 'c) t - ]} -*) -include module type of Ast_pattern_generated + val pexp_loc : + (Location.t, 'a, 'b) t -> + (expression, 'b, 'c) t -> + (expression, 'a, 'c) t + + val pexp_attributes : + (attributes, 'a, 'b) t -> + (expression, 'b, 'c) t -> + (expression, 'a, 'c) t + ]} *) + +val true_ : (bool, 'a, 'a) t -val true_ : (bool, 'a, 'a) t val false_ : (bool, 'a, 'a) t -val eint : (int , 'a, 'b) t -> (expression, 'a, 'b) t -val echar : (char , 'a, 'b) t -> (expression, 'a, 'b) t -val estring : (string , 'a, 'b) t -> (expression, 'a, 'b) t -val efloat : (string , 'a, 'b) t -> (expression, 'a, 'b) t -val eint32 : (int32 , 'a, 'b) t -> (expression, 'a, 'b) t -val eint64 : (int64 , 'a, 'b) t -> (expression, 'a, 'b) t -val enativeint : (nativeint , 'a, 'b) t -> (expression, 'a, 'b) t - -val pint : (int , 'a, 'b) t -> (pattern, 'a, 'b) t -val pchar : (char , 'a, 'b) t -> (pattern, 'a, 'b) t -val pstring : (string , 'a, 'b) t -> (pattern, 'a, 'b) t -val pfloat : (string , 'a, 'b) t -> (pattern, 'a, 'b) t -val pint32 : (int32 , 'a, 'b) t -> (pattern, 'a, 'b) t -val pint64 : (int64 , 'a, 'b) t -> (pattern, 'a, 'b) t -val pnativeint : (nativeint , 'a, 'b) t -> (pattern, 'a, 'b) t +val eint : (int, 'a, 'b) t -> (expression, 'a, 'b) t + +val echar : (char, 'a, 'b) t -> (expression, 'a, 'b) t + +val estring : (string, 'a, 'b) t -> (expression, 'a, 'b) t + +val efloat : (string, 'a, 'b) t -> (expression, 'a, 'b) t + +val eint32 : (int32, 'a, 'b) t -> (expression, 'a, 'b) t + +val eint64 : (int64, 'a, 'b) t -> (expression, 'a, 'b) t + +val enativeint : (nativeint, 'a, 'b) t -> (expression, 'a, 'b) t + +val pint : (int, 'a, 'b) t -> (pattern, 'a, 'b) t + +val pchar : (char, 'a, 'b) t -> (pattern, 'a, 'b) t + +val pstring : (string, 'a, 'b) t -> (pattern, 'a, 'b) t + +val pfloat : (string, 'a, 'b) t -> (pattern, 'a, 'b) t + +val pint32 : (int32, 'a, 'b) t -> (pattern, 'a, 'b) t + +val pint64 : (int64, 'a, 'b) t -> (pattern, 'a, 'b) t + +val pnativeint : (nativeint, 'a, 'b) t -> (pattern, 'a, 'b) t val single_expr_payload : (expression, 'a, 'b) t -> (payload, 'a, 'b) t -val no_label : (expression, 'a, 'b) t -> (Asttypes.arg_label * expression, 'a, 'b) t +val no_label : + (expression, 'a, 'b) t -> (Asttypes.arg_label * expression, 'a, 'b) t + +val attribute : + name:(string, 'a, 'b) t -> + payload:(payload, 'b, 'c) t -> + (attribute, 'a, 'c) t -val attribute : name:(string, 'a, 'b) t -> payload:(payload, 'b, 'c) t -> (attribute, 'a, 'c) t -val extension : (string, 'a, 'b) t -> (payload, 'b, 'c) t -> (extension, 'a, 'c) t +val extension : + (string, 'a, 'b) t -> (payload, 'b, 'c) t -> (extension, 'a, 'c) t val elist : (expression, 'a -> 'a, 'b) t -> (expression, 'b list -> 'c, 'c) t +val esequence : + (expression, 'a -> 'a, 'b) t -> (expression, 'b list -> 'c, 'c) t + type context + val of_func : (context -> Location.t -> 'a -> 'b -> 'c) -> ('a, 'b, 'c) t -val to_func : ('a, 'b, 'c) t -> (context -> Location.t -> 'a -> 'b -> 'c) + +val to_func : ('a, 'b, 'c) t -> context -> Location.t -> 'a -> 'b -> 'c diff -Nru ppxlib-0.15.0/src/ast_traverse.ml ppxlib-0.24.0/src/ast_traverse.ml --- ppxlib-0.15.0/src/ast_traverse.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/ast_traverse.ml 2021-12-08 21:53:37.000000000 +0000 @@ -1,161 +1,187 @@ open! Import -class map = object - inherit Ppxlib_traverse_builtins.map - inherit Ast.map -end - -class iter = object - inherit Ppxlib_traverse_builtins.iter - inherit Ast.iter -end - -class ['acc] fold = object - inherit ['acc] Ppxlib_traverse_builtins.fold - inherit ['acc] Ast.fold -end - -class ['acc] fold_map = object - inherit ['acc] Ppxlib_traverse_builtins.fold_map - inherit ['acc] Ast.fold_map -end - -class ['ctx] map_with_context = object - inherit ['ctx] Ppxlib_traverse_builtins.map_with_context - inherit ['ctx] Ast.map_with_context -end - -class virtual ['res] lift = object - inherit ['res] Ppxlib_traverse_builtins.lift - inherit ['res] Ast.lift -end - -let module_name = function - | None -> "_" - | Some name -> name +class map = + object + inherit Ppxlib_traverse_builtins.map + + inherit Ast.map + end + +class iter = + object + inherit Ppxlib_traverse_builtins.iter + + inherit Ast.iter + end + +class ['acc] fold = + object + inherit ['acc] Ppxlib_traverse_builtins.fold + + inherit ['acc] Ast.fold + end + +class ['acc] fold_map = + object + inherit ['acc] Ppxlib_traverse_builtins.fold_map + + inherit ['acc] Ast.fold_map + end + +class ['ctx] map_with_context = + object + inherit ['ctx] Ppxlib_traverse_builtins.map_with_context + + inherit ['ctx] Ast.map_with_context + end + +class virtual ['res] lift = + object + inherit ['res] Ppxlib_traverse_builtins.lift + + inherit ['res] Ast.lift + end + +let module_name = function None -> "_" | Some name -> name let enter name path = if String.is_empty path then name else path ^ "." ^ name -let enter_opt name_opt path = enter (module_name name_opt) path -class map_with_path = object - inherit [string] map_with_context as super +let enter_opt name_opt path = enter (module_name name_opt) path - (* WAS: - method! structure_item_desc path x = - match x with - | Pstr_module mb -> super#structure_item_desc (enter mb.pmb_name.txt path) x - | _ -> super#structure_item_desc path x - - Overriding [module_binding] seems to be OK because it does not catch - local module bindings because at the moment the parsetree doesn't make - use of [module_binding] for local modules, but that might change in the - future, so this might be something to keep in mind. - - The following: - - module A = struct .. end - module A = struct .. end - - is disallowed, but - - let _ = .. let module A = struct .. end in .. - module A = struct .. end - let _ = .. let module A = struct .. end in .. - - isn't, and the "path" constructed here would be able to differentiate - between them. *) - method! module_binding path mb = - super#module_binding (enter_opt mb.pmb_name.txt path) mb - - method! module_declaration path md = - super#module_declaration (enter_opt md.pmd_name.txt path) md - - method! module_type_declaration path mtd = - super#module_type_declaration (enter mtd.pmtd_name.txt path) mtd -end - -let var_names_of = object - inherit [string list] fold as super - - method! pattern p acc = - let acc = super#pattern p acc in - match p.ppat_desc with - | Ppat_var {txt; _} -> txt :: acc - | _ -> acc -end +class map_with_path = + object + inherit [string] map_with_context as super + + (* WAS: + method! structure_item_desc path x = + match x with + | Pstr_module mb -> super#structure_item_desc (enter mb.pmb_name.txt path) x + | _ -> super#structure_item_desc path x + + Overriding [module_binding] seems to be OK because it does not catch + local module bindings because at the moment the parsetree doesn't make + use of [module_binding] for local modules, but that might change in the + future, so this might be something to keep in mind. + + The following: + + module A = struct .. end + module A = struct .. end + + is disallowed, but + + let _ = .. let module A = struct .. end in .. + module A = struct .. end + let _ = .. let module A = struct .. end in .. + + isn't, and the "path" constructed here would be able to differentiate + between them. *) + method! module_binding path mb = + super#module_binding (enter_opt mb.pmb_name.txt path) mb + + method! module_declaration path md = + super#module_declaration (enter_opt md.pmd_name.txt path) md + + method! module_type_declaration path mtd = + super#module_type_declaration (enter mtd.pmtd_name.txt path) mtd + end + +let var_names_of = + object + inherit [string list] fold as super + + method! pattern p acc = + let acc = super#pattern p acc in + match p.ppat_desc with Ppat_var { txt; _ } -> txt :: acc | _ -> acc + end let ec_enter_module_opt ~loc name_opt ctxt = Expansion_context.Base.enter_module ~loc (module_name name_opt) ctxt -class map_with_expansion_context = object (self) - inherit [Expansion_context.Base.t] map_with_context as super +class map_with_expansion_context = + object (self) + inherit [Expansion_context.Base.t] map_with_context as super + + method! expression ctxt expr = + super#expression (Expansion_context.Base.enter_expr ctxt) expr + + method! module_binding ctxt mb = + super#module_binding + (ec_enter_module_opt ~loc:mb.pmb_loc mb.pmb_name.txt ctxt) + mb + + method! module_declaration ctxt md = + super#module_declaration + (ec_enter_module_opt ~loc:md.pmd_loc md.pmd_name.txt ctxt) + md + + method! module_type_declaration ctxt mtd = + super#module_type_declaration + (Expansion_context.Base.enter_module ~loc:mtd.pmtd_loc mtd.pmtd_name.txt + ctxt) + mtd + + method! value_description ctxt vd = + super#value_description + (Expansion_context.Base.enter_value ~loc:vd.pval_loc vd.pval_name.txt + ctxt) + vd + + method! value_binding ctxt { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } = + let all_var_names = var_names_of#pattern pvb_pat [] in + let var_name = Stdppx.List.last all_var_names in + let in_binding_ctxt = + match var_name with + | None -> ctxt + | Some var_name -> + Expansion_context.Base.enter_value ~loc:pvb_loc var_name ctxt + in + let pvb_pat = self#pattern ctxt pvb_pat in + let pvb_expr = self#expression in_binding_ctxt pvb_expr in + let pvb_attributes = self#attributes in_binding_ctxt pvb_attributes in + let pvb_loc = self#location ctxt pvb_loc in + { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } + end + +class sexp_of = + object + inherit [Sexp.t] Ast.lift + + method int = sexp_of_int + + method string = sexp_of_string + + method bool = sexp_of_bool + + method char = sexp_of_char + + method float = sexp_of_float + + method int32 = sexp_of_int32 + + method int64 = sexp_of_int64 + + method nativeint = sexp_of_nativeint + + method unit = sexp_of_unit + + method option = sexp_of_option + + method list = sexp_of_list + + method array : 'a. ('a -> Sexp.t) -> 'a array -> Sexp.t = sexp_of_array + + method other : 'a. 'a -> Sexp.t = fun _ -> Sexp.Atom "_" - method! expression ctxt expr = - super#expression (Expansion_context.Base.enter_expr ctxt) expr + method record fields = + List + (List.map fields ~f:(fun (label, sexp) -> + Sexp.List [ Atom label; sexp ])) - method! module_binding ctxt mb = - super#module_binding - (ec_enter_module_opt ~loc:mb.pmb_loc mb.pmb_name.txt ctxt) - mb - - method! module_declaration ctxt md = - super#module_declaration - (ec_enter_module_opt ~loc:md.pmd_loc md.pmd_name.txt ctxt) - md - - method! module_type_declaration ctxt mtd = - super#module_type_declaration - (Expansion_context.Base.enter_module ~loc:mtd.pmtd_loc mtd.pmtd_name.txt ctxt) - mtd - - method! value_description ctxt vd = - super#value_description - (Expansion_context.Base.enter_value ~loc:vd.pval_loc vd.pval_name.txt ctxt) - vd - - method! value_binding ctxt {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} = - let all_var_names = var_names_of#pattern pvb_pat [] in - let var_name = Stdppx.List.last all_var_names in - let in_binding_ctxt = - match var_name with - | None -> ctxt - | Some var_name -> Expansion_context.Base.enter_value ~loc:pvb_loc var_name ctxt - in - let pvb_pat = self#pattern ctxt pvb_pat in - let pvb_expr = self#expression in_binding_ctxt pvb_expr in - let pvb_attributes = self#attributes in_binding_ctxt pvb_attributes in - let pvb_loc = self#location ctxt pvb_loc in - { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } -end - -class sexp_of = object - inherit [Sexp.t] Ast.lift - - method int = sexp_of_int - method string = sexp_of_string - method bool = sexp_of_bool - method char = sexp_of_char - method float = sexp_of_float - method int32 = sexp_of_int32 - method int64 = sexp_of_int64 - method nativeint = sexp_of_nativeint - method unit = sexp_of_unit - method option = sexp_of_option - method list = sexp_of_list - method array : 'a. ('a -> Sexp.t) -> 'a array -> Sexp.t = sexp_of_array - - method other : 'a. 'a -> Sexp.t = fun _ -> Sexp.Atom "_" - - method record fields = - List (List.map fields ~f:(fun (label, sexp) -> - Sexp.List [Atom label; sexp])) - - method constr tag args = - match args with - | [] -> Atom tag - | _ -> List (Atom tag :: args) + method constr tag args = + match args with [] -> Atom tag | _ -> List (Atom tag :: args) - method tuple l = List l -end + method tuple l = List l + end let sexp_of = new sexp_of diff -Nru ppxlib-0.15.0/src/ast_traverse.mli ppxlib-0.24.0/src/ast_traverse.mli --- ppxlib-0.15.0/src/ast_traverse.mli 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/ast_traverse.mli 2021-12-08 21:53:37.000000000 +0000 @@ -2,68 +2,82 @@ open! Import -(** To use these classes, inherit from them and override the methods corresponding to the - types from [Parsetree] you want to process. For instance to collect all the string - constants in a structure: +(** To use these classes, inherit from them and override the methods + corresponding to the types from [Parsetree] you want to process. For + instance to collect all the string constants in a structure: {[ - let string_constants_of = object - inherit [string list] Ast_traverse.fold as super - - method! expression e acc = - let acc = super#expression e acc in - match e.pexp_desc with - | Pexp_constant (Const_string (s, _)) -> s :: acc - | _ -> acc - - method! pattern p acc = - let acc = super#pattern p acc in - match p.ppat_desc with - | Ppat_constant (Const_string (s, _)) -> s :: acc - | _ -> acc - end + let string_constants_of = + object + inherit [string list] Ast_traverse.fold as super + + method! expression e acc = + let acc = super#expression e acc in + match e.pexp_desc with + | Pexp_constant (Const_string (s, _)) -> s :: acc + | _ -> acc + + method! pattern p acc = + let acc = super#pattern p acc in + match p.ppat_desc with + | Ppat_constant (Const_string (s, _)) -> s :: acc + | _ -> acc + end let string_constants_of_structure = string_constants_of#structure - ]} -*) + ]} *) + +class map : + object + inherit Ppxlib_traverse_builtins.map + + inherit Ast.map + end + +class iter : + object + inherit Ppxlib_traverse_builtins.iter + + inherit Ast.iter + end + +class ['acc] fold : + object + inherit ['acc] Ppxlib_traverse_builtins.fold -class map : object - inherit Ppxlib_traverse_builtins.map - inherit Ast.map -end - -class iter : object - inherit Ppxlib_traverse_builtins.iter - inherit Ast.iter -end - -class ['acc] fold : object - inherit ['acc] Ppxlib_traverse_builtins.fold - inherit ['acc] Ast.fold -end - -class ['acc] fold_map : object - inherit ['acc] Ppxlib_traverse_builtins.fold_map - inherit ['acc] Ast.fold_map -end - -class ['ctx] map_with_context : object - inherit ['ctx] Ppxlib_traverse_builtins.map_with_context - inherit ['ctx] Ast.map_with_context -end + inherit ['acc] Ast.fold + end + +class ['acc] fold_map : + object + inherit ['acc] Ppxlib_traverse_builtins.fold_map + + inherit ['acc] Ast.fold_map + end + +class ['ctx] map_with_context : + object + inherit ['ctx] Ppxlib_traverse_builtins.map_with_context + + inherit ['ctx] Ast.map_with_context + end class map_with_path : [string] map_with_context class map_with_expansion_context : [Expansion_context.Base.t] map_with_context -class virtual ['res] lift : object - inherit ['res] Ppxlib_traverse_builtins.lift - inherit ['res] Ast.lift -end - -class sexp_of : object - inherit [Sexp.t] Ppxlib_traverse_builtins.std_lifters - inherit [Sexp.t] Ast.lift -end +class virtual ['res] lift : + object + inherit ['res] Ppxlib_traverse_builtins.lift + + inherit ['res] Ast.lift + end + +class sexp_of : + object + inherit [Sexp.t] Ppxlib_traverse_builtins.std_lifters + + inherit [Sexp.t] Ast.lift + end val sexp_of : sexp_of diff -Nru ppxlib-0.15.0/src/attribute.ml ppxlib-0.24.0/src/attribute.ml --- ppxlib-0.15.0/src/attribute.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/attribute.ml 2021-12-08 21:53:37.000000000 +0000 @@ -5,69 +5,95 @@ type t = T : _ -> t end in Stdppx.Poly.equal (Poly.T a) (Poly.T b) -;; module Context = struct type 'a t = - | Label_declaration : label_declaration t + | Label_declaration : label_declaration t | Constructor_declaration : constructor_declaration t - | Type_declaration : type_declaration t - | Type_exception : type_exception t - | Type_extension : type_extension t - | Extension_constructor : extension_constructor t - | Pattern : pattern t - | Core_type : core_type t - | Expression : expression t - | Value_description : value_description t - | Class_type : class_type t - | Class_type_field : class_type_field t - | Class_infos : _ class_infos t - | Class_expr : class_expr t - | Class_field : class_field t - | Module_type : module_type t - | Module_declaration : module_declaration t + | Type_declaration : type_declaration t + | Type_exception : type_exception t + | Type_extension : type_extension t + | Extension_constructor : extension_constructor t + | Pattern : pattern t + | Core_type : core_type t + | Expression : expression t + | Value_description : value_description t + | Class_type : class_type t + | Class_type_field : class_type_field t + | Class_infos : _ class_infos t + | Class_expr : class_expr t + | Class_field : class_field t + | Module_type : module_type t + | Module_declaration : module_declaration t | Module_type_declaration : module_type_declaration t - | Module_substitution : module_substitution t - | Open_description : open_description t - | Open_declaration : open_declaration t - | Include_infos : _ include_infos t - | Module_expr : module_expr t - | Value_binding : value_binding t - | Module_binding : module_binding t - | Pstr_eval : structure_item t - | Pstr_extension : structure_item t - | Psig_extension : signature_item t - | Rtag : row_field t - | Object_type_field : object_field t + | Module_substitution : module_substitution t + | Open_description : open_description t + | Open_declaration : open_declaration t + | Include_infos : _ include_infos t + | Module_expr : module_expr t + | Value_binding : value_binding t + | Module_binding : module_binding t + | Pstr_eval : structure_item t + | Pstr_extension : structure_item t + | Psig_extension : signature_item t + | Rtag : row_field t + | Object_type_field : object_field t + + let label_declaration = Label_declaration - let label_declaration = Label_declaration let constructor_declaration = Constructor_declaration - let type_declaration = Type_declaration - let type_extension = Type_extension - let type_exception = Type_exception - let extension_constructor = Extension_constructor - let pattern = Pattern - let core_type = Core_type - let expression = Expression - let value_description = Value_description - let class_type = Class_type - let class_type_field = Class_type_field - let class_infos = Class_infos - let class_expr = Class_expr - let class_field = Class_field - let module_type = Module_type - let module_declaration = Module_declaration + + let type_declaration = Type_declaration + + let type_extension = Type_extension + + let type_exception = Type_exception + + let extension_constructor = Extension_constructor + + let pattern = Pattern + + let core_type = Core_type + + let expression = Expression + + let value_description = Value_description + + let class_type = Class_type + + let class_type_field = Class_type_field + + let class_infos = Class_infos + + let class_expr = Class_expr + + let class_field = Class_field + + let module_type = Module_type + + let module_declaration = Module_declaration + let module_type_declaration = Module_type_declaration - let open_description = Open_description - let include_infos = Include_infos - let module_expr = Module_expr - let value_binding = Value_binding - let module_binding = Module_binding - let pstr_eval = Pstr_eval - let pstr_extension = Pstr_extension - let psig_extension = Psig_extension - let rtag = Rtag - let object_type_field = Object_type_field + + let open_description = Open_description + + let include_infos = Include_infos + + let module_expr = Module_expr + + let value_binding = Value_binding + + let module_binding = Module_binding + + let pstr_eval = Pstr_eval + + let pstr_extension = Pstr_extension + + let psig_extension = Psig_extension + + let rtag = Rtag + + let object_type_field = Object_type_field let get_pstr_eval st = match st.pstr_desc with @@ -84,108 +110,116 @@ | Psig_extension (e, l) -> (e, l) | _ -> failwith "Attribute.Context.get_psig_extension" - let get_attributes : type a. a t -> a -> attributes = fun t x -> + let get_attributes : type a. a t -> a -> attributes = + fun t x -> match t with - | Label_declaration -> x.pld_attributes + | Label_declaration -> x.pld_attributes | Constructor_declaration -> x.pcd_attributes - | Type_declaration -> x.ptype_attributes - | Type_extension -> x.ptyext_attributes - | Type_exception -> x.ptyexn_attributes - | Extension_constructor -> x.pext_attributes - | Pattern -> x.ppat_attributes - | Core_type -> x.ptyp_attributes - | Expression -> x.pexp_attributes - | Value_description -> x.pval_attributes - | Class_type -> x.pcty_attributes - | Class_type_field -> x.pctf_attributes - | Class_infos -> x.pci_attributes - | Class_expr -> x.pcl_attributes - | Class_field -> x.pcf_attributes - | Module_type -> x.pmty_attributes - | Module_declaration -> x.pmd_attributes + | Type_declaration -> x.ptype_attributes + | Type_extension -> x.ptyext_attributes + | Type_exception -> x.ptyexn_attributes + | Extension_constructor -> x.pext_attributes + | Pattern -> x.ppat_attributes + | Core_type -> x.ptyp_attributes + | Expression -> x.pexp_attributes + | Value_description -> x.pval_attributes + | Class_type -> x.pcty_attributes + | Class_type_field -> x.pctf_attributes + | Class_infos -> x.pci_attributes + | Class_expr -> x.pcl_attributes + | Class_field -> x.pcf_attributes + | Module_type -> x.pmty_attributes + | Module_declaration -> x.pmd_attributes | Module_type_declaration -> x.pmtd_attributes - | Module_substitution -> x.pms_attributes - | Open_description -> x.popen_attributes - | Open_declaration -> x.popen_attributes - | Include_infos -> x.pincl_attributes - | Module_expr -> x.pmod_attributes - | Value_binding -> x.pvb_attributes - | Module_binding -> x.pmb_attributes - | Pstr_eval -> snd (get_pstr_eval x) - | Pstr_extension -> snd (get_pstr_extension x) - | Psig_extension -> snd (get_psig_extension x) - | Rtag -> x.prf_attributes - | Object_type_field -> x.pof_attributes + | Module_substitution -> x.pms_attributes + | Open_description -> x.popen_attributes + | Open_declaration -> x.popen_attributes + | Include_infos -> x.pincl_attributes + | Module_expr -> x.pmod_attributes + | Value_binding -> x.pvb_attributes + | Module_binding -> x.pmb_attributes + | Pstr_eval -> snd (get_pstr_eval x) + | Pstr_extension -> snd (get_pstr_extension x) + | Psig_extension -> snd (get_psig_extension x) + | Rtag -> x.prf_attributes + | Object_type_field -> x.pof_attributes - let set_attributes : type a. a t -> a -> attributes -> a = fun t x attrs -> + let set_attributes : type a. a t -> a -> attributes -> a = + fun t x attrs -> match t with - | Label_declaration -> { x with pld_attributes = attrs } - | Constructor_declaration -> { x with pcd_attributes = attrs } - | Type_declaration -> { x with ptype_attributes = attrs } - | Type_extension -> { x with ptyext_attributes = attrs } - | Type_exception -> { x with ptyexn_attributes = attrs } - | Extension_constructor -> { x with pext_attributes = attrs } - | Pattern -> { x with ppat_attributes = attrs } - | Core_type -> { x with ptyp_attributes = attrs } - | Expression -> { x with pexp_attributes = attrs } - | Value_description -> { x with pval_attributes = attrs } - | Class_type -> { x with pcty_attributes = attrs } - | Class_type_field -> { x with pctf_attributes = attrs } - | Class_infos -> { x with pci_attributes = attrs } - | Class_expr -> { x with pcl_attributes = attrs } - | Class_field -> { x with pcf_attributes = attrs } - | Module_type -> { x with pmty_attributes = attrs } - | Module_declaration -> { x with pmd_attributes = attrs } - | Module_type_declaration -> { x with pmtd_attributes = attrs } - | Module_substitution -> { x with pms_attributes = attrs } - | Open_description -> { x with popen_attributes = attrs } - | Open_declaration -> { x with popen_attributes = attrs } - | Include_infos -> { x with pincl_attributes = attrs } - | Module_expr -> { x with pmod_attributes = attrs } - | Value_binding -> { x with pvb_attributes = attrs } - | Module_binding -> { x with pmb_attributes = attrs } + | Label_declaration -> { x with pld_attributes = attrs } + | Constructor_declaration -> { x with pcd_attributes = attrs } + | Type_declaration -> { x with ptype_attributes = attrs } + | Type_extension -> { x with ptyext_attributes = attrs } + | Type_exception -> { x with ptyexn_attributes = attrs } + | Extension_constructor -> { x with pext_attributes = attrs } + | Pattern -> { x with ppat_attributes = attrs } + | Core_type -> { x with ptyp_attributes = attrs } + | Expression -> { x with pexp_attributes = attrs } + | Value_description -> { x with pval_attributes = attrs } + | Class_type -> { x with pcty_attributes = attrs } + | Class_type_field -> { x with pctf_attributes = attrs } + | Class_infos -> { x with pci_attributes = attrs } + | Class_expr -> { x with pcl_attributes = attrs } + | Class_field -> { x with pcf_attributes = attrs } + | Module_type -> { x with pmty_attributes = attrs } + | Module_declaration -> { x with pmd_attributes = attrs } + | Module_type_declaration -> { x with pmtd_attributes = attrs } + | Module_substitution -> { x with pms_attributes = attrs } + | Open_description -> { x with popen_attributes = attrs } + | Open_declaration -> { x with popen_attributes = attrs } + | Include_infos -> { x with pincl_attributes = attrs } + | Module_expr -> { x with pmod_attributes = attrs } + | Value_binding -> { x with pvb_attributes = attrs } + | Module_binding -> { x with pmb_attributes = attrs } | Pstr_eval -> - { x with pstr_desc = Pstr_eval (get_pstr_eval x |> fst, attrs) } + { x with pstr_desc = Pstr_eval (get_pstr_eval x |> fst, attrs) } | Pstr_extension -> - { x with pstr_desc = Pstr_extension (get_pstr_extension x |> fst, attrs) } + { + x with + pstr_desc = Pstr_extension (get_pstr_extension x |> fst, attrs); + } | Psig_extension -> - { x with psig_desc = Psig_extension (get_psig_extension x |> fst, attrs) } - | Rtag -> { x with prf_attributes = attrs} - | Object_type_field -> { x with pof_attributes = attrs} + { + x with + psig_desc = Psig_extension (get_psig_extension x |> fst, attrs); + } + | Rtag -> { x with prf_attributes = attrs } + | Object_type_field -> { x with pof_attributes = attrs } let desc : type a. a t -> string = function - | Label_declaration -> "label declaration" + | Label_declaration -> "label declaration" | Constructor_declaration -> "constructor declaration" - | Type_declaration -> "type declaration" - | Type_extension -> "type extension" - | Type_exception -> "type exception" - | Extension_constructor -> "extension constructor" - | Pattern -> "pattern" - | Core_type -> "core type" - | Expression -> "expression" - | Value_description -> "value" - | Class_type -> "class type" - | Class_type_field -> "class type field" - | Class_infos -> "class declaration" - | Class_expr -> "class expression" - | Class_field -> "class field" - | Module_type -> "module type" - | Module_declaration -> "module declaration" + | Type_declaration -> "type declaration" + | Type_extension -> "type extension" + | Type_exception -> "type exception" + | Extension_constructor -> "extension constructor" + | Pattern -> "pattern" + | Core_type -> "core type" + | Expression -> "expression" + | Value_description -> "value" + | Class_type -> "class type" + | Class_type_field -> "class type field" + | Class_infos -> "class declaration" + | Class_expr -> "class expression" + | Class_field -> "class field" + | Module_type -> "module type" + | Module_declaration -> "module declaration" | Module_type_declaration -> "module type declaration" - | Module_substitution -> "module substitution" - | Open_description -> "open" - | Open_declaration -> "open" - | Include_infos -> "include" - | Module_expr -> "module expression" - | Value_binding -> "value binding" - | Module_binding -> "module binding" - | Pstr_eval -> "toplevel expression" - | Pstr_extension -> "toplevel extension" - | Psig_extension -> "toplevel signature extension" - | Rtag -> "polymorphic variant tag" - | Object_type_field -> "object type field" + | Module_substitution -> "module substitution" + | Open_description -> "open" + | Open_declaration -> "open" + | Include_infos -> "include" + | Module_expr -> "module expression" + | Value_binding -> "value binding" + | Module_binding -> "module binding" + | Pstr_eval -> "toplevel expression" + | Pstr_extension -> "toplevel extension" + | Psig_extension -> "toplevel signature extension" + | Rtag -> "polymorphic variant tag" + | Object_type_field -> "object type field" -(* + (* let pattern : type a b c d. a t -> (attributes, b, c) Ast_pattern.t -> (a, c, d) Ast_pattern.t @@ -202,155 +236,150 @@ module Floating_context = struct type 'a t = - | Structure_item : structure_item t - | Signature_item : signature_item t - | Class_field : class_field t + | Structure_item : structure_item t + | Signature_item : signature_item t + | Class_field : class_field t | Class_type_field : class_type_field t - let structure_item = Structure_item - let signature_item = Signature_item - let class_field = Class_field + let structure_item = Structure_item + + let signature_item = Signature_item + + let class_field = Class_field + let class_type_field = Class_type_field - let get_attribute_if_is_floating_node : type a. a t -> a -> attribute option - = fun t x -> - match t, x with - | Structure_item , { pstr_desc = Pstr_attribute a; _ } -> Some a - | Signature_item , { psig_desc = Psig_attribute a; _ } -> Some a - | Class_field , { pcf_desc = Pcf_attribute a; _ } -> Some a - | Class_type_field , { pctf_desc = Pctf_attribute a; _ } -> Some a - | _ -> None + let get_attribute_if_is_floating_node : type a. a t -> a -> attribute option = + fun t x -> + match (t, x) with + | Structure_item, { pstr_desc = Pstr_attribute a; _ } -> Some a + | Signature_item, { psig_desc = Psig_attribute a; _ } -> Some a + | Class_field, { pcf_desc = Pcf_attribute a; _ } -> Some a + | Class_type_field, { pctf_desc = Pctf_attribute a; _ } -> Some a + | _ -> None let get_attribute t x = match get_attribute_if_is_floating_node t x with | Some a -> a - | None -> failwith "Attribute.Floating.Context.get_attribute" + | None -> failwith "Attribute.Floating.Context.get_attribute" let replace_by_dummy : type a. a t -> a -> a = let dummy_ext = ({ txt = ""; loc = Location.none }, PStr []) in fun t x -> - match t with - | Structure_item -> { x with pstr_desc = Pstr_extension (dummy_ext, []) } - | Signature_item -> { x with psig_desc = Psig_extension (dummy_ext, []) } - | Class_field -> { x with pcf_desc = Pcf_extension dummy_ext } - | Class_type_field -> { x with pctf_desc = Pctf_extension dummy_ext } + match t with + | Structure_item -> { x with pstr_desc = Pstr_extension (dummy_ext, []) } + | Signature_item -> { x with psig_desc = Psig_extension (dummy_ext, []) } + | Class_field -> { x with pcf_desc = Pcf_extension dummy_ext } + | Class_type_field -> { x with pctf_desc = Pctf_extension dummy_ext } let desc : type a. a t -> string = function - | Structure_item -> "structure item" - | Signature_item -> "signature item" - | Class_field -> "class field" + | Structure_item -> "structure item" + | Signature_item -> "signature item" + | Class_field -> "class field" | Class_type_field -> "class type field" let equal : _ t -> _ t -> bool = poly_equal end type packed_context = - | On_item : _ Context.t -> packed_context + | On_item : _ Context.t -> packed_context | Floating : _ Floating_context.t -> packed_context type _ payload_parser = - Payload_parser - : (payload, 'a, 'b) Ast_pattern.t * (name_loc:Location.t -> 'a) - -> 'b payload_parser - -type ('a, 'b) t = - { name : Name.Pattern.t - ; context : 'a Context.t - ; payload : 'b payload_parser - } + | Payload_parser : + (payload, 'a, 'b) Ast_pattern.t * (name_loc:Location.t -> 'a) + -> 'b payload_parser + +type ('a, 'b) t = { + name : Name.Pattern.t; + context : 'a Context.t; + payload : 'b payload_parser; +} type packed = T : (_, _) t -> packed let name t = Name.Pattern.name t.name + let context t = t.context let registrar = - Name.Registrar.create - ~kind:"attribute" - ~current_file:__FILE__ + Name.Registrar.create ~kind:"attribute" ~current_file:__FILE__ ~string_of_context:(function - | On_item t -> Some (Context .desc t) - | Floating t -> Some (Floating_context.desc t ^ " (floating)")) -;; + | On_item t -> Some (Context.desc t) + | Floating t -> Some (Floating_context.desc t ^ " (floating)")) let declare_with_name_loc name context pattern k = Name.Registrar.register ~kind:`Attribute registrar (On_item context) name; - { name = Name.Pattern.make name - ; context - ; payload = Payload_parser (pattern, k) + { + name = Name.Pattern.make name; + context; + payload = Payload_parser (pattern, k); } -;; let declare name context pattern k = declare_with_name_loc name context pattern (fun ~name_loc:_ -> k) -;; -module Attribute_table = Caml.Hashtbl.Make(struct - type t = string loc - let hash : t -> int = Hashtbl.hash - let equal : t -> t -> bool = Poly.equal - end) +module Attribute_table = Caml.Hashtbl.Make (struct + type t = string loc + + let hash : t -> int = Hashtbl.hash + + let equal : t -> t -> bool = Poly.equal +end) let not_seen = Attribute_table.create 128 -let mark_as_seen { attr_name; _ } = - Attribute_table.remove not_seen attr_name -;; +let mark_as_seen { attr_name; _ } = Attribute_table.remove not_seen attr_name let mark_as_handled_manually = mark_as_seen -let explicitly_drop = object - inherit Ast_traverse.iter - method! attribute = mark_as_seen -end +let explicitly_drop = + object + inherit Ast_traverse.iter + + method! attribute = mark_as_seen + end let get_internal = let rec find_best_match t attributes longest_match = match attributes with | [] -> longest_match - | { attr_name = name; _ } as attr :: rest -> - if Name.Pattern.matches t.name name.txt then begin - match longest_match with - | None -> find_best_match t rest (Some attr) - | Some { attr_name = name'; _ } -> - let len = String.length name.txt in - let len' = String.length name'.txt in - if len > len' then - find_best_match t rest (Some attr) - else if len < len' then - find_best_match t rest longest_match - else - Location.raise_errorf ~loc:name.loc "Duplicated attribute" - end else - find_best_match t rest longest_match + | ({ attr_name = name; _ } as attr) :: rest -> + if Name.Pattern.matches t.name name.txt then + match longest_match with + | None -> find_best_match t rest (Some attr) + | Some { attr_name = name'; _ } -> + let len = String.length name.txt in + let len' = String.length name'.txt in + if len > len' then find_best_match t rest (Some attr) + else if len < len' then find_best_match t rest longest_match + else Location.raise_errorf ~loc:name.loc "Duplicated attribute" + else find_best_match t rest longest_match in - fun t attributes -> - find_best_match t attributes None -;; + fun t attributes -> find_best_match t attributes None let convert ?(do_mark_as_seen = true) pattern attr = if do_mark_as_seen then mark_as_seen attr; let (Payload_parser (pattern, k)) = pattern in - Ast_pattern.parse pattern (Common.loc_of_payload attr) attr.attr_payload + Ast_pattern.parse pattern + (Common.loc_of_payload attr) + attr.attr_payload (k ~name_loc:attr.attr_name.loc) -;; let get t ?mark_as_seen:do_mark_as_seen x = let attrs = Context.get_attributes t.context x in match get_internal t attrs with | None -> None | Some attr -> Some (convert t.payload attr ?do_mark_as_seen) -;; let consume t x = let attrs = Context.get_attributes t.context x in match get_internal t attrs with | None -> None | Some attr -> - let attrs = List.filter attrs ~f:(fun attr' -> not (attr == attr')) in - let x = Context.set_attributes t.context x attrs in - Some (x, convert t.payload attr) -;; + let attrs = List.filter attrs ~f:(fun attr' -> not (attr == attr')) in + let x = Context.set_attributes t.context x attrs in + Some (x, convert t.payload attr) let remove_seen (type a) (context : a Context.t) packeds (x : a) = let attrs = Context.get_attributes context x in @@ -358,192 +387,232 @@ let rec loop acc = function | [] -> acc | T t :: rest -> - if Context.equal t.context context then - match get_internal t attrs with - | None -> loop acc rest - | Some attr -> - let name = attr.attr_name in - if Attribute_table.mem not_seen name then - loop acc rest - else - loop (attr :: acc) rest - else - loop acc rest + if Context.equal t.context context then + match get_internal t attrs with + | None -> loop acc rest + | Some attr -> + let name = attr.attr_name in + if Attribute_table.mem not_seen name then loop acc rest + else loop (attr :: acc) rest + else loop acc rest in loop [] packeds in let attrs = - List.filter attrs ~f:(fun attr' -> - not (List.memq ~set:matched attr')) + List.filter attrs ~f:(fun attr' -> not (List.memq ~set:matched attr')) in Context.set_attributes context x attrs -;; let pattern t p = let f = Ast_pattern.to_func p in Ast_pattern.of_func (fun ctx loc x k -> - match consume t x with - | None -> f ctx loc x (k None) - | Some (x, v) -> f ctx loc x (k (Some v)) - ) -;; + match consume t x with + | None -> f ctx loc x (k None) + | Some (x, v) -> f ctx loc x (k (Some v))) module Floating = struct module Context = Floating_context - type ('a, 'b) t = - { name : Name.Pattern.t - ; context : 'a Context.t - ; payload : 'b payload_parser - } + type ('a, 'b) t = { + name : Name.Pattern.t; + context : 'a Context.t; + payload : 'b payload_parser; + } let name t = Name.Pattern.name t.name let declare name context pattern k = Name.Registrar.register ~kind:`Attribute registrar (Floating context) name; - { name = Name.Pattern.make name - ; context - ; payload = Payload_parser (pattern, fun ~name_loc:_ -> k) + { + name = Name.Pattern.make name; + context; + payload = Payload_parser (pattern, fun ~name_loc:_ -> k); } - ;; let convert ts x = match ts with | [] -> None - | { context; _ } :: _ -> - assert (List.for_all ts ~f:(fun t -> Context.equal t.context context)); - let attr = Context.get_attribute context x in - let name = attr.attr_name in - match List.filter ts ~f:(fun t -> Name.Pattern.matches t.name name.txt) with - | [] -> None - | [t] -> Some (convert t.payload attr) - | l -> - Location.raise_errorf ~loc:name.loc - "Multiple match for floating attributes: %s" - (String.concat ~sep:", " (List.map l ~f:(fun t -> Name.Pattern.name t.name))) - ;; + | { context; _ } :: _ -> ( + assert (List.for_all ts ~f:(fun t -> Context.equal t.context context)); + let attr = Context.get_attribute context x in + let name = attr.attr_name in + match + List.filter ts ~f:(fun t -> Name.Pattern.matches t.name name.txt) + with + | [] -> None + | [ t ] -> Some (convert t.payload attr) + | l -> + Location.raise_errorf ~loc:name.loc + "Multiple match for floating attributes: %s" + (String.concat ~sep:", " + (List.map l ~f:(fun t -> Name.Pattern.name t.name)))) end let check_attribute registrar context name = - if not (Name.Whitelisted.is_whitelisted ~kind:`Attribute name.txt - || Name.ignore_checks name.txt) - && Attribute_table.mem not_seen name then + if + (not + (Name.Whitelisted.is_whitelisted ~kind:`Attribute name.txt + || Name.ignore_checks name.txt)) + && Attribute_table.mem not_seen name + then let white_list = Name.Whitelisted.get_attribute_list () in Name.Registrar.raise_errorf registrar context ~white_list "Attribute `%s' was not used" name -;; - -let check_unused = object(self) - inherit Ast_traverse.iter as super - - method! attribute { attr_name = name; _ } = - Location.raise_errorf ~loc:name.loc - "attribute not expected here, Ppxlib.Attribute needs updating!" - - method private check_node : type a. a Context.t -> a -> a = fun context node -> - let attrs = Context.get_attributes context node in - match attrs with - | [] -> node - | _ -> - List.iter attrs ~f:(fun ({ attr_name = name; attr_payload = payload; _ } as attr) -> - self#payload payload; - check_attribute registrar (On_item context) name; - (* If we allow the attribute to pass through, mark it as seen *) - mark_as_seen attr); - Context.set_attributes context node [] - - method private check_floating : type a. a Floating.Context.t -> a -> a - = fun context node -> - match Floating.Context.get_attribute_if_is_floating_node context node with - | None -> node - | Some ({ attr_name = name; attr_payload = payload; _ } as attr) -> - self#payload payload; - check_attribute registrar (Floating context) name; - mark_as_seen attr; - Floating.Context.replace_by_dummy context node - - method! label_declaration x = super#label_declaration (self#check_node Label_declaration x) - method! constructor_declaration x = super#constructor_declaration (self#check_node Constructor_declaration x) - method! type_declaration x = super#type_declaration (self#check_node Type_declaration x) - method! type_extension x = super#type_extension (self#check_node Type_extension x) - method! type_exception x = super#type_exception (self#check_node Type_exception x) - method! extension_constructor x = super#extension_constructor (self#check_node Extension_constructor x) - method! pattern x = super#pattern (self#check_node Pattern x) - method! core_type x = super#core_type (self#check_node Core_type x) - method! expression x = super#expression (self#check_node Expression x) - method! value_description x = super#value_description (self#check_node Value_description x) - method! class_type x = super#class_type (self#check_node Class_type x) - method! class_infos f x = super#class_infos f (self#check_node Class_infos x) - method! class_expr x = super#class_expr (self#check_node Class_expr x) - method! module_type x = super#module_type (self#check_node Module_type x) - method! module_declaration x = super#module_declaration (self#check_node Module_declaration x) - method! module_type_declaration x = super#module_type_declaration (self#check_node Module_type_declaration x) - method! open_description x = super#open_description (self#check_node Open_description x) - method! open_declaration x = super#open_declaration (self#check_node Open_declaration x) - method! include_infos f x = super#include_infos f (self#check_node Include_infos x) - method! module_expr x = super#module_expr (self#check_node Module_expr x) - method! value_binding x = super#value_binding (self#check_node Value_binding x) - method! module_binding x = super#module_binding (self#check_node Module_binding x) - - method! class_field x = - let x = self#check_node Class_field x in - let x = self#check_floating Class_field x in - super#class_field x - - method! class_type_field x = - let x = self#check_node Class_type_field x in - let x = self#check_floating Class_type_field x in - super#class_type_field x - - method! row_field x = - let x = - match x.prf_desc with - | Rtag _ -> self#check_node Rtag x - | _ -> x - in - super#row_field x - - method! core_type_desc x = - let x = - match x with - | Ptyp_object (fields, closed_flag) -> - let fields = List.map fields ~f:(self#check_node Object_type_field) in - Ptyp_object (fields, closed_flag) - | _ -> x - in - super#core_type_desc x - - method! structure_item item = - let item = self#check_floating Structure_item item in - let item = - match item.pstr_desc with - | Pstr_eval _ -> self#check_node Pstr_eval item - | Pstr_extension _ -> self#check_node Pstr_extension item - | _ -> item - in - super#structure_item item - - method! signature_item item = - let item = self#check_floating Signature_item item in - let item = - match item.psig_desc with - | Psig_extension _ -> self#check_node Psig_extension item - | _ -> item - in - super#signature_item item -end +let check_unused = + object (self) + inherit Ast_traverse.iter as super + + method! attribute { attr_name = name; _ } = + Location.raise_errorf ~loc:name.loc + "attribute not expected here, Ppxlib.Attribute needs updating!" + + method private check_node : type a. a Context.t -> a -> a = + fun context node -> + let attrs = Context.get_attributes context node in + match attrs with + | [] -> node + | _ -> + List.iter attrs + ~f:(fun ({ attr_name = name; attr_payload = payload; _ } as attr) + -> + self#payload payload; + check_attribute registrar (On_item context) name; + (* If we allow the attribute to pass through, mark it as seen *) + mark_as_seen attr); + Context.set_attributes context node [] + + method private check_floating : type a. a Floating.Context.t -> a -> a = + fun context node -> + match + Floating.Context.get_attribute_if_is_floating_node context node + with + | None -> node + | Some ({ attr_name = name; attr_payload = payload; _ } as attr) -> + self#payload payload; + check_attribute registrar (Floating context) name; + mark_as_seen attr; + Floating.Context.replace_by_dummy context node + + method! label_declaration x = + super#label_declaration (self#check_node Label_declaration x) + + method! constructor_declaration x = + super#constructor_declaration (self#check_node Constructor_declaration x) + + method! type_declaration x = + super#type_declaration (self#check_node Type_declaration x) + + method! type_extension x = + super#type_extension (self#check_node Type_extension x) + + method! type_exception x = + super#type_exception (self#check_node Type_exception x) + + method! extension_constructor x = + super#extension_constructor (self#check_node Extension_constructor x) + + method! pattern x = super#pattern (self#check_node Pattern x) + + method! core_type x = super#core_type (self#check_node Core_type x) + + method! expression x = super#expression (self#check_node Expression x) + + method! value_description x = + super#value_description (self#check_node Value_description x) + + method! class_type x = super#class_type (self#check_node Class_type x) + + method! class_infos f x = + super#class_infos f (self#check_node Class_infos x) + + method! class_expr x = super#class_expr (self#check_node Class_expr x) + + method! module_type x = super#module_type (self#check_node Module_type x) + + method! module_declaration x = + super#module_declaration (self#check_node Module_declaration x) + + method! module_type_declaration x = + super#module_type_declaration (self#check_node Module_type_declaration x) + + method! open_description x = + super#open_description (self#check_node Open_description x) + + method! open_declaration x = + super#open_declaration (self#check_node Open_declaration x) + + method! include_infos f x = + super#include_infos f (self#check_node Include_infos x) + + method! module_expr x = super#module_expr (self#check_node Module_expr x) + + method! value_binding x = + super#value_binding (self#check_node Value_binding x) + + method! module_binding x = + super#module_binding (self#check_node Module_binding x) + + method! class_field x = + let x = self#check_node Class_field x in + let x = self#check_floating Class_field x in + super#class_field x + + method! class_type_field x = + let x = self#check_node Class_type_field x in + let x = self#check_floating Class_type_field x in + super#class_type_field x + + method! row_field x = + let x = + match x.prf_desc with Rtag _ -> self#check_node Rtag x | _ -> x + in + super#row_field x + + method! core_type_desc x = + let x = + match x with + | Ptyp_object (fields, closed_flag) -> + let fields = + List.map fields ~f:(self#check_node Object_type_field) + in + Ptyp_object (fields, closed_flag) + | _ -> x + in + super#core_type_desc x + + method! structure_item item = + let item = self#check_floating Structure_item item in + let item = + match item.pstr_desc with + | Pstr_eval _ -> self#check_node Pstr_eval item + | Pstr_extension _ -> self#check_node Pstr_extension item + | _ -> item + in + super#structure_item item + + method! signature_item item = + let item = self#check_floating Signature_item item in + let item = + match item.psig_desc with + | Psig_extension _ -> self#check_node Psig_extension item + | _ -> item + in + super#signature_item item + end let reset_checks () = Attribute_table.clear not_seen -let collect = object - inherit Ast_traverse.iter as super - - method! attribute ({ attr_name = name; attr_payload = payload; _ } as attr) = - let loc = Common.loc_of_attribute attr in - super#payload payload; - Attribute_table.add not_seen name loc -end +let collect = + object + inherit Ast_traverse.iter as super + + method! attribute ({ attr_name = name; attr_payload = payload; _ } as attr) + = + let loc = Common.loc_of_attribute attr in + super#payload payload; + Attribute_table.add not_seen name loc + end let check_all_seen () = let fail name loc = @@ -552,30 +621,31 @@ Location.raise_errorf ~loc "Attribute `%s' was silently dropped" txt in Attribute_table.iter fail not_seen -;; - -let remove_attributes_present_in table = object - inherit Ast_traverse.iter as super - method! attribute { attr_name = name; attr_payload = payload; _ } = - super#payload payload; - Attribute_table.remove table name -end +let remove_attributes_present_in table = + object + inherit Ast_traverse.iter as super + + method! attribute { attr_name = name; attr_payload = payload; _ } = + super#payload payload; + Attribute_table.remove table name + end let copy_of_not_seen () = let copy = Attribute_table.create (Attribute_table.length not_seen) in Attribute_table.iter (Attribute_table.add copy) not_seen; copy -;; let dropped_so_far_structure st = let table = copy_of_not_seen () in (remove_attributes_present_in table)#structure st; - Attribute_table.fold (fun name loc acc -> { txt = name.txt; loc } :: acc) table [] -;; + Attribute_table.fold + (fun name loc acc -> { txt = name.txt; loc } :: acc) + table [] let dropped_so_far_signature sg = let table = copy_of_not_seen () in (remove_attributes_present_in table)#signature sg; - Attribute_table.fold (fun name loc acc -> { txt = name.txt; loc } :: acc) table [] -;; + Attribute_table.fold + (fun name loc acc -> { txt = name.txt; loc } :: acc) + table [] diff -Nru ppxlib-0.15.0/src/attribute.mli ppxlib-0.24.0/src/attribute.mli --- ppxlib-0.15.0/src/attribute.mli 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/attribute.mli 2021-12-08 21:53:37.000000000 +0000 @@ -1,222 +1,240 @@ (** Attribute hygiene *) -(** This module provides hygiene for attributes. The goal is to report misuses of - attributes to the user as soon as possible so that no mistyped attribute get silently - ignored. *) +(** This module provides hygiene for attributes. The goal is to report misuses + of attributes to the user as soon as possible so that no mistyped attribute + get silently ignored. *) open! Import type ('context, 'payload) t (** Type of declared attribute. - The ['context] type parameter describes where the attribute is expected and the - ['payload] one what its payload should contain. *) + The ['context] type parameter describes where the attribute is expected and + the ['payload] one what its payload should contain. *) type packed = T : (_, _) t -> packed module Context : sig type 'a t = - | Label_declaration : label_declaration t + | Label_declaration : label_declaration t | Constructor_declaration : constructor_declaration t - | Type_declaration : type_declaration t - | Type_exception : type_exception t - | Type_extension : type_extension t - | Extension_constructor : extension_constructor t - | Pattern : pattern t - | Core_type : core_type t - | Expression : expression t - | Value_description : value_description t - | Class_type : class_type t - | Class_type_field : class_type_field t - | Class_infos : _ class_infos t - | Class_expr : class_expr t - | Class_field : class_field t - | Module_type : module_type t - | Module_declaration : module_declaration t + | Type_declaration : type_declaration t + | Type_exception : type_exception t + | Type_extension : type_extension t + | Extension_constructor : extension_constructor t + | Pattern : pattern t + | Core_type : core_type t + | Expression : expression t + | Value_description : value_description t + | Class_type : class_type t + | Class_type_field : class_type_field t + | Class_infos : _ class_infos t + | Class_expr : class_expr t + | Class_field : class_field t + | Module_type : module_type t + | Module_declaration : module_declaration t | Module_type_declaration : module_type_declaration t - | Module_substitution : module_substitution t - | Open_description : open_description t - | Open_declaration : open_declaration t - | Include_infos : _ include_infos t - | Module_expr : module_expr t - | Value_binding : value_binding t - | Module_binding : module_binding t - | Pstr_eval : structure_item t - | Pstr_extension : structure_item t - | Psig_extension : signature_item t - | Rtag : row_field t - | Object_type_field : object_field t + | Module_substitution : module_substitution t + | Open_description : open_description t + | Open_declaration : open_declaration t + | Include_infos : _ include_infos t + | Module_expr : module_expr t + | Value_binding : value_binding t + | Module_binding : module_binding t + | Pstr_eval : structure_item t + | Pstr_extension : structure_item t + | Psig_extension : signature_item t + | Rtag : row_field t + | Object_type_field : object_field t + + val label_declaration : label_declaration t - val label_declaration : label_declaration t val constructor_declaration : constructor_declaration t - val type_declaration : type_declaration t - val type_extension : type_extension t - val type_exception : type_exception t - val extension_constructor : extension_constructor t - val pattern : pattern t - val core_type : core_type t - val expression : expression t - val value_description : value_description t - val class_type : class_type t - val class_type_field : class_type_field t - val class_infos : _ class_infos t - val class_expr : class_expr t - val class_field : class_field t - val module_type : module_type t - val module_declaration : module_declaration t + + val type_declaration : type_declaration t + + val type_extension : type_extension t + + val type_exception : type_exception t + + val extension_constructor : extension_constructor t + + val pattern : pattern t + + val core_type : core_type t + + val expression : expression t + + val value_description : value_description t + + val class_type : class_type t + + val class_type_field : class_type_field t + + val class_infos : _ class_infos t + + val class_expr : class_expr t + + val class_field : class_field t + + val module_type : module_type t + + val module_declaration : module_declaration t + val module_type_declaration : module_type_declaration t - val open_description : open_description t - val include_infos : _ include_infos t - val module_expr : module_expr t - val value_binding : value_binding t - val module_binding : module_binding t - val pstr_eval : structure_item t - val pstr_extension : structure_item t - val psig_extension : signature_item t - val rtag : row_field t - val object_type_field : object_field t + + val open_description : open_description t + + val include_infos : _ include_infos t + + val module_expr : module_expr t + + val value_binding : value_binding t + + val module_binding : module_binding t + + val pstr_eval : structure_item t + + val pstr_extension : structure_item t + + val psig_extension : signature_item t + + val rtag : row_field t + + val object_type_field : object_field t end -(** [declare fully_qualified_name context payload_pattern k] declares an attribute. [k] is - used to build the value resulting from parsing the payload. +val declare : + string -> 'a Context.t -> (payload, 'b, 'c) Ast_pattern.t -> 'b -> ('a, 'c) t +(** [declare fully_qualified_name context payload_pattern k] declares an + attribute. [k] is used to build the value resulting from parsing the + payload. - For instance if a rewriter named "foo" expect the attribute [@@default] on record - field declaration with an expression as payload: + For instance if a rewriter named "foo" expect the attribute [@@default] on + record field declaration with an expression as payload: {[ let default = - Attribute.declare "foo.default" - Attribute.Context.label_declaration + Attribute.declare "foo.default" Attribute.Context.label_declaration Ast_pattern.(pstr (pstr_eval __ nil)) (fun x -> x) - ;; ]} - [fully_qualified_name] is expected to be a dot-separated list of names. When matching, - any full suffix will be accepted. So for instance an attribute declared with name - "foo.bar.default" will match exactly these attribute names: "default", "bar.default" + [fully_qualified_name] is expected to be a dot-separated list of names. When + matching, any full suffix will be accepted. So for instance an attribute + declared with name "foo.bar.default" will match exactly these attribute + names: "default", "bar.default" and "foo.bar.default". + + Additionally it is possible to prevent a suffix to be shortened by prefixing + it with '\@'. So for instance an attribute declared with name + "foo.\@bar.default" will match exactly these attribute names: "bar.default" and "foo.bar.default". - Additionally it is possible to prevent a suffix to be shortened by prefixing it with - '@'. So for instance an attribute declared with name "foo.@bar.default" will match - exactly these attribute names: "bar.default" and "foo.bar.default". - - When matching against a list of attributes on an item, if several matches are - possible, the longest one is used. For instance using the attribute "foo.default" - declared in the previous example, on this code it will match the [@foo.default 0] - attribute: - - {[ - type t = - { x : int [@default 42] [@foo.default 0] - } - ]} - - This is to allow the user to specify a [@default] attribute for all re-writers that - use it but still put a specific one for one specific re-writer. - + When matching against a list of attributes on an item, if several matches + are possible, the longest one is used. For instance using the attribute + "foo.default" declared in the previous example, on this code it will match + the [@foo.default 0] attribute: + + {[ type t = { x : int [@default 42] [@foo.default 0] } ]} + + This is to allow the user to specify a [@default] attribute for all + re-writers that use it but still put a specific one for one specific + re-writer. It is not allowed to declare an attribute with a name that matches a - previously-defined one on the same context. For instance trying to declare the same - attribute twice will fail. -*) -val declare - : string - -> 'a Context.t - -> (payload, 'b, 'c) Ast_pattern.t - -> 'b - -> ('a, 'c) t + previously-defined one on the same context. For instance trying to declare + the same attribute twice will fail. *) +val declare_with_name_loc : + string -> + 'a Context.t -> + (payload, 'b, 'c) Ast_pattern.t -> + (name_loc:Location.t -> 'b) -> + ('a, 'c) t (** Same as [declare] but the callback receives the location of the name of the attribute. *) -val declare_with_name_loc - : string - -> 'a Context.t - -> (payload, 'b, 'c) Ast_pattern.t - -> (name_loc:Location.t -> 'b) - -> ('a, 'c) t val name : _ t -> string + val context : ('a, _) t -> 'a Context.t +val get : + ('a, 'b) t -> ?mark_as_seen:bool (** default [true] *) -> 'a -> 'b option (** Gets the associated attribute value. Marks the attribute as seen unless [mark_as_seen=false]. *) -val get - : ('a, 'b) t - -> ?mark_as_seen:bool (** default [true] *) - -> 'a - -> 'b option -(** [consume t x] returns the value associated to attribute [t] on [x] if present as well - as [x] with [t] removed. *) val consume : ('a, 'b) t -> 'a -> ('a * 'b) option +(** [consume t x] returns the value associated to attribute [t] on [x] if + present as well as [x] with [t] removed. *) +val remove_seen : 'a Context.t -> packed list -> 'a -> 'a (** [remove_seen x attrs] removes the set of attributes matched by elements of [attrs]. Only remove them if they where seen by {!get} or {!consume}. *) -val remove_seen : 'a Context.t -> packed list -> 'a -> 'a module Floating : sig type ('context, 'payload) t module Context : sig type 'a t = - | Structure_item : structure_item t - | Signature_item : signature_item t - | Class_field : class_field t + | Structure_item : structure_item t + | Signature_item : signature_item t + | Class_field : class_field t | Class_type_field : class_type_field t - val structure_item : structure_item t - val signature_item : signature_item t - val class_field : class_field t + val structure_item : structure_item t + + val signature_item : signature_item t + + val class_field : class_field t + val class_type_field : class_type_field t end - val declare - : string - -> 'a Context.t - -> (payload, 'b, 'c) Ast_pattern.t - -> 'b - -> ('a, 'c) t + val declare : + string -> + 'a Context.t -> + (payload, 'b, 'c) Ast_pattern.t -> + 'b -> + ('a, 'c) t val name : _ t -> string val convert : ('a, 'b) t list -> 'a -> 'b option end -(** Code that is voluntarily dropped by a rewriter needs to be given to this object. All - attributes inside will be marked as handled. -*) val explicitly_drop : Ast_traverse.iter +(** Code that is voluntarily dropped by a rewriter needs to be given to this + object. All attributes inside will be marked as handled. *) -(** Raise if there are unused attributes *) val check_unused : Ast_traverse.iter +(** Raise if there are unused attributes *) -(** Collect all attribute names. To be used in conjuction with - {!check_all_seen}. *) val collect : Ast_traverse.iter +(** Collect all attribute names. To be used in conjunction with + {!check_all_seen}. *) +val check_all_seen : unit -> unit (** Check that all attributes collected by {!freshen_and_collect} have been: - matched at least once by one of: {!get}, {!consume} or {!Floating.convert} - seen by [check_unused] (to allow white-listed attributed to pass through) - This helps with faulty ppx rewriters that silently drop attributes. -*) -val check_all_seen : unit -> unit + This helps with faulty ppx rewriters that silently drop attributes. *) -(** Mark an attribute as seen and handled. This is only to make ppx rewriters that don't - use ppxlib works well with the ones that do use it. *) val mark_as_handled_manually : attribute -> unit +(** Mark an attribute as seen and handled. This is only to make ppx rewriters + that don't use ppxlib works well with the ones that do use it. *) -(** Return the list of attributes that have been dropped so far: attributes that haven't - been marked and are not present in the given AST. This is used to debug extensions - that drop attributes. *) val dropped_so_far_structure : structure -> string Loc.t list +(** Return the list of attributes that have been dropped so far: attributes that + haven't been marked and are not present in the given AST. This is used to + debug extensions that drop attributes. *) + val dropped_so_far_signature : signature -> string Loc.t list -val reset_checks : unit -> unit +val reset_checks : unit -> unit -val pattern - : ('a, 'b) t - -> ('a, 'c, 'd) Ast_pattern.t - -> ('a, 'b option -> 'c, 'd) Ast_pattern.t +val pattern : + ('a, 'b) t -> + ('a, 'c, 'd) Ast_pattern.t -> + ('a, 'b option -> 'c, 'd) Ast_pattern.t diff -Nru ppxlib-0.15.0/src/caller_id.ml ppxlib-0.24.0/src/caller_id.ml --- ppxlib-0.15.0/src/caller_id.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/caller_id.ml 2021-12-08 21:53:37.000000000 +0000 @@ -1,5 +1,4 @@ open! Import - module Printexc = Caml.Printexc (* Small helper to find out who is the caller of a function *) @@ -11,20 +10,14 @@ let stack = Printexc.get_callstack 16 in let len = Printexc.raw_backtrace_length stack in let rec loop pos = - if pos = len then - None + if pos = len then None else match Printexc.get_raw_backtrace_slot stack pos - |> Printexc.convert_raw_backtrace_slot - |> Printexc.Slot.location + |> Printexc.convert_raw_backtrace_slot |> Printexc.Slot.location with | None -> None | Some loc -> - if List.mem ~set:skip loc.filename then - loop (pos + 1) - else - Some loc + if List.mem ~set:skip loc.filename then loop (pos + 1) else Some loc in loop 0 -;; diff -Nru ppxlib-0.15.0/src/cinaps/ppxlib_cinaps_helpers.ml ppxlib-0.24.0/src/cinaps/ppxlib_cinaps_helpers.ml --- ppxlib-0.15.0/src/cinaps/ppxlib_cinaps_helpers.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/cinaps/ppxlib_cinaps_helpers.ml 2021-12-08 21:53:37.000000000 +0000 @@ -1,20 +1,22 @@ open Re let str_to_sig = - let re = Str.regexp {|\(_?[sS]tructure\|impl\(ementation\)?\|str_\|_str\|\b\(st\|Str\)\b\)|} in + let re = + Str.regexp + {|\(_?[sS]tructure\|impl\(ementation\)?\|str_\|_str\|\b\(st\|Str\)\b\)|} + in let map s = match Str.matched_string s with - | "st" -> "sg" - | "Str" -> "Sig" - | "structure" -> "signature" - | "Structure" -> "Signature" - | "_structure" -> "_signature" - | "_Structure" -> "_Signature" - | "str_" -> "sig_" - | "_str" -> "_sig" + | "st" -> "sg" + | "Str" -> "Sig" + | "structure" -> "signature" + | "Structure" -> "Signature" + | "_structure" -> "_signature" + | "_Structure" -> "_Signature" + | "str_" -> "sig_" + | "_str" -> "_sig" | "implementation" -> "interface" - | "impl" -> "intf" - | _ -> assert false + | "impl" -> "intf" + | _ -> assert false in - fun s -> - print_string (Str.global_substitute re map s) + fun s -> print_string (Str.global_substitute re map s) diff -Nru ppxlib-0.15.0/src/code_matcher.ml ppxlib-0.24.0/src/code_matcher.ml --- ppxlib-0.15.0/src/code_matcher.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/code_matcher.ml 2021-12-08 21:53:37.000000000 +0000 @@ -1,139 +1,147 @@ (*$ open Ppxlib_cinaps_helpers $*) open! Import - module Format = Caml.Format - module Filename = Caml.Filename (* TODO: make the "deriving." depend on the matching attribute name. *) let end_marker_sig = - Attribute.Floating.declare "deriving.end" Signature_item Ast_pattern.(pstr nil) () + Attribute.Floating.declare "deriving.end" Signature_item + Ast_pattern.(pstr nil) + () + let end_marker_str = - Attribute.Floating.declare "deriving.end" Structure_item Ast_pattern.(pstr nil) () + Attribute.Floating.declare "deriving.end" Structure_item + Ast_pattern.(pstr nil) + () module type T1 = sig type 'a t end -module Make(M : sig - type t +module Make (M : sig + type t - val get_loc : t -> Location.t + val get_loc : t -> Location.t - val end_marker : (t, unit) Attribute.Floating.t + val end_marker : (t, unit) Attribute.Floating.t - module Transform(T : T1) : sig - val apply - : < structure_item : structure_item T.t - ; signature_item : signature_item T.t - ; .. > - -> t T.t - end + module Transform (T : T1) : sig + val apply : + < structure_item : structure_item T.t + ; signature_item : signature_item T.t + ; .. > -> + t T.t + end - val parse : Lexing.lexbuf -> t list + val parse : Lexing.lexbuf -> t list - val pp : Format.formatter -> t -> unit - val to_sexp : t -> Sexp.t - end) = + val pp : Format.formatter -> t -> unit + + val to_sexp : t -> Sexp.t +end) = struct let extract_prefix ~pos l = let rec loop acc = function | [] -> - let loc = { Location. loc_start = pos; loc_end = pos; loc_ghost = false } in - Location.raise_errorf ~loc - "ppxlib: [@@@@@@%s] attribute missing" - (Attribute.Floating.name M.end_marker) - | x :: l -> - match Attribute.Floating.convert [M.end_marker] x with - | None -> loop (x :: acc) l - | Some () -> (List.rev acc, (M.get_loc x).loc_start) - | exception Failure _ -> loop (x :: acc) l + let loc = + { Location.loc_start = pos; loc_end = pos; loc_ghost = false } + in + Location.raise_errorf ~loc "ppxlib: [@@@@@@%s] attribute missing" + (Attribute.Floating.name M.end_marker) + | x :: l -> ( + match Attribute.Floating.convert [ M.end_marker ] x with + | None -> loop (x :: acc) l + | Some () -> (List.rev acc, (M.get_loc x).loc_start) + | exception Failure _ -> loop (x :: acc) l) in loop [] l - let remove_loc = object - inherit Ast_traverse.map + let remove_loc = + object + inherit Ast_traverse.map - method! location _ = Location.none + method! location _ = Location.none - method! location_stack _ = [] - - end + method! location_stack _ = [] + end - module M_map = M.Transform(struct type 'a t = 'a -> 'a end) + module M_map = M.Transform (struct + type 'a t = 'a -> 'a + end) let remove_loc x = M_map.apply remove_loc x - let rec last prev = function - | [] -> prev - | x :: l -> last x l + let rec last prev = function [] -> prev | x :: l -> last x l let diff_asts ~generated ~round_trip = let with_temp_file f = Exn.protectx (Filename.temp_file "ppxlib" "") ~finally:Caml.Sys.remove ~f in with_temp_file (fun fn1 -> - with_temp_file (fun fn2 -> - with_temp_file (fun out -> - let dump fn ast = - Out_channel.with_file fn ~f:(fun oc -> - let ppf = Format.formatter_of_out_channel oc in - Sexp.pp_hum ppf (M.to_sexp ast); - Format.pp_print_flush ppf ()) - in - dump fn1 generated; - dump fn2 round_trip; - let cmd = - Printf.sprintf - "patdiff -ascii -alt-old generated -alt-new 'generated->printed->parsed' \ - %s %s &> %s" - (Filename.quote fn1) (Filename.quote fn2) (Filename.quote out) - in - let ok = - Caml.Sys.command cmd = 1 || ( - let cmd = - Printf.sprintf - "diff --label generated --label 'generated->printed->parsed' \ - %s %s &> %s" - (Filename.quote fn1) (Filename.quote fn2) (Filename.quote out) - in - Caml.Sys.command cmd = 1 - ) - in - if ok then - In_channel.read_all out - else - ""))) + with_temp_file (fun fn2 -> + with_temp_file (fun out -> + let dump fn ast = + Out_channel.with_file fn ~f:(fun oc -> + let ppf = Format.formatter_of_out_channel oc in + Sexp.pp_hum ppf (M.to_sexp ast); + Format.pp_print_flush ppf ()) + in + dump fn1 generated; + dump fn2 round_trip; + let cmd = + Printf.sprintf + "patdiff -ascii -alt-old generated -alt-new \ + 'generated->printed->parsed' %s %s &> %s" + (Filename.quote fn1) (Filename.quote fn2) + (Filename.quote out) + in + let ok = + Caml.Sys.command cmd = 1 + || + let cmd = + Printf.sprintf + "diff --label generated --label \ + 'generated->printed->parsed' %s %s &> %s" + (Filename.quote fn1) (Filename.quote fn2) + (Filename.quote out) + in + Caml.Sys.command cmd = 1 + in + if ok then In_channel.read_all out + else ""))) let parse_string s = - match M.parse (Lexing.from_string s) with - | [x] -> x - | _ -> assert false - + match M.parse (Lexing.from_string s) with [ x ] -> x | _ -> assert false let rec match_loop ~end_pos ~mismatch_handler ~expected ~source = - match expected, source with + match (expected, source) with | [], [] -> () | [], x :: l -> - let loc = { (M.get_loc x) with loc_end = (M.get_loc (last x l)).loc_end } in - mismatch_handler loc [] + let loc = + { (M.get_loc x) with loc_end = (M.get_loc (last x l)).loc_end } + in + mismatch_handler loc [] | _, [] -> - let loc = { Location. loc_ghost = false; loc_start = end_pos; loc_end = end_pos } in - mismatch_handler loc expected + let loc = + { Location.loc_ghost = false; loc_start = end_pos; loc_end = end_pos } + in + mismatch_handler loc expected | x :: expected, y :: source -> - let loc = M.get_loc y in - let x = remove_loc x in - let y = remove_loc y in - if Poly.(<>) x y then begin - let round_trip = remove_loc (parse_string (Format.asprintf "%a@." M.pp x)) in - if Poly.(<>) x round_trip then - Location.raise_errorf ~loc - "ppxlib: the corrected code doesn't round-trip.\n\ - This is probably a bug in the OCaml printer:\n%s" - (diff_asts ~generated:x ~round_trip); - mismatch_handler loc [x]; - end; - match_loop ~end_pos ~mismatch_handler ~expected ~source + let loc = M.get_loc y in + let x = remove_loc x in + let y = remove_loc y in + if Poly.( <> ) x y then ( + let round_trip = + remove_loc (parse_string (Format.asprintf "%a@." M.pp x)) + in + if Poly.( <> ) x round_trip then + Location.raise_errorf ~loc + "ppxlib: the corrected code doesn't round-trip.\n\ + This is probably a bug in the OCaml printer:\n\ + %s" + (diff_asts ~generated:x ~round_trip); + mismatch_handler loc [ x ]); + match_loop ~end_pos ~mismatch_handler ~expected ~source let do_match ~pos ~expected ~mismatch_handler source = let source, end_pos = extract_prefix ~pos source in @@ -141,34 +149,45 @@ end (*$*) -module Str = Make(struct - type t = structure_item - let get_loc x = x.pstr_loc - let end_marker = end_marker_str +module Str = Make (struct + type t = structure_item - module Transform(T : T1) = struct - let apply o = o#structure_item - end + let get_loc x = x.pstr_loc + + let end_marker = end_marker_str + + module Transform (T : T1) = struct + let apply o = o#structure_item + end + + let parse = Parse.implementation + + let pp = Pprintast.structure_item + + let to_sexp = Ast_traverse.sexp_of#structure_item +end) - let parse = Parse.implementation - let pp = Pprintast.structure_item - let to_sexp = Ast_traverse.sexp_of#structure_item - end) (*$ str_to_sig _last_text_block *) -module Sig = Make(struct - type t = signature_item - let get_loc x = x.psig_loc - let end_marker = end_marker_sig +module Sig = Make (struct + type t = signature_item - module Transform(T : T1) = struct - let apply o = o#signature_item - end + let get_loc x = x.psig_loc + + let end_marker = end_marker_sig + + module Transform (T : T1) = struct + let apply o = o#signature_item + end + + let parse = Parse.interface + + let pp = Pprintast.signature_item + + let to_sexp = Ast_traverse.sexp_of#signature_item +end) - let parse = Parse.interface - let pp = Pprintast.signature_item - let to_sexp = Ast_traverse.sexp_of#signature_item - end) (*$*) let match_structure = Str.do_match + let match_signature = Sig.do_match diff -Nru ppxlib-0.15.0/src/code_matcher.mli ppxlib-0.24.0/src/code_matcher.mli --- ppxlib-0.15.0/src/code_matcher.mli 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/code_matcher.mli 2021-12-08 21:53:37.000000000 +0000 @@ -2,25 +2,24 @@ open! Import -(** Checks that the given code starts with [expected] followed by [@@@deriving.end] or - [@@@end]. +val match_structure : + pos:Lexing.position -> + expected:structure -> + mismatch_handler:(Location.t -> structure -> unit) -> + structure -> + unit +(** Checks that the given code starts with [expected] followed by + [@@@deriving.end] or [@@@end]. Raises if there is no [@@@deriving.end]. - If some items don't match, it calls [mismatch_handler] with the location of the source - items and the expected code. -*) -val match_structure - : pos:Lexing.position - -> expected:structure - -> mismatch_handler:(Location.t -> structure -> unit) - -> structure - -> unit + If some items don't match, it calls [mismatch_handler] with the location of + the source items and the expected code. *) +val match_signature : + pos:Lexing.position -> + expected:signature -> + mismatch_handler:(Location.t -> signature -> unit) -> + signature -> + unit (** Same for signatures *) -val match_signature - : pos:Lexing.position - -> expected:signature - -> mismatch_handler:(Location.t -> signature -> unit) - -> signature - -> unit diff -Nru ppxlib-0.15.0/src/code_path.ml ppxlib-0.24.0/src/code_path.ml --- ppxlib-0.15.0/src/code_path.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/code_path.ml 2021-12-08 21:53:37.000000000 +0000 @@ -1,51 +1,58 @@ open! Import -type t = - { file_path : string - ; main_module_name : string - ; submodule_path : string loc list - ; value : string loc option - ; in_expr : bool - } +type t = { + file_path : string; + main_module_name : string; + submodule_path : string loc list; + value : string loc option; + in_expr : bool; +} let top_level ~file_path = let main_module_name = - file_path - |> Caml.Filename.basename - |> Caml.Filename.remove_extension + file_path |> Caml.Filename.basename |> Caml.Filename.remove_extension |> String.capitalize_ascii in - {file_path; main_module_name; submodule_path = []; value = None; in_expr = false} + { + file_path; + main_module_name; + submodule_path = []; + value = None; + in_expr = false; + } let file_path t = t.file_path + let main_module_name t = t.main_module_name -let submodule_path t = List.rev_map ~f:(fun located -> located.txt) t.submodule_path + +let submodule_path t = + List.rev_map ~f:(fun located -> located.txt) t.submodule_path + let value t = Option.map ~f:(fun located -> located.txt) t.value -let fully_qualified_path t = +let fully_qualified_path t = let value = value t in - let submodule_path = List.rev_map ~f:(fun located -> Some located.txt) t.submodule_path in - let names = (Some t.main_module_name)::submodule_path @ [value] in + let submodule_path = + List.rev_map ~f:(fun located -> Some located.txt) t.submodule_path + in + let names = (Some t.main_module_name :: submodule_path) @ [ value ] in String.concat ~sep:"." @@ List.filter_opt names -let enter_expr t = {t with in_expr = true} +let enter_expr t = { t with in_expr = true } let enter_module ~loc module_name t = - if t.in_expr then - t + if t.in_expr then t else - {t with submodule_path = {txt = module_name; loc} :: t.submodule_path} + { t with submodule_path = { txt = module_name; loc } :: t.submodule_path } let enter_value ~loc value_name t = - if t.in_expr then - t - else - {t with value = Some {txt = value_name; loc}} + if t.in_expr then t else { t with value = Some { txt = value_name; loc } } -let to_string_path t = - String.concat ~sep:"." (t.file_path :: (submodule_path t)) +let to_string_path t = String.concat ~sep:"." (t.file_path :: submodule_path t) -let with_string_path f ~loc ~path = f ~loc ~path:(to_string_path path) -;; +let with_string_path f ~loc ~path = f ~loc ~path:(to_string_path path);; -let module M = struct let a = "lol" end in M.a +let module M = struct + let a = "lol" +end in +M.a diff -Nru ppxlib-0.15.0/src/code_path.mli ppxlib-0.24.0/src/code_path.mli --- ppxlib-0.15.0/src/code_path.mli 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/code_path.mli 2021-12-08 21:53:37.000000000 +0000 @@ -1,54 +1,53 @@ -open !Import +open! Import -(** Type for path to AST nodes *) type t +(** Type for path to AST nodes *) -(** Return the path to the .ml or .mli file for this code path. *) val file_path : t -> string +(** Return the path to the .ml or .mli file for this code path. *) -(** Return the module name corresponding to the file to which this code path leads to. *) val main_module_name : t -> string +(** Return the module name corresponding to the file to which this code path + leads to. *) -(** Return the path within the main module this code path represents as a list of module names. -*) val submodule_path : t -> string list +(** Return the path within the main module this code path represents as a list + of module names. *) -(** Return the name of the value to which this code path leads or [None] if it leads to the - toplevel of a module or submodule. -*) val value : t -> string option +(** Return the name of the value to which this code path leads or [None] if it + leads to the toplevel of a module or submodule. *) -(** Return the fully qualified path to the module or value this code path leads to, eg - ["Some_main_module.Some_submodule.some_value"]. - Note that the fully qualified path doesn't descend into expressions which means it will always - stop at the first value description or value binding. -*) val fully_qualified_path : t -> string +(** Return the fully qualified path to the module or value this code path leads + to, eg ["Some_main_module.Some_submodule.some_value"]. Note that the fully + qualified path doesn't descend into expressions which means it will always + stop at the first value description or value binding. *) -(** Return the string version of this code path as built by [Ast_traverse.map_with_path]. - Used for compatibility with path from version 0.5.0 and lower. -*) val to_string_path : t -> string +(** Return the string version of this code path as built by + [Ast_traverse.map_with_path]. Used for compatibility with path from version + 0.5.0 and lower. *) (**/**) + (** Undocumented section *) -(** [top_level ~file_path] returns the code path for any toplevel item in the file at [file_path]. *) -val top_level : file_path: string -> t +val top_level : file_path:string -> t +(** [top_level ~file_path] returns the code path for any toplevel item in the + file at [file_path]. *) -(** Return a new code path that now descends into an expression. - This is used to delimit the "toplevel" path. It's required because of first class modules - and toplevel expressions [Pstr_eval ...]. -*) val enter_expr : t -> t +(** Return a new code path that now descends into an expression. This is used to + delimit the "toplevel" path. It's required because of first class modules + and toplevel expressions [Pstr_eval ...]. *) -(** Return a new code path updated with the given module name and location. *) val enter_module : loc:Location.t -> string -> t -> t +(** Return a new code path updated with the given module name and location. *) -(** Return a new code path updated with the given variable name and location. *) val enter_value : loc:Location.t -> string -> t -> t +(** Return a new code path updated with the given variable name and location. *) -(** Wrap a [fun ~loc ~path] expecting a string path into one expecting a [t]. *) val with_string_path : - (loc:Location.t -> path:string -> 'a) -> - (loc:Location.t -> path:t -> 'a) + (loc:Location.t -> path:string -> 'a) -> loc:Location.t -> path:t -> 'a +(** Wrap a [fun ~loc ~path] expecting a string path into one expecting a [t]. *) diff -Nru ppxlib-0.15.0/src/common.ml ppxlib-0.24.0/src/common.ml --- ppxlib-0.15.0/src/common.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/common.ml 2021-12-08 21:53:37.000000000 +0000 @@ -1,8 +1,6 @@ open! Import open Ast_builder.Default - module Buffer = Caml.Buffer - module Format = Caml.Format let lident x = Longident.Lident x @@ -12,35 +10,58 @@ ptyp_constr ~loc (Located.map lident td.ptype_name) (List.map td.ptype_params ~f:fst) -;; + +let strip_gen_symbol_suffix = + let chop n ~or_more string pos f = + let target = !pos - n in + while !pos > 0 && (or_more || !pos > target) && f string.[!pos - 1] do + pos := !pos - 1 + done; + !pos <= target + in + fun string -> + let pos = ref (String.length string) in + if + chop 1 ~or_more:false string pos (Char.equal '_') + && chop 3 ~or_more:true string pos (function + | '0' .. '9' -> true + | _ -> false) + && chop 2 ~or_more:false string pos (Char.equal '_') + then String.prefix string !pos + else string let gen_symbol = let cnt = ref 0 in fun ?(prefix = "_x") () -> cnt := !cnt + 1; + let prefix = strip_gen_symbol_suffix prefix in Printf.sprintf "%s__%03i_" prefix !cnt -;; let name_type_params_in_td (td : type_declaration) : type_declaration = - let name_param (tp, variance) = + let prefix_string i = + (* a, b, ..., y, z, aa, bb, ... *) + String.make ((i / 26) + 1) (Char.chr (Char.code 'a' + (i mod 26))) + in + let name_param i (tp, variance) = let ptyp_desc = match tp.ptyp_desc with - | Ptyp_any -> Ptyp_var ("v" ^ gen_symbol ()) + | Ptyp_any -> Ptyp_var (gen_symbol ~prefix:(prefix_string i) ()) | Ptyp_var _ as v -> v | _ -> Location.raise_errorf ~loc:tp.ptyp_loc "not a type parameter" in ({ tp with ptyp_desc }, variance) in - { td with ptype_params = List.map td.ptype_params ~f:name_param } -;; + { td with ptype_params = List.mapi td.ptype_params ~f:name_param } let combinator_type_of_type_declaration td ~f = let td = name_type_params_in_td td in - let result_type = f ~loc:td.ptype_name.loc (core_type_of_type_declaration td) in - List.fold_right td.ptype_params ~init:result_type ~f:(fun (tp, _variance) acc -> - let loc = tp.ptyp_loc in - ptyp_arrow ~loc Nolabel (f ~loc tp) acc) -;; + let result_type = + f ~loc:td.ptype_name.loc (core_type_of_type_declaration td) + in + List.fold_right td.ptype_params ~init:result_type + ~f:(fun (tp, _variance) acc -> + let loc = tp.ptyp_loc in + ptyp_arrow ~loc Nolabel (f ~loc tp) acc) let string_of_core_type ct = let buf = Buffer.create 128 in @@ -48,7 +69,6 @@ Pprintast.core_type ppf ct; Format.pp_print_flush ppf (); Buffer.contents buf -;; let get_type_param_name (ty, _) = let loc = ty.ptyp_loc in @@ -56,156 +76,156 @@ | Ptyp_var name -> Located.mk ~loc name | _ -> Location.raise_errorf ~loc "not a type parameter" - exception Type_is_recursive -class type_is_recursive rec_flag tds = object(self) - inherit Ast_traverse.iter as super - - val type_names : string list = List.map tds ~f:(fun td -> td.ptype_name.txt) - - method return_true () = raise_notrace Type_is_recursive - - method! core_type ctype = - match ctype.ptyp_desc with - | Ptyp_arrow _ -> () - | Ptyp_constr ({ txt = Longident.Lident id; _ }, _) - when List.mem ~set:type_names id -> - self#return_true () - | _ -> super#core_type ctype - - method! constructor_declaration cd = - (* Don't recurse through cd.pcd_res *) - match cd.pcd_args with - | Pcstr_tuple args -> List.iter args ~f:self#core_type - | Pcstr_record fields -> List.iter fields ~f:self#label_declaration - - method go () = - match rec_flag with - | Nonrecursive -> Nonrecursive - | Recursive -> - match List.iter tds ~f:self#type_declaration with - | exception Type_is_recursive -> Recursive - | () -> Nonrecursive - -end +class type_is_recursive rec_flag tds = + object (self) + inherit Ast_traverse.iter as super + + val type_names : string list = List.map tds ~f:(fun td -> td.ptype_name.txt) + + method return_true () = raise_notrace Type_is_recursive + + method! core_type ctype = + match ctype.ptyp_desc with + | Ptyp_arrow _ -> () + | Ptyp_constr ({ txt = Longident.Lident id; _ }, _) + when List.mem ~set:type_names id -> + self#return_true () + | _ -> super#core_type ctype + + method! constructor_declaration cd = + (* Don't recurse through cd.pcd_res *) + match cd.pcd_args with + | Pcstr_tuple args -> List.iter args ~f:self#core_type + | Pcstr_record fields -> List.iter fields ~f:self#label_declaration + + method! attributes _ = (* Don't recurse through attributes *) + () + + method go () = + match rec_flag with + | Nonrecursive -> Nonrecursive + | Recursive -> ( + match List.iter tds ~f:self#type_declaration with + | exception Type_is_recursive -> Recursive + | () -> Nonrecursive) + end let really_recursive rec_flag tds = (new type_is_recursive rec_flag tds)#go () -let rec last x l = - match l with - | [] -> x - | x :: l -> last x l -;; +let rec last x l = match l with [] -> x | x :: l -> last x l let loc_of_name_and_payload name payload = match payload with - | PStr [] -> name.loc - | PStr (x :: l) -> { x.pstr_loc with loc_end = (last x l).pstr_loc.loc_end } - | PSig [] -> name.loc - | PSig (x :: l) -> { x.psig_loc with loc_end = (last x l).psig_loc.loc_end } - | PTyp t -> t.ptyp_loc - | PPat (x, None) -> x.ppat_loc + | PStr [] -> name.loc + | PStr (x :: l) -> { x.pstr_loc with loc_end = (last x l).pstr_loc.loc_end } + | PSig [] -> name.loc + | PSig (x :: l) -> { x.psig_loc with loc_end = (last x l).psig_loc.loc_end } + | PTyp t -> t.ptyp_loc + | PPat (x, None) -> x.ppat_loc | PPat (x, Some e) -> { x.ppat_loc with loc_end = e.pexp_loc.loc_end } -;; -let loc_of_payload { attr_name; attr_payload; attr_loc = _; } = +let loc_of_payload { attr_name; attr_payload; attr_loc = _ } = loc_of_name_and_payload attr_name attr_payload -let loc_of_attribute { attr_name; attr_payload; attr_loc = _; } = +let loc_of_attribute { attr_name; attr_payload; attr_loc = _ } = (* TODO: fix this in the compiler, and move the logic to omp when converting from older asts. *) (* "ocaml.doc" attributes are generated with [Location.none], which is not helpful for error messages. *) - if Poly.(=) attr_name.loc Location.none then + if Poly.( = ) attr_name.loc Location.none then loc_of_name_and_payload attr_name attr_payload else - { attr_name.loc with loc_end = (loc_of_name_and_payload attr_name attr_payload).loc_end } -;; + { + attr_name.loc with + loc_end = (loc_of_name_and_payload attr_name attr_payload).loc_end; + } let loc_of_extension (name, payload) = - if Poly.(=) name.loc Location.none then - loc_of_name_and_payload name payload + if Poly.( = ) name.loc Location.none then loc_of_name_and_payload name payload else { name.loc with loc_end = (loc_of_name_and_payload name payload).loc_end } -;; let curry_applications expr = let open Ast_builder_generated.M in match expr.pexp_desc with - | Pexp_apply (f,orig_forward_args) -> - let loc = expr.pexp_loc in - let rec loop = function - | [] -> f - | last_arg::rev_front_args -> pexp_apply ~loc (loop rev_front_args) [last_arg] - in - loop (List.rev orig_forward_args) + | Pexp_apply (f, orig_forward_args) -> + let loc = expr.pexp_loc in + let rec loop = function + | [] -> f + | last_arg :: rev_front_args -> + pexp_apply ~loc (loop rev_front_args) [ last_arg ] + in + loop (List.rev orig_forward_args) | _ -> expr -;; let rec assert_no_attributes = function | [] -> () - | { attr_name = name; attr_loc = _; attr_payload = _; } :: rest when Name.ignore_checks name.Location.txt -> - assert_no_attributes rest + | { attr_name = name; attr_loc = _; attr_payload = _ } :: rest + when Name.ignore_checks name.Location.txt -> + assert_no_attributes rest | attr :: _ -> - let loc = loc_of_attribute attr in - Location.raise_errorf ~loc "Attributes not allowed here" + let loc = loc_of_attribute attr in + Location.raise_errorf ~loc "Attributes not allowed here" -let assert_no_attributes_in = object - inherit Ast_traverse.iter +let assert_no_attributes_in = + object + inherit Ast_traverse.iter - method! attribute a = assert_no_attributes [a] -end + method! attribute a = assert_no_attributes [ a ] + end let attribute_of_warning loc s = - { attr_name = { loc; txt = "ocaml.ppwarning" }; - attr_payload = PStr ([pstr_eval ~loc (estring ~loc s) []]); - attr_loc = loc; } + { + attr_name = { loc; txt = "ocaml.ppwarning" }; + attr_payload = PStr [ pstr_eval ~loc (estring ~loc s) [] ]; + attr_loc = loc; + } let is_polymorphic_variant = let rec check = function | { ptyp_desc = Ptyp_variant _; _ } -> `Definitely - | { ptyp_desc = Ptyp_alias (typ,_); _ } -> check typ + | { ptyp_desc = Ptyp_alias (typ, _); _ } -> check typ | { ptyp_desc = Ptyp_constr _; _ } -> `Maybe - | _ -> `Surely_not (* Type vars go here even though they could be polymorphic - variants, however we don't handle it if they get substituted - by a polymorphic variant that is then included. *) + | _ -> `Surely_not + (* Type vars go here even though they could be polymorphic + variants, however we don't handle it if they get substituted + by a polymorphic variant that is then included. *) in fun td ~sig_ -> match td.ptype_kind with | Ptype_variant _ | Ptype_record _ | Ptype_open -> `Surely_not - | Ptype_abstract -> - match td.ptype_manifest with - | None -> if sig_ then `Maybe else `Surely_not - | Some typ -> check typ + | Ptype_abstract -> ( + match td.ptype_manifest with + | None -> if sig_ then `Maybe else `Surely_not + | Some typ -> check typ) let mk_named_sig ~loc ~sg_name ~handle_polymorphic_variant = function - | [ td ] when String.equal td.ptype_name.txt "t" && List.is_empty td.ptype_cstrs -> - if not handle_polymorphic_variant && - Poly.(=) (is_polymorphic_variant td ~sig_:true) `Definitely - then - None - else - let arity = List.length td.ptype_params in - if arity >= 4 then - None + | [ td ] + when String.equal td.ptype_name.txt "t" && List.is_empty td.ptype_cstrs -> + if + (not handle_polymorphic_variant) + && Poly.( = ) (is_polymorphic_variant td ~sig_:true) `Definitely + then None else - let mty = - if arity = 0 - then sg_name - else Printf.sprintf "%s%d" sg_name arity - in - let td = name_type_params_in_td td in - let for_subst = - Ast_helper.Type.mk ~loc td.ptype_name ~params:td.ptype_params - ~manifest:( - ptyp_constr ~loc (Located.map_lident td.ptype_name) - (List.map ~f:fst td.ptype_params) - ) - in - Some ( - include_infos ~loc - (pmty_with ~loc (pmty_ident ~loc (Located.lident mty ~loc)) - [Pwith_typesubst (Located.lident ~loc "t", for_subst)]) - ) + let arity = List.length td.ptype_params in + if arity >= 4 then None + else + let mty = + if arity = 0 then sg_name else Printf.sprintf "%s%d" sg_name arity + in + let td = name_type_params_in_td td in + let for_subst = + Ast_helper.Type.mk ~loc td.ptype_name ~params:td.ptype_params + ~manifest: + (ptyp_constr ~loc + (Located.map_lident td.ptype_name) + (List.map ~f:fst td.ptype_params)) + in + Some + (include_infos ~loc + (pmty_with ~loc + (pmty_ident ~loc (Located.lident mty ~loc)) + [ Pwith_typesubst (Located.lident ~loc "t", for_subst) ])) | _ -> None diff -Nru ppxlib-0.15.0/src/common.mli ppxlib-0.24.0/src/common.mli --- ppxlib-0.15.0/src/common.mli 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/common.mli 2021-12-08 21:53:37.000000000 +0000 @@ -6,73 +6,80 @@ val name_type_params_in_td : type_declaration -> type_declaration -val combinator_type_of_type_declaration - : type_declaration - -> f:(loc:Location.t -> core_type -> core_type) - -> core_type +val combinator_type_of_type_declaration : + type_declaration -> f:(loc:Location.t -> core_type -> core_type) -> core_type -val gen_symbol : ?prefix : string -> unit -> string +val gen_symbol : ?prefix:string -> unit -> string (** [gen_symbol ?prefix ()] generates a fresh variable name with [prefix]. - @param prefix default = "_x" -*) + @param prefix default = "_x" *) val string_of_core_type : core_type -> string val assert_no_attributes : attributes -> unit + val assert_no_attributes_in : Ast_traverse.iter -val get_type_param_name : (core_type * variance) -> string Loc.t -(** [get_tparam_id tp] @return the string identifier associated with [tp] if it is a type - parameter. *) - -(** [(new type_is_recursive rec_flag tds)#go ()] returns whether [rec_flag, tds] is really - a recursive type. We disregard recursive occurrences appearing in arrow types. You can - override the search for certain type expressions by inheriting from this class. *) -class type_is_recursive : rec_flag -> type_declaration list -> object - inherit Ast_traverse.iter +val get_type_param_name : core_type * (variance * injectivity) -> string Loc.t +(** [get_tparam_id tp] returns the string identifier associated with [tp] if it + is a type parameter. *) + +(** [(new type_is_recursive rec_flag tds)#go ()] returns whether [rec_flag, tds] + is really a recursive type. We disregard recursive occurrences appearing in + arrow types. You can override the search for certain type expressions by + inheriting from this class. *) +class type_is_recursive : + rec_flag + -> type_declaration list + -> object + inherit Ast_traverse.iter - val type_names : string list + val type_names : string list - method return_true : unit -> unit + method return_true : unit -> unit - method go : unit -> rec_flag - end + method go : unit -> rec_flag + end -(** [really_recursive rec_flag tds = (new type_is_recursive rec_flag tds)#go ()] *) val really_recursive : rec_flag -> type_declaration list -> rec_flag +(** [really_recursive rec_flag tds = (new type_is_recursive rec_flag tds)#go ()] *) + +val loc_of_payload : attribute -> Location.t -val loc_of_payload : attribute -> Location.t val loc_of_attribute : attribute -> Location.t + val loc_of_extension : extension -> Location.t -(** convert multi-arg function applications into a cascade of 1-arg applications *) val curry_applications : expression -> expression +(** convert multi-arg function applications into a cascade of 1-arg applications *) -(** Encode a warning message into an 'ocaml.ppwarning' attribute which can be inserted in - a generated Parsetree. The compiler will be responsible for reporting the warning. *) val attribute_of_warning : Location.t -> string -> attribute - -val is_polymorphic_variant - : type_declaration -> sig_:bool -> [> `Definitely | `Maybe | `Surely_not ] - +(** Encode a warning message into an 'ocaml.ppwarning' attribute which can be + inserted in a generated Parsetree. The compiler will be responsible for + reporting the warning. *) + +val is_polymorphic_variant : + type_declaration -> sig_:bool -> [> `Definitely | `Maybe | `Surely_not ] + +val mk_named_sig : + loc:Location.t -> + sg_name:string -> + handle_polymorphic_variant:bool -> + type_declaration list -> + include_description option (** [mk_named_sig ~loc ~sg_name:"Foo" ~handle_polymorphic_variant tds] will generate + {[ include Foo (* or Foo1, Foo2, Foo3 *) with type (* ('a, 'b, 'c) *) t := (* ('a, 'b, 'c) *) t ]} + when: + - there is only one type declaration - the type is named t - there are less than 4 type parameters - there are no constraints on the type parameters - It will take care of giving fresh names to unnamed type parameters. -*) -val mk_named_sig - : loc:Location.t - -> sg_name:string - -> handle_polymorphic_variant:bool - -> type_declaration list - -> include_description option + It will take care of giving fresh names to unnamed type parameters. *) diff -Nru ppxlib-0.15.0/src/context_free.ml ppxlib-0.24.0/src/context_free.ml --- ppxlib-0.15.0/src/context_free.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/context_free.ml 2021-12-08 21:53:37.000000000 +0000 @@ -1,53 +1,53 @@ (*$ open Ppxlib_cinaps_helpers $*) open! Import open Common - -module E = Extension +module E = Extension module EC = Extension.Context -module A = Attribute +module A = Attribute module AC = Attribute.Context module Rule = struct module Attr_group_inline = struct - type ('a, 'b, 'c) unpacked = - { attribute : ('b, 'c) Attribute.t - ; expect : bool - ; expand : (ctxt:Expansion_context.Deriver.t - -> Asttypes.rec_flag - -> 'b list - -> 'c option list - -> 'a list) - } + type ('a, 'b, 'c) unpacked = { + attribute : ('b, 'c) Attribute.t; + expect : bool; + expand : + ctxt:Expansion_context.Deriver.t -> + Asttypes.rec_flag -> + 'b list -> + 'c option list -> + 'a list; + } type ('a, 'b) t = T : ('a, 'b, _) unpacked -> ('a, 'b) t let attr_name (T t) = Attribute.name t.attribute - let split_normal_and_expect l = List.partition l ~f:(fun (T t) -> not t.expect) + let split_normal_and_expect l = + List.partition l ~f:(fun (T t) -> not t.expect) end module Attr_inline = struct - type ('a, 'b, 'c) unpacked = - { attribute : ('b, 'c) Attribute.t - ; expect : bool - ; expand : (ctxt:Expansion_context.Deriver.t - -> 'b - -> 'c - -> 'a list) - } + type ('a, 'b, 'c) unpacked = { + attribute : ('b, 'c) Attribute.t; + expect : bool; + expand : ctxt:Expansion_context.Deriver.t -> 'b -> 'c -> 'a list; + } type ('a, 'b) t = T : ('a, 'b, _) unpacked -> ('a, 'b) t + let attr_name (T t) = Attribute.name t.attribute - let split_normal_and_expect l = List.partition l ~f:(fun (T t) -> not t.expect) + let split_normal_and_expect l = + List.partition l ~f:(fun (T t) -> not t.expect) end module Special_function = struct - type t = - { name : string - ; ident : Longident.t - ; expand : Parsetree.expression -> Parsetree.expression option - } + type t = { + name : string; + ident : Longident.t; + expand : Parsetree.expression -> Parsetree.expression option; + } end module Constant_kind = struct @@ -55,40 +55,45 @@ end module Constant = struct - type t = - { suffix : char - ; kind : Constant_kind.t - ; expand : Location.t -> string -> Parsetree.expression - } + type t = { + suffix : char; + kind : Constant_kind.t; + expand : Location.t -> string -> Parsetree.expression; + } end module Field = struct type 'a t = - | Extension : Extension.t t - | Special_function : Special_function.t t - | Constant : Constant.t t - | Attr_str_type_decl : (structure_item, type_declaration) Attr_group_inline.t t - | Attr_sig_type_decl : (signature_item, type_declaration) Attr_group_inline.t t - | Attr_str_module_type_decl : (structure_item, module_type_declaration) Attr_inline.t t - | Attr_sig_module_type_decl : (signature_item, module_type_declaration) Attr_inline.t t - | Attr_str_type_ext : (structure_item, type_extension) Attr_inline.t t - | Attr_sig_type_ext : (signature_item, type_extension) Attr_inline.t t - | Attr_str_exception : (structure_item, type_exception) Attr_inline.t t - | Attr_sig_exception : (signature_item, type_exception) Attr_inline.t t + | Extension : Extension.t t + | Special_function : Special_function.t t + | Constant : Constant.t t + | Attr_str_type_decl + : (structure_item, type_declaration) Attr_group_inline.t t + | Attr_sig_type_decl + : (signature_item, type_declaration) Attr_group_inline.t t + | Attr_str_module_type_decl + : (structure_item, module_type_declaration) Attr_inline.t t + | Attr_sig_module_type_decl + : (signature_item, module_type_declaration) Attr_inline.t t + | Attr_str_type_ext : (structure_item, type_extension) Attr_inline.t t + | Attr_sig_type_ext : (signature_item, type_extension) Attr_inline.t t + | Attr_str_exception : (structure_item, type_exception) Attr_inline.t t + | Attr_sig_exception : (signature_item, type_exception) Attr_inline.t t type (_, _) equality = Eq : ('a, 'a) equality | Ne : (_, _) equality - let eq : type a b. a t -> b t -> (a, b) equality = fun a b -> - match a, b with - | Extension , Extension -> Eq - | Special_function , Special_function -> Eq - | Constant , Constant -> Eq - | Attr_str_type_decl , Attr_str_type_decl -> Eq - | Attr_sig_type_decl , Attr_sig_type_decl -> Eq - | Attr_str_type_ext , Attr_str_type_ext -> Eq - | Attr_sig_type_ext , Attr_sig_type_ext -> Eq - | Attr_str_exception , Attr_str_exception -> Eq - | Attr_sig_exception , Attr_sig_exception -> Eq + let eq : type a b. a t -> b t -> (a, b) equality = + fun a b -> + match (a, b) with + | Extension, Extension -> Eq + | Special_function, Special_function -> Eq + | Constant, Constant -> Eq + | Attr_str_type_decl, Attr_str_type_decl -> Eq + | Attr_sig_type_decl, Attr_sig_type_decl -> Eq + | Attr_str_type_ext, Attr_str_type_ext -> Eq + | Attr_sig_type_ext, Attr_sig_type_ext -> Eq + | Attr_str_exception, Attr_str_exception -> Eq + | Attr_sig_exception, Attr_sig_exception -> Eq | Attr_str_module_type_decl, Attr_str_module_type_decl -> Eq | Attr_sig_module_type_decl, Attr_sig_module_type_decl -> Eq | _ -> Ne @@ -97,120 +102,95 @@ type t = T : 'a Field.t * 'a -> t type ('a, 'b, 'c) attr_group_inline = - ('b, 'c) Attribute.t - -> (ctxt:Expansion_context.Deriver.t - -> Asttypes.rec_flag - -> 'b list - -> 'c option list - -> 'a list) - -> t + ('b, 'c) Attribute.t -> + (ctxt:Expansion_context.Deriver.t -> + Asttypes.rec_flag -> + 'b list -> + 'c option list -> + 'a list) -> + t type ('a, 'b, 'c) attr_inline = - ('b, 'c) Attribute.t - -> (ctxt:Expansion_context.Deriver.t - -> 'b - -> 'c - -> 'a list) - -> t + ('b, 'c) Attribute.t -> + (ctxt:Expansion_context.Deriver.t -> 'b -> 'c -> 'a list) -> + t - let rec filter : type a. a Field.t -> t list -> a list = fun field l -> + let rec filter : type a. a Field.t -> t list -> a list = + fun field l -> match l with | [] -> [] - | (T (field', x)) :: l -> - match Field.eq field field' with - | Field.Eq -> x :: filter field l - | Field.Ne -> filter field l - ;; + | T (field', x) :: l -> ( + match Field.eq field field' with + | Field.Eq -> x :: filter field l + | Field.Ne -> filter field l) let extension ext = T (Extension, ext) let special_function id f = - T (Special_function, { name = id - ; ident = Longident.parse id - ; expand = f - }) - ;; - - let constant kind suffix expand = - T (Constant, { suffix; kind; expand }) - ;; + T (Special_function, { name = id; ident = Longident.parse id; expand = f }) + + let constant kind suffix expand = T (Constant, { suffix; kind; expand }) let attr_str_type_decl attribute expand = T (Attr_str_type_decl, T { attribute; expand; expect = false }) - ;; let attr_sig_type_decl attribute expand = T (Attr_sig_type_decl, T { attribute; expand; expect = false }) - ;; let attr_str_module_type_decl attribute expand = T (Attr_str_module_type_decl, T { attribute; expand; expect = false }) - ;; let attr_sig_module_type_decl attribute expand = T (Attr_sig_module_type_decl, T { attribute; expand; expect = false }) - ;; let attr_str_type_ext attribute expand = T (Attr_str_type_ext, T { attribute; expand; expect = false }) - ;; let attr_sig_type_ext attribute expand = T (Attr_sig_type_ext, T { attribute; expand; expect = false }) - ;; let attr_str_exception attribute expand = T (Attr_str_exception, T { attribute; expand; expect = false }) - ;; let attr_sig_exception attribute expand = T (Attr_sig_exception, T { attribute; expand; expect = false }) - ;; let attr_str_type_decl_expect attribute expand = T (Attr_str_type_decl, T { attribute; expand; expect = true }) - ;; let attr_sig_type_decl_expect attribute expand = T (Attr_sig_type_decl, T { attribute; expand; expect = true }) - ;; let attr_str_module_type_decl_expect attribute expand = T (Attr_str_module_type_decl, T { attribute; expand; expect = true }) - ;; let attr_sig_module_type_decl_expect attribute expand = T (Attr_sig_module_type_decl, T { attribute; expand; expect = true }) - ;; let attr_str_type_ext_expect attribute expand = T (Attr_str_type_ext, T { attribute; expand; expect = true }) - ;; let attr_sig_type_ext_expect attribute expand = T (Attr_sig_type_ext, T { attribute; expand; expect = true }) - ;; let attr_str_exception_expect attribute expand = T (Attr_str_exception, T { attribute; expand; expect = true }) - ;; let attr_sig_exception_expect attribute expand = T (Attr_sig_exception, T { attribute; expand; expect = true }) - ;; end module Generated_code_hook = struct - type 'a single_or_many = - | Single of 'a - | Many of 'a list + type 'a single_or_many = Single of 'a | Many of 'a list - type t = - { f : 'a. 'a Extension.Context.t -> Location.t -> 'a single_or_many -> unit } + type t = { + f : 'a. 'a Extension.Context.t -> Location.t -> 'a single_or_many -> unit; + } let nop = { f = (fun _ _ _ -> ()) } let replace t context loc x = t.f context loc x + let insert_after t context (loc : Location.t) x = match x with | Many [] -> () @@ -218,115 +198,134 @@ end let rec map_node_rec context ts super_call loc base_ctxt x = - let ctxt = Expansion_context.Extension.make ~extension_point_loc:loc ~base:base_ctxt () in + let ctxt = + Expansion_context.Extension.make ~extension_point_loc:loc ~base:base_ctxt () + in match EC.get_extension context x with | None -> super_call base_ctxt x - | Some (ext, attrs) -> - match E.For_context.convert ts ~ctxt ext with - | None -> super_call base_ctxt x - | Some x -> - map_node_rec context ts super_call loc base_ctxt (EC.merge_attributes context x attrs) -;; + | Some (ext, attrs) -> ( + match E.For_context.convert ts ~ctxt ext with + | None -> super_call base_ctxt x + | Some x -> + map_node_rec context ts super_call loc base_ctxt + (EC.merge_attributes context x attrs)) let map_node context ts super_call loc base_ctxt x ~hook = - let ctxt = Expansion_context.Extension.make ~extension_point_loc:loc ~base:base_ctxt () in + let ctxt = + Expansion_context.Extension.make ~extension_point_loc:loc ~base:base_ctxt () + in match EC.get_extension context x with | None -> super_call base_ctxt x - | Some (ext, attrs) -> - match E.For_context.convert ts ~ctxt ext with - | None -> super_call base_ctxt x - | Some x -> - let generated_code = - map_node_rec context ts super_call loc base_ctxt (EC.merge_attributes context x attrs) - in - Generated_code_hook.replace hook context loc (Single generated_code); - generated_code -;; + | Some (ext, attrs) -> ( + match E.For_context.convert ts ~ctxt ext with + | None -> super_call base_ctxt x + | Some x -> + let generated_code = + map_node_rec context ts super_call loc base_ctxt + (EC.merge_attributes context x attrs) + in + Generated_code_hook.replace hook context loc (Single generated_code); + generated_code) -let rec map_nodes context ts super_call get_loc base_ctxt l ~hook ~in_generated_code = +let rec map_nodes context ts super_call get_loc base_ctxt l ~hook + ~in_generated_code = match l with | [] -> [] - | x :: l -> - match EC.get_extension context x with - | None -> - (* These two lets force the evaluation order, so that errors are reported in the - same order as they appear in the source file. *) - let x = super_call base_ctxt x in - let l = map_nodes context ts super_call get_loc base_ctxt l ~hook ~in_generated_code in - x :: l - | Some (ext, attrs) -> - let extension_point_loc = get_loc x in - let ctxt = Expansion_context.Extension.make ~extension_point_loc ~base:base_ctxt () in - match E.For_context.convert_inline ts ~ctxt ext with + | x :: l -> ( + match EC.get_extension context x with | None -> - let x = super_call base_ctxt x in - let l = - map_nodes context ts super_call get_loc base_ctxt l ~hook ~in_generated_code - in - x :: l - | Some x -> - assert_no_attributes attrs; - let generated_code = - map_nodes context ts super_call get_loc base_ctxt x ~hook - ~in_generated_code:true - in - if not in_generated_code then - Generated_code_hook.replace hook context extension_point_loc (Many generated_code); - generated_code - @ map_nodes context ts super_call get_loc base_ctxt l ~hook ~in_generated_code + (* These two lets force the evaluation order, so that errors are reported in the + same order as they appear in the source file. *) + let x = super_call base_ctxt x in + let l = + map_nodes context ts super_call get_loc base_ctxt l ~hook + ~in_generated_code + in + x :: l + | Some (ext, attrs) -> ( + let extension_point_loc = get_loc x in + let ctxt = + Expansion_context.Extension.make ~extension_point_loc + ~base:base_ctxt () + in + match E.For_context.convert_inline ts ~ctxt ext with + | None -> + let x = super_call base_ctxt x in + let l = + map_nodes context ts super_call get_loc base_ctxt l ~hook + ~in_generated_code + in + x :: l + | Some x -> + assert_no_attributes attrs; + let generated_code = + map_nodes context ts super_call get_loc base_ctxt x ~hook + ~in_generated_code:true + in + if not in_generated_code then + Generated_code_hook.replace hook context extension_point_loc + (Many generated_code); + generated_code + @ map_nodes context ts super_call get_loc base_ctxt l ~hook + ~in_generated_code)) let map_nodes = map_nodes ~in_generated_code:false let table_of_special_functions special_functions = match - List.map special_functions ~f:(fun { Rule.Special_function.ident; expand; _ } -> - (ident, expand)) + List.map special_functions + ~f:(fun { Rule.Special_function.ident; expand; _ } -> (ident, expand)) (* We expect the lookup to fail most of the time, by making the table big (and sparse), we make it more likely to fail quickly *) |> Hashtbl.of_alist ~size:(max 1024 (List.length special_functions * 2)) with | Ok table -> table | Error ident -> - Printf.ksprintf invalid_arg - "Context_free.V1.map_top_down: \ - %s present twice in list of special functions" - (List.find_map_exn special_functions ~f:(fun r -> - if Poly.equal r.ident ident then - Some r.name - else - None)) -;; - + Printf.ksprintf invalid_arg + "Context_free.V1.map_top_down: %s present twice in list of special \ + functions" + (List.find_map_exn special_functions ~f:(fun r -> + if Poly.equal r.ident ident then Some r.name else None)) + +(* [get_group attr l] returns the list of the attributes for each + node in [l]. + If [l] is empty or if none of the nodes in [l] have an attribute attached, + [get_group] returns [None]. + If [l] is not empty and at least one of the nodes in [l] has an attribue + attached, [get_group] returns the equivalent of + [Some (List.map ~f:(Attribute.get attr) l)]. *) let rec get_group attr l = match l with | [] -> None - | x :: l -> - match Attribute.get attr x, get_group attr l with - | None , None -> None - | None , Some vals -> Some (None :: vals) - | Some value , None -> Some (Some value :: List.map l ~f:(fun _ -> None)) - | Some value , Some vals -> Some (Some value :: vals) -;; + | x :: l -> ( + match (Attribute.get attr x, get_group attr l) with + | None, None -> None + | None, Some vals -> Some (None :: vals) + | Some value, None -> Some (Some value :: List.map l ~f:(fun _ -> None)) + | Some value, Some vals -> Some (Some value :: vals)) (* Same as [List.rev] then [List.concat] but expecting the input to be of length <= 2 *) let rev_concat = function | [] -> [] - | [x] -> x - | [x; y] -> y @ x + | [ x ] -> x + | [ x; y ] -> y @ x | l -> List.concat (List.rev l) -;; let sort_attr_group_inline l = List.sort l ~cmp:(fun a b -> - String.compare - (Rule.Attr_group_inline.attr_name a) - (Rule.Attr_group_inline.attr_name b)) + String.compare + (Rule.Attr_group_inline.attr_name a) + (Rule.Attr_group_inline.attr_name b)) let sort_attr_inline l = List.sort l ~cmp:(fun a b -> - String.compare - (Rule.Attr_inline.attr_name a) - (Rule.Attr_inline.attr_name b)) + String.compare + (Rule.Attr_inline.attr_name a) + (Rule.Attr_inline.attr_name b)) + +let context_free_attribute_modification ~loc = + Location.raise_errorf ~loc + "A context-free rule deleted or added attribues of a str/sig item" (* Returns the code generated by attribute handlers. We don't remove these attributes, as another pass might interpret them later. For instance both ppx_deriving and @@ -335,41 +334,47 @@ This complexity is horrible, but in practice we don't care as [attrs] is always a list of one element; it only has [@@deriving]. *) -let handle_attr_group_inline attrs rf items ~loc ~base_ctxt = - List.fold_left attrs ~init:[] - ~f:(fun acc (Rule.Attr_group_inline.T group) -> - match get_group group.attribute items with - | None -> acc - | Some values -> - let ctxt = - Expansion_context.Deriver.make ~derived_item_loc:loc - ~inline:group.expect ~base:base_ctxt () - in - let expect_items = group.expand ~ctxt rf items values in - expect_items :: acc) - -let handle_attr_inline attrs item ~loc ~base_ctxt = - List.fold_left attrs ~init:[] - ~f:(fun acc (Rule.Attr_inline.T a) -> - match Attribute.get a.attribute item with - | None -> acc - | Some value -> - let ctxt = - Expansion_context.Deriver.make ~derived_item_loc:loc - ~inline:a.expect ~base:base_ctxt () - in - let expect_items = a.expand ~ctxt item value in - expect_items :: acc) +let handle_attr_group_inline attrs rf ~items ~expanded_items ~loc ~base_ctxt = + List.fold_left attrs ~init:[] ~f:(fun acc (Rule.Attr_group_inline.T group) -> + match + ( get_group group.attribute items, + get_group group.attribute expanded_items ) + with + | None, None -> acc + | None, Some _ | Some _, None -> context_free_attribute_modification ~loc + | Some values, Some _ -> + let ctxt = + Expansion_context.Deriver.make ~derived_item_loc:loc + ~inline:group.expect ~base:base_ctxt () + in + let expect_items = group.expand ~ctxt rf expanded_items values in + expect_items :: acc) + +let handle_attr_inline attrs ~item ~expanded_item ~loc ~base_ctxt = + List.fold_left attrs ~init:[] ~f:(fun acc (Rule.Attr_inline.T a) -> + match + (Attribute.get a.attribute item, Attribute.get a.attribute expanded_item) + with + | None, None -> acc + | None, Some _ | Some _, None -> context_free_attribute_modification ~loc + | Some value, Some _ -> + let ctxt = + Expansion_context.Deriver.make ~derived_item_loc:loc + ~inline:a.expect ~base:base_ctxt () + in + let expect_items = a.expand ~ctxt expanded_item value in + expect_items :: acc) module Expect_mismatch_handler = struct - type t = - { f : 'a. 'a Attribute.Floating.Context.t -> Location.t -> 'a list -> unit } + type t = { + f : 'a. 'a Attribute.Floating.Context.t -> Location.t -> 'a list -> unit; + } - let nop = { f = fun _ _ _ -> () } + let nop = { f = (fun _ _ _ -> ()) } end -class map_top_down ?(expect_mismatch_handler=Expect_mismatch_handler.nop) - ?(generated_code_hook=Generated_code_hook.nop) rules = +class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) + ?(generated_code_hook = Generated_code_hook.nop) rules = let hook = generated_code_hook in let special_functions = @@ -377,71 +382,63 @@ in let constants = Rule.filter Constant rules - |> List.map ~f:(fun (c:Rule.Constant.t) -> ((c.suffix,c.kind),c.expand)) + |> List.map ~f:(fun (c : Rule.Constant.t) -> ((c.suffix, c.kind), c.expand)) |> Hashtbl.of_alist_exn in let extensions = Rule.filter Extension rules in - let class_expr = E.filter_by_context EC.class_expr extensions - and class_field = E.filter_by_context EC.class_field extensions - and class_type = E.filter_by_context EC.class_type extensions + let class_expr = E.filter_by_context EC.class_expr extensions + and class_field = E.filter_by_context EC.class_field extensions + and class_type = E.filter_by_context EC.class_type extensions and class_type_field = E.filter_by_context EC.class_type_field extensions - and core_type = E.filter_by_context EC.core_type extensions - and expression = E.filter_by_context EC.expression extensions - and module_expr = E.filter_by_context EC.module_expr extensions - and module_type = E.filter_by_context EC.module_type extensions - and pattern = E.filter_by_context EC.pattern extensions - and signature_item = E.filter_by_context EC.signature_item extensions - and structure_item = E.filter_by_context EC.structure_item extensions - in + and core_type = E.filter_by_context EC.core_type extensions + and expression = E.filter_by_context EC.expression extensions + and module_expr = E.filter_by_context EC.module_expr extensions + and module_type = E.filter_by_context EC.module_type extensions + and pattern = E.filter_by_context EC.pattern extensions + and signature_item = E.filter_by_context EC.signature_item extensions + and structure_item = E.filter_by_context EC.structure_item extensions + and ppx_import = E.filter_by_context EC.Ppx_import extensions in let attr_str_type_decls, attr_str_type_decls_expect = Rule.filter Attr_str_type_decl rules - |> sort_attr_group_inline - |> Rule.Attr_group_inline.split_normal_and_expect + |> sort_attr_group_inline |> Rule.Attr_group_inline.split_normal_and_expect in let attr_sig_type_decls, attr_sig_type_decls_expect = Rule.filter Attr_sig_type_decl rules - |> sort_attr_group_inline - |> Rule.Attr_group_inline.split_normal_and_expect + |> sort_attr_group_inline |> Rule.Attr_group_inline.split_normal_and_expect in let attr_str_module_type_decls, attr_str_module_type_decls_expect = Rule.filter Attr_str_module_type_decl rules - |> sort_attr_inline - |> Rule.Attr_inline.split_normal_and_expect + |> sort_attr_inline |> Rule.Attr_inline.split_normal_and_expect in let attr_sig_module_type_decls, attr_sig_module_type_decls_expect = Rule.filter Attr_sig_module_type_decl rules - |> sort_attr_inline - |> Rule.Attr_inline.split_normal_and_expect + |> sort_attr_inline |> Rule.Attr_inline.split_normal_and_expect in let attr_str_type_exts, attr_str_type_exts_expect = Rule.filter Attr_str_type_ext rules - |> sort_attr_inline - |> Rule.Attr_inline.split_normal_and_expect + |> sort_attr_inline |> Rule.Attr_inline.split_normal_and_expect in let attr_sig_type_exts, attr_sig_type_exts_expect = Rule.filter Attr_sig_type_ext rules - |> sort_attr_inline - |> Rule.Attr_inline.split_normal_and_expect + |> sort_attr_inline |> Rule.Attr_inline.split_normal_and_expect in let attr_str_exceptions, attr_str_exceptions_expect = Rule.filter Attr_str_exception rules - |> sort_attr_inline - |> Rule.Attr_inline.split_normal_and_expect + |> sort_attr_inline |> Rule.Attr_inline.split_normal_and_expect in let attr_sig_exceptions, attr_sig_exceptions_expect = Rule.filter Attr_sig_exception rules - |> sort_attr_inline - |> Rule.Attr_inline.split_normal_and_expect + |> sort_attr_inline |> Rule.Attr_inline.split_normal_and_expect in - let map_node = map_node ~hook in + let map_node = map_node ~hook in let map_nodes = map_nodes ~hook in - object(self) + object (self) inherit Ast_traverse.map_with_expansion_context as super (* No point recursing into every location *) @@ -457,63 +454,66 @@ let e = match e.pexp_desc with | Pexp_extension _ -> - map_node EC.expression expression (fun _ e -> e) e.pexp_loc base_ctxt e + map_node EC.expression expression + (fun _ e -> e) + e.pexp_loc base_ctxt e | _ -> e in let expand_constant kind char text = - match Hashtbl.find_opt constants (char,kind) with + match Hashtbl.find_opt constants (char, kind) with | None -> super#expression base_ctxt e | Some expand -> self#expression base_ctxt (expand e.pexp_loc text) in match e.pexp_desc with - | Pexp_apply ({ pexp_desc = Pexp_ident id; _ } as func, args) -> begin + | Pexp_apply (({ pexp_desc = Pexp_ident id; _ } as func), args) -> ( match Hashtbl.find_opt special_functions id.txt with | None -> - self#pexp_apply_without_traversing_function base_ctxt e func args - | Some pattern -> - match pattern e with - | None -> self#pexp_apply_without_traversing_function base_ctxt e func args - | Some e -> - self#expression base_ctxt e - end - | Pexp_ident id -> begin + | Some pattern -> ( + match pattern e with + | None -> + self#pexp_apply_without_traversing_function base_ctxt e func + args + | Some e -> self#expression base_ctxt e)) + | Pexp_ident id -> ( match Hashtbl.find_opt special_functions id.txt with - | None -> - super#expression base_ctxt e - | Some pattern -> - match pattern e with - | None -> - super#expression base_ctxt e - | Some e -> - self#expression base_ctxt e - end - | Pexp_constant (Pconst_integer (s, Some c)) -> expand_constant Integer c s - | Pexp_constant (Pconst_float (s, Some c)) -> expand_constant Float c s - | _ -> - super#expression base_ctxt e + | None -> super#expression base_ctxt e + | Some pattern -> ( + match pattern e with + | None -> super#expression base_ctxt e + | Some e -> self#expression base_ctxt e)) + | Pexp_constant (Pconst_integer (s, Some c)) -> + expand_constant Integer c s + | Pexp_constant (Pconst_float (s, Some c)) -> expand_constant Float c s + | _ -> super#expression base_ctxt e (* Pre-conditions: - e.pexp_desc = Pexp_apply(func, args) - func.pexp_desc = Pexp_ident _ *) - method private pexp_apply_without_traversing_function base_ctxt e func args = - let { pexp_desc = _; pexp_loc; pexp_attributes; pexp_loc_stack; } = e in + method private pexp_apply_without_traversing_function base_ctxt e func args + = + let { pexp_desc = _; pexp_loc; pexp_attributes; pexp_loc_stack } = e in let func = let { pexp_desc; pexp_loc; pexp_attributes; pexp_loc_stack } = func in let pexp_attributes = self#attributes base_ctxt pexp_attributes in - { pexp_desc - ; pexp_loc (* location doesn't need to be traversed *) - ; pexp_attributes - ; pexp_loc_stack + { + pexp_desc; + pexp_loc (* location doesn't need to be traversed *); + pexp_attributes; + pexp_loc_stack; } in - let args = List.map args ~f:(fun (lab, exp) -> (lab, self#expression base_ctxt exp)) in + let args = + List.map args ~f:(fun (lab, exp) -> + (lab, self#expression base_ctxt exp)) + in let pexp_attributes = self#attributes base_ctxt pexp_attributes in - { pexp_loc - ; pexp_attributes - ; pexp_desc = Pexp_apply (func, args) - ; pexp_loc_stack + { + pexp_loc; + pexp_attributes; + pexp_desc = Pexp_apply (func, args); + pexp_loc_stack; } method! class_type base_ctxt x = @@ -527,42 +527,55 @@ map_node EC.class_expr class_expr super#class_expr x.pcl_loc base_ctxt x method! class_field base_ctxt x = - map_node EC.class_field class_field super#class_field x.pcf_loc base_ctxt x + map_node EC.class_field class_field super#class_field x.pcf_loc base_ctxt + x method! module_type base_ctxt x = - map_node EC.module_type module_type super#module_type x.pmty_loc base_ctxt x + map_node EC.module_type module_type super#module_type x.pmty_loc base_ctxt + x method! module_expr base_ctxt x = - map_node EC.module_expr module_expr super#module_expr x.pmod_loc base_ctxt x + map_node EC.module_expr module_expr super#module_expr x.pmod_loc base_ctxt + x method! structure_item base_ctxt x = - map_node EC.structure_item structure_item super#structure_item x.pstr_loc base_ctxt x + map_node EC.structure_item structure_item super#structure_item x.pstr_loc + base_ctxt x method! signature_item base_ctxt x = - map_node EC.signature_item signature_item super#signature_item x.psig_loc base_ctxt x + map_node EC.signature_item signature_item super#signature_item x.psig_loc + base_ctxt x method! class_structure base_ctxt { pcstr_self; pcstr_fields } = let pcstr_self = self#pattern base_ctxt pcstr_self in let pcstr_fields = map_nodes EC.class_field class_field super#class_field - (fun x -> x.pcf_loc) base_ctxt pcstr_fields + (fun x -> x.pcf_loc) + base_ctxt pcstr_fields in { pcstr_self; pcstr_fields } + method! type_declaration base_ctxt x = + map_node EC.Ppx_import ppx_import super#type_declaration x.ptype_loc + base_ctxt x + method! class_signature base_ctxt { pcsig_self; pcsig_fields } = let pcsig_self = self#core_type base_ctxt pcsig_self in let pcsig_fields = map_nodes EC.class_type_field class_type_field super#class_type_field - (fun x -> x.pctf_loc) base_ctxt pcsig_fields + (fun x -> x.pctf_loc) + base_ctxt pcsig_fields in { pcsig_self; pcsig_fields } (* TODO: try to factorize #structure and #signature without meta-programming *) (*$*) method! structure base_ctxt st = - let rec with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code = - let item = super#structure_item base_ctxt item in - let extra_items = loop (rev_concat extra_items) ~in_generated_code:true in + let rec with_extra_items item ~extra_items ~expect_items ~rest + ~in_generated_code = + let extra_items = + loop (rev_concat extra_items) ~in_generated_code:true + in if not in_generated_code then Generated_code_hook.insert_after hook Structure_item item.pstr_loc (Many extra_items); @@ -571,79 +584,99 @@ (match expect_items with | [] -> () | _ -> - let expected = rev_concat expect_items in - let pos = item.pstr_loc.loc_end in - Code_matcher.match_structure original_rest ~pos ~expected - ~mismatch_handler:(fun loc repl -> - expect_mismatch_handler.f Structure_item loc repl)); + let expected = rev_concat expect_items in + let pos = item.pstr_loc.loc_end in + Code_matcher.match_structure original_rest ~pos ~expected + ~mismatch_handler:(fun loc repl -> + expect_mismatch_handler.f Structure_item loc repl)); item :: (extra_items @ rest) and loop st ~in_generated_code = match st with | [] -> [] - | item :: rest -> - let loc = item.pstr_loc in - match item.pstr_desc with - | Pstr_extension (ext, attrs) -> begin - let extension_point_loc = item.pstr_loc in - let ctxt = Expansion_context.Extension.make ~extension_point_loc ~base:base_ctxt () in - match E.For_context.convert_inline structure_item ~ctxt ext with - | None -> - let item = super#structure_item base_ctxt item in - let rest = self#structure base_ctxt rest in - item :: rest - | Some items -> - assert_no_attributes attrs; - let items = loop items ~in_generated_code:true in - if not in_generated_code then - Generated_code_hook.replace hook Structure_item item.pstr_loc - (Many items); - items @ loop rest ~in_generated_code - end - - | Pstr_type(rf, tds) -> - let extra_items = - handle_attr_group_inline attr_str_type_decls rf tds ~loc ~base_ctxt - in - let expect_items = - handle_attr_group_inline attr_str_type_decls_expect rf tds ~loc ~base_ctxt - in - with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code - - | Pstr_modtype mtd -> - let extra_items = - handle_attr_inline attr_str_module_type_decls mtd ~loc ~base_ctxt - in - let expect_items = - handle_attr_inline attr_str_module_type_decls_expect mtd ~loc ~base_ctxt - in - with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code - - | Pstr_typext te -> - let extra_items = handle_attr_inline attr_str_type_exts te ~loc ~base_ctxt in - let expect_items = - handle_attr_inline attr_str_type_exts_expect te ~loc ~base_ctxt - in - with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code - - | Pstr_exception ec -> - let extra_items = handle_attr_inline attr_str_exceptions ec ~loc ~base_ctxt in - let expect_items = - handle_attr_inline attr_str_exceptions_expect ec ~loc ~base_ctxt - in - with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code - - | _ -> - let item = self#structure_item base_ctxt item in - let rest = self#structure base_ctxt rest in - item :: rest + | item :: rest -> ( + let loc = item.pstr_loc in + match item.pstr_desc with + | Pstr_extension (ext, attrs) -> ( + let extension_point_loc = item.pstr_loc in + let ctxt = + Expansion_context.Extension.make ~extension_point_loc + ~base:base_ctxt () + in + match E.For_context.convert_inline structure_item ~ctxt ext with + | None -> + let item = super#structure_item base_ctxt item in + let rest = self#structure base_ctxt rest in + item :: rest + | Some items -> + assert_no_attributes attrs; + let items = loop items ~in_generated_code:true in + if not in_generated_code then + Generated_code_hook.replace hook Structure_item + item.pstr_loc (Many items); + items @ loop rest ~in_generated_code) + | _ -> ( + let expanded_item = super#structure_item base_ctxt item in + match (item.pstr_desc, expanded_item.pstr_desc) with + | Pstr_type (rf, tds), Pstr_type (exp_rf, exp_tds) -> + (* No context-free rule can rewrite rec flags atm, this + assert acts as a failsafe in case it ever changes *) + assert (Poly.(rf = exp_rf)); + let extra_items = + handle_attr_group_inline attr_str_type_decls rf ~items:tds + ~expanded_items:exp_tds ~loc ~base_ctxt + in + let expect_items = + handle_attr_group_inline attr_str_type_decls_expect rf + ~items:tds ~expanded_items:exp_tds ~loc ~base_ctxt + in + with_extra_items expanded_item ~extra_items ~expect_items + ~rest ~in_generated_code + | Pstr_modtype mtd, Pstr_modtype exp_mtd -> + let extra_items = + handle_attr_inline attr_str_module_type_decls ~item:mtd + ~expanded_item:exp_mtd ~loc ~base_ctxt + in + let expect_items = + handle_attr_inline attr_str_module_type_decls_expect + ~item:mtd ~expanded_item:exp_mtd ~loc ~base_ctxt + in + with_extra_items expanded_item ~extra_items ~expect_items + ~rest ~in_generated_code + | Pstr_typext te, Pstr_typext exp_te -> + let extra_items = + handle_attr_inline attr_str_type_exts ~item:te + ~expanded_item:exp_te ~loc ~base_ctxt + in + let expect_items = + handle_attr_inline attr_str_type_exts_expect ~item:te + ~expanded_item:exp_te ~loc ~base_ctxt + in + with_extra_items expanded_item ~extra_items ~expect_items + ~rest ~in_generated_code + | Pstr_exception ec, Pstr_exception exp_ec -> + let extra_items = + handle_attr_inline attr_str_exceptions ~item:ec + ~expanded_item:exp_ec ~loc ~base_ctxt + in + let expect_items = + handle_attr_inline attr_str_exceptions_expect ~item:ec + ~expanded_item:exp_ec ~loc ~base_ctxt + in + with_extra_items expanded_item ~extra_items ~expect_items + ~rest ~in_generated_code + | _, _ -> + let rest = self#structure base_ctxt rest in + expanded_item :: rest)) in loop st ~in_generated_code:false (*$ str_to_sig _last_text_block *) method! signature base_ctxt sg = - let rec with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code = - let item = super#signature_item base_ctxt item in - let extra_items = loop (rev_concat extra_items) ~in_generated_code:true in + let rec with_extra_items item ~extra_items ~expect_items ~rest + ~in_generated_code = + let extra_items = + loop (rev_concat extra_items) ~in_generated_code:true + in if not in_generated_code then Generated_code_hook.insert_after hook Signature_item item.psig_loc (Many extra_items); @@ -652,71 +685,89 @@ (match expect_items with | [] -> () | _ -> - let expected = rev_concat expect_items in - let pos = item.psig_loc.loc_end in - Code_matcher.match_signature original_rest ~pos ~expected - ~mismatch_handler:(fun loc repl -> - expect_mismatch_handler.f Signature_item loc repl)); + let expected = rev_concat expect_items in + let pos = item.psig_loc.loc_end in + Code_matcher.match_signature original_rest ~pos ~expected + ~mismatch_handler:(fun loc repl -> + expect_mismatch_handler.f Signature_item loc repl)); item :: (extra_items @ rest) and loop sg ~in_generated_code = match sg with | [] -> [] - | item :: rest -> - let loc = item.psig_loc in - match item.psig_desc with - | Psig_extension (ext, attrs) -> begin - let extension_point_loc = item.psig_loc in - let ctxt = Expansion_context.Extension.make ~extension_point_loc ~base:base_ctxt () in - match E.For_context.convert_inline signature_item ~ctxt ext with - | None -> - let item = super#signature_item base_ctxt item in - let rest = self#signature base_ctxt rest in - item :: rest - | Some items -> - assert_no_attributes attrs; - let items = loop items ~in_generated_code:true in - if not in_generated_code then - Generated_code_hook.replace hook Signature_item item.psig_loc - (Many items); - items @ loop rest ~in_generated_code - end - - | Psig_type(rf, tds) -> - let extra_items = - handle_attr_group_inline attr_sig_type_decls rf tds ~loc ~base_ctxt - in - let expect_items = - handle_attr_group_inline attr_sig_type_decls_expect rf tds ~loc ~base_ctxt - in - with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code - - | Psig_modtype mtd -> - let extra_items = - handle_attr_inline attr_sig_module_type_decls mtd ~loc ~base_ctxt - in - let expect_items = - handle_attr_inline attr_sig_module_type_decls_expect mtd ~loc ~base_ctxt - in - with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code - - | Psig_typext te -> - let extra_items = handle_attr_inline attr_sig_type_exts te ~loc ~base_ctxt in - let expect_items = - handle_attr_inline attr_sig_type_exts_expect te ~loc ~base_ctxt - in - with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code - - | Psig_exception ec -> - let extra_items = handle_attr_inline attr_sig_exceptions ec ~loc ~base_ctxt in - let expect_items = - handle_attr_inline attr_sig_exceptions_expect ec ~loc ~base_ctxt - in - with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code - - | _ -> - let item = self#signature_item base_ctxt item in - let rest = self#signature base_ctxt rest in - item :: rest + | item :: rest -> ( + let loc = item.psig_loc in + match item.psig_desc with + | Psig_extension (ext, attrs) -> ( + let extension_point_loc = item.psig_loc in + let ctxt = + Expansion_context.Extension.make ~extension_point_loc + ~base:base_ctxt () + in + match E.For_context.convert_inline signature_item ~ctxt ext with + | None -> + let item = super#signature_item base_ctxt item in + let rest = self#signature base_ctxt rest in + item :: rest + | Some items -> + assert_no_attributes attrs; + let items = loop items ~in_generated_code:true in + if not in_generated_code then + Generated_code_hook.replace hook Signature_item + item.psig_loc (Many items); + items @ loop rest ~in_generated_code) + | _ -> ( + let expanded_item = super#signature_item base_ctxt item in + match (item.psig_desc, expanded_item.psig_desc) with + | Psig_type (rf, tds), Psig_type (exp_rf, exp_tds) -> + (* No context-free rule can rewrite rec flags atm, this + assert acts as a failsafe in case it ever changes *) + assert (Poly.(rf = exp_rf)); + let extra_items = + handle_attr_group_inline attr_sig_type_decls rf ~items:tds + ~expanded_items:exp_tds ~loc ~base_ctxt + in + let expect_items = + handle_attr_group_inline attr_sig_type_decls_expect rf + ~items:tds ~expanded_items:exp_tds ~loc ~base_ctxt + in + with_extra_items expanded_item ~extra_items ~expect_items + ~rest ~in_generated_code + | Psig_modtype mtd, Psig_modtype exp_mtd -> + let extra_items = + handle_attr_inline attr_sig_module_type_decls ~item:mtd + ~expanded_item:exp_mtd ~loc ~base_ctxt + in + let expect_items = + handle_attr_inline attr_sig_module_type_decls_expect + ~item:mtd ~expanded_item:exp_mtd ~loc ~base_ctxt + in + with_extra_items expanded_item ~extra_items ~expect_items + ~rest ~in_generated_code + | Psig_typext te, Psig_typext exp_te -> + let extra_items = + handle_attr_inline attr_sig_type_exts ~item:te + ~expanded_item:exp_te ~loc ~base_ctxt + in + let expect_items = + handle_attr_inline attr_sig_type_exts_expect ~item:te + ~expanded_item:exp_te ~loc ~base_ctxt + in + with_extra_items expanded_item ~extra_items ~expect_items + ~rest ~in_generated_code + | Psig_exception ec, Psig_exception exp_ec -> + let extra_items = + handle_attr_inline attr_sig_exceptions ~item:ec + ~expanded_item:exp_ec ~loc ~base_ctxt + in + let expect_items = + handle_attr_inline attr_sig_exceptions_expect ~item:ec + ~expanded_item:exp_ec ~loc ~base_ctxt + in + with_extra_items expanded_item ~extra_items ~expect_items + ~rest ~in_generated_code + | _, _ -> + let rest = self#signature base_ctxt rest in + expanded_item :: rest)) in loop sg ~in_generated_code:false diff -Nru ppxlib-0.15.0/src/context_free.mli ppxlib-0.24.0/src/context_free.mli --- ppxlib-0.15.0/src/context_free.mli 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/context_free.mli 2021-12-08 21:53:37.000000000 +0000 @@ -5,128 +5,142 @@ (** Local rewriting rules. This module lets you define local rewriting rules, such as extension point - expanders. It is not completely generic and you cannot define any kind of rewriting, - it currently focuses on what is commonly used. New scheme can be added on demand. + expanders. It is not completely generic and you cannot define any kind of + rewriting, it currently focuses on what is commonly used. New scheme can be + added on demand. - We have some ideas to make this fully generic, but this hasn't been a priority so - far. -*) + We have some ideas to make this fully generic, but this hasn't been a + priority so far. *) module Rule : sig type t - (** Rewrite an extension point *) val extension : Extension.t -> t + (** Rewrite an extension point *) - (** [special_function id expand] is a rule to rewrite a function call at parsing time. - [id] is the identifier to match on and [expand] is used to expand the full function - application (it gets the Pexp_apply node). If the function is found in the tree - without being applied, [expand] gets only the identifier (Pexp_ident node) so you - should handle both cases. - - If [id] is an operator identifier and contains dots, it should be parenthesized - (e.g. ["(+.+)"]). - - [expand] must decide whether the expression it receive can be rewritten or not. - Especially ppxlib makes the assumption that [expand] is idempotent. It will loop - if it is not. *) - val special_function - : string - -> (expression -> expression option) - -> t + val special_function : string -> (expression -> expression option) -> t + (** [special_function id expand] is a rule to rewrite a function call at + parsing time. [id] is the identifier to match on and [expand] is used to + expand the full function application (it gets the Pexp_apply node). If the + function is found in the tree without being applied, [expand] gets only + the identifier (Pexp_ident node) so you should handle both cases. + + If [id] is an operator identifier and contains dots, it should be + parenthesized (e.g. ["(+.+)"]). + + [expand] must decide whether the expression it receive can be rewritten or + not. Especially ppxlib makes the assumption that [expand] is idempotent. + It will loop if it is not. *) (** Used for the [constant] function. *) module Constant_kind : sig type t = Float | Integer end - (** [constant kind suffix expander] Registers an extension for transforming constants - literals, based on the suffix character. *) - val constant - : Constant_kind.t - -> char - -> (Location.t -> string -> Parsetree.expression) - -> t - - (** The rest of this API is for rewriting rules that apply when a certain attribute is - present. The API is not complete and is currently only enough to implement - deriving. *) + val constant : + Constant_kind.t -> + char -> + (Location.t -> string -> Parsetree.expression) -> + t + (** [constant kind suffix expander] Registers an extension for transforming + constants literals, based on the suffix character. *) + + (** The rest of this API is for rewriting rules that apply when a certain + attribute is present. The API is not complete and is currently only enough + to implement deriving. *) + type ('a, 'b, 'c) attr_group_inline = + ('b, 'c) Attribute.t -> + (ctxt:Expansion_context.Deriver.t -> + Asttypes.rec_flag -> + 'b list -> + 'c option list -> + 'a list) -> + t (** Match the attribute on a group of items, such as a group of recursive type - definitions (Pstr_type, Psig_type). The expander will be triggered if any of the - item has the attribute. The expander is called as follow: + definitions (Pstr_type, Psig_type). The expander will be triggered if any + of the item has the attribute. The expander is called as follow: [expand ~loc ~path rec_flag items values] - where [values] is the list of values associated to the attribute for each item in - [items]. [expand] must return a list of element to add after the group. For instance - a list of structure item to add after a group of type definitions. - *) - type ('a, 'b, 'c) attr_group_inline = - ('b, 'c) Attribute.t - -> (ctxt:Expansion_context.Deriver.t - -> Asttypes.rec_flag - -> 'b list - -> 'c option list - -> 'a list) - -> t - - val attr_str_type_decl : (structure_item, type_declaration, _) attr_group_inline - val attr_sig_type_decl : (signature_item, type_declaration, _) attr_group_inline - - (** The _expect variants are for producing code that is compared to what the user wrote - in the source code. *) - val attr_str_type_decl_expect : (structure_item, type_declaration, _) attr_group_inline - val attr_sig_type_decl_expect : (signature_item, type_declaration, _) attr_group_inline + where [values] is the list of values associated to the attribute for each + item in [items]. [expand] must return a list of element to add after the + group. For instance a list of structure item to add after a group of type + definitions. *) + + val attr_str_type_decl : + (structure_item, type_declaration, _) attr_group_inline + + val attr_sig_type_decl : + (signature_item, type_declaration, _) attr_group_inline + + val attr_str_type_decl_expect : + (structure_item, type_declaration, _) attr_group_inline + (** The _expect variants are for producing code that is compared to what the + user wrote in the source code. *) + + val attr_sig_type_decl_expect : + (signature_item, type_declaration, _) attr_group_inline - (** Same as [attr_group_inline] but for elements that are not part of a group, such as - exceptions and type extensions *) type ('a, 'b, 'c) attr_inline = - ('b, 'c) Attribute.t - -> (ctxt:Expansion_context.Deriver.t - -> 'b - -> 'c - -> 'a list) - -> t + ('b, 'c) Attribute.t -> + (ctxt:Expansion_context.Deriver.t -> 'b -> 'c -> 'a list) -> + t + (** Same as [attr_group_inline] but for elements that are not part of a group, + such as exceptions and type extensions *) + + val attr_str_module_type_decl : + (structure_item, module_type_declaration, _) attr_inline + + val attr_sig_module_type_decl : + (signature_item, module_type_declaration, _) attr_inline - val attr_str_module_type_decl : (structure_item, module_type_declaration, _) attr_inline - val attr_sig_module_type_decl : (signature_item, module_type_declaration, _) attr_inline + val attr_str_module_type_decl_expect : + (structure_item, module_type_declaration, _) attr_inline - val attr_str_module_type_decl_expect : (structure_item, module_type_declaration, _) attr_inline - val attr_sig_module_type_decl_expect : (signature_item, module_type_declaration, _) attr_inline + val attr_sig_module_type_decl_expect : + (signature_item, module_type_declaration, _) attr_inline val attr_str_type_ext : (structure_item, type_extension, _) attr_inline + val attr_sig_type_ext : (signature_item, type_extension, _) attr_inline val attr_str_type_ext_expect : (structure_item, type_extension, _) attr_inline + val attr_sig_type_ext_expect : (signature_item, type_extension, _) attr_inline val attr_str_exception : (structure_item, type_exception, _) attr_inline + val attr_sig_exception : (signature_item, type_exception, _) attr_inline - val attr_str_exception_expect : (structure_item, type_exception, _) attr_inline - val attr_sig_exception_expect : (signature_item, type_exception, _) attr_inline + val attr_str_exception_expect : + (structure_item, type_exception, _) attr_inline + + val attr_sig_exception_expect : + (signature_item, type_exception, _) attr_inline end (**/**) + (*_ This API is not stable *) module Generated_code_hook : sig - type 'a single_or_many = - | Single of 'a - | Many of 'a list + type 'a single_or_many = Single of 'a | Many of 'a list (*_ Hook called whenever we generate code some *) - type t = - { f : 'a. 'a Extension.Context.t -> Location.t -> 'a single_or_many -> unit } + type t = { + f : 'a. 'a Extension.Context.t -> Location.t -> 'a single_or_many -> unit; + } val nop : t end module Expect_mismatch_handler : sig - type t = - { f : 'a. 'a Attribute.Floating.Context.t -> Location.t -> 'a list -> unit } + type t = { + f : 'a. 'a Attribute.Floating.Context.t -> Location.t -> 'a list -> unit; + } val nop : t end + (**/**) (* TODO: a simple comment here is fine, while we would expect only docstring or (*_ *) @@ -134,10 +148,10 @@ This means https://github.com/ocaml/ocaml/pull/477 was not complete and indeed the parser should be fixed. *) -class map_top_down - : ?expect_mismatch_handler:Expect_mismatch_handler.t - (* default: Expect_mismatch_handler.nop *) - -> ?generated_code_hook:Generated_code_hook.t - (* default: Generated_code_hook.nop *) - -> Rule.t list - -> Ast_traverse.map_with_expansion_context +class map_top_down : + ?expect_mismatch_handler: + Expect_mismatch_handler.t (* default: Expect_mismatch_handler.nop *) + -> ?generated_code_hook: + Generated_code_hook.t (* default: Generated_code_hook.nop *) + -> Rule.t list + -> Ast_traverse.map_with_expansion_context diff -Nru ppxlib-0.15.0/src/deriving.ml ppxlib-0.24.0/src/deriving.ml --- ppxlib-0.15.0/src/deriving.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/deriving.ml 2021-12-08 21:53:37.000000000 +0000 @@ -5,105 +5,124 @@ contains compiler attribute to disable unused warnings, instead of inserting [let _ = ... ]. *) let do_insert_unused_warning_attribute = ref false + let keep_w32_impl = ref false + let keep_w32_intf = ref false + let () = let keep_w32_spec = Caml.Arg.Symbol - (["impl"; "intf"; "both"], - (function - | "impl" -> keep_w32_impl := true - | "intf" -> keep_w32_intf := true - | "both" -> - keep_w32_impl := true; - keep_w32_intf := true - | _ -> assert false)) + ( [ "impl"; "intf"; "both" ], + function + | "impl" -> keep_w32_impl := true + | "intf" -> keep_w32_intf := true + | "both" -> + keep_w32_impl := true; + keep_w32_intf := true + | _ -> assert false ) in let conv_w32_spec = Caml.Arg.Symbol - (["code"; "attribute"], - (function - | "code" -> do_insert_unused_warning_attribute := false - | "attribute" -> do_insert_unused_warning_attribute := true - | _ -> assert false)) + ( [ "code"; "attribute" ], + function + | "code" -> do_insert_unused_warning_attribute := false + | "attribute" -> do_insert_unused_warning_attribute := true + | _ -> assert false ) in - Driver.add_arg "-deriving-keep-w32" - keep_w32_spec + Driver.add_arg "-deriving-keep-w32" keep_w32_spec ~doc:" Do not try to disable warning 32 for the generated code"; - Driver.add_arg "-deriving-disable-w32-method" - conv_w32_spec + Driver.add_arg "-deriving-disable-w32-method" conv_w32_spec ~doc:" How to disable warning 32 for the generated code"; - Driver.add_arg "-type-conv-keep-w32" - keep_w32_spec + Driver.add_arg "-type-conv-keep-w32" keep_w32_spec ~doc:" Deprecated, use -deriving-keep-w32"; - Driver.add_arg "-type-conv-w32" - conv_w32_spec + Driver.add_arg "-type-conv-w32" conv_w32_spec ~doc:" Deprecated, use -deriving-disable-w32-method" let keep_w32_impl () = !keep_w32_impl || Driver.pretty () + let keep_w32_intf () = !keep_w32_intf || Driver.pretty () -module Args = struct - include (Ast_pattern : module type of struct include Ast_pattern end - with type ('a, 'b, 'c) t := ('a, 'b, 'c) Ast_pattern.t) +let keep_w60_impl = ref false - type 'a param = - { name : string - ; pattern : (expression, 'a) Ast_pattern.Packed.t - ; default : 'a - } +let keep_w60_intf = ref false + +let () = + let keep_w60_spec = + Caml.Arg.Symbol + ( [ "impl"; "intf"; "both" ], + function + | "impl" -> keep_w60_impl := true + | "intf" -> keep_w60_intf := true + | "both" -> + keep_w60_impl := true; + keep_w60_intf := true + | _ -> assert false ) + in + Driver.add_arg "-deriving-keep-w60" keep_w60_spec + ~doc:" Do not try to disable warning 60 for the generated code" + +let keep_w60_impl () = !keep_w60_impl || Driver.pretty () + +let keep_w60_intf () = !keep_w60_intf || Driver.pretty () + +module Args = struct + include ( + Ast_pattern : + module type of struct + include Ast_pattern + end + with type ('a, 'b, 'c) t := ('a, 'b, 'c) Ast_pattern.t) + + type 'a param = { + name : string; + pattern : (expression, 'a) Ast_pattern.Packed.t; + default : 'a; + } let arg name pattern = - { name - ; default = None - ; pattern = Ast_pattern.Packed.create pattern (fun x -> Some x) + { + name; + default = None; + pattern = Ast_pattern.Packed.create pattern (fun x -> Some x); } - ;; let flag name = let pattern = pexp_ident (lident (string name)) in - { name - ; default = false - ; pattern = Ast_pattern.Packed.create pattern true - } - ;; + { name; default = false; pattern = Ast_pattern.Packed.create pattern true } type (_, _) t = - | Nil : ('m, 'm) t + | Nil : ('m, 'm) t | Cons : ('m1, 'a -> 'm2) t * 'a param -> ('m1, 'm2) t let empty = Nil + let ( +> ) a b = Cons (a, b) let rec names : type a b. (a, b) t -> string list = function | Nil -> [] | Cons (t, p) -> p.name :: names t - ;; module Instance = struct type (_, _) instance = - | I_nil : ('m, 'm) instance + | I_nil : ('m, 'm) instance | I_cons : ('m1, 'a -> 'm2) instance * 'a -> ('m1, 'm2) instance - let rec create - : type a b. (a, b) t -> (string * expression) list -> (a, b) instance - = fun spec args -> - match spec with - | Nil -> I_nil - | Cons (t, p) -> + let rec create : + type a b. (a, b) t -> (string * expression) list -> (a, b) instance = + fun spec args -> + match spec with + | Nil -> I_nil + | Cons (t, p) -> let value = match List.assoc_opt p.name args with | None -> p.default | Some expr -> Ast_pattern.Packed.parse p.pattern expr.pexp_loc expr in I_cons (create t args, value) - ;; - let rec apply : type a b. (a, b) instance -> a -> b = fun t f -> - match t with - | I_nil -> f - | I_cons (t, x) -> apply t f x - ;; + let rec apply : type a b. (a, b) instance -> a -> b = + fun t f -> match t with I_nil -> f | I_cons (t, x) -> apply t f x end let apply t args f = Instance.apply (Instance.create t args) f @@ -114,40 +133,39 @@ +-----------------------------------------------------------------+ *) type t = string + let ignore (_ : t) = () type parsed_args = - | Args of (string * expression) list + | Args of (string * expression) list | Unknown_syntax of Location.t * string module Generator = struct type deriver = t + type ('a, 'b) t = - | T : { spec : ('c, 'a) Args.t - ; gen : ctxt:Expansion_context.Deriver.t -> 'b -> 'c - ; arg_names : String.Set.t - ; attributes : Attribute.packed list - ; deps : deriver list - } -> ('a, 'b) t + | T : { + spec : ('c, 'a) Args.t; + gen : ctxt:Expansion_context.Deriver.t -> 'b -> 'c; + arg_names : String.Set.t; + attributes : Attribute.packed list; + deps : deriver list; + } + -> ('a, 'b) t let deps (T t) = t.deps module V2 = struct - let make ?(attributes=[]) ?(deps=[]) spec gen = + let make ?(attributes = []) ?(deps = []) spec gen = let arg_names = String.Set.of_list (Args.names spec) in - T { spec - ; gen - ; arg_names - ; attributes - ; deps - } - ;; + T { spec; gen; arg_names; attributes; deps } let make_noarg ?attributes ?deps gen = make ?attributes ?deps Args.empty gen end let make ?attributes ?deps spec gen = - V2.make ?attributes ?deps spec (Expansion_context.Deriver.with_loc_and_path gen) + V2.make ?attributes ?deps spec + (Expansion_context.Deriver.with_loc_and_path gen) let make_noarg ?attributes ?deps gen = make ?attributes ?deps Args.empty gen @@ -160,110 +178,149 @@ let check_arguments name generators (args : (string * expression) list) = List.iter args ~f:(fun (label, e) -> - if String.is_empty label then - Location.raise_errorf ~loc:e.pexp_loc - "Ppxlib.Deriving: generator arguments must be labelled"); - Option.iter (List.find_a_dup args ~compare:(fun (a, _) (b, _) -> String.compare a b)) + if String.is_empty label then + Location.raise_errorf ~loc:e.pexp_loc + "Ppxlib.Deriving: generator arguments must be labelled"); + Option.iter + (List.find_a_dup args ~compare:(fun (a, _) (b, _) -> String.compare a b)) ~f:(fun (label, e) -> Location.raise_errorf ~loc:e.pexp_loc "Ppxlib.Deriving: argument labelled '%s' appears more than once" label); let accepted_args = merge_accepted_args generators in List.iter args ~f:(fun (label, e) -> - if not (String.Set.mem label accepted_args) then - let spellcheck_msg = - match Spellcheck.spellcheck (String.Set.elements accepted_args) label with - | None -> "" - | Some s -> ".\n" ^ s - in - Location.raise_errorf ~loc:e.pexp_loc - "Ppxlib.Deriving: generator '%s' doesn't accept argument '%s'%s" - name label spellcheck_msg); - ;; - - let apply (T t) ~name:_ ~ctxt x args = - Args.apply t.spec args (t.gen ~ctxt x) - ;; + if not (String.Set.mem label accepted_args) then + let spellcheck_msg = + match + Spellcheck.spellcheck (String.Set.elements accepted_args) label + with + | None -> "" + | Some s -> ".\n" ^ s + in + Location.raise_errorf ~loc:e.pexp_loc + "Ppxlib.Deriving: generator '%s' doesn't accept argument '%s'%s" + name label spellcheck_msg) + + let apply (T t) ~name:_ ~ctxt x args = Args.apply t.spec args (t.gen ~ctxt x) let apply_all ~ctxt entry (name, generators, args) = check_arguments name.txt generators args; - List.concat_map generators ~f:(fun t -> apply t ~name:name.txt ~ctxt entry args) - ;; + List.concat_map generators ~f:(fun t -> + apply t ~name:name.txt ~ctxt entry args) let apply_all ~ctxt entry generators = List.concat_map generators ~f:(apply_all ~ctxt entry) - ;; end module Deriver = struct module Actual_deriver = struct - type t = - { name : string - ; str_type_decl : (structure, rec_flag * type_declaration list) Generator.t option - ; str_type_ext : (structure, type_extension ) Generator.t option - ; str_exception : (structure, type_exception ) Generator.t option - ; str_module_type_decl : (structure, module_type_declaration ) Generator.t option - ; sig_type_decl : (signature, rec_flag * type_declaration list) Generator.t option - ; sig_type_ext : (signature, type_extension ) Generator.t option - ; sig_exception : (signature, type_exception ) Generator.t option - ; sig_module_type_decl : (signature, module_type_declaration ) Generator.t option - ; extension : (loc:Location.t -> path:string -> core_type -> expression) option - } + type t = { + name : string; + str_type_decl : + (structure, rec_flag * type_declaration list) Generator.t option; + str_type_ext : (structure, type_extension) Generator.t option; + str_exception : (structure, type_exception) Generator.t option; + str_module_type_decl : + (structure, module_type_declaration) Generator.t option; + sig_type_decl : + (signature, rec_flag * type_declaration list) Generator.t option; + sig_type_ext : (signature, type_extension) Generator.t option; + sig_exception : (signature, type_exception) Generator.t option; + sig_module_type_decl : + (signature, module_type_declaration) Generator.t option; + extension : + (loc:Location.t -> path:string -> core_type -> expression) option; + } end module Alias = struct - type t = - { str_type_decl : string list - ; str_type_ext : string list - ; str_exception : string list - ; str_module_type_decl : string list - ; sig_type_decl : string list - ; sig_type_ext : string list - ; sig_exception : string list - ; sig_module_type_decl : string list - } + type t = { + str_type_decl : string list; + str_type_ext : string list; + str_exception : string list; + str_module_type_decl : string list; + sig_type_decl : string list; + sig_type_ext : string list; + sig_exception : string list; + sig_module_type_decl : string list; + } end module Field = struct type kind = Str | Sig - type ('a, 'b) t = - { name : string - ; kind : kind - ; get : Actual_deriver.t -> ('a, 'b) Generator.t option - ; get_set : Alias.t -> string list - } - - let str_type_decl = { kind = Str; name = "type" - ; get = (fun t -> t.str_type_decl) - ; get_set = (fun t -> t.str_type_decl) } - let str_type_ext = { kind = Str; name = "type extension" - ; get = (fun t -> t.str_type_ext) - ; get_set = (fun t -> t.str_type_ext ) } - let str_exception = { kind = Str; name = "exception" - ; get = (fun t -> t.str_exception) - ; get_set = (fun t -> t.str_exception) } + type ('a, 'b) t = { + name : string; + kind : kind; + get : Actual_deriver.t -> ('a, 'b) Generator.t option; + get_set : Alias.t -> string list; + } + + let str_type_decl = + { + kind = Str; + name = "type"; + get = (fun t -> t.str_type_decl); + get_set = (fun t -> t.str_type_decl); + } + + let str_type_ext = + { + kind = Str; + name = "type extension"; + get = (fun t -> t.str_type_ext); + get_set = (fun t -> t.str_type_ext); + } + + let str_exception = + { + kind = Str; + name = "exception"; + get = (fun t -> t.str_exception); + get_set = (fun t -> t.str_exception); + } + let str_module_type_decl = - { kind = Str; name = "module type" - ; get = (fun t -> t.str_module_type_decl) - ; get_set = (fun t -> t.str_module_type_decl) } - let sig_type_decl = { kind = Sig; name = "signature type" - ; get = (fun t -> t.sig_type_decl) - ; get_set = (fun t -> t.sig_type_decl) } - let sig_type_ext = { kind = Sig; name = "signature type extension" - ; get = (fun t -> t.sig_type_ext) - ; get_set = (fun t -> t.sig_type_ext ) } - let sig_exception = { kind = Sig; name = "signature exception" - ; get = (fun t -> t.sig_exception) - ; get_set = (fun t -> t.sig_exception) } + { + kind = Str; + name = "module type"; + get = (fun t -> t.str_module_type_decl); + get_set = (fun t -> t.str_module_type_decl); + } + + let sig_type_decl = + { + kind = Sig; + name = "signature type"; + get = (fun t -> t.sig_type_decl); + get_set = (fun t -> t.sig_type_decl); + } + + let sig_type_ext = + { + kind = Sig; + name = "signature type extension"; + get = (fun t -> t.sig_type_ext); + get_set = (fun t -> t.sig_type_ext); + } + + let sig_exception = + { + kind = Sig; + name = "signature exception"; + get = (fun t -> t.sig_exception); + get_set = (fun t -> t.sig_exception); + } + let sig_module_type_decl = - { kind = Sig; name = "signature module type" - ; get = (fun t -> t.sig_module_type_decl) - ; get_set = (fun t -> t.sig_module_type_decl) } + { + kind = Sig; + name = "signature module type"; + get = (fun t -> t.sig_module_type_decl); + get_set = (fun t -> t.sig_module_type_decl); + } end - type t = - | Actual_deriver of Actual_deriver.t - | Alias of Alias.t + type t = Actual_deriver of Actual_deriver.t | Alias of Alias.t type Ppx_derivers.deriver += T of t @@ -276,211 +333,187 @@ let resolve_actual_derivers (field : (_, _) Field.t) name = let rec loop name collected = - if List.exists collected - ~f:(fun (d : Actual_deriver.t) -> String.equal d.name name) then - collected + if + List.exists collected ~f:(fun (d : Actual_deriver.t) -> + String.equal d.name name) + then collected else match Ppx_derivers.lookup name with | Some (T (Actual_deriver drv)) -> drv :: collected | Some (T (Alias alias)) -> - let set = field.get_set alias in - List.fold_right set ~init:collected ~f:loop + let set = field.get_set alias in + List.fold_right set ~init:collected ~f:loop | _ -> raise (Not_supported name) in List.rev (loop name []) let resolve_internal (field : (_, _) Field.t) name = List.map (resolve_actual_derivers field name) ~f:(fun drv -> - match field.get drv with - | None -> raise (Not_supported name) - | Some g -> (drv.name, g)) - ;; + match field.get drv with + | None -> raise (Not_supported name) + | Some g -> (drv.name, g)) let supported_for field = - List.fold_left (derivers ()) ~init:String.Set.empty - ~f:(fun acc (name, _) -> + List.fold_left (derivers ()) ~init:String.Set.empty ~f:(fun acc (name, _) -> match resolve_internal field name with | _ -> String.Set.add name acc | exception Not_supported _ -> acc) |> String.Set.elements - ;; - let not_supported (field : (_, _) Field.t) ?(spellcheck=true) name = + let not_supported (field : (_, _) Field.t) ?(spellcheck = true) name = let spellcheck_msg = if spellcheck then match Spellcheck.spellcheck (supported_for field) name.txt with | None -> "" | Some s -> ".\n" ^ s - else - "" + else "" in Location.raise_errorf ~loc:name.loc "Ppxlib.Deriving: '%s' is not a supported %s deriving generator%s" name.txt field.name spellcheck_msg - ;; let resolve field name = - try - resolve_internal field name.txt + try resolve_internal field name.txt with Not_supported name' -> not_supported field ~spellcheck:(String.equal name.txt name') name - ;; let resolve_all field derivers = let derivers_and_args = List.filter_map derivers ~f:(fun (name, args) -> - match Ppx_derivers.lookup name.txt with - | None -> - not_supported field name - | Some (T _) -> - (* It's one of ours, parse the arguments now. We can't do it before since - ppx_deriving uses a different syntax for arguments. *) - Some - (name, - match args with - | Args l -> l - | Unknown_syntax (loc, msg) -> - Location.raise_errorf ~loc "Ppxlib.Deriving: %s" msg) - | Some _ -> - (* It's not one of ours, ignore it. *) - None) + match Ppx_derivers.lookup name.txt with + | None -> not_supported field name + | Some (T _) -> + (* It's one of ours, parse the arguments now. We can't do it before since + ppx_deriving uses a different syntax for arguments. *) + Some + ( name, + match args with + | Args l -> l + | Unknown_syntax (loc, msg) -> + Location.raise_errorf ~loc "Ppxlib.Deriving: %s" msg ) + | Some _ -> + (* It's not one of ours, ignore it. *) + None) in (* Set of actual deriver names *) let seen = Hashtbl.create 16 in List.map derivers_and_args ~f:(fun (name, args) -> - let named_generators = resolve field name in - List.iter named_generators ~f:(fun (actual_deriver_name, gen) -> - if Options.fail_on_duplicate_derivers - && Hashtbl.mem seen actual_deriver_name then - Location.raise_errorf ~loc:name.loc - "Deriver %s appears twice" actual_deriver_name; - List.iter (Generator.deps gen) ~f:(fun dep -> - List.iter (resolve_actual_derivers field dep) ~f:(fun drv -> - let dep_name = drv.name in - if not (Hashtbl.mem seen dep_name) then - Location.raise_errorf ~loc:name.loc - "Deriver %s is needed for %s, you need to add it before in the list" - dep_name name.txt)); - Hashtbl.set seen ~key:actual_deriver_name ~data:()); - (name, List.map named_generators ~f:snd, args)) - ;; - - let add - ?str_type_decl - ?str_type_ext - ?str_exception - ?str_module_type_decl - ?sig_type_decl - ?sig_type_ext - ?sig_exception - ?sig_module_type_decl - ?extension - name - = + let named_generators = resolve field name in + List.iter named_generators ~f:(fun (actual_deriver_name, gen) -> + if + Options.fail_on_duplicate_derivers + && Hashtbl.mem seen actual_deriver_name + then + Location.raise_errorf ~loc:name.loc "Deriver %s appears twice" + actual_deriver_name; + List.iter (Generator.deps gen) ~f:(fun dep -> + List.iter (resolve_actual_derivers field dep) ~f:(fun drv -> + let dep_name = drv.name in + if not (Hashtbl.mem seen dep_name) then + Location.raise_errorf ~loc:name.loc + "Deriver %s is needed for %s, you need to add it \ + before in the list" + dep_name name.txt)); + Hashtbl.set seen ~key:actual_deriver_name ~data:()); + (name, List.map named_generators ~f:snd, args)) + + let add ?str_type_decl ?str_type_ext ?str_exception ?str_module_type_decl + ?sig_type_decl ?sig_type_ext ?sig_exception ?sig_module_type_decl + ?extension name = let actual_deriver : Actual_deriver.t = - { name - ; str_type_decl - ; str_type_ext - ; str_exception - ; str_module_type_decl - ; sig_type_decl - ; sig_type_ext - ; sig_exception - ; sig_module_type_decl - ; extension + { + name; + str_type_decl; + str_type_ext; + str_exception; + str_module_type_decl; + sig_type_decl; + sig_type_ext; + sig_exception; + sig_module_type_decl; + extension; } in Ppx_derivers.register name (T (Actual_deriver actual_deriver)); (match extension with - | None -> () - | Some f -> - let extension = Extension.declare name Expression Ast_pattern.(ptyp __) f in - Driver.register_transformation ("Ppxlib.Deriving." ^ name) - ~rules:[ Context_free.Rule.extension extension ]); + | None -> () + | Some f -> + let extension = + Extension.declare name Expression Ast_pattern.(ptyp __) f + in + Driver.register_transformation + ("Ppxlib.Deriving." ^ name) + ~rules:[ Context_free.Rule.extension extension ]); name - ;; - let add_alias - name - ?str_type_decl - ?str_type_ext - ?str_exception - ?str_module_type_decl - ?sig_type_decl - ?sig_type_ext - ?sig_exception - ?sig_module_type_decl - set - = + let add_alias name ?str_type_decl ?str_type_ext ?str_exception + ?str_module_type_decl ?sig_type_decl ?sig_type_ext ?sig_exception + ?sig_module_type_decl set = let alias : Alias.t = - let get = function - | None -> set - | Some set -> set - in - { str_type_decl = get str_type_decl - ; str_type_ext = get str_type_ext - ; str_exception = get str_exception - ; str_module_type_decl = get str_module_type_decl - ; sig_type_decl = get sig_type_decl - ; sig_type_ext = get sig_type_ext - ; sig_exception = get sig_exception - ; sig_module_type_decl = get sig_module_type_decl + let get = function None -> set | Some set -> set in + { + str_type_decl = get str_type_decl; + str_type_ext = get str_type_ext; + str_exception = get str_exception; + str_module_type_decl = get str_module_type_decl; + sig_type_decl = get sig_type_decl; + sig_type_ext = get sig_type_ext; + sig_exception = get sig_exception; + sig_module_type_decl = get sig_module_type_decl; } in Ppx_derivers.register name (T (Alias alias)); name - ;; end -let add = Deriver.add +let add = Deriver.add + let add_alias = Deriver.add_alias (* +-----------------------------------------------------------------+ | [@@deriving ] parsing | +-----------------------------------------------------------------+ *) -let invalid_with ~loc = Location.raise_errorf ~loc "invalid [@@deriving ] attribute syntax" +let invalid_with ~loc = + Location.raise_errorf ~loc "invalid [@@deriving ] attribute syntax" let generator_name_of_id loc id = match Longident.flatten_exn id with | l -> { loc; txt = String.concat ~sep:"." l } - | exception _ -> invalid_with ~loc:loc -;; + | exception _ -> invalid_with ~loc exception Unknown_syntax of Location.t * string let parse_arguments l = try - Args ( - match l with - | [(Nolabel, e)] -> begin + Args + (match l with + | [ (Nolabel, e) ] -> ( match e.pexp_desc with - | Pexp_record (fields, None) -> - List.map fields ~f:(fun (id, expr) -> - let name = - match id.txt with - | Lident s -> s - | _ -> raise_notrace - (Unknown_syntax - (id.loc, "simple identifier expected")) - in - (name, expr)) + | Pexp_record (fields, None) -> + List.map fields ~f:(fun (id, expr) -> + let name = + match id.txt with + | Lident s -> s + | _ -> + raise_notrace + (Unknown_syntax (id.loc, "simple identifier expected")) + in + (name, expr)) | _ -> - raise_notrace - (Unknown_syntax - (e.pexp_loc, "non-optional labelled argument or record expected")) - end + raise_notrace + (Unknown_syntax + ( e.pexp_loc, + "non-optional labelled argument or record expected" ))) | l -> - List.map l ~f:(fun (label, expr) -> - match label with - | Labelled s -> - (s, expr) - | _ -> - raise_notrace - (Unknown_syntax - (expr.pexp_loc, "non-optional labelled argument expected")))) - with Unknown_syntax (loc, msg) -> - Unknown_syntax (loc, msg) + List.map l ~f:(fun (label, expr) -> + match label with + | Labelled s -> (s, expr) + | _ -> + raise_notrace + (Unknown_syntax + (expr.pexp_loc, "non-optional labelled argument expected")))) + with Unknown_syntax (loc, msg) -> Unknown_syntax (loc, msg) let mk_deriving_attr context ~prefix ~suffix = Attribute.declare @@ -488,90 +521,99 @@ context Ast_pattern.( let generator_name () = - map' (pexp_ident __) ~f:(fun loc f id -> f (generator_name_of_id loc id)) + map' (pexp_ident __) ~f:(fun loc f id -> + f (generator_name_of_id loc id)) in let generator () = - map (generator_name ()) ~f:(fun f x -> f (x, Args [])) ||| - pack2 (pexp_apply (generator_name ()) (map1 (many __) ~f:parse_arguments)) + map (generator_name ()) ~f:(fun f x -> f (x, Args [])) + ||| pack2 + (pexp_apply (generator_name ()) + (map1 (many __) ~f:parse_arguments)) in let generators = - pexp_tuple (many (generator ())) ||| - map (generator ()) ~f:(fun f x -> f [x]) + pexp_tuple (many (generator ())) + ||| map (generator ()) ~f:(fun f x -> f [ x ]) in - pstr (pstr_eval generators nil ^:: nil) - ) + pstr (pstr_eval generators nil ^:: nil)) (fun x -> x) -;; (* +-----------------------------------------------------------------+ | Unused warning stuff + locations check silencing | +-----------------------------------------------------------------+ *) -let disable_unused_warning_attribute = +let disable_warnings_attribute warnings = let loc = Location.none in - { attr_name = { txt = "ocaml.warning"; loc }; - attr_payload = PStr [pstr_eval ~loc (estring ~loc "-32") []]; - attr_loc = loc; } -;; + let string = + List.sort warnings ~cmp:Int.compare + |> List.map ~f:(fun warning -> "-" ^ Int.to_string warning) + |> String.concat ~sep:"" + in + { + attr_name = { txt = "ocaml.warning"; loc }; + attr_payload = PStr [ pstr_eval ~loc (estring ~loc string) [] ]; + attr_loc = loc; + } let inline_doc_attr = let loc = Location.none in - { attr_name = { txt = "ocaml.doc"; loc }; - attr_payload = PStr [pstr_eval ~loc (estring ~loc "@inline") []]; - attr_loc = loc; } -;; + { + attr_name = { txt = "ocaml.doc"; loc }; + attr_payload = PStr [ pstr_eval ~loc (estring ~loc "@inline") [] ]; + attr_loc = loc; + } let wrap_str ~loc ~hide st = let include_infos = include_infos ~loc (pmod_structure ~loc st) in let pincl_attributes = - if hide then - [ inline_doc_attr; Merlin_helpers.hide_attribute ] - else - [ inline_doc_attr ] + if hide then [ inline_doc_attr; Merlin_helpers.hide_attribute ] + else [ inline_doc_attr ] in - [pstr_include ~loc {include_infos with pincl_attributes}] + [ pstr_include ~loc { include_infos with pincl_attributes } ] let wrap_str ~loc ~hide st = let loc = { loc with loc_ghost = true } in - let wrap, st = - if keep_w32_impl () then - hide, st + let warnings, st = + if keep_w32_impl () then ([], st) else if not !do_insert_unused_warning_attribute then - hide, Ignore_unused_warning.add_dummy_user_for_values#structure st - else - (* note: a structure is created because it is not currently possible to - attach an [@@ocaml.warning] attribute to a single structure item. *) - true, (pstr_attribute ~loc disable_unused_warning_attribute :: st) + ([], Ignore_unused_warning.add_dummy_user_for_values#structure st) + else ([ 32 ], st) in - if wrap then - wrap_str ~loc ~hide st - else - st -;; + let warnings, st = + if + keep_w60_impl () + || not (Ignore_unused_warning.binds_module_names#structure st false) + then (warnings, st) + else (60 :: warnings, st) + in + let wrap, st = + if List.is_empty warnings then (hide, st) + else (true, pstr_attribute ~loc (disable_warnings_attribute warnings) :: st) + in + if wrap then wrap_str ~loc ~hide st else st let wrap_sig ~loc ~hide st = let include_infos = include_infos ~loc (pmty_signature ~loc st) in let pincl_attributes = - if hide then - [ inline_doc_attr; Merlin_helpers.hide_attribute ] - else - [ inline_doc_attr ] + if hide then [ inline_doc_attr; Merlin_helpers.hide_attribute ] + else [ inline_doc_attr ] in - [psig_include ~loc {include_infos with pincl_attributes}] + [ psig_include ~loc { include_infos with pincl_attributes } ] let wrap_sig ~loc ~hide sg = let loc = { loc with loc_ghost = true } in + let warnings = if keep_w32_intf () then [] else [ 32 ] in + let warnings = + if + keep_w60_intf () + || not (Ignore_unused_warning.binds_module_names#signature sg false) + then warnings + else 60 :: warnings + in let wrap, sg = - if keep_w32_intf () then - hide, sg - else - true, (psig_attribute ~loc disable_unused_warning_attribute :: sg) + if List.is_empty warnings then (hide, sg) + else (true, psig_attribute ~loc (disable_warnings_attribute warnings) :: sg) in - if wrap then - wrap_sig ~loc ~hide sg - else - sg -;; + if wrap then wrap_sig ~loc ~hide sg else sg (* +-----------------------------------------------------------------+ | Remove attributes used by syntax extensions | @@ -600,32 +642,23 @@ | Main expansion | +-----------------------------------------------------------------+ *) -let types_used_by_deriving (tds : type_declaration list) - : structure_item list = - if keep_w32_impl () then - [] +let types_used_by_deriving (tds : type_declaration list) : structure_item list = + if keep_w32_impl () then [] else List.map tds ~f:(fun td -> - let typ = Common.core_type_of_type_declaration td in - let loc = td.ptype_loc in - pstr_value - ~loc - Nonrecursive - [value_binding - ~loc - ~pat:(ppat_any ~loc) - ~expr:(pexp_fun - ~loc - Nolabel - None - (ppat_constraint ~loc (ppat_any ~loc) typ) - (eunit ~loc))] - ) + let typ = Common.core_type_of_type_declaration td in + let loc = td.ptype_loc in + pstr_value ~loc Nonrecursive + [ + value_binding ~loc ~pat:(ppat_any ~loc) + ~expr: + (pexp_fun ~loc Nolabel None + (ppat_constraint ~loc (ppat_any ~loc) typ) + (eunit ~loc)); + ]) let merge_generators field l = - List.filter_map l ~f:(fun x -> x) - |> List.concat - |> Deriver.resolve_all field + List.filter_map l ~f:(fun x -> x) |> List.concat |> Deriver.resolve_all field let expand_str_type_decls ~ctxt rec_flag tds values = let generators = merge_generators Deriver.Field.str_type_decl values in @@ -633,67 +666,87 @@ should add a tag [@@unused]. *) let generated = types_used_by_deriving tds - @ Generator.apply_all ~ctxt (rec_flag, tds) generators; + @ Generator.apply_all ~ctxt (rec_flag, tds) generators in - wrap_str ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) - ~hide:(not @@ Expansion_context.Deriver.inline ctxt) generated + wrap_str + ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) + ~hide:(not @@ Expansion_context.Deriver.inline ctxt) + generated let expand_sig_type_decls ~ctxt rec_flag tds values = let generators = merge_generators Deriver.Field.sig_type_decl values in let generated = Generator.apply_all ~ctxt (rec_flag, tds) generators in - wrap_sig ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) - ~hide:(not @@ Expansion_context.Deriver.inline ctxt) generated + wrap_sig + ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) + ~hide:(not @@ Expansion_context.Deriver.inline ctxt) + generated let expand_str_module_type_decl ~ctxt mtd generators = - let generators = Deriver.resolve_all Deriver.Field.str_module_type_decl generators in + let generators = + Deriver.resolve_all Deriver.Field.str_module_type_decl generators + in let generated = Generator.apply_all ~ctxt mtd generators in - wrap_str ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) - ~hide:(not @@ Expansion_context.Deriver.inline ctxt) generated + wrap_str + ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) + ~hide:(not @@ Expansion_context.Deriver.inline ctxt) + generated let expand_sig_module_type_decl ~ctxt mtd generators = - let generators = Deriver.resolve_all Deriver.Field.sig_module_type_decl generators in + let generators = + Deriver.resolve_all Deriver.Field.sig_module_type_decl generators + in let generated = Generator.apply_all ~ctxt mtd generators in - wrap_sig ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) - ~hide:(not @@ Expansion_context.Deriver.inline ctxt) generated + wrap_sig + ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) + ~hide:(not @@ Expansion_context.Deriver.inline ctxt) + generated let expand_str_exception ~ctxt ec generators = let generators = Deriver.resolve_all Deriver.Field.str_exception generators in let generated = Generator.apply_all ~ctxt ec generators in - wrap_str ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) - ~hide:(not @@ Expansion_context.Deriver.inline ctxt) generated + wrap_str + ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) + ~hide:(not @@ Expansion_context.Deriver.inline ctxt) + generated let expand_sig_exception ~ctxt ec generators = let generators = Deriver.resolve_all Deriver.Field.sig_exception generators in let generated = Generator.apply_all ~ctxt ec generators in - wrap_sig ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) - ~hide:(not @@ Expansion_context.Deriver.inline ctxt) generated + wrap_sig + ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) + ~hide:(not @@ Expansion_context.Deriver.inline ctxt) + generated let expand_str_type_ext ~ctxt te generators = let generators = Deriver.resolve_all Deriver.Field.str_type_ext generators in let generated = Generator.apply_all ~ctxt te generators in - wrap_str ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) - ~hide:(not @@ Expansion_context.Deriver.inline ctxt) generated + wrap_str + ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) + ~hide:(not @@ Expansion_context.Deriver.inline ctxt) + generated let expand_sig_type_ext ~ctxt te generators = let generators = Deriver.resolve_all Deriver.Field.sig_type_ext generators in let generated = Generator.apply_all ~ctxt te generators in - wrap_sig ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) - ~hide:(not @@ Expansion_context.Deriver.inline ctxt) generated + wrap_sig + ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) + ~hide:(not @@ Expansion_context.Deriver.inline ctxt) + generated let rules ~typ ~expand_sig ~expand_str ~rule_str ~rule_sig ~rule_str_expect - ~rule_sig_expect = + ~rule_sig_expect = let prefix = "ppxlib." in let deriving_attr = mk_deriving_attr ~suffix:"" ~prefix typ in let deriving_attr_expect = mk_deriving_attr ~suffix:"_inline" ~prefix typ in - [ rule_sig deriving_attr expand_sig - ; rule_str deriving_attr expand_str - ; rule_str_expect deriving_attr_expect expand_str - ; rule_sig_expect deriving_attr_expect expand_sig + [ + rule_sig deriving_attr expand_sig; + rule_str deriving_attr expand_str; + rule_str_expect deriving_attr_expect expand_str; + rule_sig_expect deriving_attr_expect expand_sig; ] let rules_type_decl = - rules ~typ:Type_declaration - ~expand_str:expand_str_type_decls + rules ~typ:Type_declaration ~expand_str:expand_str_type_decls ~expand_sig:expand_sig_type_decls ~rule_str:Context_free.Rule.attr_str_type_decl ~rule_sig:Context_free.Rule.attr_sig_type_decl @@ -701,8 +754,7 @@ ~rule_sig_expect:Context_free.Rule.attr_sig_type_decl_expect let rules_type_ext = - rules ~typ:Type_extension - ~expand_str:expand_str_type_ext + rules ~typ:Type_extension ~expand_str:expand_str_type_ext ~expand_sig:expand_sig_type_ext ~rule_str:Context_free.Rule.attr_str_type_ext ~rule_sig:Context_free.Rule.attr_sig_type_ext @@ -710,8 +762,7 @@ ~rule_sig_expect:Context_free.Rule.attr_sig_type_ext_expect let rules_exception = - rules ~typ:Type_exception - ~expand_str:expand_str_exception + rules ~typ:Type_exception ~expand_str:expand_str_exception ~expand_sig:expand_sig_exception ~rule_str:Context_free.Rule.attr_str_exception ~rule_sig:Context_free.Rule.attr_sig_exception @@ -719,8 +770,7 @@ ~rule_sig_expect:Context_free.Rule.attr_sig_exception_expect let rules_module_type_decl = - rules ~typ:Module_type_declaration - ~expand_str:expand_str_module_type_decl + rules ~typ:Module_type_declaration ~expand_str:expand_str_module_type_decl ~expand_sig:expand_sig_module_type_decl ~rule_str:Context_free.Rule.attr_str_module_type_decl ~rule_sig:Context_free.Rule.attr_sig_module_type_decl @@ -729,12 +779,7 @@ let () = let rules = - [ rules_type_decl - ; rules_type_ext - ; rules_exception - ; rules_module_type_decl - ] + [ rules_type_decl; rules_type_ext; rules_exception; rules_module_type_decl ] |> List.concat in - Driver.register_transformation "deriving" ~aliases:["type_conv"] ~rules -;; + Driver.register_transformation "deriving" ~aliases:[ "type_conv" ] ~rules diff -Nru ppxlib-0.15.0/src/deriving.mli ppxlib-0.24.0/src/deriving.mli --- ppxlib-0.15.0/src/deriving.mli 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/deriving.mli 2021-12-08 21:53:37.000000000 +0000 @@ -5,18 +5,19 @@ (** Specification of generator arguments *) module Args : sig type ('a, 'b) t + type 'a param - val empty : ('m, 'm) t + val empty : ('m, 'm) t - val arg - : string - -> (expression, 'a -> 'a option, 'a option) Ast_pattern.t - -> 'a option param + val arg : + string -> + (expression, 'a -> 'a option, 'a option) Ast_pattern.t -> + 'a option param - (** Flag matches punned labelled argument, i.e. of the form - [~foo]. It returns [true] iff the argument is present. *) val flag : string -> bool param + (** Flag matches punned labelled argument, i.e. of the form [~foo]. It returns + [true] iff the argument is present. *) val ( +> ) : ('m1, 'a -> 'm2) t -> 'a param -> ('m1, 'm2) t @@ -24,107 +25,109 @@ open both [Ast_pattern] and [Deriving.Args]: {[ - Deriving.Args.(empty - +> arg_option "foo" (estring __) - +> arg_option "bar" (pack2 (eint __ ** eint __)) - +> flag "dotdotdot" - ) - ]} - *) - include module type of struct include Ast_pattern end - with type ('a, 'b, 'c) t := ('a, 'b, 'c) Ast_pattern.t + Deriving.Args.( + empty + +> arg_option "foo" (estring __) + +> arg_option "bar" (pack2 (eint __ ** eint __)) + +> flag "dotdotdot") + ]} *) + include module type of struct + include Ast_pattern + end + with type ('a, 'b, 'c) t := ('a, 'b, 'c) Ast_pattern.t end -(** {6 Generator registration} *) +(** {5 Generator registration} *) -(** Type of registered derivers *) type t +(** Type of registered derivers *) module Generator : sig type deriver = t + type ('output_ast, 'input_ast) t - val make - : ?attributes:Attribute.packed list - -> ?deps:deriver list - -> ('f, 'output_ast) Args.t - -> (loc:Location.t -> path:string -> 'input_ast -> 'f) - -> ('output_ast, 'input_ast) t - - val make_noarg - : ?attributes:Attribute.packed list - -> ?deps:deriver list - -> (loc:Location.t -> path:string -> 'input_ast -> 'output_ast) - -> ('output_ast, 'input_ast) t + val make : + ?attributes:Attribute.packed list -> + ?deps:deriver list -> + ('f, 'output_ast) Args.t -> + (loc:Location.t -> path:string -> 'input_ast -> 'f) -> + ('output_ast, 'input_ast) t + + val make_noarg : + ?attributes:Attribute.packed list -> + ?deps:deriver list -> + (loc:Location.t -> path:string -> 'input_ast -> 'output_ast) -> + ('output_ast, 'input_ast) t module V2 : sig - val make - : ?attributes:Attribute.packed list - -> ?deps:deriver list - -> ('f, 'output_ast) Args.t - -> (ctxt:Expansion_context.Deriver.t -> 'input_ast -> 'f) - -> ('output_ast, 'input_ast) t - - val make_noarg - : ?attributes:Attribute.packed list - -> ?deps:deriver list - -> (ctxt:Expansion_context.Deriver.t -> 'input_ast -> 'output_ast) - -> ('output_ast, 'input_ast) t + val make : + ?attributes:Attribute.packed list -> + ?deps:deriver list -> + ('f, 'output_ast) Args.t -> + (ctxt:Expansion_context.Deriver.t -> 'input_ast -> 'f) -> + ('output_ast, 'input_ast) t + + val make_noarg : + ?attributes:Attribute.packed list -> + ?deps:deriver list -> + (ctxt:Expansion_context.Deriver.t -> 'input_ast -> 'output_ast) -> + ('output_ast, 'input_ast) t end - val apply - : ('output_ast, 'input_ast) t - -> name:string - -> ctxt:Expansion_context.Deriver.t - -> 'input_ast - -> (string * expression) list - -> 'output_ast -end with type deriver := t + val apply : + ('output_ast, 'input_ast) t -> + name:string -> + ctxt:Expansion_context.Deriver.t -> + 'input_ast -> + (string * expression) list -> + 'output_ast +end +with type deriver := t +val add : + ?str_type_decl:(structure, rec_flag * type_declaration list) Generator.t -> + ?str_type_ext:(structure, type_extension) Generator.t -> + ?str_exception:(structure, type_exception) Generator.t -> + ?str_module_type_decl:(structure, module_type_declaration) Generator.t -> + ?sig_type_decl:(signature, rec_flag * type_declaration list) Generator.t -> + ?sig_type_ext:(signature, type_extension) Generator.t -> + ?sig_exception:(signature, type_exception) Generator.t -> + ?sig_module_type_decl:(signature, module_type_declaration) Generator.t -> + ?extension:(loc:Location.t -> path:string -> core_type -> expression) -> + string -> + t (** Register a new deriving generator. - The various arguments are for the various items on which derivers - can be attached in structure and signatures. + The various arguments are for the various items on which derivers can be + attached in structure and signatures. - We distinguish [exception] from [type_extension] as [exception E] - is not exactly the same as [type exn += E]. Indeed if the type - [exn] is redefined, then [type exn += E] will add [E] to the new - [exn] type while [exception E] will add [E] to the predefined [exn] - type. - - [extension] register an expander for extension with the name of - the deriver. This is here mostly to support the ppx_deriving - backend. *) -val add - : ?str_type_decl:(structure, rec_flag * type_declaration list) Generator.t - -> ?str_type_ext :(structure, type_extension ) Generator.t - -> ?str_exception:(structure, type_exception ) Generator.t - -> ?str_module_type_decl:(structure, module_type_declaration ) Generator.t - -> ?sig_type_decl:(signature, rec_flag * type_declaration list) Generator.t - -> ?sig_type_ext :(signature, type_extension ) Generator.t - -> ?sig_exception:(signature, type_exception ) Generator.t - -> ?sig_module_type_decl:(signature, module_type_declaration ) Generator.t - -> ?extension:(loc:Location.t -> path:string -> core_type -> expression) - -> string - -> t - -(** [add_alias name set] add an alias. When the user write the alias, - all the generator of [set] will be used instead. It is possible to - override the set for any of the context by passing the specific set - in the approriate optional argument of [add_alias]. *) -val add_alias - : string - -> ?str_type_decl:t list - -> ?str_type_ext :t list - -> ?str_exception:t list - -> ?str_module_type_decl:t list - -> ?sig_type_decl:t list - -> ?sig_type_ext :t list - -> ?sig_exception:t list - -> ?sig_module_type_decl:t list - -> t list - -> t + We distinguish [exception] from [type_extension] as [exception E] is not + exactly the same as [type exn += E]. Indeed if the type [exn] is redefined, + then [type exn += E] will add [E] to the new [exn] type while [exception E] + will add [E] to the predefined [exn] type. + + [extension] register an expander for extension with the name of the deriver. + This is here mostly to support the ppx_deriving backend. *) + +val add_alias : + string -> + ?str_type_decl:t list -> + ?str_type_ext:t list -> + ?str_exception:t list -> + ?str_module_type_decl:t list -> + ?sig_type_decl:t list -> + ?sig_type_ext:t list -> + ?sig_exception:t list -> + ?sig_module_type_decl:t list -> + t list -> + t +(** [add_alias name set] add an alias. When the user write the alias, all the + generator of [set] will be used instead. It is possible to override the set + for any of the context by passing the specific set in the approriate + optional argument of [add_alias]. *) -(** Ignore a deriver. So that one can write: [Deriving.add ... |> - Deriving.ignore] *) val ignore : t -> unit +(** Ignore a deriver. So that one can write: + [Deriving.add ... |> + Deriving.ignore] *) diff -Nru ppxlib-0.15.0/src/driver.ml ppxlib-0.24.0/src/driver.ml --- ppxlib-0.15.0/src/driver.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/driver.ml 2021-12-08 21:53:37.000000000 +0000 @@ -1,7 +1,6 @@ (*$ open Ppxlib_cinaps_helpers $*) open Import open Utils - module Arg = Caml.Arg let exe_name = Caml.Filename.basename Caml.Sys.executable_name @@ -11,20 +10,35 @@ let add_arg key spec ~doc = args := (key, spec, doc) :: !args let loc_fname = ref None + let perform_checks = ref Options.perform_checks + let perform_checks_on_extensions = ref Options.perform_checks_on_extensions + let perform_locations_check = ref Options.perform_locations_check + let debug_attribute_drop = ref false + let apply_list = ref None + let preprocessor = ref None + let no_merge = ref false + let request_print_passes = ref false + let request_print_transformations = ref false + let use_color = ref true + let diff_command = ref Options.diff_command + let pretty = ref false + let styler = ref None + let output_metadata_filename = ref None + let corrected_suffix = ref ".ppx-corrected" module Lint_error = struct @@ -34,50 +48,91 @@ end module Cookies = struct - type t = Migrate_parsetree.Driver.cookies + type t = T + + let given_through_cli = ref [] - let get t name pattern = - Option.map (Migrate_parsetree.Driver.get_cookie t name (module Ppxlib_ast.Selected_ast)) - ~f:(fun e -> + let get T name pattern = + Option.map (Astlib.Ast_metadata.get_cookie name) ~f:(fun e -> + let e = Selected_ast.of_ocaml Expression e in Ast_pattern.parse pattern e.pexp_loc e Fn.id) - let set t name expr = - Migrate_parsetree.Driver.set_cookie t name (module Ppxlib_ast.Selected_ast) expr + let set T name expr = + Astlib.Ast_metadata.set_cookie name (Selected_ast.to_ocaml Expression expr) let handlers = ref [] - let add_handler f = handlers := !handlers @ [f] + + let add_handler f = handlers := !handlers @ [ f ] let add_simple_handler name pattern ~f = - add_handler (fun t -> f (get t name pattern)) + add_handler (fun T -> f (get T name pattern)) - let acknoledge_cookies t = - List.iter !handlers ~f:(fun f -> f t) + let acknowledge_cookies T = List.iter !handlers ~f:(fun f -> f T) let post_handlers = ref [] - let add_post_handler f = post_handlers := !post_handlers @ [f] - let call_post_handlers t = - List.iter !post_handlers ~f:(fun f -> f t) + let add_post_handler f = post_handlers := !post_handlers @ [ f ] + + let call_post_handlers T = List.iter !post_handlers ~f:(fun f -> f T) +end + +module Instrument = struct + type pos = Before | After + + type t = { + transformation : + Expansion_context.Base.t -> Parsetree.structure -> Parsetree.structure; + position : pos; + } + + module V2 = struct + let make transformation ~position = { transformation; position } + end + + let make transformation ~position = + let transformation _ st = transformation st in + V2.make transformation ~position end module Transform = struct - type t = - { name : string - ; aliases : string list - ; impl : (Parsetree.structure -> Parsetree.structure) option - ; intf : (Parsetree.signature -> Parsetree.signature) option - ; lint_impl : (Parsetree.structure -> Lint_error.t list) option - ; lint_intf : (Parsetree.signature -> Lint_error.t list) option - ; preprocess_impl : (Parsetree.structure -> Parsetree.structure) option - ; preprocess_intf : (Parsetree.signature -> Parsetree.signature) option - ; enclose_impl : (Location.t option -> Parsetree.structure * Parsetree.structure) option - ; enclose_intf : (Location.t option -> Parsetree.signature * Parsetree.signature) option - ; rules : Context_free.Rule.t list - ; registered_at : Caller_id.t - } + type t = { + name : string; + aliases : string list; + impl : + (Expansion_context.Base.t -> Parsetree.structure -> Parsetree.structure) + option; + intf : + (Expansion_context.Base.t -> Parsetree.signature -> Parsetree.signature) + option; + lint_impl : + (Expansion_context.Base.t -> Parsetree.structure -> Lint_error.t list) + option; + lint_intf : + (Expansion_context.Base.t -> Parsetree.signature -> Lint_error.t list) + option; + preprocess_impl : + (Expansion_context.Base.t -> Parsetree.structure -> Parsetree.structure) + option; + preprocess_intf : + (Expansion_context.Base.t -> Parsetree.signature -> Parsetree.signature) + option; + enclose_impl : + (Expansion_context.Base.t -> + Location.t option -> + Parsetree.structure * Parsetree.structure) + option; + enclose_intf : + (Expansion_context.Base.t -> + Location.t option -> + Parsetree.signature * Parsetree.signature) + option; + instrument : Instrument.t option; + rules : Context_free.Rule.t list; + registered_at : Caller_id.t; + } let has_name t name = - (String.equal name t.name) || (List.exists ~f:(String.equal name) t.aliases) + String.equal name t.name || List.exists ~f:(String.equal name) t.aliases let all : t list ref = ref [] @@ -85,416 +140,445 @@ match caller_id with | None -> output_string oc "" | Some loc -> Printf.fprintf oc "%s:%d" loc.filename loc.line_number - ;; - let register ?(extensions=[]) ?(rules=[]) ?enclose_impl ?enclose_intf - ?impl ?intf ?lint_impl ?lint_intf ?preprocess_impl ?preprocess_intf - ?(aliases=[]) name = - let rules = - List.map extensions ~f:Context_free.Rule.extension @ rules - in - let caller_id = Caller_id.get ~skip:[Caml.__FILE__] in - begin match List.filter !all ~f:(fun ct -> has_name ct name) with + let register ?(extensions = []) ?(rules = []) ?enclose_impl ?enclose_intf + ?impl ?intf ?lint_impl ?lint_intf ?preprocess_impl ?preprocess_intf + ?instrument ?(aliases = []) name = + let rules = List.map extensions ~f:Context_free.Rule.extension @ rules in + let caller_id = Caller_id.get ~skip:[ Caml.__FILE__ ] in + (match List.filter !all ~f:(fun ct -> has_name ct name) with | [] -> () | ct :: _ -> - Printf.eprintf "Warning: code transformation %s registered twice.\n" name; - Printf.eprintf " - first time was at %a\n" print_caller_id ct.registered_at; - Printf.eprintf " - second time is at %a\n" print_caller_id caller_id; - end; + Printf.eprintf "Warning: code transformation %s registered twice.\n" + name; + Printf.eprintf " - first time was at %a\n" print_caller_id + ct.registered_at; + Printf.eprintf " - second time is at %a\n" print_caller_id caller_id); let ct = - { name - ; aliases - ; rules - ; enclose_impl - ; enclose_intf - ; impl - ; intf - ; lint_impl - ; preprocess_impl - ; preprocess_intf - ; lint_intf - ; registered_at = caller_id + { + name; + aliases; + rules; + enclose_impl; + enclose_intf; + impl; + intf; + lint_impl; + preprocess_impl; + preprocess_intf; + lint_intf; + instrument; + registered_at = caller_id; } in all := ct :: !all - ;; - let rec last prev l = - match l with - | [] -> prev - | x :: l -> last x l - ;; + let rec last prev l = match l with [] -> prev | x :: l -> last x l let loc_of_list ~get_loc l = match l with | [] -> None | x :: l -> - let first : Location.t = get_loc x in - let last = get_loc (last x l) in - Some { first with loc_end = last.loc_end } - ;; + let first : Location.t = get_loc x in + let last = get_loc (last x l) in + Some { first with loc_end = last.loc_end } - let merge_into_generic_mappers t ~hook ~expect_mismatch_handler ~tool_name = + let merge_into_generic_mappers t ~hook ~expect_mismatch_handler ~tool_name + ~input_name = let { rules; enclose_impl; enclose_intf; impl; intf; _ } = t in let map = - new Context_free.map_top_down rules - ~generated_code_hook:hook - ~expect_mismatch_handler + new Context_free.map_top_down + rules ~generated_code_hook:hook ~expect_mismatch_handler in let gen_header_and_footer context whole_loc f = let header, footer = f whole_loc in (match whole_loc with - | Some (loc : Location.t) -> - let loc_header = { loc with loc_end = loc.loc_start } in - let loc_footer = { loc with loc_start = loc.loc_end } in - (match header with [] -> () | _ -> hook.f context loc_header (Many header)); - (match footer with [] -> () | _ -> hook.f context loc_footer (Many footer)) - | None -> - match header @ footer with - | [] -> () - | l -> - let pos = - { Lexing. - pos_fname = "" - ; pos_lnum = 1 - ; pos_bol = 0 - ; pos_cnum = 0 - } - in - let loc = { Location. loc_start = pos; loc_end = pos; loc_ghost = false } in - hook.f context loc (Many l)); + | Some (loc : Location.t) -> ( + let loc_header = { loc with loc_end = loc.loc_start } in + let loc_footer = { loc with loc_start = loc.loc_end } in + (match header with + | [] -> () + | _ -> hook.f context loc_header (Many header)); + match footer with + | [] -> () + | _ -> hook.f context loc_footer (Many footer)) + | None -> ( + match header @ footer with + | [] -> () + | l -> + let pos = + { + Lexing.pos_fname = ""; + pos_lnum = 1; + pos_bol = 0; + pos_cnum = 0; + } + in + let loc = + { Location.loc_start = pos; loc_end = pos; loc_ghost = false } + in + hook.f context loc (Many l))); (header, footer) in - let map_impl st_with_attrs = + let input_name = + match input_name with Some input_name -> input_name | None -> "_none_" + in + let map_impl ctxt st_with_attrs = let st = let attrs, st = List.split_while st_with_attrs ~f:(function | { pstr_desc = Pstr_attribute _; _ } -> true | _ -> false) in + let file_path = File_path.get_default_path_str st in + let base_ctxt = + Expansion_context.Base.top_level ~tool_name ~file_path ~input_name + in let header, footer = match enclose_impl with - | None -> ([], []) + | None -> ([], []) | Some f -> - let whole_loc = loc_of_list st ~get_loc:(fun st -> st.Parsetree.pstr_loc) in - gen_header_and_footer Structure_item whole_loc f + let whole_loc = + loc_of_list st ~get_loc:(fun st -> st.Parsetree.pstr_loc) + in + gen_header_and_footer Structure_item whole_loc (f base_ctxt) in - let file_path = File_path.get_default_path_str st in - let base_ctxt = Expansion_context.Base.top_level ~tool_name ~file_path in let attrs = map#structure base_ctxt attrs in let st = map#structure base_ctxt st in List.concat [ attrs; header; st; footer ] in - match impl with - | None -> st - | Some f -> f st + match impl with None -> st | Some f -> f ctxt st in - let map_intf sg_with_attrs = + let map_intf ctxt sg_with_attrs = let sg = let attrs, sg = List.split_while sg_with_attrs ~f:(function | { psig_desc = Psig_attribute _; _ } -> true | _ -> false) in + let file_path = File_path.get_default_path_sig sg in + let base_ctxt = + Expansion_context.Base.top_level ~tool_name ~file_path ~input_name + in let header, footer = match enclose_intf with - | None -> ([], []) + | None -> ([], []) | Some f -> - let whole_loc = loc_of_list sg ~get_loc:(fun sg -> sg.Parsetree.psig_loc) in - gen_header_and_footer Signature_item whole_loc f + let whole_loc = + loc_of_list sg ~get_loc:(fun sg -> sg.Parsetree.psig_loc) + in + gen_header_and_footer Signature_item whole_loc (f base_ctxt) in - let file_path = File_path.get_default_path_sig sg in - let base_ctxt = Expansion_context.Base.top_level ~tool_name ~file_path in let attrs = map#signature base_ctxt attrs in let sg = map#signature base_ctxt sg in List.concat [ attrs; header; sg; footer ] in - match intf with - | None -> sg - | Some f -> f sg + match intf with None -> sg | Some f -> f ctxt sg in - { t with - impl = Some map_impl - ; intf = Some map_intf - } + { t with impl = Some map_impl; intf = Some map_intf } - let builtin_of_context_free_rewriters ~hook ~rules ~enclose_impl ~enclose_intf = - merge_into_generic_mappers ~hook - { name = "" - ; aliases = [] - ; impl = None - ; intf = None - ; lint_impl = None - ; lint_intf = None - ; preprocess_impl = None - ; preprocess_intf = None - ; enclose_impl - ; enclose_intf - ; rules - ; registered_at = Caller_id.get ~skip:[] + let builtin_of_context_free_rewriters ~hook ~rules ~enclose_impl ~enclose_intf + ~input_name = + merge_into_generic_mappers ~hook ~input_name + { + name = ""; + aliases = []; + impl = None; + intf = None; + lint_impl = None; + lint_intf = None; + preprocess_impl = None; + preprocess_intf = None; + enclose_impl; + enclose_intf; + instrument = None; + rules; + registered_at = Caller_id.get ~skip:[]; } let partition_transformations ts = - (`Linters - (List.filter_map ts ~f:(fun t -> - if Option.is_some t.lint_impl || Option.is_some t.lint_intf then - Some - { name = Printf.sprintf "" t.name - ; aliases = [] - ; impl = None - ; intf = None - ; lint_impl = t.lint_impl - ; lint_intf = t.lint_intf - ; enclose_impl = None - ; enclose_intf = None - ; preprocess_impl = None - ; preprocess_intf = None - ; rules = [] - ; registered_at = t.registered_at - } - else - None)), - `Preprocess - (List.filter_map ts ~f:(fun t -> - if Option.is_some t.preprocess_impl || Option.is_some t.preprocess_intf - then - Some - { name = Printf.sprintf "" t.name - ; aliases = [] - ; impl = t.preprocess_impl - ; intf = t.preprocess_intf - ; lint_impl = None - ; lint_intf = None - ; enclose_impl = None - ; enclose_intf = None - ; preprocess_impl = None - ; preprocess_intf = None - ; rules = [] - ; registered_at = t.registered_at - } - else - None)), - `Rest - (List.map ts ~f:(fun t -> - { t with - lint_impl = None - ; lint_intf = None - ; preprocess_impl = None - ; preprocess_intf = None - }))) + let before_instrs, after_instrs, rest = + List.fold_left ts ~init:([], [], []) ~f:(fun (bef_i, aft_i, rest) t -> + let reduced_t = + { + t with + lint_impl = None; + lint_intf = None; + preprocess_impl = None; + preprocess_intf = None; + } + in + let f instr = + (instr.Instrument.position, instr.Instrument.transformation) + in + match Option.map t.instrument ~f with + | Some (Before, transf) -> + ({ reduced_t with impl = Some transf } :: bef_i, aft_i, rest) + | Some (After, transf) -> + (bef_i, { reduced_t with impl = Some transf } :: aft_i, rest) + | None -> (bef_i, aft_i, reduced_t :: rest)) + in + ( `Linters + (List.filter_map ts ~f:(fun t -> + if Option.is_some t.lint_impl || Option.is_some t.lint_intf then + Some + { + name = Printf.sprintf "" t.name; + aliases = []; + impl = None; + intf = None; + lint_impl = t.lint_impl; + lint_intf = t.lint_intf; + enclose_impl = None; + enclose_intf = None; + preprocess_impl = None; + preprocess_intf = None; + instrument = None; + rules = []; + registered_at = t.registered_at; + } + else None)), + `Preprocess + (List.filter_map ts ~f:(fun t -> + if + Option.is_some t.preprocess_impl + || Option.is_some t.preprocess_intf + then + Some + { + name = Printf.sprintf "" t.name; + aliases = []; + impl = t.preprocess_impl; + intf = t.preprocess_intf; + lint_impl = None; + lint_intf = None; + enclose_impl = None; + enclose_intf = None; + preprocess_impl = None; + preprocess_intf = None; + instrument = None; + rules = []; + registered_at = t.registered_at; + } + else None)), + `Before_instrs before_instrs, + `After_instrs after_instrs, + `Rest rest ) +end + +module V2 = struct + let register_transformation = Transform.register + + let register_transformation_using_ocaml_current_ast ?impl ?intf ?aliases name + = + let impl = + Option.map impl ~f:(Ppxlib_ast.Selected_ast.of_ocaml_mapper Structure) + in + let intf = + Option.map intf ~f:(Ppxlib_ast.Selected_ast.of_ocaml_mapper Signature) + in + register_transformation ?impl ?intf ?aliases name end -let register_transformation = Transform.register +let add_ctxt_arg (f : 'a -> 'b) : Expansion_context.Base.t -> 'a -> 'b = + fun _ x -> f x + +let register_transformation ?extensions ?rules ?enclose_impl ?enclose_intf ?impl + ?intf ?lint_impl ?lint_intf ?preprocess_impl ?preprocess_intf = + let impl = Option.map impl ~f:add_ctxt_arg in + let intf = Option.map intf ~f:add_ctxt_arg in + let preprocess_impl = Option.map preprocess_impl ~f:add_ctxt_arg in + let preprocess_intf = Option.map preprocess_intf ~f:add_ctxt_arg in + let lint_impl = Option.map lint_impl ~f:add_ctxt_arg in + let lint_intf = Option.map lint_intf ~f:add_ctxt_arg in + let enclose_impl = Option.map enclose_impl ~f:add_ctxt_arg in + let enclose_intf = Option.map enclose_intf ~f:add_ctxt_arg in + V2.register_transformation ?extensions ?rules ?enclose_impl ?enclose_intf + ?impl ?intf ?lint_impl ?lint_intf ?preprocess_impl ?preprocess_intf -let register_code_transformation ~name ?(aliases=[]) ~impl ~intf = +let register_code_transformation ~name ?(aliases = []) ~impl ~intf = register_transformation name ~impl ~intf ~aliases -;; + [@@warning "-16"] +(* This function triggers a warning 16 as of ocaml 4.12 *) -let register_transformation_using_ocaml_current_ast ?impl ?intf ?aliases name = - let impl = Option.map impl ~f:(Ppxlib_ast.Selected_ast.of_ocaml_mapper Structure) in - let intf = Option.map intf ~f:(Ppxlib_ast.Selected_ast.of_ocaml_mapper Signature) in - register_transformation ?impl ?intf ?aliases name +let register_transformation_using_ocaml_current_ast ?impl ?intf = + let impl = Option.map impl ~f:add_ctxt_arg in + let intf = Option.map intf ~f:add_ctxt_arg in + V2.register_transformation_using_ocaml_current_ast ?impl ?intf let debug_dropped_attribute name ~old_dropped ~new_dropped = let print_diff what a b = let diff = List.filter a ~f:(fun (name : _ Loc.t) -> - not (List.exists b ~f:(fun (name' : _ Location.loc) -> name.txt == name'.txt))) + not + (List.exists b ~f:(fun (name' : _ Location.loc) -> + name.txt == name'.txt))) in - if not (List.is_empty diff) then begin - Printf.eprintf "The following attributes %s after applying %s:\n" - what name; - List.iter diff ~f:(fun { Location. txt; loc } -> - Caml.Format.eprintf "- %a: %s\n" Location.print loc txt); - Caml.Format.eprintf "@." - end + if not (List.is_empty diff) then ( + Printf.eprintf "The following attributes %s after applying %s:\n" what + name; + List.iter diff ~f:(fun { Location.txt; loc } -> + Caml.Format.eprintf "- %a: %s\n" Location.print loc txt); + Caml.Format.eprintf "@.") in print_diff "disappeared" new_dropped old_dropped; - print_diff "reappeared" old_dropped new_dropped -;; + print_diff "reappeared" old_dropped new_dropped -let get_whole_ast_passes ~hook ~expect_mismatch_handler ~tool_name = +let get_whole_ast_passes ~hook ~expect_mismatch_handler ~tool_name ~input_name = let cts = match !apply_list with | None -> List.rev !Transform.all | Some names -> - List.map names ~f:(fun name -> - List.find !Transform.all ~f:(fun (ct : Transform.t) -> - Transform.has_name ct name)) + List.map names ~f:(fun name -> + List.find !Transform.all ~f:(fun (ct : Transform.t) -> + Transform.has_name ct name)) + in + let ( `Linters linters, + `Preprocess preprocess, + `Before_instrs before_instrs, + `After_instrs after_instrs, + `Rest cts ) = + Transform.partition_transformations cts in - let (`Linters linters, `Preprocess preprocess, `Rest cts) = - Transform.partition_transformations cts in (* Allow only one preprocessor to assure deterministic order *) - if (List.length preprocess) > 1 then begin - let pp = String.concat ~sep:", " (List.map preprocess ~f:(fun t -> t.name)) in - let err = Printf.sprintf "At most one preprocessor is allowed, while got: %s" pp in - failwith err - end; - let cts = + (if List.length preprocess > 1 then + let pp = + String.concat ~sep:", " (List.map preprocess ~f:(fun t -> t.name)) + in + let err = + Printf.sprintf "At most one preprocessor is allowed, while got: %s" pp + in + failwith err); + let make_generic transforms = if !no_merge then - List.map cts ~f:(Transform.merge_into_generic_mappers ~hook ~tool_name - ~expect_mismatch_handler) - else begin - let get_enclosers ~f = - List.filter_map cts ~f:(fun (ct : Transform.t) -> - match f ct with - | None -> None - | Some x -> Some (ct.name, x)) - (* Sort them to ensure deterministic ordering *) - |> List.sort ~cmp:(fun (a, _) (b, _) -> String.compare a b) - |> List.map ~f:snd - in + List.map transforms + ~f: + (Transform.merge_into_generic_mappers ~hook ~tool_name + ~expect_mismatch_handler ~input_name) + else + (let get_enclosers ~f = + List.filter_map transforms ~f:(fun (ct : Transform.t) -> + match f ct with None -> None | Some x -> Some (ct.name, x)) + (* Sort them to ensure deterministic ordering *) + |> List.sort ~cmp:(fun (a, _) (b, _) -> String.compare a b) + |> List.map ~f:snd + in + + let rules = + List.map transforms ~f:(fun (ct : Transform.t) -> ct.rules) + |> List.concat + and impl_enclosers = get_enclosers ~f:(fun ct -> ct.enclose_impl) + and intf_enclosers = get_enclosers ~f:(fun ct -> ct.enclose_intf) in + match (rules, impl_enclosers, intf_enclosers) with + | [], [], [] -> transforms + | _ -> + let merge_encloser = function + | [] -> None + | enclosers -> + Some + (fun ctxt loc -> + let headers, footers = + List.map enclosers ~f:(fun f -> f ctxt loc) |> List.split + in + let headers = List.concat headers in + let footers = List.concat (List.rev footers) in + (headers, footers)) + in + Transform.builtin_of_context_free_rewriters ~rules ~hook + ~expect_mismatch_handler + ~enclose_impl:(merge_encloser impl_enclosers) + ~enclose_intf:(merge_encloser intf_enclosers) + ~tool_name ~input_name + :: transforms) + |> List.filter ~f:(fun (ct : Transform.t) -> + match (ct.impl, ct.intf) with None, None -> false | _ -> true) + in + linters @ preprocess @ make_generic before_instrs @ make_generic cts + @ make_generic after_instrs - let rules = - List.map cts ~f:(fun (ct : Transform.t) -> ct.rules) |> List.concat - and impl_enclosers = - get_enclosers ~f:(fun ct -> ct.enclose_impl) - and intf_enclosers = - get_enclosers ~f:(fun ct -> ct.enclose_intf) - in - match rules, impl_enclosers, intf_enclosers with - | [], [], [] -> cts - | _ -> - let merge_encloser = function - | [] -> None - | enclosers -> Some (fun loc -> - let headers, footers = - List.map enclosers ~f:(fun f -> f loc) - |> List.split - in - let headers = List.concat headers in - let footers = List.concat (List.rev footers) in - (headers, footers)) - in - Transform.builtin_of_context_free_rewriters ~rules ~hook ~expect_mismatch_handler - ~enclose_impl:(merge_encloser impl_enclosers) - ~enclose_intf:(merge_encloser intf_enclosers) - ~tool_name - :: cts - end - in linters @ preprocess @ List.filter cts ~f:(fun (ct : Transform.t) -> - match ct.impl, ct.intf with - | None, None -> false - | _ -> true) -;; - -let apply_transforms - ~tool_name ~field ~lint_field ~dropped_so_far ~hook ~expect_mismatch_handler x = - let cts = get_whole_ast_passes ~tool_name ~hook ~expect_mismatch_handler in +let apply_transforms ~tool_name ~file_path ~field ~lint_field ~dropped_so_far + ~hook ~expect_mismatch_handler ~input_name x = + let cts = + get_whole_ast_passes ~tool_name ~hook ~expect_mismatch_handler ~input_name + in let x, _dropped, lint_errors = - List.fold_left cts ~init:(x, [], []) - ~f:(fun (x, dropped, lint_errors) (ct : Transform.t) -> - let lint_errors = - match lint_field ct with - | None -> lint_errors - | Some f -> lint_errors @ f x - in - match field ct with - | None -> (x, dropped, lint_errors) - | Some f -> - let x = f x in - let dropped = - if !debug_attribute_drop then begin - let new_dropped = dropped_so_far x in - debug_dropped_attribute ct.name ~old_dropped:dropped ~new_dropped; - new_dropped - end else - [] + List.fold_left cts ~init:(x, [], []) + ~f:(fun (x, dropped, lint_errors) (ct : Transform.t) -> + let input_name = + match input_name with + | Some input_name -> input_name + | None -> "_none_" + in + let ctxt = + Expansion_context.Base.top_level ~tool_name ~file_path ~input_name in - (x, dropped, lint_errors)) + let lint_errors = + match lint_field ct with + | None -> lint_errors + | Some f -> lint_errors @ f ctxt x + in + match field ct with + | None -> (x, dropped, lint_errors) + | Some f -> + let x = f ctxt x in + let dropped = + if !debug_attribute_drop then ( + let new_dropped = dropped_so_far x in + debug_dropped_attribute ct.name ~old_dropped:dropped + ~new_dropped; + new_dropped) + else [] + in + (x, dropped, lint_errors)) in - (x, List.map lint_errors ~f:(fun (loc, s) -> Common.attribute_of_warning loc s)) -;; + ( x, + List.map lint_errors ~f:(fun (loc, s) -> Common.attribute_of_warning loc s) + ) (* +-----------------------------------------------------------------+ | Actual rewriting of structure/signatures | +-----------------------------------------------------------------+ *) -(* We want driver registered plugins to work with omp driver and vice-versa. To - simplify things we do as follow: - - - we register driver as a single omp driver plugin - - driver calls the omp driver rewriting functions, which will apply everything - - The registration with omp driver is at the end of the file. -*) - -module C = struct - type t = - { hook : Context_free.Generated_code_hook.t - ; expect_mismatch_handler : Context_free.Expect_mismatch_handler.t - } - - type Migrate_parsetree.Driver.extra += T of t - - let default = - { hook = Context_free.Generated_code_hook.nop - ; expect_mismatch_handler = Context_free.Expect_mismatch_handler.nop - } - - let find (config : Migrate_parsetree.Driver.config) = - List.find_map config.extras ~f:(function - | T config -> Some config - | _ -> None) - |> Option.value ~default -end - -let config ~hook ~expect_mismatch_handler = - Migrate_parsetree.Driver.make_config () - ~tool_name:"ppxlib_driver" - ~extras:[C.T { hook - ; expect_mismatch_handler - }] - -let as_ppx_config () = - Migrate_parsetree.Driver.make_config () - ~tool_name:(Ocaml_common.Ast_mapper.tool_name ()) - ~include_dirs:!Ocaml_common.Clflags.include_dirs - ~load_path:(Compiler_specifics.get_load_path ()) - ~debug:!Ocaml_common.Clflags.debug - ?for_package:!Ocaml_common.Clflags.for_package - let print_passes () = let tool_name = "ppxlib_driver" in let hook = Context_free.Generated_code_hook.nop in let expect_mismatch_handler = Context_free.Expect_mismatch_handler.nop in - let cts = get_whole_ast_passes ~hook ~expect_mismatch_handler ~tool_name in + let cts = + get_whole_ast_passes ~hook ~expect_mismatch_handler ~tool_name + ~input_name:None + in if !perform_checks then Printf.printf "\n"; List.iter cts ~f:(fun ct -> Printf.printf "%s\n" ct.Transform.name); - if !perform_checks then - begin - Printf.printf "\n"; - if !perform_checks_on_extensions - then Printf.printf "\n" - end -;; + if !perform_checks then ( + Printf.printf "\n"; + if !perform_checks_on_extensions then + Printf.printf "\n") (*$*) -let real_map_structure config cookies st = - let { C. hook; expect_mismatch_handler } = C.find config in - Cookies.acknoledge_cookies cookies; - if !perform_checks then begin +let map_structure_gen st ~tool_name ~hook ~expect_mismatch_handler ~input_name = + Cookies.acknowledge_cookies T; + if !perform_checks then ( Attribute.reset_checks (); - Attribute.collect#structure st - end; + Attribute.collect#structure st); let st, lint_errors = - apply_transforms st - ~tool_name:config.Migrate_parsetree.Driver.tool_name + let file_path = File_path.get_default_path_str st in + apply_transforms st ~tool_name ~file_path ~field:(fun (ct : Transform.t) -> ct.impl) ~lint_field:(fun (ct : Transform.t) -> ct.lint_impl) - ~dropped_so_far:Attribute.dropped_so_far_structure ~hook ~expect_mismatch_handler + ~dropped_so_far:Attribute.dropped_so_far_structure ~hook + ~expect_mismatch_handler ~input_name in let st = match lint_errors with | [] -> st - | _ -> - List.map lint_errors ~f:(fun ({ attr_name = { loc; _ }; _} as attr) -> - Ast_builder.Default.pstr_attribute ~loc attr) - @ st + | _ -> + List.map lint_errors ~f:(fun ({ attr_name = { loc; _ }; _ } as attr) -> + Ast_builder.Default.pstr_attribute ~loc attr) + @ st in - Cookies.call_post_handlers cookies; - if !perform_checks then begin + Cookies.call_post_handlers T; + if !perform_checks then ( (* TODO: these two passes could be merged, we now have more passes for checks than for actual rewriting. *) Attribute.check_unused#structure st; @@ -502,47 +586,43 @@ Attribute.check_all_seen (); if !perform_locations_check then let open Location_check in - ignore ( - (enforce_invariants !loc_fname)#structure - st Non_intersecting_ranges.empty : Non_intersecting_ranges.t) - end; + ignore + ((enforce_invariants !loc_fname)#structure st + Non_intersecting_ranges.empty + : Non_intersecting_ranges.t)); st -;; - -let map_structure_gen st ~config : Migrate_parsetree.Driver.some_structure = - Migrate_parsetree.Driver.rewrite_structure - config - (module Ppxlib_ast.Selected_ast) - st let map_structure st = - map_structure_gen st ~config:(as_ppx_config ()) + map_structure_gen st + ~tool_name:(Astlib.Ast_metadata.tool_name ()) + ~hook:Context_free.Generated_code_hook.nop + ~expect_mismatch_handler:Context_free.Expect_mismatch_handler.nop + ~input_name:None (*$ str_to_sig _last_text_block *) -let real_map_signature config cookies sg = - let { C. hook; expect_mismatch_handler } = C.find config in - Cookies.acknoledge_cookies cookies; - if !perform_checks then begin +let map_signature_gen sg ~tool_name ~hook ~expect_mismatch_handler ~input_name = + Cookies.acknowledge_cookies T; + if !perform_checks then ( Attribute.reset_checks (); - Attribute.collect#signature sg - end; + Attribute.collect#signature sg); let sg, lint_errors = - apply_transforms sg - ~tool_name:config.Migrate_parsetree.Driver.tool_name + let file_path = File_path.get_default_path_sig sg in + apply_transforms sg ~tool_name ~file_path ~field:(fun (ct : Transform.t) -> ct.intf) ~lint_field:(fun (ct : Transform.t) -> ct.lint_intf) - ~dropped_so_far:Attribute.dropped_so_far_signature ~hook ~expect_mismatch_handler + ~dropped_so_far:Attribute.dropped_so_far_signature ~hook + ~expect_mismatch_handler ~input_name in let sg = match lint_errors with | [] -> sg - | _ -> - List.map lint_errors ~f:(fun ({ attr_name = { loc; _ }; _} as attr) -> - Ast_builder.Default.psig_attribute ~loc attr) - @ sg + | _ -> + List.map lint_errors ~f:(fun ({ attr_name = { loc; _ }; _ } as attr) -> + Ast_builder.Default.psig_attribute ~loc attr) + @ sg in - Cookies.call_post_handlers cookies; - if !perform_checks then begin + Cookies.call_post_handlers T; + if !perform_checks then ( (* TODO: these two passes could be merged, we now have more passes for checks than for actual rewriting. *) Attribute.check_unused#signature sg; @@ -550,21 +630,18 @@ Attribute.check_all_seen (); if !perform_locations_check then let open Location_check in - ignore ( - (enforce_invariants !loc_fname)#signature - sg Non_intersecting_ranges.empty : Non_intersecting_ranges.t) - end; + ignore + ((enforce_invariants !loc_fname)#signature sg + Non_intersecting_ranges.empty + : Non_intersecting_ranges.t)); sg -;; - -let map_signature_gen sg ~config : Migrate_parsetree.Driver.some_signature = - Migrate_parsetree.Driver.rewrite_signature - config - (module Ppxlib_ast.Selected_ast) - sg let map_signature sg = - map_signature_gen sg ~config:(as_ppx_config ()) + map_signature_gen sg + ~tool_name:(Astlib.Ast_metadata.tool_name ()) + ~hook:Context_free.Generated_code_hook.nop + ~expect_mismatch_handler:Context_free.Expect_mismatch_handler.nop + ~input_name:None (*$*) @@ -572,168 +649,120 @@ | Entry points | +-----------------------------------------------------------------+ *) -let mapper = - let module Js = Ppxlib_ast.Selected_ast in - (*$*) - let structure _ st = - Js.of_ocaml Structure st - |> map_structure - |> Migrate_parsetree.Driver.migrate_some_structure - (module Migrate_parsetree.OCaml_current) - in - (*$ str_to_sig _last_text_block *) - let signature _ sg = - Js.of_ocaml Signature sg - |> map_signature - |> Migrate_parsetree.Driver.migrate_some_signature - (module Migrate_parsetree.OCaml_current) - in - (*$*) - { Ocaml_common.Ast_mapper.default_mapper with structure; signature } -;; - -let as_ppx_rewriter_main argv = - let argv = Caml.Sys.executable_name :: argv in - let usage = - Printf.sprintf "%s [extra_args] " exe_name - in - match - Arg.parse_argv (Array.of_list argv) (Arg.align (List.rev !args)) - (fun _ -> raise (Arg.Bad "anonymous arguments not accepted")) - usage - with - | exception Arg.Bad msg -> Printf.eprintf "%s" msg; Caml.exit 2 - | exception Arg.Help msg -> Printf.eprintf "%s" msg; Caml.exit 0 - | () -> mapper - -let run_as_ppx_rewriter () = - perform_checks := false; - Ocaml_common.Ast_mapper.run_main as_ppx_rewriter_main; - Caml.exit 0 - let string_contains_binary_ast s = let test magic_number = String.is_prefix s ~prefix:(String.sub magic_number ~pos:0 ~len:9) in - test Ast_magic.ast_intf_magic_number || - test Ast_magic.ast_impl_magic_number - -type pp_error = { filename : string; command_line : string } -exception Pp_error of pp_error - -let report_pp_error e = - let buff = Buffer.create 128 in - let ppf = Caml.Format.formatter_of_buffer buff in - Caml.Format.fprintf ppf "Error while running external preprocessor@.\ - Command line: %s@." e.command_line; - Caml.Format.pp_print_flush ppf (); - Buffer.contents buff + test Ast_magic.ast_intf_magic_number || test Ast_magic.ast_impl_magic_number -let () = - Location.Error.register_error_of_exn - (function - | Pp_error e -> - Some (Location.Error.make ~loc:(Location.in_file e.filename) ~sub:[] - (report_pp_error e)) - | _ -> None) +let versioned_errorf input_version input_file_name = + Printf.ksprintf (fun msg -> + let err = + Location.Error.make ~loc:(Location.in_file input_file_name) msg ~sub:[] + in + Error (err, input_version)) -let remove_no_error fn = - try Caml.Sys.remove fn with Sys_error _ -> () +let remove_no_error fn = try Caml.Sys.remove fn with Sys_error _ -> () let protectx x ~f ~finally = match f x with - | v -> finally x; v - | exception e -> finally x; raise e -;; + | v -> + finally x; + v + | exception e -> + finally x; + raise e let with_preprocessed_file fn ~f = match !preprocessor with | None -> f fn | Some pp -> - protectx (Caml.Filename.temp_file "ocamlpp" "") - ~finally:remove_no_error - ~f:(fun tmpfile -> - let comm = - Printf.sprintf "%s %s > %s" - pp (if String.equal fn "-" then "" else Caml.Filename.quote fn) - (Caml.Filename.quote tmpfile) - in - if Caml.Sys.command comm <> 0 then - raise (Pp_error { filename = fn - ; command_line = comm - }); - f tmpfile) - -let with_preprocessed_input fn ~f = - with_preprocessed_file fn ~f:(fun fn -> - if String.equal fn "-" then - f stdin - else - In_channel.with_file fn ~f) -;; - -let relocate_mapper = object - inherit [string * string] Ast_traverse.map_with_context - - method! position (old_fn, new_fn) pos = - if String.equal pos.pos_fname old_fn then - { pos with pos_fname = new_fn } - else - pos -end + protectx (Caml.Filename.temp_file "ocamlpp" "") ~finally:remove_no_error + ~f:(fun tmpfile -> + match System.run_preprocessor ~pp ~input:fn ~output:tmpfile with + | Ok () -> f tmpfile + | Error (failed_command, fall_back_version) -> + versioned_errorf fall_back_version fn + "Error while running external preprocessor\nCommand line: %s\n" + failed_command) + +let relocate_mapper = + object + inherit [string * string] Ast_traverse.map_with_context + + method! position (old_fn, new_fn) pos = + if String.equal pos.pos_fname old_fn then { pos with pos_fname = new_fn } + else pos + end (* Set the input name globally. This is used by some ppx rewriters such as bisect_ppx. *) -let set_input_name name = - Ocaml_common.Location.input_name := name +let set_input_name = Astlib.Location.set_input_name -let load_input (kind : Kind.t) fn input_name ~relocate ic = +let load_input ~(kind : Kind.t) ~input_name ~relocate fn = set_input_name input_name; - match Migrate_parsetree.Ast_io.from_channel ic with - | Ok (ast_input_name, ast) -> - let ast = Intf_or_impl.of_ast_io ast in - if not (Kind.equal kind (Intf_or_impl.kind ast)) then + let input_source = if String.equal fn "-" then Ast_io.Stdin else File fn in + let input_kind = Ast_io.Possibly_source (kind, input_name) in + match Ast_io.read input_source ~input_kind with + | Ok { input_name = ast_input_name; input_version; ast } -> + let ast_kind = Intf_or_impl.kind ast in + if not (Kind.equal kind ast_kind) then + versioned_errorf input_version fn + "File contains a binary %s AST but an %s was expected" + (Kind.describe ast_kind) (Kind.describe kind) + else if String.equal ast_input_name input_name || not relocate then ( + set_input_name ast_input_name; + Ok (ast_input_name, input_version, ast)) + else + Ok + ( input_name, + input_version, + Intf_or_impl.map_with_context ast relocate_mapper + (ast_input_name, input_name) ) + | Error (Unknown_version (unknown_magic, fall_back_version)) -> + versioned_errorf fall_back_version fn + "File is a binary ast for an unknown version of OCaml with magic \ + number '%s'" + unknown_magic + | Error (System_error (error, fall_back_version)) + | Error (Source_parse_error (error, fall_back_version)) -> + Error (error, fall_back_version) + | Error Not_a_binary_ast -> assert false + +let load_input_run_as_ppx fn = + (* If there's an error while loading in run_as_ppx mode, the kind of AST (impl/intf) is still unknown. + That's why, as opposed to load_input, this function raises errors instead of returning a result: + handling an error by returning an AST with the error packed as extension node wouldn't be possible. *) + match Ast_io.read (File fn) ~input_kind:Ast_io.Necessarily_binary with + | Ok { input_name = ast_input_name; input_version; ast } -> + let ast = + match !loc_fname with + | None -> + set_input_name ast_input_name; + ast + | Some input_name -> + set_input_name input_name; + if String.equal ast_input_name input_name then ast + else + Intf_or_impl.map_with_context ast relocate_mapper + (ast_input_name, input_name) + in + (* With `--as-ppx`, ocaml calls the standalone separately for every structure/signature item + with the filename as metadata that it gets from the previous call. relocate_mapper only + relocates positions whose position filename coincides with that metadata filename. + So always return the metadata filename itself, even if `-loc-filename` is provided. *) + (ast_input_name, input_version, ast) + | Error (Unknown_version (unknown_magic, _)) -> Location.raise_errorf ~loc:(Location.in_file fn) - "File contains a binary %s AST but an %s was expected" - (Kind.describe (Intf_or_impl.kind ast)) - (Kind.describe kind); - if String.equal ast_input_name input_name || not relocate then begin - set_input_name ast_input_name; - (ast_input_name, ast) - end else - (input_name, - Intf_or_impl.map_with_context ast relocate_mapper - (ast_input_name, input_name)) - - | Error (Unknown_version _) -> - Location.raise_errorf ~loc:(Location.in_file fn) - "File is a binary ast for an unknown version of OCaml" - | Error (Not_a_binary_ast prefix_read_from_file) -> - (* To test if a file is an AST file, we have to read the first few bytes of the - file. If it is not, we have to parse these bytes and the rest of the file as - source code. - - The compiler just does [seek_on 0] in this case, however this doesn't work when - the input is a pipe. - - What we do instead is create a lexing buffer from the input channel and pre-fill - it with what we read to do the test. *) - let lexbuf = Lexing.from_channel ic in - let len = String.length prefix_read_from_file in - Bytes.blit_string ~src:prefix_read_from_file ~src_pos:0 ~dst:lexbuf.lex_buffer ~dst_pos:0 - ~len; - lexbuf.lex_buffer_len <- len; - lexbuf.lex_curr_p <- - { pos_fname = input_name - ; pos_lnum = 1 - ; pos_bol = 0 - ; pos_cnum = 0 - }; - Lexer.skip_hash_bang lexbuf; - match kind with - | Intf -> input_name, Intf (Parse.interface lexbuf) - | Impl -> input_name, Impl (Parse.implementation lexbuf) -;; + "The input is a binary ast for an unknown version of OCaml with magic \ + number '%s'" + unknown_magic + | Error Not_a_binary_ast -> + Location.raise_errorf ~loc:(Location.in_file fn) + "Expected a binary AST as input" + | Error (System_error (error, _)) | Error (Source_parse_error (error, _)) -> + let open Location.Error in + Location.set_filename (get_location error) fn |> update_loc error |> raise let load_source_file fn = let s = In_channel.read_all fn in @@ -741,7 +770,6 @@ Location.raise_errorf ~loc:(Location.in_file fn) "ppxlib_driver: cannot use -reconcile with binary AST files"; s -;; type output_mode = | Pretty_print @@ -752,36 +780,60 @@ (*$*) let extract_cookies_str st = - match st with - | { pstr_desc = Pstr_attribute {attr_name={txt = "ocaml.ppx.context"; _}; _}; _ } as prefix - :: st -> - let prefix = Ppxlib_ast.Selected_ast.to_ocaml Structure [prefix] in - assert (List.is_empty - (Ocaml_common.Ast_mapper.drop_ppx_context_str ~restore:true prefix)); - st - | _ -> st + let st = + match st with + | ({ + pstr_desc = + Pstr_attribute { attr_name = { txt = "ocaml.ppx.context"; _ }; _ }; + _; + } as prefix) + :: st -> + let prefix = Ppxlib_ast.Selected_ast.to_ocaml Structure [ prefix ] in + assert ( + List.is_empty + (Astlib.Ast_metadata.drop_ppx_context_str ~restore:true prefix)); + st + | _ -> st + in + (* The cli cookies have to be set after restoring the ppx context, + since restoring the ppx context resets the cookies *) + List.iter !Cookies.given_through_cli ~f:(fun (name, expr) -> + Cookies.set T name expr); + st let add_cookies_str st = let prefix = - Ocaml_common.Ast_mapper.add_ppx_context_str ~tool_name:"ppxlib_driver" [] + Astlib.Ast_metadata.add_ppx_context_str ~tool_name:"ppxlib_driver" [] |> Ppxlib_ast.Selected_ast.of_ocaml Structure in prefix @ st (*$ str_to_sig _last_text_block *) let extract_cookies_sig sg = - match sg with - | { psig_desc = Psig_attribute {attr_name={txt = "ocaml.ppx.context"; _}; _}; _ } as prefix - :: sg -> - let prefix = Ppxlib_ast.Selected_ast.to_ocaml Signature [prefix] in - assert (List.is_empty - (Ocaml_common.Ast_mapper.drop_ppx_context_sig ~restore:true prefix)); - sg - | _ -> sg + let sg = + match sg with + | ({ + psig_desc = + Psig_attribute { attr_name = { txt = "ocaml.ppx.context"; _ }; _ }; + _; + } as prefix) + :: sg -> + let prefix = Ppxlib_ast.Selected_ast.to_ocaml Signature [ prefix ] in + assert ( + List.is_empty + (Astlib.Ast_metadata.drop_ppx_context_sig ~restore:true prefix)); + sg + | _ -> sg + in + (* The cli cookies have to be set after restoring the ppx context, + since restoring the ppx context resets the cookies *) + List.iter !Cookies.given_through_cli ~f:(fun (name, expr) -> + Cookies.set T name expr); + sg let add_cookies_sig sg = let prefix = - Ocaml_common.Ast_mapper.add_ppx_context_sig ~tool_name:"ppxlib_driver" [] + Astlib.Ast_metadata.add_ppx_context_sig ~tool_name:"ppxlib_driver" [] |> Ppxlib_ast.Selected_ast.of_ocaml Signature in prefix @ sg @@ -804,22 +856,19 @@ let register_correction ~loc ~repl = add_to_list corrections - (Reconcile.Replacement.make_text () - ~start:loc.loc_start - ~stop:loc.loc_end + (Reconcile.Replacement.make_text () ~start:loc.loc_start ~stop:loc.loc_end ~repl) let process_file_hooks = ref [] -let register_process_file_hook f = - add_to_list process_file_hooks f +let register_process_file_hook f = add_to_list process_file_hooks f module File_property = struct - type 'a t = - { name : string - ; mutable data : 'a option - ; sexp_of_t : 'a -> Sexp.t - } + type 'a t = { + name : string; + mutable data : 'a option; + sexp_of_t : 'a -> Sexp.t; + } type packed = T : _ t -> packed @@ -827,160 +876,179 @@ let register t = add_to_list all (T t) - let reset_all () = - List.iter !all ~f:(fun (T t) -> t.data <- None) + let reset_all () = List.iter !all ~f:(fun (T t) -> t.data <- None) let dump_and_reset_all () = List.filter_map (List.rev !all) ~f:(fun (T t) -> - match t.data with - | None -> None - | Some v -> - t.data <- None; - Some (t.name, t.sexp_of_t v)) + match t.data with + | None -> None + | Some v -> + t.data <- None; + Some (t.name, t.sexp_of_t v)) end -module Create_file_property(Name : sig val name : string end)(T : Sexpable.S) = struct +module Create_file_property (Name : sig + val name : string +end) +(T : Sexpable.S) = +struct let t : _ File_property.t = - { name = Name.name - ; data = None - ; sexp_of_t = T.sexp_of_t - } + { name = Name.name; data = None; sexp_of_t = T.sexp_of_t } let () = File_property.register t let set x = t.data <- Some x end -let process_file (kind : Kind.t) fn ~input_name ~relocate ~output_mode ~embed_errors ~output = +let error_to_extension error ~(kind : Kind.t) = + let loc = Location.none in + let ext = Location.Error.to_extension error in + let open Ast_builder.Default in + let ast = + match kind with + | Intf -> Intf_or_impl.Intf [ psig_extension ~loc ext [] ] + | Impl -> Intf_or_impl.Impl [ pstr_extension ~loc ext [] ] + in + ast + +let exn_to_extension exn ~(kind : Kind.t) = + match Location.Error.of_exn exn with + | None -> raise exn + | Some error -> error_to_extension error ~kind + +let process_ast (ast : Intf_or_impl.t) ~input_name ~tool_name ~hook + ~expect_mismatch_handler = + match ast with + | Intf x -> + Intf_or_impl.Intf + (map_signature_gen x ~tool_name ~hook ~expect_mismatch_handler + ~input_name:(Some input_name)) + | Impl x -> + Intf_or_impl.Impl + (map_structure_gen x ~tool_name ~hook ~expect_mismatch_handler + ~input_name:(Some input_name)) + +let process_file (kind : Kind.t) fn ~input_name ~relocate ~output_mode + ~embed_errors ~output = File_property.reset_all (); List.iter (List.rev !process_file_hooks) ~f:(fun f -> f ()); corrections := []; let replacements = ref [] in + let tool_name = "ppx_driver" in let hook : Context_free.Generated_code_hook.t = match output_mode with | Reconcile (Using_line_directives | Delimiting_generated_blocks) -> - { f = fun context (loc : Location.t) generated -> - add_to_list replacements - (Reconcile.Replacement.make () - ~context:(Extension context) - ~start:loc.loc_start - ~stop:loc.loc_end - ~repl:generated) - } - | _ -> - Context_free.Generated_code_hook.nop + { + f = + (fun context (loc : Location.t) generated -> + add_to_list replacements + (Reconcile.Replacement.make () ~context:(Extension context) + ~start:loc.loc_start ~stop:loc.loc_end ~repl:generated)); + } + | _ -> Context_free.Generated_code_hook.nop in let expect_mismatch_handler : Context_free.Expect_mismatch_handler.t = - { f = fun context (loc : Location.t) generated -> - add_to_list corrections - (Reconcile.Replacement.make () - ~context:(Floating_attribute context) - ~start:loc.loc_start - ~stop:loc.loc_end - ~repl:(Many generated)) + { + f = + (fun context (loc : Location.t) generated -> + add_to_list corrections + (Reconcile.Replacement.make () ~context:(Floating_attribute context) + ~start:loc.loc_start ~stop:loc.loc_end ~repl:(Many generated))); } in - let input_name, ast = - try - let input_name, ast = - with_preprocessed_input fn ~f:(load_input kind fn input_name ~relocate) - in - let ast = extract_cookies ast in - let config = config ~hook ~expect_mismatch_handler in - match ast with - | Intf x -> input_name, Some_intf_or_impl.Intf (map_signature_gen x ~config) - | Impl x -> input_name, Some_intf_or_impl.Impl (map_structure_gen x ~config) - with exn when embed_errors -> - match Location.Error.of_exn exn with - | None -> raise exn - | Some error -> - let loc = Location.none in - let ext = Location.Error.to_extension error in - let open Ast_builder.Default in - let ast = match kind with - | Intf -> - Some_intf_or_impl.Intf - (Sig ((module Ppxlib_ast.Selected_ast), - [ psig_extension ~loc ext [] ])) - | Impl -> - Some_intf_or_impl.Impl - (Str ((module Ppxlib_ast.Selected_ast), - [ pstr_extension ~loc ext [] ])) - in - input_name, ast + let input_name, input_version, ast = + let preprocessed_and_loaded = + with_preprocessed_file fn ~f:(load_input ~kind ~input_name ~relocate) in - - Option.iter !output_metadata_filename ~f:(fun fn -> + match preprocessed_and_loaded with + | Ok (input_fname, input_version, ast) -> ( + try + let ast = + extract_cookies ast + |> process_ast ~input_name ~tool_name ~hook ~expect_mismatch_handler + in + (input_fname, input_version, ast) + with exn when embed_errors -> + (input_fname, input_version, exn_to_extension exn ~kind)) + | Error (error, input_version) when embed_errors -> + (input_name, input_version, error_to_extension error ~kind) + | Error (error, _) -> + let open Location.Error in + Location.set_filename (get_location error) fn + |> update_loc error |> raise + in + Option.iter !output_metadata_filename ~f:(fun fn -> let metadata = File_property.dump_and_reset_all () in Out_channel.write_all fn - ~data:( - List.map metadata ~f:(fun (s, sexp) -> - Sexp.to_string_hum (Sexp.List [Atom s; sexp]) ^ "\n") + ~data: + (List.map metadata ~f:(fun (s, sexp) -> + Sexp.to_string_hum (Sexp.List [ Atom s; sexp ]) ^ "\n") |> String.concat ~sep:"")); - let input_contents = lazy (load_source_file fn) in - let corrected = fn ^ !corrected_suffix in - let mismatches_found = - match !corrections with - | [] -> + let input_contents = lazy (load_source_file fn) in + let corrected = fn ^ !corrected_suffix in + let mismatches_found = + match !corrections with + | [] -> if Caml.Sys.file_exists corrected then Caml.Sys.remove corrected; false - | corrections -> - Reconcile.reconcile corrections ~contents:(Lazy.force input_contents) - ~output:(Some corrected) ~input_filename:fn ~input_name ~target:Corrected - ?styler:!styler ~kind; + | corrections -> + Reconcile.reconcile corrections + ~contents:(Lazy.force input_contents) + ~output:(Some corrected) ~input_filename:fn ~input_name + ~target:Corrected ?styler:!styler ~kind; true - in + in - (match output_mode with - | Null -> () - | Pretty_print -> - with_output output ~binary:false ~f:(fun oc -> - let ppf = Caml.Format.formatter_of_out_channel oc in - let ast = Intf_or_impl.of_some_intf_or_impl ast in - (match ast with + (match output_mode with + | Null -> () + | Pretty_print -> + with_output output ~binary:false ~f:(fun oc -> + let ppf = Caml.Format.formatter_of_out_channel oc in + (match ast with | Intf ast -> Pprintast.signature ppf ast | Impl ast -> Pprintast.structure ppf ast); - let null_ast = - match ast with - | Intf [] | Impl [] -> true - | _ -> false - in - if not null_ast then Caml.Format.pp_print_newline ppf ()) - | Dump_ast -> - with_output output ~binary:true ~f:(fun oc -> - let ast = Some_intf_or_impl.to_ast_io ast ~add_ppx_context:true in - Migrate_parsetree.Ast_io.to_channel oc input_name ast) - | Dparsetree -> - with_output output ~binary:false ~f:(fun oc -> - let ppf = Caml.Format.formatter_of_out_channel oc in - let ast = Intf_or_impl.of_some_intf_or_impl ast in - let ast = add_cookies ast in - (match ast with + let null_ast = + match ast with Intf [] | Impl [] -> true | _ -> false + in + if not null_ast then Caml.Format.pp_print_newline ppf ()) + | Dump_ast -> + with_output output ~binary:true ~f:(fun oc -> + Ast_io.write oc + { input_name; input_version; ast } + ~add_ppx_context:true) + | Dparsetree -> + with_output output ~binary:false ~f:(fun oc -> + let ppf = Caml.Format.formatter_of_out_channel oc in + let ast = add_cookies ast in + (match ast with | Intf ast -> Sexp.pp_hum ppf (Ast_traverse.sexp_of#signature ast) | Impl ast -> Sexp.pp_hum ppf (Ast_traverse.sexp_of#structure ast)); - Caml.Format.pp_print_newline ppf ()) - | Reconcile mode -> - Reconcile.reconcile !replacements ~contents:(Lazy.force input_contents) ~output - ~input_filename:fn ~input_name ~target:(Output mode) ?styler:!styler - ~kind); - - if mismatches_found && - (match !diff_command with - | Some "-" -> false - | _ -> true) then begin - Ppxlib_print_diff.print () ~file1:fn ~file2:corrected ~use_color:!use_color - ?diff_command:!diff_command; - Caml.exit 1 - end -;; + Caml.Format.pp_print_newline ppf ()) + | Reconcile mode -> + Reconcile.reconcile !replacements + ~contents:(Lazy.force input_contents) + ~output ~input_filename:fn ~input_name ~target:(Output mode) + ?styler:!styler ~kind); + + if + mismatches_found && match !diff_command with Some "-" -> false | _ -> true + then ( + Ppxlib_print_diff.print () ~file1:fn ~file2:corrected ~use_color:!use_color + ?diff_command:!diff_command; + Caml.exit 1) let output_mode = ref Pretty_print + let output = ref None + let kind = ref None + let input = ref None + let embed_errors = ref false + let set_input fn = match !input with | None -> input := Some fn @@ -989,53 +1057,54 @@ let set_kind k = match !kind with | Some k' when not (Kind.equal k k') -> - raise (Arg.Bad "must specify at most one of -impl or -intf") + raise (Arg.Bad "must specify at most one of -impl or -intf") | _ -> kind := Some k -;; let set_output_mode mode = - match !output_mode, mode with + match (!output_mode, mode) with | Pretty_print, _ -> output_mode := mode | _, Pretty_print -> assert false - | Dump_ast , Dump_ast - | Dparsetree , Dparsetree -> () + | Dump_ast, Dump_ast | Dparsetree, Dparsetree -> () | Reconcile a, Reconcile b when Poly.equal a b -> () | x, y -> - let arg_of_output_mode = function - | Pretty_print -> assert false - | Dump_ast -> "-dump-ast" - | Dparsetree -> "-dparsetree" - | Reconcile Using_line_directives -> "-reconcile" - | Reconcile Delimiting_generated_blocks -> "-reconcile-with-comments" - | Null -> "-null" - in - raise (Arg.Bad (Printf.sprintf - "%s and %s are incompatible" - (arg_of_output_mode x) (arg_of_output_mode y))) -;; + let arg_of_output_mode = function + | Pretty_print -> assert false + | Dump_ast -> "-dump-ast" + | Dparsetree -> "-dparsetree" + | Reconcile Using_line_directives -> "-reconcile" + | Reconcile Delimiting_generated_blocks -> "-reconcile-with-comments" + | Null -> "-null" + in + raise + (Arg.Bad + (Printf.sprintf "%s and %s are incompatible" (arg_of_output_mode x) + (arg_of_output_mode y))) let print_transformations () = List.iter !Transform.all ~f:(fun (ct : Transform.t) -> - Printf.printf "%s\n" ct.name); -;; + Printf.printf "%s\n" ct.name) let parse_apply_list s = - let names = if String.equal s "" then [] else String.split_on_char s ~sep:',' in + let names = + if String.equal s "" then [] else String.split_on_char s ~sep:',' + in List.iter names ~f:(fun name -> - if not (List.exists !Transform.all ~f:(fun (ct : Transform.t) -> - Transform.has_name ct name)) then - raise (Caml.Arg.Bad (Printf.sprintf "code transformation '%s' does not exist" name))); + if + not + (List.exists !Transform.all ~f:(fun (ct : Transform.t) -> + Transform.has_name ct name)) + then + raise + (Caml.Arg.Bad + (Printf.sprintf "code transformation '%s' does not exist" name))); names -type mask = - { mutable apply : string list option - ; mutable dont_apply : string list option - } +type mask = { + mutable apply : string list option; + mutable dont_apply : string list option; +} -let mask = - { apply = None - ; dont_apply = None - } +let mask = { apply = None; dont_apply = None } let handle_apply s = if Option.is_some mask.apply then @@ -1051,7 +1120,7 @@ mask.dont_apply <- Some (parse_apply_list s) let interpret_mask () = - if Option.is_some mask.apply || Option.is_some mask.dont_apply then begin + if Option.is_some mask.apply || Option.is_some mask.dont_apply then let selected_transform_name ct = let is_candidate = match mask.apply with @@ -1062,255 +1131,278 @@ match mask.dont_apply with | None -> is_candidate | Some names -> - is_candidate - && not (List.exists names ~f:(Transform.has_name ct)) + is_candidate && not (List.exists names ~f:(Transform.has_name ct)) in - if is_selected then - Some ct.name - else - None + if is_selected then Some ct.name else None in - apply_list := Some (List.filter_map !Transform.all ~f:selected_transform_name) - end + apply_list := + Some (List.filter_map !Transform.all ~f:selected_transform_name) + +let set_cookie s = + match String.lsplit2 s ~on:'=' with + | None -> + raise (Arg.Bad "invalid cookie, must be of the form \"=\"") + | Some (name, value) -> + let lexbuf = Lexing.from_string value in + lexbuf.Lexing.lex_curr_p <- + { + Lexing.pos_fname = ""; + pos_lnum = 1; + pos_bol = 0; + pos_cnum = 0; + }; + let expr = Parse.expression lexbuf in + Cookies.given_through_cli := (name, expr) :: !Cookies.given_through_cli let shared_args = - [ "-loc-filename", Arg.String (fun s -> loc_fname := Some s), - " File name to use in locations" - ; "-reserve-namespace", Arg.String Name.Reserved_namespaces.reserve, - " Mark the given namespace as reserved" - ; "-no-check", Arg.Clear perform_checks, - " Disable checks (unsafe)" - ; "-check", Arg.Set perform_checks, - " Enable checks" - ; "-no-check-on-extensions", Arg.Clear perform_checks_on_extensions, - " Disable checks on extension point only" - ; "-check-on-extensions", Arg.Set perform_checks_on_extensions, - " Enable checks on extension point only" - ; "-no-locations-check", Arg.Clear perform_locations_check, - " Disable locations check only" - ; "-locations-check", Arg.Set perform_locations_check, - " Enable locations check only" - ; "-apply", Arg.String handle_apply, - " Apply these transformations in order (comma-separated list)" - ; "-dont-apply", Arg.String handle_dont_apply, - " Exclude these transformations" - ; "-no-merge", Arg.Set no_merge, - " Do not merge context free transformations (better for debugging rewriters)" + [ + ( "-loc-filename", + Arg.String (fun s -> loc_fname := Some s), + " File name to use in locations" ); + ( "-reserve-namespace", + Arg.String Name.Reserved_namespaces.reserve, + " Mark the given namespace as reserved" ); + ("-no-check", Arg.Clear perform_checks, " Disable checks (unsafe)"); + ("-check", Arg.Set perform_checks, " Enable checks"); + ( "-no-check-on-extensions", + Arg.Clear perform_checks_on_extensions, + " Disable checks on extension point only" ); + ( "-check-on-extensions", + Arg.Set perform_checks_on_extensions, + " Enable checks on extension point only" ); + ( "-no-locations-check", + Arg.Clear perform_locations_check, + " Disable locations check only" ); + ( "-locations-check", + Arg.Set perform_locations_check, + " Enable locations check only" ); + ( "-apply", + Arg.String handle_apply, + " Apply these transformations in order (comma-separated list)" ); + ( "-dont-apply", + Arg.String handle_dont_apply, + " Exclude these transformations" ); + ( "-no-merge", + Arg.Set no_merge, + " Do not merge context free transformations (better for debugging \ + rewriters)" ); + ("-cookie", Arg.String set_cookie, "NAME=EXPR Set the cookie NAME to EXPR"); + ("--cookie", Arg.String set_cookie, " Same as -cookie"); ] let () = List.iter shared_args ~f:(fun (key, spec, doc) -> add_arg key spec ~doc) -let set_cookie s = - match String.lsplit2 s ~on:'=' with - | None -> - raise (Arg.Bad "invalid cookie, must be of the form \"=\"") - | Some (name, value) -> - let lexbuf = Lexing.from_string value in - lexbuf.Lexing.lex_curr_p <- - { Lexing. - pos_fname = "" - ; pos_lnum = 1 - ; pos_bol = 0 - ; pos_cnum = 0 - }; - let expr = Parse.expression lexbuf in - Migrate_parsetree.Driver.set_global_cookie name - (module Ppxlib_ast.Selected_ast) expr - let as_pp () = set_output_mode Dump_ast; embed_errors := true let standalone_args = - [ "-as-ppx", Arg.Unit (fun () -> raise (Arg.Bad "-as-ppx must be the first argument")), - " Run as a -ppx rewriter (must be the first argument)" - ; "--as-ppx", Arg.Unit (fun () -> raise (Arg.Bad "--as-ppx must be the first argument")), - " Same as -as-ppx" - ; "-as-pp", Arg.Unit as_pp, - " Shorthand for: -dump-ast -embed-errors" - ; "--as-pp", Arg.Unit as_pp, - " Same as -as-pp" - ; "-o", Arg.String (fun s -> output := Some s), - " Output file (use '-' for stdout)" - ; "-", Arg.Unit (fun () -> set_input "-"), - " Read input from stdin" - ; "-dump-ast", Arg.Unit (fun () -> set_output_mode Dump_ast), - " Dump the marshaled ast to the output file instead of pretty-printing it" - ; "--dump-ast", Arg.Unit (fun () -> set_output_mode Dump_ast), - " Same as -dump-ast" - ; "-dparsetree", Arg.Unit (fun () -> set_output_mode Dparsetree), - " Print the parsetree (same as ocamlc -dparsetree)" - ; "-embed-errors", Arg.Set embed_errors, - " Embed errors in the output AST (default: true when -dump-ast, false otherwise)" - ; "-null", Arg.Unit (fun () -> set_output_mode Null), - " Produce no output, except for errors" - ; "-impl", Arg.Unit (fun () -> set_kind Impl), - " Treat the input as a .ml file" - ; "--impl", Arg.Unit (fun () -> set_kind Impl), - " Same as -impl" - ; "-intf", Arg.Unit (fun () -> set_kind Intf), - " Treat the input as a .mli file" - ; "--intf", Arg.Unit (fun () -> set_kind Intf), - " Same as -intf" - ; "-debug-attribute-drop", Arg.Set debug_attribute_drop, - " Debug attribute dropping" - ; "-print-transformations", Arg.Set request_print_transformations, - " Print linked-in code transformations, in the order they are applied" - ; "-print-passes", Arg.Set request_print_passes, - " Print the actual passes over the whole AST in the order they are applied" - ; "-ite-check", - Arg.Unit (fun () -> - Printf.eprintf "Warning: the -ite-check flag is deprecated \ - and has no effect.\n%!"; - Extra_warnings.care_about_ite_branch := true), - " (no effect -- kept for compatibility)" - ; "-pp", Arg.String (fun s -> preprocessor := Some s), - " Pipe sources through preprocessor (incompatible with -as-ppx)" - ; "-reconcile", Arg.Unit (fun () -> set_output_mode (Reconcile Using_line_directives)), - " (WIP) Pretty print the output using a mix of the input source \ - and the generated code" - ; "-reconcile-with-comments", - Arg.Unit (fun () -> set_output_mode (Reconcile Delimiting_generated_blocks)), - " (WIP) same as -reconcile but uses comments to enclose the generated code" - ; "-no-color", Arg.Clear use_color, - " Don't use colors when printing errors" - ; "-diff-cmd", Arg.String (fun s -> diff_command := Some s), - " Diff command when using code expectations (use - to disable diffing)" - ; "-pretty", Arg.Set pretty, - " Instruct code generators to improve the prettiness of the generated code" - ; "-styler", Arg.String (fun s -> styler := Some s), - " Code styler" - ; "-cookie", Arg.String set_cookie, - "NAME=EXPR Set the cookie NAME to EXPR" - ; "--cookie", Arg.String set_cookie, - " Same as -cookie" - ; "-output-metadata", Arg.String (fun s -> output_metadata_filename := Some s), - "FILE Where to store the output metadata" - ; "-corrected-suffix", Arg.Set_string corrected_suffix, - "SUFFIX Suffix to happend to corrected files" + [ + ( "-as-ppx", + Arg.Unit (fun () -> raise (Arg.Bad "-as-ppx must be the first argument")), + " Run as a -ppx rewriter (must be the first argument)" ); + ( "--as-ppx", + Arg.Unit (fun () -> raise (Arg.Bad "--as-ppx must be the first argument")), + " Same as -as-ppx" ); + ("-as-pp", Arg.Unit as_pp, " Shorthand for: -dump-ast -embed-errors"); + ("--as-pp", Arg.Unit as_pp, " Same as -as-pp"); + ( "-o", + Arg.String (fun s -> output := Some s), + " Output file (use '-' for stdout)" ); + ("-", Arg.Unit (fun () -> set_input "-"), " Read input from stdin"); + ( "-dump-ast", + Arg.Unit (fun () -> set_output_mode Dump_ast), + " Dump the marshaled ast to the output file instead of pretty-printing it" + ); + ( "--dump-ast", + Arg.Unit (fun () -> set_output_mode Dump_ast), + " Same as -dump-ast" ); + ( "-dparsetree", + Arg.Unit (fun () -> set_output_mode Dparsetree), + " Print the parsetree (same as ocamlc -dparsetree)" ); + ( "-embed-errors", + Arg.Set embed_errors, + " Embed errors in the output AST (default: true when -dump-ast, false \ + otherwise)" ); + ( "-null", + Arg.Unit (fun () -> set_output_mode Null), + " Produce no output, except for errors" ); + ( "-impl", + Arg.Unit (fun () -> set_kind Impl), + " Treat the input as a .ml file" ); + ("--impl", Arg.Unit (fun () -> set_kind Impl), " Same as -impl"); + ( "-intf", + Arg.Unit (fun () -> set_kind Intf), + " Treat the input as a .mli file" ); + ("--intf", Arg.Unit (fun () -> set_kind Intf), " Same as -intf"); + ( "-debug-attribute-drop", + Arg.Set debug_attribute_drop, + " Debug attribute dropping" ); + ( "-print-transformations", + Arg.Set request_print_transformations, + " Print linked-in code transformations, in the order they are applied" ); + ( "-print-passes", + Arg.Set request_print_passes, + " Print the actual passes over the whole AST in the order they are \ + applied" ); + ( "-ite-check", + Arg.Unit + (fun () -> + Printf.eprintf + "Warning: the -ite-check flag is deprecated and has no effect.\n%!"; + Extra_warnings.care_about_ite_branch := true), + " (no effect -- kept for compatibility)" ); + ( "-pp", + Arg.String (fun s -> preprocessor := Some s), + " Pipe sources through preprocessor (incompatible \ + with -as-ppx)" ); + ( "-reconcile", + Arg.Unit (fun () -> set_output_mode (Reconcile Using_line_directives)), + " (WIP) Pretty print the output using a mix of the input source and the \ + generated code" ); + ( "-reconcile-with-comments", + Arg.Unit + (fun () -> set_output_mode (Reconcile Delimiting_generated_blocks)), + " (WIP) same as -reconcile but uses comments to enclose the generated \ + code" ); + ("-no-color", Arg.Clear use_color, " Don't use colors when printing errors"); + ( "-diff-cmd", + Arg.String (fun s -> diff_command := Some s), + " Diff command when using code expectations (use - to disable diffing)" ); + ( "-pretty", + Arg.Set pretty, + " Instruct code generators to improve the prettiness of the generated \ + code" ); + ("-styler", Arg.String (fun s -> styler := Some s), " Code styler"); + ( "-output-metadata", + Arg.String (fun s -> output_metadata_filename := Some s), + "FILE Where to store the output metadata" ); + ( "-corrected-suffix", + Arg.Set_string corrected_suffix, + "SUFFIX Suffix to append to corrected files" ); ] -;; -let get_args ?(standalone_args=standalone_args) () = - let args = standalone_args @ List.rev !args in - let my_arg_names = - List.rev_map args ~f:(fun (name, _, _) -> name) - |> String.Set.of_list - in - let omp_args = - (* Filter out arguments that we override *) - List.filter (Migrate_parsetree.Driver.registered_args ()) - ~f:(fun (name, _, _) -> - not (String.Set.mem name my_arg_names)) - in - args @ omp_args -;; +let get_args ?(standalone_args = standalone_args) () = + standalone_args @ List.rev !args let standalone_main () = - let usage = - Printf.sprintf "%s [extra_args] []" exe_name - in + let usage = Printf.sprintf "%s [extra_args] []" exe_name in let args = get_args () in - Migrate_parsetree.Driver.reset_args (); Arg.parse (Arg.align args) set_input usage; interpret_mask (); - if !request_print_transformations then begin + if !request_print_transformations then ( print_transformations (); - Caml.exit 0; - end; - if !request_print_passes then begin + Caml.exit 0); + if !request_print_passes then ( print_passes (); - Caml.exit 0; - end; + Caml.exit 0); match !input with - | None -> - Printf.eprintf "%s: no input file given\n%!" exe_name; - Caml.exit 2 + | None -> + Printf.eprintf "%s: no input file given\n%!" exe_name; + Caml.exit 2 | Some fn -> - let kind = - match !kind with - | Some k -> k - | None -> - match Kind.of_filename fn with + let kind = + match !kind with | Some k -> k - | None -> - Printf.eprintf "%s: don't know what to do with '%s', use -impl or -intf.\n" - exe_name fn; - Caml.exit 2 - in - let input_name, relocate = - match !loc_fname with - | None -> fn, false - | Some fn -> fn, true - in - process_file kind fn ~input_name ~relocate ~output_mode:!output_mode ~output:!output - ~embed_errors:!embed_errors -;; + | None -> ( + match Kind.of_filename fn with + | Some k -> k + | None -> + Printf.eprintf + "%s: don't know what to do with '%s', use -impl or -intf.\n" + exe_name fn; + Caml.exit 2) + in + let input_name, relocate = + match !loc_fname with None -> (fn, false) | Some fn -> (fn, true) + in + process_file kind fn ~input_name ~relocate ~output_mode:!output_mode + ~output:!output ~embed_errors:!embed_errors + +let rewrite_binary_ast_file input_fn output_fn = + let input_name, input_version, ast = load_input_run_as_ppx input_fn in + let ast = + try + let ast = extract_cookies ast in + let tool_name = Astlib.Ast_metadata.tool_name () in + let hook = Context_free.Generated_code_hook.nop in + let expect_mismatch_handler = Context_free.Expect_mismatch_handler.nop in + process_ast ast ~input_name ~tool_name ~hook ~expect_mismatch_handler + with exn -> exn_to_extension exn ~kind:(Intf_or_impl.kind ast) + in + with_output (Some output_fn) ~binary:true ~f:(fun oc -> + Ast_io.write oc { input_name; input_version; ast } ~add_ppx_context:true) + +let parse_input passed_in_args ~valid_args ~incorrect_input_msg = + try + Arg.parse_argv passed_in_args (Arg.align valid_args) + (fun _ -> raise (Arg.Bad "anonymous arguments not accepted")) + incorrect_input_msg + with + | Arg.Bad msg -> + Printf.eprintf "%s" msg; + Caml.exit 2 + | Arg.Help msg -> + Printf.eprintf "%s" msg; + Caml.exit 0 + +let run_as_ppx_rewriter_main ~standalone_args ~usage input = + let valid_args = get_args ~standalone_args () in + match List.rev @@ Array.to_list @@ input with + | output_fn :: input_fn :: flags_and_prog_name + when List.length flags_and_prog_name > 0 -> + let prog_name_and_flags = List.rev flags_and_prog_name |> Array.of_list in + parse_input prog_name_and_flags ~valid_args ~incorrect_input_msg:usage; + interpret_mask (); + rewrite_binary_ast_file input_fn output_fn; + Caml.exit 0 + | [ help; _ ] when String.equal help "-help" || String.equal help "--help" -> + parse_input input ~valid_args ~incorrect_input_msg:usage; + assert false + | _ -> + Printf.eprintf "Usage: %s\n%!" usage; + Caml.exit 2 let standalone_run_as_ppx_rewriter () = let n = Array.length Caml.Sys.argv in - let usage = Printf.sprintf "%s -as-ppx [extra_args] " exe_name in - if n < 4 then begin - Printf.eprintf "Usage: %s\n%!" usage; - Caml.exit 2 - end; - let argv = Array.make (n - 3) "" in + let usage = + Printf.sprintf "%s -as-ppx [extra_args] " exe_name + in + let argv = Array.make (n - 1) "" in argv.(0) <- Caml.Sys.argv.(0); - for i = 1 to (n - 4) do + for i = 1 to n - 2 do argv.(i) <- Caml.Sys.argv.(i + 1) done; let standalone_args = List.map standalone_args ~f:(fun (arg, spec, _doc) -> - (arg, spec, " Unused with -as-ppx")) + (arg, spec, " Unused with -as-ppx")) in - let args = get_args ~standalone_args () in - Migrate_parsetree.Driver.reset_args (); - match - Arg.parse_argv argv (Arg.align args) - (fun _ -> raise (Arg.Bad "anonymous arguments not accepted")) - usage - with - | exception Arg.Bad msg -> Printf.eprintf "%s" msg; Caml.exit 2 - | exception Arg.Help msg -> Printf.eprintf "%s" msg; Caml.exit 0 - | () -> - interpret_mask (); - Ocaml_common.Ast_mapper.apply - ~source:Caml.Sys.argv.(n - 2) ~target:Caml.Sys.argv.(n - 1) mapper -;; + run_as_ppx_rewriter_main ~standalone_args ~usage argv let standalone () = - Compiler_specifics.read_clflags_from_env (); + Astlib.init_error_reporting_style_using_env_vars (); try - if Array.length Caml.Sys.argv >= 2 && - match Caml.Sys.argv.(1) with - | "-as-ppx" | "--as-ppx" -> true - | _ -> false - then - standalone_run_as_ppx_rewriter () - else - standalone_main (); + if + Array.length Caml.Sys.argv >= 2 + && + match Caml.Sys.argv.(1) with "-as-ppx" | "--as-ppx" -> true | _ -> false + then standalone_run_as_ppx_rewriter () + else standalone_main (); Caml.exit 0 with exn -> Location.report_exception Caml.Format.err_formatter exn; Caml.exit 1 -;; -let pretty () = !pretty +let run_as_ppx_rewriter () = + let usage = Printf.sprintf "%s [extra_args] " exe_name in + let input = Caml.Sys.argv in + try run_as_ppx_rewriter_main ~standalone_args:[] ~usage input + with exn -> + Location.report_exception Caml.Format.err_formatter exn; + Caml.exit 1 -let () = - Migrate_parsetree.Driver.register - ~name:"ppxlib_driver" - (* This doesn't take arguments registered by rewriters. It's not worth supporting - them, since [--cookie] is a much better replacement for passing parameters to - individual rewriters. *) - ~args:shared_args - (module Ppxlib_ast.Selected_ast) - (fun config cookies -> - let module A = Ppxlib_ast.Selected_ast.Ast.Ast_mapper in - let structure _ st = real_map_structure config cookies st in - let signature _ sg = real_map_signature config cookies sg in - { A.default_mapper with structure; signature }) +let pretty () = !pretty let enable_checks () = (* We do not enable the locations check here, we currently require that one @@ -1318,13 +1410,8 @@ perform_checks := true; perform_checks_on_extensions := true -let enable_location_check () = - perform_locations_check := true +let enable_location_check () = perform_locations_check := true -let disable_location_check () = - perform_locations_check := false +let disable_location_check () = perform_locations_check := false -let map_structure st = - map_structure st - |> Migrate_parsetree.Driver.migrate_some_structure - (module Ppxlib_ast.Selected_ast) +let map_structure st = map_structure st diff -Nru ppxlib-0.15.0/src/driver.mli ppxlib-0.24.0/src/driver.mli --- ppxlib-0.15.0/src/driver.mli 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/driver.mli 2021-12-08 21:53:37.000000000 +0000 @@ -1,7 +1,7 @@ open Import -(** Add one argument to the command line *) val add_arg : Caml.Arg.key -> Caml.Arg.spec -> doc:string -> unit +(** Add one argument to the command line *) (** Error reported by linters *) module Lint_error : sig @@ -13,172 +13,250 @@ module Cookies : sig type t - (** [get cookies name pattern] look for a cookie named [name] and parse it using - [pattern]. *) val get : t -> string -> (expression, 'a -> 'a, 'b) Ast_pattern.t -> 'b option + (** [get cookies name pattern] look for a cookie named [name] and parse it + using [pattern]. *) - (** [set cookies name expr] set cookie [name] to [expr]. *) val set : t -> string -> expression -> unit + (** [set cookies name expr] set cookie [name] to [expr]. *) - (** Register a callback that is called before a rewriting. The handler is expected to - lookup some cookies and set some global variables. - - This API is a temporary hack to allow to migrate from [add_arg] to the use of - cookie, until ppxlib has been upgraded to pass cookies through. *) val add_handler : (t -> unit) -> unit + (** Register a callback that is called before a rewriting. The handler is + expected to lookup some cookies and set some global variables. + + This API is a temporary hack to allow to migrate from [add_arg] to the use + of cookie, until ppxlib has been upgraded to pass cookies through. *) + val add_simple_handler : + string -> + (expression, 'a -> 'a, 'b) Ast_pattern.t -> + f:('b option -> unit) -> + unit (** Shorthand for: [add_handler (fun t -> f (get t name pattern))] *) - val add_simple_handler - : string - -> (expression, 'a -> 'a, 'b) Ast_pattern.t - -> f:('b option -> unit) - -> unit - (** Register a callback that is called after a rewriting. The handler is expected to set - some cookies from some global variables. *) val add_post_handler : (t -> unit) -> unit + (** Register a callback that is called after a rewriting. The handler is + expected to set some cookies from some global variables. *) end +module Instrument : sig + type t + + type pos = Before | After + + val make : (Parsetree.structure -> Parsetree.structure) -> position:pos -> t + (** [make transformation ~position] creates an instrumentation that can be + passed to [Driver.register_transformation] to instrument an implementation + file. [transformation] is the transformation that will be applied to the + AST; [position] specifies if it should be applied before or after + rewriters defined through [rules], [impl] or [intf] are applied.*) + + module V2 : sig + val make : + (Expansion_context.Base.t -> Parsetree.structure -> Parsetree.structure) -> + position:pos -> + t + (** Same as [Instrument.make], but the transformation that will be applied + to the AST has access to an expansion context. To be used together with + [Driver.V2].*) + end +end + +val register_transformation : + ?extensions:Extension.t list (* deprecated, use ~rules instead *) -> + ?rules:Context_free.Rule.t list -> + ?enclose_impl:(Location.t option -> structure * structure) -> + ?enclose_intf:(Location.t option -> signature * signature) -> + ?impl:(structure -> structure) -> + ?intf:(signature -> signature) -> + ?lint_impl:(structure -> Lint_error.t list) -> + ?lint_intf:(signature -> Lint_error.t list) -> + ?preprocess_impl:(structure -> structure) -> + ?preprocess_intf:(signature -> signature) -> + ?instrument:Instrument.t -> + ?aliases:string list -> + string -> + unit (** [register_transformation name] registers a code transformation. [name] is a logical name for the transformation (such as [sexp_conv] or [bin_prot]). It is mostly used for debugging purposes. - [rules] is a list of context independent rewriting rules, such as extension point - expanders. This is what most code transformation should use. Rules from all registered - transformations are all applied at the same time, before any other - transformations. Moreover they are applied in a top-down manner, giving more control - to extensions on how they interpret their payload. + [rules] is a list of context independent rewriting rules, such as extension + point expanders. This is what most code transformation should use. Rules + from all registered transformations are all applied at the same time, before + any other transformations. Moreover they are applied in a top-down manner, + giving more control to extensions on how they interpret their payload. For instance: - - some extensions capture a pretty-print of the payload in their expansion and using - top-down ensures that the payload is as close as possible to the original code - - some extensions process other extension in a special way inside their payload. For - instance [%here] (from ppx_here) will normally expand to a record of type - [Lexing.position]. However when used inside [%sexp] (from ppx_sexp_value) it will - expand to the human-readable sexp representation of a source code position. + - some extensions capture a pretty-print of the payload in their expansion + and using top-down ensures that the payload is as close as possible to the + original code + - some extensions process other extension in a special way inside their + payload. For instance [%here] (from ppx_here) will normally expand to a + record of type [Lexing.position]. However when used inside [%sexp] (from + ppx_sexp_value) it will expand to the human-readable sexp representation + of a source code position. - [extensions] is a special cases of [rules] and is deprecated. It is only kept for - backward compatibility. + [extensions] is a special cases of [rules] and is deprecated. It is only + kept for backward compatibility. [enclose_impl] and [enclose_intf] produces a header and footer for - implementation/interface files. They are a special case of [impl] and [intf]. The - header is placed after any initial module-level attributes; the footer is placed after - everything else. Both functions receive a location that denotes all of the items - between header and footer, or [None] if the that list of items is empty. - - [impl] is an optional function that is applied on implementation files and [intf] is - an optional function that is applied on interface files. These two functions are - applied on the AST of the whole file. They should only be used when the other - mechanism are not enough. For instance if the transformation expands extension points - that depend on the context. - - If no rewriter is using [impl] and [intf], then the whole transformation is completely - independent of the order in which the various rewriter are specified. Moreover the - resulting driver will be faster as it will do only one pass (excluding safety checks) - on the whole AST. - - [lint_impl] and [lint_intf] are applied to the unprocessed source. Errors they return - will be reported to the user as preprocessor warnings. + implementation/interface files. They are a special case of [impl] and + [intf]. The header is placed after any initial module-level attributes; the + footer is placed after everything else. Both functions receive a location + that denotes all of the items between header and footer, or [None] if the + that list of items is empty. + + [impl] is an optional function that is applied on implementation files and + [intf] is an optional function that is applied on interface files. These two + functions are applied on the AST of the whole file. They should only be used + when the other mechanism are not enough. For instance if the transformation + expands extension points that depend on the context. + + If no rewriter is using [impl] and [intf], then the whole transformation is + completely independent of the order in which the various rewriter are + specified. Moreover the resulting driver will be faster as it will do only + one pass (excluding safety checks) on the whole AST. + + [lint_impl] and [lint_intf] are applied to the unprocessed source. Errors + they return will be reported to the user as preprocessor warnings. + + [instrument] can be used to instrument implementation files. Its + transformation is applied to the AST of the whole file. The difference to + [impl] is that you can specify if it should be applied before or after all + rewriters defined through [rules], [impl] or [intf] are applied. Rewritings are applied in the following order: + - linters ([lint_impl], [lint_intf]) - preprocessing ([preprocess_impl], [preprocess_intf]) + - "before" instrumentations ([instrument], where instrument = + [Instrument.make ~position:Before (...)]) - context-independent rules ([rules], [extensions]) - - whole-file transformations ([impl], [intf], [enclose_impl], [enclose_intf]) -*) -val register_transformation - : ?extensions : Extension.t list (* deprecated, use ~rules instead *) - -> ?rules : Context_free.Rule.t list - -> ?enclose_impl : (Location.t option -> structure * structure) - -> ?enclose_intf : (Location.t option -> signature * signature) - -> ?impl : (structure -> structure) - -> ?intf : (signature -> signature) - -> ?lint_impl : (structure -> Lint_error.t list) - -> ?lint_intf : (signature -> Lint_error.t list) - -> ?preprocess_impl : (structure -> structure) - -> ?preprocess_intf : (signature -> signature) - -> ?aliases : string list - -> string - -> unit - -(** Same as [register_transformation] except that it uses the same AST as the current - ocaml compiler. - - This is not the intended way of using driver. This is only for ppx rewriters that - are not written using ppxlib but want to export a driver compatible - library. -*) -val register_transformation_using_ocaml_current_ast - : ?impl : (Migrate_parsetree.OCaml_current.Ast.Parsetree.structure -> - Migrate_parsetree.OCaml_current.Ast.Parsetree.structure) - -> ?intf : (Migrate_parsetree.OCaml_current.Ast.Parsetree.signature -> - Migrate_parsetree.OCaml_current.Ast.Parsetree.signature) - -> ?aliases : string list - -> string - -> unit - + - non-instrumentation whole-file transformations ([impl], [intf], + [enclose_impl], [enclose_intf]) + - "after" instrumentations ([instrument], where instrument = + [Instrument.make ~position:After (...)]) *) + +val register_transformation_using_ocaml_current_ast : + ?impl: + (Compiler_version.Ast.Parsetree.structure -> + Compiler_version.Ast.Parsetree.structure) -> + ?intf: + (Compiler_version.Ast.Parsetree.signature -> + Compiler_version.Ast.Parsetree.signature) -> + ?aliases:string list -> + string -> + unit +(** Same as [register_transformation] except that it uses the same AST as the + current ocaml compiler. + + This is not the intended way of using driver. This is only for ppx rewriters + that are not written using ppxlib but want to export a driver compatible + library. *) + +val register_code_transformation : + name:string -> + ?aliases:string list -> + impl:(structure -> structure) -> + intf:(signature -> signature) -> + unit + [@@deprecated "[since 2015-11] use register_transformation instead"] (** Same as: - {[ - register_transformation - ~name - ~impl - ~intf - () - ]} -*) -val register_code_transformation - : name:string - -> ?aliases:string list - -> impl:(structure -> structure) - -> intf:(signature -> signature) - -> unit - [@@deprecated "[since 2015-11] use register_transformation instead"] + {[ register_transformation ~name ~impl ~intf () ]} *) -(** Rewriters might call this function to suggest a correction to the code source. When - they do this, the driver will generate a [file.ml.ppx-corrected] file with the - suggested replacement. The build system will then show the diff to the user who is - free to accept the correction or not. *) val register_correction : loc:Location.t -> repl:string -> unit +(** Rewriters might call this function to suggest a correction to the code + source. When they do this, the driver will generate a + [file.ml.ppx-corrected] file with the suggested replacement. The build + system will then show the diff to the user who is free to accept the + correction or not. *) -(** Hook called before processing a file *) val register_process_file_hook : (unit -> unit) -> unit +(** Hook called before processing a file *) + +module V2 : sig + val register_transformation : + ?extensions:Extension.t list (* deprecated, use ~rules instead *) -> + ?rules:Context_free.Rule.t list -> + ?enclose_impl: + (Expansion_context.Base.t -> Location.t option -> structure * structure) -> + ?enclose_intf: + (Expansion_context.Base.t -> Location.t option -> signature * signature) -> + ?impl:(Expansion_context.Base.t -> structure -> structure) -> + ?intf:(Expansion_context.Base.t -> signature -> signature) -> + ?lint_impl:(Expansion_context.Base.t -> structure -> Lint_error.t list) -> + ?lint_intf:(Expansion_context.Base.t -> signature -> Lint_error.t list) -> + ?preprocess_impl:(Expansion_context.Base.t -> structure -> structure) -> + ?preprocess_intf:(Expansion_context.Base.t -> signature -> signature) -> + ?instrument:Instrument.t -> + ?aliases:string list -> + string -> + unit + (** Same as [Driver.register_transformation], but the callbacks have access to + an expansion context. Their signatures coincide with the signatures of the + respective methods in [Ast_traverse.map_with_expansion_context]. *) + + val register_transformation_using_ocaml_current_ast : + ?impl: + (Expansion_context.Base.t -> + Compiler_version.Ast.Parsetree.structure -> + Compiler_version.Ast.Parsetree.structure) -> + ?intf: + (Expansion_context.Base.t -> + Compiler_version.Ast.Parsetree.signature -> + Compiler_version.Ast.Parsetree.signature) -> + ?aliases:string list -> + string -> + unit + (** Same as [Driver.register_transformation_using_ocaml_current_ast], but the + callbacks [?impl] and [?intf] have access to an expansion context. *) +end (** Create a new file property. - A file property represent a piece of information about a file that can be set during - preprocessing. If the [-output-metadata FILE] command line option was passed to the - driver, then it will output this information to the given file. - - This mechanism is used to pass information gathered while preprocessing the file to - the build system. For instance, this is used by ppx_inline_test to tell whether a file - contains tests or not. - - In the future we could also use this to directly compute the dependencies and pass - them here, to avoid calling ocamldep separately. -*) -module Create_file_property(Name : sig val name : string end)(T : Sexpable.S) : sig + A file property represent a piece of information about a file that can be + set during preprocessing. If the [-output-metadata FILE] command line option + was passed to the driver, then it will output this information to the given + file. + + This mechanism is used to pass information gathered while preprocessing the + file to the build system. For instance, this is used by ppx_inline_test to + tell whether a file contains tests or not. + + In the future we could also use this to directly compute the dependencies + and pass them here, to avoid calling ocamldep separately. *) +module Create_file_property (Name : sig + val name : string +end) +(T : Sexpable.S) : sig val set : T.t -> unit end +val standalone : unit -> unit (** Suitable for -pp and also usable as a standalone command line tool. - If the first command line argument is [-as-ppx] then it will run as a ppx rewriter. *) -val standalone : unit -> unit + If the first command line argument is [-as-ppx] then it will run as a ppx + rewriter. *) -(** Suitable for -ppx. Used only for the public release. *) val run_as_ppx_rewriter : unit -> unit +(** Suitable for -ppx. Used only for the public release. *) -(** If [true], code transformations should avoid generating code that is not strictly - necessary, such as extra type annotations. *) val pretty : unit -> bool +(** If [true], code transformations should avoid generating code that is not + strictly necessary, such as extra type annotations. *) (**/**) + val map_structure : structure -> structure +val map_signature : signature -> signature + val enable_checks : unit -> unit + val enable_location_check : unit -> unit -val disable_location_check : unit -> unit +val disable_location_check : unit -> unit diff -Nru ppxlib-0.15.0/src/dune ppxlib-0.24.0/src/dune --- ppxlib-0.15.0/src/dune 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/dune 2021-12-08 21:53:37.000000000 +0000 @@ -2,21 +2,23 @@ (name ppxlib) (public_name ppxlib) (libraries - ocaml-compiler-libs.common - compiler-libs.common + (re_export ppxlib_ast) ocaml-compiler-libs.shadow - ocaml-migrate-parsetree - ppxlib_ast + astlib ppxlib_print_diff ppx_derivers ppxlib_traverse_builtins - stdppx) - (flags (:standard -open Ocaml_shadow -safe-string)) + stdppx + stdlib-shims + sexplib0) + (flags + (:standard -safe-string)) (ppx.driver - (main Ppxlib.Driver.standalone) - (replaces ocaml-migrate-parsetree) - (flags (-corrected-suffix %{corrected-suffix} -diff-cmd - -dump-ast)) - (lint_flags (-corrected-suffix %{corrected-suffix} -diff-cmd - -null )))) + (main Ppxlib.Driver.standalone) + (flags + (-corrected-suffix %{corrected-suffix} -diff-cmd - -dump-ast)) + (lint_flags + (-corrected-suffix %{corrected-suffix} -diff-cmd - -null)))) (cinaps (files *.ml *.mli) @@ -24,17 +26,14 @@ (rule (targets ast_pattern_generated.ml) - (deps gen/gen_ast_pattern.exe) - (action (run ./gen/gen_ast_pattern.exe %{lib:ppxlib.ast:ast.ml}))) + (deps gen/gen_ast_pattern.exe) + (action + (run ./gen/gen_ast_pattern.exe %{lib:ppxlib.ast:ast.ml}))) (rule (targets ast_builder_generated.ml) (deps gen/gen_ast_builder.exe) - (action (run ./gen/gen_ast_builder.exe %{lib:ppxlib.ast:ast.ml}))) + (action + (run ./gen/gen_ast_builder.exe %{lib:ppxlib.ast:ast.ml}))) -;; This is to make the code compatible with different versions of -;; OCaml -(rule - (targets compiler_specifics.ml) - (deps gen-compiler_specifics) - (action (run %{ocaml} %{deps} %{ocaml_version} %{targets}))) +(ocamllex skip_hash_bang) diff -Nru ppxlib-0.15.0/src/expansion_context.ml ppxlib-0.24.0/src/expansion_context.ml --- ppxlib-0.15.0/src/expansion_context.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/expansion_context.ml 2021-12-08 21:53:37.000000000 +0000 @@ -1,49 +1,60 @@ module Base = struct - type t = - { tool_name : string - ; code_path : Code_path.t - } + type t = { tool_name : string; code_path : Code_path.t; input_name : string } - let top_level ~tool_name ~file_path = + let top_level ~tool_name ~file_path ~input_name = let code_path = Code_path.top_level ~file_path in - {tool_name; code_path} + { tool_name; code_path; input_name } - let enter_expr t = {t with code_path = Code_path.enter_expr t.code_path} - let enter_module ~loc name t = {t with code_path = Code_path.enter_module ~loc name t.code_path} - let enter_value ~loc name t = {t with code_path = Code_path.enter_value ~loc name t.code_path} + let code_path t = t.code_path + + let input_name t = t.input_name + + let tool_name t = t.tool_name + + let enter_expr t = { t with code_path = Code_path.enter_expr t.code_path } + + let enter_module ~loc name t = + { t with code_path = Code_path.enter_module ~loc name t.code_path } + + let enter_value ~loc name t = + { t with code_path = Code_path.enter_value ~loc name t.code_path } end module Extension = struct - type t = - { extension_point_loc : Location.t - ; base : Base.t - } + type t = { extension_point_loc : Location.t; base : Base.t } - let make ~extension_point_loc ~base () = {extension_point_loc; base} + let make ~extension_point_loc ~base () = { extension_point_loc; base } let extension_point_loc t = t.extension_point_loc + let code_path t = t.base.code_path + + let input_name t = t.base.input_name + let tool_name t = t.base.tool_name - let with_loc_and_path f = - fun ~ctxt -> - f ~loc:ctxt.extension_point_loc ~path:(Code_path.to_string_path ctxt.base.code_path) + let with_loc_and_path f ~ctxt = + f ~loc:ctxt.extension_point_loc + ~path:(Code_path.to_string_path ctxt.base.code_path) end module Deriver = struct - type t = - { derived_item_loc : Location.t - ; inline : bool - ; base : Base.t - } + type t = { derived_item_loc : Location.t; inline : bool; base : Base.t } - let make ~derived_item_loc ~inline ~base () = {derived_item_loc; base; inline} + let make ~derived_item_loc ~inline ~base () = + { derived_item_loc; base; inline } let derived_item_loc t = t.derived_item_loc + let code_path t = t.base.code_path + + let input_name t = t.base.input_name + let tool_name t = t.base.tool_name + let inline t = t.inline - let with_loc_and_path f = - fun ~ctxt -> f ~loc:ctxt.derived_item_loc ~path:(Code_path.to_string_path ctxt.base.code_path) + let with_loc_and_path f ~ctxt = + f ~loc:ctxt.derived_item_loc + ~path:(Code_path.to_string_path ctxt.base.code_path) end diff -Nru ppxlib-0.15.0/src/expansion_context.mli ppxlib-0.24.0/src/expansion_context.mli --- ppxlib-0.15.0/src/expansion_context.mli 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/expansion_context.mli 2021-12-08 21:53:37.000000000 +0000 @@ -1,71 +1,133 @@ module Base : sig - (** Type for the location independent parts of the expansion context *) type t + (** Type for the location independent parts of the expansion context *) + + val code_path : t -> Code_path.t + (** Return the code path for the given context In Driver, Deriving and + Extension, the context is initialized so that the [file_path] component of + the [code_path] is determined from the first location found in the input + AST. That means that: + + - It's the empty string in empty structures or signatures + - It can be altered by line directives *) + + val input_name : t -> string + (** Return the input name for the given context. In Driver, Deriving and + Extension, the context argument is initialized so that the [input_name] + matches the input filename passed to the driver on the command line. That + means that: + + - It has a value even for empty files + - It is not affected by line directives + - It is ["_none_"] when using [Driver.map_structure] or + [Driver.map_signature] *) + + val tool_name : t -> string + (** Can be used within a ppx preprocessor to know which tool is calling it + ["ocamlc"], ["ocamlopt"], ["ocamldep"], ["ocaml"], ... . *) + + (**/**) - (**/*) (** Undocumented section *) + val top_level : tool_name:string -> file_path:string -> input_name:string -> t (** Build a new base context at the top level of the given file with the given - calling tool name. - *) - val top_level : - tool_name:string -> - file_path:string -> - t + calling tool name. *) - (** Proxy functions to update the wrapped code path. See code_path.mli for details. *) val enter_expr : t -> t + (** Proxy functions to update the wrapped code path. See code_path.mli for + details. *) + val enter_module : loc:Location.t -> string -> t -> t + val enter_value : loc:Location.t -> string -> t -> t end module Extension : sig - (** Type of expansion contexts for extensions *) type t + (** Type of expansion contexts for extensions *) - (** Return the location of the extension point being expanded *) val extension_point_loc : t -> Location.t + (** Return the location of the extension point being expanded *) - (** Return the code path for the given context *) val code_path : t -> Code_path.t + (** Return the code path for the given context In Driver, Deriving and + Extension, the context is initialized so that the [file_path] component of + the [code_path] is determined from the first location found in the input + AST. That means that: + + - It's the empty string in empty structures or signatures + - It can be altered by line directives *) + + val input_name : t -> string + (** Return the input name for the given context. In Driver, Deriving and + Extension, the context argument is initialized so that the [input_name] + matches the input filename passed to the driver on the command line. That + means that: + + - It has a value even for empty files + - It is not affected by line directives + - It is ["_none_"] when using [Driver.map_structure] or + [Driver.map_signature] *) - (** Can be used within a ppx preprocessor to know which tool is - calling it ["ocamlc"], ["ocamlopt"], ["ocamldep"], ["ocaml"], ... . *) val tool_name : t -> string + (** Can be used within a ppx preprocessor to know which tool is calling it + ["ocamlc"], ["ocamlopt"], ["ocamldep"], ["ocaml"], ... . *) + val with_loc_and_path : (loc:Location.t -> path:string -> 'a) -> ctxt:t -> 'a (** Wrap a [fun ~loc ~path] into a [fun ~ctxt] *) - val with_loc_and_path : (loc:Location.t -> path:string -> 'a) -> (ctxt:t -> 'a) (**/**) + (** Undocumented section *) - (** Build a new expansion context with the given extension point location and base context *) val make : extension_point_loc:Location.t -> base:Base.t -> unit -> t + (** Build a new expansion context with the given extension point location and + base context *) end module Deriver : sig - (** Type of expansion contexts for derivers *) type t + (** Type of expansion contexts for derivers *) - (** Return the location of the item to which the deriver is being applied *) val derived_item_loc : t -> Location.t + (** Return the location of the item to which the deriver is being applied *) - (** Return the code path for the given context *) val code_path : t -> Code_path.t + (** Return the code path for the given context In Driver, Deriving and + Extension, the context is initialized so that the [file_path] component of + the [code_path] is determined from the first location found in the input + AST. That means that: + + - It's the empty string in empty structures or signatures + - It can be altered by line directives *) + + val input_name : t -> string + (** Return the input name for the given context. In Driver, Deriving and + Extension, the context argument is initialized so that the [input_name] + matches the input filename passed to the driver on the command line. That + means that: + + - It has a value even for empty files + - It is not affected by line directives + - It is ["_none_"] when using [Driver.map_structure] or + [Driver.map_signature] *) - (** Can be used within a ppx preprocessor to know which tool is - calling it ["ocamlc"], ["ocamlopt"], ["ocamldep"], ["ocaml"], ... . *) val tool_name : t -> string + (** Can be used within a ppx preprocessor to know which tool is calling it + ["ocamlc"], ["ocamlopt"], ["ocamldep"], ["ocaml"], ... . *) + val with_loc_and_path : (loc:Location.t -> path:string -> 'a) -> ctxt:t -> 'a (** Wrap a [fun ~loc ~path] into a [fun ~ctxt] *) - val with_loc_and_path : (loc:Location.t -> path:string -> 'a) -> (ctxt:t -> 'a) - (** Whether the derived code is going to be inlined in the source *) val inline : t -> bool + (** Whether the derived code is going to be inlined in the source *) (**/**) + (** Undocumented section *) + val make : + derived_item_loc:Location.t -> inline:bool -> base:Base.t -> unit -> t (** Build a new expansion context with the given item location and code path *) - val make : derived_item_loc:Location.t -> inline:bool -> base:Base.t -> unit -> t end diff -Nru ppxlib-0.15.0/src/extension.ml ppxlib-0.24.0/src/extension.ml --- ppxlib-0.15.0/src/extension.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/extension.ml 2021-12-08 21:53:37.000000000 +0000 @@ -5,118 +5,182 @@ module Context = struct type 'a t = - | Class_expr : class_expr t - | Class_field : class_field t - | Class_type : class_type t + | Class_expr : class_expr t + | Class_field : class_field t + | Class_type : class_type t | Class_type_field : class_type_field t - | Core_type : core_type t - | Expression : expression t - | Module_expr : module_expr t - | Module_type : module_type t - | Pattern : pattern t - | Signature_item : signature_item t - | Structure_item : structure_item t + | Core_type : core_type t + | Expression : expression t + | Module_expr : module_expr t + | Module_type : module_type t + | Pattern : pattern t + | Signature_item : signature_item t + | Structure_item : structure_item t + | Ppx_import : type_declaration t type packed = T : _ t -> packed - let class_expr = Class_expr - let class_field = Class_field - let class_type = Class_type + let class_expr = Class_expr + + let class_field = Class_field + + let class_type = Class_type + let class_type_field = Class_type_field - let core_type = Core_type - let expression = Expression - let module_expr = Module_expr - let module_type = Module_type - let pattern = Pattern - let signature_item = Signature_item - let structure_item = Structure_item + + let core_type = Core_type + + let expression = Expression + + let module_expr = Module_expr + + let module_type = Module_type + + let pattern = Pattern + + let signature_item = Signature_item + + let structure_item = Structure_item let desc : type a. a t -> string = function - | Class_expr -> "class expression" - | Class_field -> "class field" - | Class_type -> "class type" + | Class_expr -> "class expression" + | Class_field -> "class field" + | Class_type -> "class type" | Class_type_field -> "class type field" - | Core_type -> "core type" - | Expression -> "expression" - | Module_expr -> "module expression" - | Module_type -> "module type" - | Pattern -> "pattern" - | Signature_item -> "signature item" - | Structure_item -> "structure item" - - let eq : type a b. a t -> b t -> (a, b) equality = fun a b -> - match a, b with - | Class_expr , Class_expr -> Eq - | Class_field , Class_field -> Eq - | Class_type , Class_type -> Eq - | Class_type_field , Class_type_field -> Eq - | Core_type , Core_type -> Eq - | Expression , Expression -> Eq - | Module_expr , Module_expr -> Eq - | Module_type , Module_type -> Eq - | Pattern , Pattern -> Eq - | Signature_item , Signature_item -> Eq - | Structure_item , Structure_item -> Eq - | _ -> assert (Poly.(<>) (T a) (T b)); Ne - - let get_extension : type a. a t -> a -> (extension * attributes) option = fun t x -> - match t, x with - | Class_expr , {pcl_desc =Pcl_extension e; pcl_attributes =a;_} -> Some (e, a) - | Class_field , {pcf_desc =Pcf_extension e; pcf_attributes =a;_} -> Some (e, a) - | Class_type , {pcty_desc=Pcty_extension e; pcty_attributes=a;_} -> Some (e, a) - | Class_type_field , {pctf_desc=Pctf_extension e; pctf_attributes=a;_} -> Some (e, a) - | Core_type , {ptyp_desc=Ptyp_extension e; ptyp_attributes=a;_} -> Some (e, a) - | Expression , {pexp_desc=Pexp_extension e; pexp_attributes=a;_} -> Some (e, a) - | Module_expr , {pmod_desc=Pmod_extension e; pmod_attributes=a;_} -> Some (e, a) - | Module_type , {pmty_desc=Pmty_extension e; pmty_attributes=a;_} -> Some (e, a) - | Pattern , {ppat_desc=Ppat_extension e; ppat_attributes=a;_} -> Some (e, a) - | Signature_item , {psig_desc=Psig_extension(e, a) ;_} -> Some (e, a) - | Structure_item , {pstr_desc=Pstr_extension(e, a) ;_} -> Some (e, a) + | Core_type -> "core type" + | Expression -> "expression" + | Module_expr -> "module expression" + | Module_type -> "module type" + | Pattern -> "pattern" + | Signature_item -> "signature item" + | Structure_item -> "structure item" + | Ppx_import -> "type declaration" + + let eq : type a b. a t -> b t -> (a, b) equality = + fun a b -> + match (a, b) with + | Class_expr, Class_expr -> Eq + | Class_field, Class_field -> Eq + | Class_type, Class_type -> Eq + | Class_type_field, Class_type_field -> Eq + | Core_type, Core_type -> Eq + | Expression, Expression -> Eq + | Module_expr, Module_expr -> Eq + | Module_type, Module_type -> Eq + | Pattern, Pattern -> Eq + | Signature_item, Signature_item -> Eq + | Structure_item, Structure_item -> Eq + | Ppx_import, Ppx_import -> Eq + | _ -> + assert (Poly.( <> ) (T a) (T b)); + Ne + + let get_ppx_import_extension type_decl = + match type_decl with + | { ptype_manifest = Some { ptyp_desc = Ptyp_extension (name, _); _ }; _ } + -> + let virtual_payload = + Ast_builder.Default.pstr_type ~loc:type_decl.ptype_loc Recursive + [ type_decl ] + in + let attr = [] in + Some ((name, PStr [ virtual_payload ]), attr) + | _ -> None + + let get_extension : type a. a t -> a -> (extension * attributes) option = + fun t x -> + match (t, x) with + | Class_expr, { pcl_desc = Pcl_extension e; pcl_attributes = a; _ } -> + Some (e, a) + | Class_field, { pcf_desc = Pcf_extension e; pcf_attributes = a; _ } -> + Some (e, a) + | Class_type, { pcty_desc = Pcty_extension e; pcty_attributes = a; _ } -> + Some (e, a) + | Class_type_field, { pctf_desc = Pctf_extension e; pctf_attributes = a; _ } + -> + Some (e, a) + | Core_type, { ptyp_desc = Ptyp_extension e; ptyp_attributes = a; _ } -> + Some (e, a) + | Expression, { pexp_desc = Pexp_extension e; pexp_attributes = a; _ } -> + Some (e, a) + | Module_expr, { pmod_desc = Pmod_extension e; pmod_attributes = a; _ } -> + Some (e, a) + | Module_type, { pmty_desc = Pmty_extension e; pmty_attributes = a; _ } -> + Some (e, a) + | Pattern, { ppat_desc = Ppat_extension e; ppat_attributes = a; _ } -> + Some (e, a) + | Signature_item, { psig_desc = Psig_extension (e, a); _ } -> Some (e, a) + | Structure_item, { pstr_desc = Pstr_extension (e, a); _ } -> Some (e, a) + | Ppx_import, type_decl -> get_ppx_import_extension type_decl | _ -> None - let merge_attributes : type a. a t -> a -> attributes -> a = fun t x attrs -> + let merge_attributes : type a. a t -> a -> attributes -> a = + fun t x attrs -> match t with - | Class_expr -> { x with pcl_attributes = x.pcl_attributes @ attrs } - | Class_field -> { x with pcf_attributes = x.pcf_attributes @ attrs } - | Class_type -> { x with pcty_attributes = x.pcty_attributes @ attrs } + | Class_expr -> { x with pcl_attributes = x.pcl_attributes @ attrs } + | Class_field -> { x with pcf_attributes = x.pcf_attributes @ attrs } + | Class_type -> { x with pcty_attributes = x.pcty_attributes @ attrs } | Class_type_field -> { x with pctf_attributes = x.pctf_attributes @ attrs } - | Core_type -> { x with ptyp_attributes = x.ptyp_attributes @ attrs } - | Expression -> { x with pexp_attributes = x.pexp_attributes @ attrs } - | Module_expr -> { x with pmod_attributes = x.pmod_attributes @ attrs } - | Module_type -> { x with pmty_attributes = x.pmty_attributes @ attrs } - | Pattern -> { x with ppat_attributes = x.ppat_attributes @ attrs } - | Signature_item -> assert_no_attributes attrs; x - | Structure_item -> assert_no_attributes attrs; x + | Core_type -> { x with ptyp_attributes = x.ptyp_attributes @ attrs } + | Expression -> { x with pexp_attributes = x.pexp_attributes @ attrs } + | Module_expr -> { x with pmod_attributes = x.pmod_attributes @ attrs } + | Module_type -> { x with pmty_attributes = x.pmty_attributes @ attrs } + | Pattern -> { x with ppat_attributes = x.ppat_attributes @ attrs } + | Signature_item -> + assert_no_attributes attrs; + x + | Structure_item -> + assert_no_attributes attrs; + x + | Ppx_import -> + assert_no_attributes attrs; + x end let registrar = - Name.Registrar.create - ~kind:"extension" - ~current_file:__FILE__ + Name.Registrar.create ~kind:"extension" ~current_file:__FILE__ ~string_of_context:(fun (Context.T ctx) -> Some (Context.desc ctx)) -;; - -module Make(Callback : sig type 'a t end) = struct +module Make (Callback : sig + type 'a t +end) = +struct type ('a, 'b) payload_parser = - Payload_parser : ('a, 'b, 'c) Ast_pattern.t * 'b Callback.t - -> ('a, 'c) payload_parser - - type ('context, 'payload) t = - { name : Name.Pattern.t - ; context : 'context Context.t - ; payload : (payload, 'payload) payload_parser - ; with_arg : bool - } - - let declare ~with_arg name context pattern k = + | Payload_parser : + ('a, 'b, 'c) Ast_pattern.t * 'b Callback.t + -> ('a, 'c) payload_parser + + type ('context, 'payload) t = { + name : Name.Pattern.t; + context : 'context Context.t; + payload : (payload, 'payload) payload_parser; + with_arg : bool; + } + + let declare : + type a. + with_arg:bool -> + string -> + a Context.t -> + (payload, 'b, 'payload) Ast_pattern.t -> + 'b Callback.t -> + (a, 'payload) t = + fun ~with_arg name context pattern k -> + (* Check that there is no collisions between ppx_import and core_type + extensions *) + (match context with + | Context.Ppx_import -> + Name.Registrar.check_collisions registrar (Context.T Core_type) name + | Context.Core_type -> + Name.Registrar.check_collisions registrar (Context.T Ppx_import) name + | _ -> ()); Name.Registrar.register ~kind:`Extension registrar (Context.T context) name; - { name = Name.Pattern.make name - ; context - ; payload = Payload_parser (pattern, k) - ; with_arg + { + name = Name.Pattern.make name; + context; + payload = Payload_parser (pattern, k); + with_arg; } - ;; let find ts (ext : extension) = let { txt = name; loc } = fst ext in @@ -124,30 +188,33 @@ match List.filter ts ~f:(fun t -> Name.Pattern.matches t.name name) with | [] -> None | _ :: _ :: _ as l -> - Location.raise_errorf ~loc - "Multiple match for extensions: %s" - (String.concat ~sep:", " (List.map l ~f:(fun t -> Name.Pattern.name t.name))) - | [t] -> - if not t.with_arg && Option.is_some arg then - Location.raise_errorf ~loc - "Extension %s doesn't expect a path argument" - name; - let arg = - Option.map arg ~f:(fun s -> - let shift = String.length name + 1 in - let start = loc.loc_start in - { txt = Longident.parse s - ; loc = { loc with loc_start = - { start with pos_cnum = start.pos_cnum + shift } - } - }) - in - Some (t, arg) - ;; + Location.raise_errorf ~loc "Multiple match for extensions: %s" + (String.concat ~sep:", " + (List.map l ~f:(fun t -> Name.Pattern.name t.name))) + | [ t ] -> + if (not t.with_arg) && Option.is_some arg then + Location.raise_errorf ~loc + "Extension %s doesn't expect a path argument" name; + let arg = + Option.map arg ~f:(fun s -> + let shift = String.length name + 1 in + let start = loc.loc_start in + { + txt = Longident.parse s; + loc = + { + loc with + loc_start = { start with pos_cnum = start.pos_cnum + shift }; + }; + }) + in + Some (t, arg) end module Expert = struct - include Make(struct type 'a t = arg:Longident.t Loc.t option -> 'a end) + include Make (struct + type 'a t = arg:Longident.t Loc.t option -> 'a + end) let declare_with_path_arg name ctx patt f = declare ~with_arg:true name ctx patt f @@ -159,16 +226,15 @@ match find ts ext with | None -> None | Some ({ payload = Payload_parser (pattern, f); _ }, arg) -> - Some (Ast_pattern.parse pattern loc (snd ext) (f ~arg)) + Some (Ast_pattern.parse pattern loc (snd ext) (f ~arg)) end -module M = Make(struct - type 'a t = ctxt:Expansion_context.Extension.t -> arg:Longident.t Loc.t option -> 'a - end) +module M = Make (struct + type 'a t = + ctxt:Expansion_context.Extension.t -> arg:Longident.t Loc.t option -> 'a +end) -type 'a expander_result = - | Simple of 'a - | Inline of 'a list +type 'a expander_result = Simple of 'a | Inline of 'a list module For_context = struct type 'a t = ('a, 'a expander_result) M.t @@ -177,145 +243,159 @@ let loc = Expansion_context.Extension.extension_point_loc ctxt in match M.find ts ext with | None -> None - | Some ({ payload = M.Payload_parser (pattern, f); _ }, arg) -> - match Ast_pattern.parse pattern loc (snd ext) (f ~ctxt ~arg) with - | Simple x -> Some x - | Inline _ -> failwith "Extension.convert" - ;; + | Some ({ payload = M.Payload_parser (pattern, f); _ }, arg) -> ( + match Ast_pattern.parse pattern loc (snd ext) (f ~ctxt ~arg) with + | Simple x -> Some x + | Inline _ -> failwith "Extension.convert") let convert_inline ts ~ctxt ext = let loc = Expansion_context.Extension.extension_point_loc ctxt in match M.find ts ext with | None -> None - | Some ({ payload = M.Payload_parser (pattern, f); _ }, arg) -> - match Ast_pattern.parse pattern loc (snd ext) (f ~ctxt ~arg) with - | Simple x -> Some [x] - | Inline l -> Some l - ;; + | Some ({ payload = M.Payload_parser (pattern, f); _ }, arg) -> ( + match Ast_pattern.parse pattern loc (snd ext) (f ~ctxt ~arg) with + | Simple x -> Some [ x ] + | Inline l -> Some l) end type t = T : _ For_context.t -> t let check_context_for_inline : type a. func:string -> a Context.t -> unit = - fun ~func ctx -> - match ctx with - | Context.Class_field -> () - | Context.Class_type_field -> () - | Context.Signature_item -> () - | Context.Structure_item -> () - | context -> - Printf.ksprintf invalid_arg "%s: %s can't be inlined" - func + fun ~func ctx -> + match ctx with + | Context.Class_field -> () + | Context.Class_type_field -> () + | Context.Signature_item -> () + | Context.Structure_item -> () + | context -> + Printf.ksprintf invalid_arg "%s: %s can't be inlined" func (Context.desc context) -;; -let rec filter_by_context - : type a. a Context.t -> t list -> a For_context.t list = - fun context expanders -> - match expanders with - | [] -> [] - | T t :: rest -> - match Context.eq context t.context with - | Eq -> t :: filter_by_context context rest - | Ne -> filter_by_context context rest -;; +let rec filter_by_context : + type a. a Context.t -> t list -> a For_context.t list = + fun context expanders -> + match expanders with + | [] -> [] + | T t :: rest -> ( + match Context.eq context t.context with + | Eq -> t :: filter_by_context context rest + | Ne -> filter_by_context context rest) let fail ctx (name, _) = - if not (Name.Whitelisted.is_whitelisted ~kind:`Extension name.txt - || Name.ignore_checks name.txt) then + if + not + (Name.Whitelisted.is_whitelisted ~kind:`Extension name.txt + || Name.ignore_checks name.txt) + then Name.Registrar.raise_errorf registrar (Context.T ctx) "Extension `%s' was not translated" name -;; - -let check_unused = object - inherit Ast_traverse.iter as super - method! extension (name, _) = - Location.raise_errorf ~loc:name.loc - "extension not expected here, Ppxlib.Extension needs updating!" - - method! core_type_desc = function - | Ptyp_extension ext -> fail Core_type ext - | x -> super#core_type_desc x - - method! pattern_desc = function - | Ppat_extension ext -> fail Pattern ext - | x -> super#pattern_desc x - - method! expression_desc = function - | Pexp_extension ext -> fail Expression ext - | x -> super#expression_desc x - - method! class_type_desc = function - | Pcty_extension ext -> fail Class_type ext - | x -> super#class_type_desc x - - method! class_type_field_desc = function - | Pctf_extension ext -> fail Class_type_field ext - | x -> super#class_type_field_desc x - - method! class_expr_desc = function - | Pcl_extension ext -> fail Class_expr ext - | x -> super#class_expr_desc x - - method! class_field_desc = function - | Pcf_extension ext -> fail Class_field ext - | x -> super#class_field_desc x - - method! module_type_desc = function - | Pmty_extension ext -> fail Module_type ext - | x -> super#module_type_desc x - - method! signature_item_desc = function - | Psig_extension (ext, _) -> fail Signature_item ext - | x -> super#signature_item_desc x - - method! module_expr_desc = function - | Pmod_extension ext -> fail Module_expr ext - | x -> super#module_expr_desc x - - method! structure_item_desc = function - | Pstr_extension (ext, _) -> fail Structure_item ext - | x -> super#structure_item_desc x -end +let check_unused = + object + inherit Ast_traverse.iter as super + + method! extension (name, _) = + Location.raise_errorf ~loc:name.loc + "extension not expected here, Ppxlib.Extension needs updating!" + + method! core_type_desc = + function + | Ptyp_extension ext -> fail Core_type ext | x -> super#core_type_desc x + + method! pattern_desc = + function + | Ppat_extension ext -> fail Pattern ext | x -> super#pattern_desc x + + method! expression_desc = + function + | Pexp_extension ext -> fail Expression ext | x -> super#expression_desc x + + method! class_type_desc = + function + | Pcty_extension ext -> fail Class_type ext | x -> super#class_type_desc x + + method! class_type_field_desc = + function + | Pctf_extension ext -> fail Class_type_field ext + | x -> super#class_type_field_desc x + + method! class_expr_desc = + function + | Pcl_extension ext -> fail Class_expr ext | x -> super#class_expr_desc x + + method! class_field_desc = + function + | Pcf_extension ext -> fail Class_field ext + | x -> super#class_field_desc x + + method! module_type_desc = + function + | Pmty_extension ext -> fail Module_type ext + | x -> super#module_type_desc x + + method! signature_item_desc = + function + | Psig_extension (ext, _) -> fail Signature_item ext + | x -> super#signature_item_desc x + + method! module_expr_desc = + function + | Pmod_extension ext -> fail Module_expr ext + | x -> super#module_expr_desc x + + method! structure_item_desc = + function + | Pstr_extension (ext, _) -> fail Structure_item ext + | x -> super#structure_item_desc x + end module V3 = struct type nonrec t = t let declare name context pattern k = let pattern = Ast_pattern.map_result pattern ~f:(fun x -> Simple x) in - T (M.declare ~with_arg:false name context pattern - (fun ~ctxt ~arg:_ -> k ~ctxt)) + T + (M.declare ~with_arg:false name context pattern (fun ~ctxt ~arg:_ -> + k ~ctxt)) let declare_inline name context pattern k = check_context_for_inline context ~func:"Extension.declare_inline"; let pattern = Ast_pattern.map_result pattern ~f:(fun x -> Inline x) in - T (M.declare ~with_arg:false name context pattern - (fun ~ctxt ~arg:_ -> k ~ctxt)) + T + (M.declare ~with_arg:false name context pattern (fun ~ctxt ~arg:_ -> + k ~ctxt)) end let declare name context pattern f = - V3.declare name context pattern (Expansion_context.Extension.with_loc_and_path f) + V3.declare name context pattern + (Expansion_context.Extension.with_loc_and_path f) let declare_inline name context pattern f = - V3.declare_inline name context pattern (Expansion_context.Extension.with_loc_and_path f) + V3.declare_inline name context pattern + (Expansion_context.Extension.with_loc_and_path f) let declare_with_path_arg name context pattern k = let k' = Expansion_context.Extension.with_loc_and_path k in let pattern = Ast_pattern.map_result pattern ~f:(fun x -> Simple x) in - T (M.declare ~with_arg:true name context pattern k') -;; + T (M.declare ~with_arg:true name context pattern k') let declare_inline_with_path_arg name context pattern k = let k' = Expansion_context.Extension.with_loc_and_path k in - check_context_for_inline context ~func:"Extension.declare_inline_with_path_arg"; + check_context_for_inline context + ~func:"Extension.declare_inline_with_path_arg"; let pattern = Ast_pattern.map_result pattern ~f:(fun x -> Inline x) in T (M.declare ~with_arg:true name context pattern k') -;; + +let __declare_ppx_import name expand = + (* This pattern is used to unwrap the type declaration from the payload + assembled by [Context.get_ppx_import_extension] *) + let pattern = Ast_pattern.(pstr (pstr_type recursive (__ ^:: nil) ^:: nil)) in + V3.declare name Context.Ppx_import pattern expand module V2 = struct type nonrec t = t let declare = declare + let declare_inline = declare_inline end diff -Nru ppxlib-0.15.0/src/extension.mli ppxlib-0.24.0/src/extension.mli --- ppxlib-0.15.0/src/extension.mli 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/extension.mli 2021-12-08 21:53:37.000000000 +0000 @@ -4,139 +4,148 @@ module Context : sig type 'a t = - | Class_expr : class_expr t - | Class_field : class_field t - | Class_type : class_type t + | Class_expr : class_expr t + | Class_field : class_field t + | Class_type : class_type t | Class_type_field : class_type_field t - | Core_type : core_type t - | Expression : expression t - | Module_expr : module_expr t - | Module_type : module_type t - | Pattern : pattern t - | Signature_item : signature_item t - | Structure_item : structure_item t - - val class_expr : class_expr t - val class_field : class_field t - val class_type : class_type t + | Core_type : core_type t + | Expression : expression t + | Module_expr : module_expr t + | Module_type : module_type t + | Pattern : pattern t + | Signature_item : signature_item t + | Structure_item : structure_item t + | Ppx_import : type_declaration t + (** For ppx_import compat only, please do not use *) + + val class_expr : class_expr t + + val class_field : class_field t + + val class_type : class_type t + val class_type_field : class_type_field t - val core_type : core_type t - val expression : expression t - val module_expr : module_expr t - val module_type : module_type t - val pattern : pattern t - val signature_item : signature_item t - val structure_item : structure_item t + + val core_type : core_type t + + val expression : expression t + + val module_expr : module_expr t + + val module_type : module_type t + + val pattern : pattern t + + val signature_item : signature_item t + + val structure_item : structure_item t val eq : 'a t -> 'b t -> ('a, 'b) equality + val get_extension : 'a t -> 'a -> (extension * attributes) option + val merge_attributes : 'a t -> 'a -> attributes -> 'a end type t (** Type of declared extensions. *) -(** [declare name context pattern expander] declares the extension names [name] for - [context]. - - [expander] is responsible for producing the code to replace the extension in the - AST. It receives as argument: - - - [loc]: the location of the enclosing node. For instance for expression it is the - [pexp_loc] field - - [path]: the current module path -*) -val declare - : string - -> 'context Context.t - -> (payload, 'a, 'context) Ast_pattern.t - -> (loc:Location.t -> path:string -> 'a) - -> t - +val declare : + string -> + 'context Context.t -> + (payload, 'a, 'context) Ast_pattern.t -> + (loc:Location.t -> path:string -> 'a) -> + t +(** [declare name context pattern expander] declares the extension names [name] + for [context]. + + [expander] is responsible for producing the code to replace the extension in + the AST. It receives as argument: + + - [loc]: the location of the enclosing node. For instance for expression it + is the [pexp_loc] field + - [path]: the current module path *) + +val declare_with_path_arg : + string -> + 'context Context.t -> + (payload, 'a, 'context) Ast_pattern.t -> + (loc:Location.t -> path:string -> arg:Longident.t Asttypes.loc option -> 'a) -> + t (** Same as [declare] except that the extension name takes an additional path argument. The path is the part of the name that start with a capitalized - component. For instance in the following, the extension ["map"] would receive the path - argument [Foo.Bar]: + component. For instance in the following, the extension ["map"] would + receive the path argument [Foo.Bar]: {[ let%map.Foo.Bar x = 1 in ... - ]} -*) -val declare_with_path_arg - : string - -> 'context Context.t - -> (payload, 'a, 'context) Ast_pattern.t - -> (loc:Location.t -> path:string -> arg:Longident.t Asttypes.loc option -> 'a) - -> t + ]} *) -(** Inline the result of the expansion into its parent. Only works for these contexts: +val declare_inline : + string -> + 'context Context.t -> + (payload, 'a, 'context list) Ast_pattern.t -> + (loc:Location.t -> path:string -> 'a) -> + t +(** Inline the result of the expansion into its parent. Only works for these + contexts: - [class_field] - [class_type_field] - [signature_item] - - [structure_item] -*) -val declare_inline - : string - -> 'context Context.t - -> (payload, 'a, 'context list) Ast_pattern.t - -> (loc:Location.t -> path:string -> 'a) - -> t - -val declare_inline_with_path_arg - : string - -> 'context Context.t - -> (payload, 'a, 'context list) Ast_pattern.t - -> (loc:Location.t -> path:string -> arg:Longident.t Asttypes.loc option -> 'a) - -> t + - [structure_item] *) + +val declare_inline_with_path_arg : + string -> + 'context Context.t -> + (payload, 'a, 'context list) Ast_pattern.t -> + (loc:Location.t -> path:string -> arg:Longident.t Asttypes.loc option -> 'a) -> + t module For_context : sig (** This module is used to implement {!Context_free.V1.map_top_down} *) type 'a t - val convert - : 'a t list - -> ctxt:Expansion_context.Extension.t - -> extension - -> 'a option - - val convert_inline - : 'a t list - -> ctxt:Expansion_context.Extension.t - -> extension - -> 'a list option + val convert : + 'a t list -> ctxt:Expansion_context.Extension.t -> extension -> 'a option + + val convert_inline : + 'a t list -> + ctxt:Expansion_context.Extension.t -> + extension -> + 'a list option end -(** Given a context and a list of extension expander, returns all the ones that are for - this context. *) val filter_by_context : 'a Context.t -> t list -> 'a For_context.t list +(** Given a context and a list of extension expander, returns all the ones that + are for this context. *) module Expert : sig - (** This module allows to declare extensions that do not produce a value of the context - type. This is typically useful for extensions point that depends on more things from - the context than the path and location. *) + (** This module allows to declare extensions that do not produce a value of + the context type. This is typically useful for extensions point that + depends on more things from the context than the path and location. *) type ('context, 'payload) t (** Type of declared expert extensions. - The ['context] type parameter describes where the extension is expected and the - ['payload] one what its payload should contain. *) + The ['context] type parameter describes where the extension is expected + and the ['payload] one what its payload should contain. *) - val declare - : string - -> 'context Context.t - -> (payload, 'a, 'b) Ast_pattern.t - -> 'a - -> ('context, 'b) t - - val declare_with_path_arg - : string - -> 'context Context.t - -> (payload, 'a, 'b) Ast_pattern.t - -> (arg:Longident.t Loc.t option -> 'a) - -> ('context, 'b) t + val declare : + string -> + 'context Context.t -> + (payload, 'a, 'b) Ast_pattern.t -> + 'a -> + ('context, 'b) t + + val declare_with_path_arg : + string -> + 'context Context.t -> + (payload, 'a, 'b) Ast_pattern.t -> + (arg:Longident.t Loc.t option -> 'a) -> + ('context, 'b) t val convert : (_, 'a) t list -> loc:Location.t -> extension -> 'a option end @@ -145,35 +154,45 @@ module V2 : sig type nonrec t = t - val declare - : string - -> 'context Context.t - -> (payload, 'a, 'context) Ast_pattern.t - -> (loc:Location.t -> path:string -> 'a) - -> t - val declare_inline - : string - -> 'context Context.t - -> (payload, 'a, 'context list) Ast_pattern.t - -> (loc:Location.t -> path:string -> 'a) - -> t + + val declare : + string -> + 'context Context.t -> + (payload, 'a, 'context) Ast_pattern.t -> + (loc:Location.t -> path:string -> 'a) -> + t + + val declare_inline : + string -> + 'context Context.t -> + (payload, 'a, 'context list) Ast_pattern.t -> + (loc:Location.t -> path:string -> 'a) -> + t end module V3 : sig type nonrec t = t - val declare - : string - -> 'context Context.t - -> (payload, 'a, 'context) Ast_pattern.t - -> (ctxt:Expansion_context.Extension.t -> 'a) - -> t - val declare_inline - : string - -> 'context Context.t - -> (payload, 'a, 'context list) Ast_pattern.t - -> (ctxt:Expansion_context.Extension.t -> 'a) - -> t + + val declare : + string -> + 'context Context.t -> + (payload, 'a, 'context) Ast_pattern.t -> + (ctxt:Expansion_context.Extension.t -> 'a) -> + t + + val declare_inline : + string -> + 'context Context.t -> + (payload, 'a, 'context list) Ast_pattern.t -> + (ctxt:Expansion_context.Extension.t -> 'a) -> + t end (**/**) + val check_context_for_inline : func:string -> 'a Context.t -> unit + +val __declare_ppx_import : + string -> + (ctxt:Expansion_context.Extension.t -> type_declaration -> type_declaration) -> + t diff -Nru ppxlib-0.15.0/src/file_path.ml ppxlib-0.24.0/src/file_path.ml --- ppxlib-0.15.0/src/file_path.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/file_path.ml 2021-12-08 21:53:37.000000000 +0000 @@ -3,23 +3,18 @@ let chop_prefix ~prefix x = if String.is_prefix ~prefix x then Some (String.drop_prefix x (String.length prefix)) - else - None -;; + else None let get_default_path (loc : Location.t) = let fname = loc.loc_start.pos_fname in match chop_prefix ~prefix:"./" fname with | Some fname -> fname - | None -> fname -;; + | None -> fname let get_default_path_str : structure -> string = function | [] -> "" | { pstr_loc = loc; _ } :: _ -> get_default_path loc -;; let get_default_path_sig : signature -> string = function | [] -> "" | { psig_loc = loc; _ } :: _ -> get_default_path loc -;; diff -Nru ppxlib-0.15.0/src/file_path.mli ppxlib-0.24.0/src/file_path.mli --- ppxlib-0.15.0/src/file_path.mli 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/file_path.mli 2021-12-08 21:53:37.000000000 +0000 @@ -2,6 +2,8 @@ (** Return the path used as root in a file *) -val get_default_path : Location.t -> string -val get_default_path_str : structure -> string -val get_default_path_sig : signature -> string +val get_default_path : Location.t -> string + +val get_default_path_str : structure -> string + +val get_default_path_sig : signature -> string diff -Nru ppxlib-0.15.0/src/gen/dune ppxlib-0.24.0/src/gen/dune --- ppxlib-0.15.0/src/gen/dune 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/gen/dune 2021-12-08 21:53:37.000000000 +0000 @@ -1,9 +1,5 @@ (executables (names gen_ast_pattern gen_ast_builder) - (flags (:standard -safe-string)) - (libraries - ppxlib_ast - compiler-libs.common - compiler-libs.bytecomp - ppxlib_traverse_builtins - stdppx)) + (flags + (:standard -safe-string)) + (libraries ppxlib_ast astlib ppxlib_traverse_builtins stdppx stdlib-shims)) diff -Nru ppxlib-0.15.0/src/gen/gen_ast_builder.ml ppxlib-0.24.0/src/gen/gen_ast_builder.ml --- ppxlib-0.15.0/src/gen/gen_ast_builder.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/gen/gen_ast_builder.ml 2021-12-08 21:53:37.000000000 +0000 @@ -5,151 +5,134 @@ let prefix_of_record lds = common_prefix (List.map lds ~f:(fun ld -> ld.pld_name.txt)) -module Gen(Fixed_loc : sig val fixed_loc : bool end) = struct +module Gen (Fixed_loc : sig + val fixed_loc : bool +end) = +struct open Fixed_loc - let gen_combinator_for_constructor ~wrapper:(wpath, wprefix, has_attrs, has_loc_stack) path ~prefix cd = + let gen_combinator_for_constructor + ~wrapper:(wpath, wprefix, has_attrs, has_loc_stack) path ~prefix cd = match cd.pcd_args with | Pcstr_record _ -> - (* TODO. *) - failwith "Pcstr_record not supported" + (* TODO. *) + failwith "Pcstr_record not supported" | Pcstr_tuple cd_args -> - let args = - List.mapi cd_args ~f:(fun i _ -> sprintf "x%d" i) - in - let exp = - Exp.construct (Loc.mk (fqn_longident path cd.pcd_name.txt)) - (match args with - | [] -> None - | [x] -> Some (evar x) - | _ -> Some (Exp.tuple (List.map args ~f:evar))) - in - let body = - let fields = - [ ( Loc.mk (fqn_longident' wpath (wprefix ^ "loc")) - , evar "loc" - ) - ; ( Loc.mk (fqn_longident' wpath (wprefix ^ "desc")) - , exp - ) - ] + let args = List.mapi cd_args ~f:(fun i _ -> sprintf "x%d" i) in + let exp = + Exp.construct + (Loc.mk (fqn_longident path cd.pcd_name.txt)) + (match args with + | [] -> None + | [ x ] -> Some (evar x) + | _ -> Some (Exp.tuple (List.map args ~f:evar))) in - let fields = - if has_attrs then - ( Loc.mk (fqn_longident' wpath (wprefix ^ "attributes")) - , M.expr "[]" - ) - :: fields - else - fields - in - let fields = - if has_loc_stack then - ( Loc.mk (fqn_longident' wpath (wprefix ^ "loc_stack")) - , M.expr "[]" - ) - :: fields - else - fields + let body = + let fields = + [ + (Loc.mk (fqn_longident' wpath (wprefix ^ "loc")), evar "loc"); + (Loc.mk (fqn_longident' wpath (wprefix ^ "desc")), exp); + ] + in + let fields = + if has_attrs then + ( Loc.mk (fqn_longident' wpath (wprefix ^ "attributes")), + M.expr "[]" ) + :: fields + else fields + in + let fields = + if has_loc_stack then + ( Loc.mk (fqn_longident' wpath (wprefix ^ "loc_stack")), + M.expr "[]" ) + :: fields + else fields + in + Exp.record fields None in - Exp.record fields None - in - let body = - (* match args with - | [] -> [%expr fun () -> [%e body]] - | _ ->*) + let body = + (* match args with + | [] -> [%expr fun () -> [%e body]] + | _ ->*) List.fold_right args ~init:body ~f:(fun arg acc -> - M.expr "fun %a -> %a" A.patt (pvar arg) A.expr acc) - in - (* let body = - if not has_attrs then - body - else - [%expr fun ?(attrs=[]) -> [%e body]] - in*) - let body = - if fixed_loc then - body - else - M.expr "fun ~loc -> %a" A.expr body - in - M.stri "let %a = %a" - A.patt (pvar (function_name_of_id ~prefix cd.pcd_name.txt)) - A.expr body - ;; + M.expr "fun %a -> %a" A.patt (pvar arg) A.expr acc) + in + (* let body = + if not has_attrs then + body + else + [%expr fun ?(attrs=[]) -> [%e body]] + in*) + let body = + if fixed_loc then body else M.expr "fun ~loc -> %a" A.expr body + in + M.stri "let %a = %a" A.patt + (pvar (function_name_of_id ~prefix cd.pcd_name.txt)) + A.expr body let gen_combinator_for_record path ~prefix lds = - let fields = List.map lds ~f:(fun ld -> fqn_longident path ld.pld_name.txt) in + let fields = + List.map lds ~f:(fun ld -> fqn_longident path ld.pld_name.txt) + in let funcs = List.map lds ~f:(fun ld -> - map_keyword (without_prefix ~prefix ld.pld_name.txt)) + map_keyword (without_prefix ~prefix ld.pld_name.txt)) in let body = Exp.record (List.map2 fields funcs ~f:(fun field func -> - (Loc.mk field, if func = "attributes" then M.expr "[]" else evar func))) + ( Loc.mk field, + if func = "attributes" then M.expr "[]" else evar func ))) None in let body = let l = List.filter funcs ~f:(fun f -> f <> "loc" && f <> "attributes") in match l with - | [x] -> Exp.fun_ Nolabel None (pvar x) body + | [ x ] -> Exp.fun_ Nolabel None (pvar x) body | _ -> - List.fold_right l ~init:body ~f:(fun func acc -> - Exp.fun_ (Labelled func) None (pvar func) acc - ) + List.fold_right l ~init:body ~f:(fun func acc -> + Exp.fun_ (Labelled func) None (pvar func) acc) in -(* let body = - if List.mem "attributes" ~set:funcs then - [%expr fun ?(attrs=[]) -> [%e body]] - else - body - in*) + (* let body = + if List.mem "attributes" ~set:funcs then + [%expr fun ?(attrs=[]) -> [%e body]] + else + body + in*) let body = if List.mem "loc" ~set:funcs && not fixed_loc then M.expr "fun ~loc -> %a" A.expr body - else - body + else body in - M.stri "let %a = %a" - A.patt (pvar (function_name_of_path path)) - A.expr body - ;; + M.stri "let %a = %a" A.patt (pvar (function_name_of_path path)) A.expr body let gen_td ?wrapper path td = - if is_loc path then - [] + if is_loc path then [] else match td.ptype_kind with - | Ptype_variant cds -> - begin match wrapper with - | None -> [] - | Some wrapper -> - let prefix = - common_prefix (List.map cds ~f:(fun cd -> cd.pcd_name.txt)) - in - List.map cds ~f:(fun cd -> - gen_combinator_for_constructor ~wrapper path ~prefix cd) - end + | Ptype_variant cds -> ( + match wrapper with + | None -> [] + | Some wrapper -> + let prefix = + common_prefix (List.map cds ~f:(fun cd -> cd.pcd_name.txt)) + in + List.map cds ~f:(fun cd -> + gen_combinator_for_constructor ~wrapper path ~prefix cd)) | Ptype_record lds -> - let prefix = prefix_of_record lds in - [gen_combinator_for_record path ~prefix lds] + let prefix = prefix_of_record lds in + [ gen_combinator_for_record path ~prefix lds ] | Ptype_abstract | Ptype_open -> [] - ;; end let filter_labels ~prefix lds = List.filter lds ~f:(fun ld -> - match without_prefix ~prefix ld.pld_name.txt with - | "loc" | "loc_stack" | "attributes" -> false - | _ -> true) -;; + match without_prefix ~prefix ld.pld_name.txt with + | "loc" | "loc_stack" | "attributes" -> false + | _ -> true) let is_abstract td = - match td.ptype_kind with - | Ptype_abstract -> true - | _ -> false -;; + match td.ptype_kind with Ptype_abstract -> true | _ -> false let dump fn ~ext printer x = let oc = open_out (fn ^ ext) in @@ -162,83 +145,82 @@ let types = get_types ~filename in let types_with_wrapped = List.map types ~f:(fun (path, td) -> - match td.ptype_kind with - | Ptype_record lds -> - let prefix = prefix_of_record lds in - let lds' = filter_labels ~prefix lds in - (match is_wrapper ~prefix lds' with - | None -> (path, td, None) - | Some p -> - let has_attrs = List.exists lds ~f:(fun ld -> - ld.pld_name.txt = prefix ^ "attributes") - in - let has_loc_stack = List.exists lds ~f:(fun ld -> - ld.pld_name.txt = prefix ^ "loc_stack") - in - (path, td, Some (prefix, has_attrs, has_loc_stack, p.txt))) - | _ -> (path, td, None)) + match td.ptype_kind with + | Ptype_record lds -> ( + let prefix = prefix_of_record lds in + let lds' = filter_labels ~prefix lds in + match is_wrapper ~prefix lds' with + | None -> (path, td, None) + | Some p -> + let has_attrs = + List.exists lds ~f:(fun ld -> + ld.pld_name.txt = prefix ^ "attributes") + in + let has_loc_stack = + List.exists lds ~f:(fun ld -> + ld.pld_name.txt = prefix ^ "loc_stack") + in + (path, td, Some (prefix, has_attrs, has_loc_stack, p.txt))) + | _ -> (path, td, None)) in let wrapped = List.filter_map types_with_wrapped ~f:(fun (_, _, x) -> - match x with - | None -> None - | Some (_, _, _, p) -> Some p) + match x with None -> None | Some (_, _, _, p) -> Some p) in let types = List.filter types_with_wrapped ~f:(fun (path, _, _) -> - not (List.mem path ~set:wrapped)) + not (List.mem path ~set:wrapped)) |> List.map ~f:(fun (path, td, wrapped) -> - match wrapped with - | None -> (path, td, None) - | Some (prefix, has_attrs, has_loc_stack, p) -> - (path, td, Some (prefix, has_attrs, has_loc_stack, p, List.assoc p types))) + match wrapped with + | None -> (path, td, None) + | Some (prefix, has_attrs, has_loc_stack, p) -> + ( path, + td, + Some (prefix, has_attrs, has_loc_stack, p, List.assoc p types) + )) in (* let all_types = List.map fst types in*) - let types = - List.sort types ~cmp:(fun (a, _, _) (b, _, _) -> - compare a b) - in + let types = List.sort types ~cmp:(fun (a, _, _) (b, _, _) -> compare a b) in let items fixed_loc = - let module G = Gen(struct let fixed_loc = fixed_loc end) in + let module G = Gen (struct + let fixed_loc = fixed_loc + end) in List.map types ~f:(fun (path, td, wrapped) -> - if is_abstract td then - [] - else - match wrapped with - | None -> G.gen_td path td - | Some (prefix, has_attrs, has_loc_stack, path', td') -> - G.gen_td ~wrapper:(path, prefix, has_attrs, has_loc_stack) path' td' - ) + if is_abstract td then [] + else + match wrapped with + | None -> G.gen_td path td + | Some (prefix, has_attrs, has_loc_stack, path', td') -> + G.gen_td + ~wrapper:(path, prefix, has_attrs, has_loc_stack) + path' td') |> List.flatten in let st = - [ Str.open_ (Opn.mk (Mod.ident (Loc.lident "Import"))) - ; Str.module_ (Mb.mk (Loc.mk (Some "M")) (Mod.structure (items false))) - ; Str.module_ (Mb.mk (Loc.mk (Some "Make")) - (Mod.functor_ - (Named - ( (Loc.mk (Some "Loc")) - , (Mty.signature [ - Sig.value - (Val.mk (Loc.mk "loc") (M.ctyp "Location.t")) - ]) )) - (Mod.structure - (M.stri "let loc = Loc.loc" - :: items true)))) + [ + Str.open_ (Opn.mk (Mod.ident (Loc.lident "Import"))); + Str.module_ (Mb.mk (Loc.mk (Some "M")) (Mod.structure (items false))); + Str.module_ + (Mb.mk (Loc.mk (Some "Make")) + (Mod.functor_ + (Named + ( Loc.mk (Some "Loc"), + Mty.signature + [ Sig.value (Val.mk (Loc.mk "loc") (M.ctyp "Location.t")) ] + )) + (Mod.structure (M.stri "let loc = Loc.loc" :: items true)))); ] in dump "ast_builder_generated" Pprintast.structure st ~ext:".ml" -let args = - [ ] +let args = [] let usage = Printf.sprintf "%s [options] <.ml files>\n" Sys.argv.(0) let () = let fns = ref [] in Arg.parse (Arg.align args) (fun fn -> fns := fn :: !fns) usage; - try - List.iter (List.rev !fns) ~f:generate + try List.iter (List.rev !fns) ~f:generate with exn -> - Errors.report_error Format.err_formatter exn; + Astlib.Location.report_exception Format.err_formatter exn; exit 2 diff -Nru ppxlib-0.15.0/src/gen/gen_ast_pattern.ml ppxlib-0.24.0/src/gen/gen_ast_pattern.ml --- ppxlib-0.15.0/src/gen/gen_ast_pattern.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/gen/gen_ast_pattern.ml 2021-12-08 21:53:37.000000000 +0000 @@ -3,101 +3,84 @@ open Printf let apply_parsers funcs args types = - List.fold_right2 (List.combine funcs args) types ~init:(M.expr "k", false) + List.fold_right2 (List.combine funcs args) types + ~init:(M.expr "k", false) ~f:(fun (func, arg) typ (acc, needs_loc) -> match typ.ptyp_desc with | Ptyp_constr (path, _) when is_loc path.txt -> - M.expr "let k = %a ctx %a.loc %a.txt k in %a" - A.expr (evar func) - A.expr arg - A.expr arg - A.expr acc, - needs_loc + ( M.expr "let k = %a ctx %a.loc %a.txt k in %a" A.expr (evar func) + A.expr arg A.expr arg A.expr acc, + needs_loc ) | _ -> - M.expr "let k = %a ctx loc %a k in %a" - A.expr (evar func) - A.expr arg - A.expr acc, - true) -;; + ( M.expr "let k = %a ctx loc %a k in %a" A.expr (evar func) A.expr arg + A.expr acc, + true )) let assert_no_attributes ~path ~prefix = - M.expr "Common.assert_no_attributes x.%a" - A.id (fqn_longident' path (prefix ^ "attributes")) + M.expr "Common.assert_no_attributes x.%a" A.id + (fqn_longident' path (prefix ^ "attributes")) let gen_combinator_for_constructor ?wrapper path ~prefix cd = match cd.pcd_args with | Pcstr_record _ -> failwith "Pcstr_record not supported" | Pcstr_tuple cd_args -> - let args = - List.mapi cd_args ~f:(fun i _ -> sprintf "x%d" i) - in - let funcs = - List.mapi cd_args ~f:(fun i _ -> sprintf "f%d" i) - in - let pat = - Pat.construct (Loc.mk (fqn_longident path cd.pcd_name.txt)) - (match args with - | [] -> None - | [x] -> Some (pvar x) - | _ -> Some (Pat.tuple (List.map args ~f:pvar))) - in - let exp, _ = - apply_parsers funcs (List.map args ~f:evar) cd_args - in - let expected = without_prefix ~prefix cd.pcd_name.txt in - let body = - M.expr - {|match x with + let args = List.mapi cd_args ~f:(fun i _ -> sprintf "x%d" i) in + let funcs = List.mapi cd_args ~f:(fun i _ -> sprintf "f%d" i) in + let pat = + Pat.construct + (Loc.mk (fqn_longident path cd.pcd_name.txt)) + (match args with + | [] -> None + | [ x ] -> Some (pvar x) + | _ -> Some (Pat.tuple (List.map args ~f:pvar))) + in + let exp, _ = apply_parsers funcs (List.map args ~f:evar) cd_args in + let expected = without_prefix ~prefix cd.pcd_name.txt in + let body = + M.expr + {|match x with | %a -> ctx.matched <- ctx.matched + 1; %a | _ -> fail loc %S|} - A.patt pat - A.expr exp - expected - in - let body = - match wrapper with - | None -> body - | Some (path, prefix, has_attrs) -> - let body = - M.expr - {|let loc = x.%a in + A.patt pat A.expr exp expected + in + let body = + match wrapper with + | None -> body + | Some (path, prefix, has_attrs) -> + let body = + M.expr + {|let loc = x.%a in let x = x.%a in %a|} - A.id (fqn_longident' path (prefix ^ "loc")) - A.id (fqn_longident' path (prefix ^ "desc")) - A.expr body + A.id + (fqn_longident' path (prefix ^ "loc")) + A.id + (fqn_longident' path (prefix ^ "desc")) + A.expr body + in + if has_attrs then + Exp.sequence (assert_no_attributes ~path ~prefix) body + else body + in + let body = + let loc = + match wrapper with None -> M.patt "loc" | Some _ -> M.patt "_loc" in - if has_attrs then - Exp.sequence (assert_no_attributes ~path ~prefix) body - else - body - in - let body = - let loc = - match wrapper with - | None -> M.patt "loc" - | Some _ -> M.patt "_loc" + M.expr "T (fun ctx %a x k -> %a)" A.patt loc A.expr body + in + let body = + List.fold_right funcs ~init:body ~f:(fun func acc -> + M.expr "fun (T %a) -> %a" A.patt (pvar func) A.expr acc) in - M.expr "T (fun ctx %a x k -> %a)" - A.patt loc + M.stri "let %a = %a" A.patt + (pvar (function_name_of_id ~prefix cd.pcd_name.txt)) A.expr body - in - let body = - List.fold_right funcs ~init:body ~f:(fun func acc -> - M.expr "fun (T %a) -> %a" - A.patt (pvar func) - A.expr acc) - in - M.stri "let %a = %a" - A.patt (pvar (function_name_of_id ~prefix cd.pcd_name.txt)) - A.expr body -;; let gen_combinator_for_record path ~prefix ~has_attrs lds = let fields = List.map lds ~f:(fun ld -> fqn_longident path ld.pld_name.txt) in let funcs = - List.map lds ~f:(fun ld -> map_keyword (without_prefix ~prefix ld.pld_name.txt)) + List.map lds ~f:(fun ld -> + map_keyword (without_prefix ~prefix ld.pld_name.txt)) in let body, needs_loc = apply_parsers funcs @@ -105,10 +88,8 @@ (List.map lds ~f:(fun ld -> ld.pld_type)) in let body = - if has_attrs then - Exp.sequence (assert_no_attributes ~path ~prefix) body - else - body + if has_attrs then Exp.sequence (assert_no_attributes ~path ~prefix) body + else body in let body = M.expr "T (fun ctx %s x k -> %a)" @@ -117,25 +98,21 @@ in let body = List.fold_right funcs ~init:body ~f:(fun func acc -> - Exp.fun_ (Labelled func) None (M.patt "T %a" A.patt (pvar func)) acc) + Exp.fun_ (Labelled func) None (M.patt "T %a" A.patt (pvar func)) acc) in - M.stri "let %a = %a" - A.patt (pvar (function_name_of_path path)) - A.expr body -;; + M.stri "let %a = %a" A.patt (pvar (function_name_of_path path)) A.expr body -let prefix_of_record lds = common_prefix (List.map lds ~f:(fun ld -> ld.pld_name.txt)) +let prefix_of_record lds = + common_prefix (List.map lds ~f:(fun ld -> ld.pld_name.txt)) let filter_labels ~prefix lds = List.filter lds ~f:(fun ld -> - match without_prefix ~prefix ld.pld_name.txt with - | "loc" | "loc_stack" | "attributes" -> false - | _ -> true) -;; + match without_prefix ~prefix ld.pld_name.txt with + | "loc" | "loc_stack" | "attributes" -> false + | _ -> true) let has_ld ~prefix lds label = List.exists lds ~f:(fun ld -> ld.pld_name.txt = prefix ^ label) -;; let attributes_parser ~prefix ~name ~has_loc = let field s = Lident (prefix ^ s) in @@ -145,82 +122,66 @@ let x = { x with %a = [] } in let k = f2 ctx loc x k in k|} - A.id (field "attributes") - A.id (field "attributes") + A.id (field "attributes") A.id (field "attributes") in let body = - if has_loc then - M.expr "let loc = x.%a in %a" - A.id (field "loc") - A.expr body - else - body + if has_loc then M.expr "let loc = x.%a in %a" A.id (field "loc") A.expr body + else body in - let loc_patt = - if has_loc then M.patt "_loc" else M.patt "loc" - in - M.stri - "let %a (T f1) (T f2) = T (fun ctx %a x k -> %a)" - A.patt (pvar name) - A.patt loc_patt - A.expr body + let loc_patt = if has_loc then M.patt "_loc" else M.patt "loc" in + M.stri "let %a (T f1) (T f2) = T (fun ctx %a x k -> %a)" A.patt (pvar name) + A.patt loc_patt A.expr body let gen_td ?wrapper path td = - if is_loc path then - [] + if is_loc path then [] else match td.ptype_kind with - | Ptype_variant cds -> begin + | Ptype_variant cds -> ( let prefix = common_prefix (List.map cds ~f:(fun cd -> cd.pcd_name.txt)) in let items = List.map cds ~f:(fun cd -> - gen_combinator_for_constructor ?wrapper path ~prefix cd) + gen_combinator_for_constructor ?wrapper path ~prefix cd) in match wrapper with | Some (_, prefix, has_attrs) -> - let field s = Exp.field (evar "x") (Loc.lident @@ prefix ^ s) in - let items = - if has_attrs then - attributes_parser ~has_loc:true ~prefix ~name:(prefix ^ "attributes") - :: items - else - items - in - M.stri - {|let %a = fun (T f1) (T f2) -> + let field s = Exp.field (evar "x") (Loc.lident @@ prefix ^ s) in + let items = + if has_attrs then + attributes_parser ~has_loc:true ~prefix + ~name:(prefix ^ "attributes") + :: items + else items + in + M.stri + {|let %a = fun (T f1) (T f2) -> T (fun ctx _loc x k -> let loc = %a in let k = f1 ctx loc loc k in let k = f2 ctx loc x k in k )|} - A.patt (pvar @@ prefix ^ "loc") - A.expr (field "loc") - :: items - | _ -> items - end + A.patt + (pvar @@ prefix ^ "loc") + A.expr (field "loc") + :: items + | _ -> items) | Ptype_record lds -> - let prefix = prefix_of_record lds in - let has_attrs = has_ld ~prefix lds "attributes" in - let has_loc = has_ld ~prefix lds "loc" in - let lds = filter_labels ~prefix lds in - let items = [gen_combinator_for_record path ~prefix ~has_attrs lds] in - if has_attrs then - attributes_parser ~has_loc ~prefix - ~name:(function_name_of_path path ^ "_attributes") - :: items - else - items + let prefix = prefix_of_record lds in + let has_attrs = has_ld ~prefix lds "attributes" in + let has_loc = has_ld ~prefix lds "loc" in + let lds = filter_labels ~prefix lds in + let items = [ gen_combinator_for_record path ~prefix ~has_attrs lds ] in + if has_attrs then + attributes_parser ~has_loc ~prefix + ~name:(function_name_of_path path ^ "_attributes") + :: items + else items | Ptype_abstract | Ptype_open -> [] -;; let is_abstract td = - match td.ptype_kind with - | Ptype_abstract -> true - | _ -> false -;; + match td.ptype_kind with Ptype_abstract -> true | _ -> false let dump fn ~ext printer x = let oc = open_out (fn ^ ext) in @@ -232,47 +193,40 @@ let types = get_types ~filename in let types_with_wrapped = List.map types ~f:(fun (path, td) -> - match td.ptype_kind with - | Ptype_record lds -> - let prefix = prefix_of_record lds in - let lds' = filter_labels ~prefix lds in - (match is_wrapper ~prefix lds' with - | None -> (path, td, None) - | Some p -> - let has_attrs = has_ld ~prefix lds "attributes" in - (path, td, Some (prefix, has_attrs, p.txt))) - | _ -> (path, td, None)) + match td.ptype_kind with + | Ptype_record lds -> ( + let prefix = prefix_of_record lds in + let lds' = filter_labels ~prefix lds in + match is_wrapper ~prefix lds' with + | None -> (path, td, None) + | Some p -> + let has_attrs = has_ld ~prefix lds "attributes" in + (path, td, Some (prefix, has_attrs, p.txt))) + | _ -> (path, td, None)) in let wrapped = List.filter_map types_with_wrapped ~f:(fun (_, _, x) -> - match x with - | None -> None - | Some (_, _, p) -> Some p) + match x with None -> None | Some (_, _, p) -> Some p) in let types = List.filter types_with_wrapped ~f:(fun (path, _, _) -> - not (List.mem path ~set:wrapped)) + not (List.mem path ~set:wrapped)) |> List.map ~f:(fun (path, td, wrapped) -> - match wrapped with - | None -> (path, td, None) - | Some (prefix, has_attrs, p) -> - (path, td, Some (prefix, has_attrs, p, List.assoc p types))) + match wrapped with + | None -> (path, td, None) + | Some (prefix, has_attrs, p) -> + (path, td, Some (prefix, has_attrs, p, List.assoc p types))) in (* let all_types = List.map fst types in*) - let types = - List.sort types ~cmp:(fun (a, _, _) (b, _, _) -> - compare a b) - in + let types = List.sort types ~cmp:(fun (a, _, _) (b, _, _) -> compare a b) in let items = List.map types ~f:(fun (path, td, wrapped) -> - if is_abstract td then - [] - else - match wrapped with - | None -> gen_td path td - | Some (prefix, has_attrs, path', td') -> - gen_td ~wrapper:(path, prefix, has_attrs) path' td' - ) + if is_abstract td then [] + else + match wrapped with + | None -> gen_td path td + | Some (prefix, has_attrs, path', td') -> + gen_td ~wrapper:(path, prefix, has_attrs) path' td') |> List.flatten in let st = @@ -282,16 +236,14 @@ in dump "ast_pattern_generated" Pprintast.structure st ~ext:".ml" -let args = - [ ] +let args = [] let usage = Printf.sprintf "%s [options] <.ml files>\n" Sys.argv.(0) let () = let fns = ref [] in Arg.parse (Arg.align args) (fun fn -> fns := fn :: !fns) usage; - try - List.iter (List.rev !fns) ~f:generate + try List.iter (List.rev !fns) ~f:generate with exn -> - Errors.report_error Format.err_formatter exn; + Astlib.Location.report_exception Format.err_formatter exn; exit 2 diff -Nru ppxlib-0.15.0/src/gen/import.ml ppxlib-0.24.0/src/gen/import.ml --- ppxlib-0.15.0/src/gen/import.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/gen/import.ml 2021-12-08 21:53:37.000000000 +0000 @@ -1,3 +1,4 @@ +open Astlib include Ppxlib_ast include Ast open Ast_helper @@ -10,8 +11,9 @@ let lident x = Longident.Lident x module Loc = struct - let mk x = { Location.loc; txt = x } - let lident x = mk (Longident.parse x) + let mk x = { Location.loc; txt = x } + + let lident x = mk (Longident.parse x) [@@warning "-3"] end module List = Stdppx.List @@ -19,139 +21,133 @@ module Array = Stdppx.Array let evar v = Exp.ident (Loc.lident v) + let pvar v = Pat.var (Loc.mk v) let common_prefix l = match l with | [] -> "" - | x :: l -> - match String.index x '_' with - | i -> - let plen = i + 1 in - let prefix = String.sub x ~pos:0 ~len:plen in - let has_prefix s = - String.length s >= plen && String.sub s ~pos:0 ~len:plen = prefix - in - if List.for_all l ~f:has_prefix then - prefix - else - "" - | exception _ -> "" -;; + | x :: l -> ( + match String.index x '_' with + | i -> + let plen = i + 1 in + let prefix = String.sub x ~pos:0 ~len:plen in + let has_prefix s = + String.length s >= plen && String.sub s ~pos:0 ~len:plen = prefix + in + if List.for_all l ~f:has_prefix then prefix else "" + | exception _ -> "") let map_keyword = function - | "open" - | "private" - | "downto" - | "to" - | "mutable" - | "rec" - | "nonrec" - | "virtual" - | "type" - | "mod" - | "begin" - | "end" as s -> s ^ "_" + | ( "open" | "private" | "downto" | "to" | "mutable" | "rec" | "nonrec" + | "virtual" | "type" | "mod" | "begin" | "end" ) as s -> + s ^ "_" | s -> s -;; let function_name_of_path path = - match path with - | Lident id -> id - | _ -> assert false -;; + match path with Lident id -> id | _ -> assert false let without_prefix ~prefix s = let plen = String.length prefix in String.sub s ~pos:plen ~len:(String.length s - plen) -;; -let function_name_of_id ?(prefix="") id = +let function_name_of_id ?(prefix = "") id = let s = without_prefix ~prefix id in -(* let prefix = - if prefix <> "" && (prefix.[0] = 'p' || prefix.[0] = 'P') then - String.sub prefix ~pos:1 ~len:(String.length prefix - 1) - else - prefix - in*) + (* let prefix = + if prefix <> "" && (prefix.[0] = 'p' || prefix.[0] = 'P') then + String.sub prefix ~pos:1 ~len:(String.length prefix - 1) + else + prefix + in*) match prefix ^ s with | "::" -> "cons" | "[]" -> "nil" | "true" -> "true_" | "false" -> "false_" | s -> String.lowercase_ascii s |> map_keyword -;; let fqn_longident' path s : Longident.t = match path with | Lident _ -> Lident s | Ldot (p, _) -> Ldot (p, s) | Lapply _ -> assert false -;; let fqn_longident path id : Longident.t = fqn_longident' path id -let is_loc = function - | Lident "loc" -> true - | _ -> false -;; +let is_loc = function Lident "loc" -> true | _ -> false let get_types ~filename = (* Expand "longident_loc" into "longident loc" as it is preferable for what we do here. *) - let map = object - inherit Ast.map as super - inherit Ppxlib_traverse_builtins.map - method! core_type_desc = function - | Ptyp_constr ({ txt = Lident "longident_loc"; loc }, []) -> - Ptyp_constr ({ txt = Lident "loc"; loc}, - [Typ.constr ~loc { loc; txt = Lident "longident" } []]) - | ty -> super#core_type_desc ty - end in + let map = + object + inherit Ast.map as super + + inherit Ppxlib_traverse_builtins.map + + method! core_type_desc = + function + | Ptyp_constr ({ txt = Lident "longident_loc"; loc }, []) -> + Ptyp_constr + ( { txt = Lident "loc"; loc }, + [ Typ.constr ~loc { loc; txt = Lident "longident" } [] ] ) + | ty -> super#core_type_desc ty + end + in let ic = open_in_bin filename in let lb = Lexing.from_channel ic in let st = Parse.implementation lb in close_in ic; List.map st ~f:(function - | { pstr_desc = Pstr_type (_, tds); _} -> tds + | { pstr_desc = Pstr_type (_, tds); _ } -> tds | _ -> []) |> List.concat |> List.map ~f:map#type_declaration - |> List.map ~f:(fun td -> - (Lident td.ptype_name.txt, td)) -;; + |> List.map ~f:(fun td -> (Lident td.ptype_name.txt, td)) let is_wrapper ~prefix lds = match lds with - | [ { pld_name = { txt = s; _ } - ; pld_type = { ptyp_desc = Ptyp_constr (p, _); _ }; _ } ] + | [ + { + pld_name = { txt = s; _ }; + pld_type = { ptyp_desc = Ptyp_constr (p, _); _ }; + _; + }; + ] when s = prefix ^ "desc" -> - Some p + Some p | _ -> None -;; (* Small metaquotation system *) module M = struct let parse f fmt = Format.kasprintf (fun s -> f (Lexing.from_string s)) fmt - let expr fmt = parse Parse.expression fmt - let patt fmt = parse Parse.pattern fmt - let ctyp fmt = parse Parse.core_type fmt - let str fmt = parse Parse.implementation fmt + let expr fmt = parse Parse.expression fmt + + let patt fmt = parse Parse.pattern fmt + + let ctyp fmt = parse Parse.core_type fmt + + let str fmt = parse Parse.implementation fmt let stri fmt = Format.kasprintf (fun s -> - match Parse.implementation (Lexing.from_string s) with - | [x] -> x - | _ -> assert false) - fmt + match Parse.implementation (Lexing.from_string s) with + | [ x ] -> x + | _ -> assert false) + fmt end (* Antiquotations *) module A = struct let expr = Pprintast.expression + let patt = Pprintast.pattern + let ctyp = Pprintast.core_type - let str = Pprintast.structure - let id ppf x = Format.pp_print_string ppf (Longident.flatten x |> String.concat ~sep:".") + + let str = Pprintast.structure + + let id ppf x = + Format.pp_print_string ppf (Longident.flatten x |> String.concat ~sep:".") end diff -Nru ppxlib-0.15.0/src/gen-compiler_specifics ppxlib-0.24.0/src/gen-compiler_specifics --- ppxlib-0.15.0/src/gen-compiler_specifics 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/gen-compiler_specifics 1970-01-01 00:00:00.000000000 +0000 @@ -1,17 +0,0 @@ -(* -*- tuareg -*- *) - -open Printf - -let () = - let ver = Scanf.sscanf Sys.argv.(1) "%u.%u" (fun a b -> a, b) in - let oc = open_out_bin Sys.argv.(2) in - let pr fmt = fprintf oc (fmt ^^ "\n") in - pr "module O = Ocaml_common"; - if ver < (4, 08) then ( - pr "let get_load_path () = !Ocaml_common.Config.load_path"; - pr "let read_clflags_from_env () = ()" - ) else ( - pr "let get_load_path () = Ocaml_common.Load_path.get_paths ()"; - pr "let read_clflags_from_env () = Ocaml_common.Compmisc.read_clflags_from_env ()" - ); - close_out oc diff -Nru ppxlib-0.15.0/src/ignore_unused_warning.ml ppxlib-0.24.0/src/ignore_unused_warning.ml --- ppxlib-0.15.0/src/ignore_unused_warning.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/ignore_unused_warning.ml 2021-12-08 21:53:37.000000000 +0000 @@ -5,33 +5,78 @@ let loc = exp.pexp_loc in value_binding ~loc ~pat:(ppat_any ~loc) ~expr:exp -let vars_of = object - inherit [Longident.t Located.t list] Ast_traverse.fold as super - method! pattern patt acc = - match patt.ppat_desc with - | Ppat_var v -> Located.map (fun var -> Longident.Lident var) v :: acc - | _ -> super#pattern patt acc -end +let vars_of = + object + inherit [Longident.t Located.t list] Ast_traverse.fold as super + + method! pattern patt acc = + match patt.ppat_desc with + | Ppat_var v -> Located.map (fun var -> Longident.Lident var) v :: acc + | _ -> super#pattern patt acc + end (* For every [let x = ...] structure item, add a [let _ = x] *) -let add_dummy_user_for_values = object - inherit Ast_traverse.map as super - method! structure st = - let rec loop st acc = - match st with - | [] -> List.rev acc - | { pstr_desc = Pstr_value (_, vbs); pstr_loc = loc } as item :: rest -> - let vars = - List.fold_left vbs ~init:[] ~f:(fun acc vb -> vars_of#pattern vb.pvb_pat acc) - in - let ign = - pstr_value_list ~loc Nonrecursive - (List.rev_map vars ~f:(fun v -> - underscore_binding (pexp_ident ~loc:v.loc v))) - in - loop rest (ign @ (item :: acc)) - | item :: rest -> - loop rest (item :: acc) - in - loop (super#structure st) [] -end +let add_dummy_user_for_values = + object + inherit Ast_traverse.map as super + + method! structure st = + let rec loop st acc = + match st with + | [] -> List.rev acc + | ({ pstr_desc = Pstr_value (_, vbs); pstr_loc = loc } as item) :: rest + -> + let vars = + List.fold_left vbs ~init:[] ~f:(fun acc vb -> + vars_of#pattern vb.pvb_pat acc) + in + let ign = + pstr_value_list ~loc Nonrecursive + (List.rev_map vars ~f:(fun v -> + underscore_binding (pexp_ident ~loc:v.loc v))) + in + loop rest (ign @ (item :: acc)) + | item :: rest -> loop rest (item :: acc) + in + loop (super#structure st) [] + end + +let binds_module_names = + object + inherit [bool] Ast_traverse.fold as super + + method! module_binding mb acc = + match mb.pmb_name.txt with + | Some (_ : string) -> true + | None -> super#module_binding mb acc + + method! module_declaration md acc = + match md.pmd_name.txt with + | Some (_ : string) -> true + | None -> super#module_declaration md acc + + method! module_substitution ms _ = + match ms.pms_name.txt with (_ : string) -> true + + method! functor_parameter fp acc = + match fp with + | Unit -> acc + | Named (name, _) -> ( + match name.txt with + | Some (_ : string) -> true + | None -> super#functor_parameter fp acc) + + method! pattern pat acc = + match pat.ppat_desc with + | Ppat_unpack name -> ( + match name.txt with Some (_ : string) -> true | None -> acc) + | _ -> super#pattern pat acc + + method! expression expr acc = + match expr.pexp_desc with + | Pexp_letmodule (name, _, _) -> ( + match name.txt with + | Some (_ : string) -> true + | None -> super#expression expr acc) + | _ -> super#expression expr acc + end diff -Nru ppxlib-0.15.0/src/ignore_unused_warning.mli ppxlib-0.24.0/src/ignore_unused_warning.mli --- ppxlib-0.15.0/src/ignore_unused_warning.mli 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/ignore_unused_warning.mli 2021-12-08 21:53:37.000000000 +0000 @@ -1 +1,3 @@ val add_dummy_user_for_values : Ast_traverse.map + +val binds_module_names : bool Ast_traverse.fold diff -Nru ppxlib-0.15.0/src/keyword.ml ppxlib-0.24.0/src/keyword.ml --- ppxlib-0.15.0/src/keyword.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/src/keyword.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,3 @@ +open! Import + +let is_keyword = Astlib.Keyword.is_keyword diff -Nru ppxlib-0.15.0/src/keyword.mli ppxlib-0.24.0/src/keyword.mli --- ppxlib-0.15.0/src/keyword.mli 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/src/keyword.mli 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,2 @@ +val is_keyword : string -> bool +(** Check if a string is an OCaml keyword. *) diff -Nru ppxlib-0.15.0/src/location_check.ml ppxlib-0.24.0/src/location_check.ml --- ppxlib-0.15.0/src/location_check.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/location_check.ml 2021-12-08 21:53:37.000000000 +0000 @@ -14,48 +14,45 @@ val find_outside : Location.t -> t -> string * Location.t end = struct - type t = - { min_pos: Lexing.position option - ; max_pos: Lexing.position option - ; ranges : (string * Location.t) list - } + type t = { + min_pos : Lexing.position option; + max_pos : Lexing.position option; + ranges : (string * Location.t) list; + } let empty = { min_pos = None; max_pos = None; ranges = [] } - let rec insert ranges (node_name, node_loc as node) = + let rec insert ranges ((node_name, node_loc) as node) = match ranges with | [] -> [ node ] - | (x_name, x_loc) as x :: xs -> - let open Location in - if compare_pos node_loc.loc_start x_loc.loc_end >= 0 then - node :: x :: xs - else if compare_pos x_loc.loc_start node_loc.loc_end >= 0 then - x :: insert xs node - else - raise_errorf ~loc:node_loc - "invalid output from ppx, %s overlaps with %s at location:@.%a" - node_name x_name Location.print x_loc + | ((x_name, x_loc) as x) :: xs -> + let open Location in + if compare_pos node_loc.loc_start x_loc.loc_end >= 0 then + node :: x :: xs + else if compare_pos x_loc.loc_start node_loc.loc_end >= 0 then + x :: insert xs node + else + raise_errorf ~loc:node_loc + "invalid output from ppx, %s overlaps with %s at location:@.%a" + node_name x_name Location.print x_loc let min_pos p1 p2 = - match p1, p2 with + match (p1, p2) with | None, None -> None - | (Some _ as p), None - | None, (Some _ as p) -> p + | (Some _ as p), None | None, (Some _ as p) -> p | Some p1, Some p2 -> Some (Location.min_pos p1 p2) let max_pos p1 p2 = - match p1, p2 with + match (p1, p2) with | None, None -> None - | (Some _ as p), None - | None, (Some _ as p) -> p + | (Some _ as p), None | None, (Some _ as p) -> p | Some p1, Some p2 -> Some (Location.max_pos p1 p2) let longest_first l1 l2 ~stop_after = let rec loop xs ys n = - match xs, ys, n with - | [], _, _ - | _, _, 0 -> l2, l1 - | _, [], _ -> l1, l2 + match (xs, ys, n) with + | [], _, _ | _, _, 0 -> (l2, l1) + | _, [], _ -> (l1, l2) | _ :: xs, _ :: ys, n -> loop xs ys (n - 1) in loop l1 l2 stop_after @@ -63,30 +60,33 @@ let union t1 t2 = let init, l = longest_first t1.ranges t2.ranges ~stop_after:42 in let ranges = List.fold_left l ~init ~f:insert in - { min_pos = min_pos t1.min_pos t2.min_pos - ; max_pos = max_pos t1.max_pos t2.max_pos - ; ranges } + { + min_pos = min_pos t1.min_pos t2.min_pos; + max_pos = max_pos t1.max_pos t2.max_pos; + ranges; + } let insert ~node_name loc t = - { min_pos = min_pos (Some loc.loc_start) t.min_pos - ; max_pos = max_pos (Some loc.loc_end) t.max_pos - ; ranges = insert t.ranges (node_name, loc) + { + min_pos = min_pos (Some loc.loc_start) t.min_pos; + max_pos = max_pos (Some loc.loc_end) t.max_pos; + ranges = insert t.ranges (node_name, loc); } let covered_by t ~loc = - match t.min_pos, t.max_pos with + match (t.min_pos, t.max_pos) with | None, None -> true | Some min_pos, Some max_pos -> - Location.compare_pos min_pos loc.loc_start >= 0 && - Location.compare_pos max_pos loc.loc_end <= 0 - | _, _ -> (* there are no open ranges *) - assert false + Location.compare_pos min_pos loc.loc_start >= 0 + && Location.compare_pos max_pos loc.loc_end <= 0 + | _, _ -> + (* there are no open ranges *) + assert false let find_outside loc t = List.find t.ranges ~f:(fun (_, l) -> - Location.compare_pos loc.loc_start l.loc_start > 0 || - Location.compare_pos loc.loc_end l.loc_end < 0 - ) + Location.compare_pos loc.loc_start l.loc_start > 0 + || Location.compare_pos loc.loc_end l.loc_end < 0) end let reloc_pmty_functors x = @@ -94,21 +94,17 @@ let rec aux x = match x.pmty_desc with | Pmty_functor (Unit, initial_res) -> - let res = aux initial_res in - if res == initial_res then - x - else - { x with pmty_desc = Pmty_functor (Unit, res) } + let res = aux initial_res in + if res == initial_res then x + else { x with pmty_desc = Pmty_functor (Unit, res) } | Pmty_functor (Named (id, mty), initial_res) -> - let res = aux initial_res in - if Location.compare outmost_loc res.pmty_loc = 0 then - let loc_start = mty.pmty_loc.loc_end in - let res = { res with pmty_loc = { res.pmty_loc with loc_start } } in - { x with pmty_desc = Pmty_functor (Named (id, mty), res) } - else if res == initial_res then - x - else - { x with pmty_desc = Pmty_functor (Named (id, mty), res) } + let res = aux initial_res in + if Location.compare outmost_loc res.pmty_loc = 0 then + let loc_start = mty.pmty_loc.loc_end in + let res = { res with pmty_loc = { res.pmty_loc with loc_start } } in + { x with pmty_desc = Pmty_functor (Named (id, mty), res) } + else if res == initial_res then x + else { x with pmty_desc = Pmty_functor (Named (id, mty), res) } | _ -> x in aux x @@ -118,68 +114,69 @@ let rec aux x = match x.pmod_desc with | Pmod_functor (Unit, initial_res) -> - let res = aux initial_res in - if res == initial_res then - x - else - { x with pmod_desc = Pmod_functor (Unit, res) } + let res = aux initial_res in + if res == initial_res then x + else { x with pmod_desc = Pmod_functor (Unit, res) } | Pmod_functor (Named (id, mty), initial_res) -> - let res = aux initial_res in - if Location.compare outmost_loc res.pmod_loc = 0 then - let loc_start = mty.pmty_loc.loc_end in - let res = { res with pmod_loc = { res.pmod_loc with loc_start } } in - { x with pmod_desc = Pmod_functor (Named (id, mty), res) } - else if res == initial_res then - x - else - { x with pmod_desc = Pmod_functor (Named (id, mty), res) } + let res = aux initial_res in + if Location.compare outmost_loc res.pmod_loc = 0 then + let loc_start = mty.pmty_loc.loc_end in + let res = { res with pmod_loc = { res.pmod_loc with loc_start } } in + { x with pmod_desc = Pmod_functor (Named (id, mty), res) } + else if res == initial_res then x + else { x with pmod_desc = Pmod_functor (Named (id, mty), res) } | _ -> x in aux x let all_payloads_inside_parent ~loc = - List.for_all - ~f:(fun attr -> Location.compare_pos loc.loc_end attr.attr_loc.loc_end >= 0) + List.for_all ~f:(fun attr -> + Location.compare_pos loc.loc_end attr.attr_loc.loc_end >= 0) let file : string option ref = ref None + let same_file_so_far = ref true -let stayed_in_the_same_file = - fun fname -> - (* TODO: remove uses of Location.none from the ppxes. *) - if String.equal fname "_none_" then - true (* do nothing for now. *) - else - match !file with - | None -> file := Some fname; true - | Some orig_fname -> - String.equal orig_fname fname || (same_file_so_far := false; false) +let stayed_in_the_same_file fname = + (* TODO: remove uses of Location.none from the ppxes. *) + if String.equal fname "_none_" then true (* do nothing for now. *) + else + match !file with + | None -> + file := Some fname; + true + | Some orig_fname -> + String.equal orig_fname fname + || + (same_file_so_far := false; + false) let should_ignore loc attrs = (* If the filename changed, then there were line directives, and the locations are all messed up. *) - not (stayed_in_the_same_file loc.loc_start.pos_fname) || - (* Ignore things explicitely marked. *) - List.exists ~f:(fun attr -> - String.equal attr.attr_name.txt Merlin_helpers.hide_attribute.attr_name.txt - ) attrs + (not (stayed_in_the_same_file loc.loc_start.pos_fname)) + || (* Ignore things explicitly marked. *) + List.exists + ~f:(fun attr -> + String.equal attr.attr_name.txt + Merlin_helpers.hide_attribute.attr_name.txt) + 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, None, ct) -> Some (e, ct) | Pexp_newtype (name, exp) -> - Option.map (extract_constraint exp) ~f:(fun (exp, ct) -> - { e with - pexp_desc = Pexp_newtype (name, exp); - pexp_loc = { e.pexp_loc with loc_ghost = true } - }, ct - ) + Option.map (extract_constraint exp) ~f:(fun (exp, ct) -> + ( { + e with + pexp_desc = Pexp_newtype (name, exp); + pexp_loc = { e.pexp_loc with loc_ghost = true }; + }, + ct )) | _ -> None let do_check ~node_name node_loc childrens_locs siblings_locs = - if not !same_file_so_far then - Non_intersecting_ranges.empty + if not !same_file_so_far then Non_intersecting_ranges.empty else if node_loc.loc_ghost then Non_intersecting_ranges.union childrens_locs siblings_locs else if Non_intersecting_ranges.covered_by childrens_locs ~loc:node_loc then @@ -189,17 +186,18 @@ Non_intersecting_ranges.find_outside node_loc childrens_locs in Location.raise_errorf ~loc:node_loc - "invalid output from ppx:@ this %s is built from a%s whose location is outside \ - of this node's.@.Child %s found at:@ %a" + "invalid output from ppx:@ this %s is built from a%s whose location is \ + outside of this node's.@.Child %s found at:@ %a" node_name ((match String.unsafe_get child_name 0 with - | 'a' | 'e' | 'i' | 'o' | 'u' -> "n " - | _ -> " ") ^ child_name) + | 'a' | 'e' | 'i' | 'o' | 'u' -> "n " + | _ -> " ") + ^ child_name) child_name Location.print child_loc let enforce_invariants fname = let () = file := fname in - object(self) + object (self) inherit [Non_intersecting_ranges.t] Ast_traverse.fold as super (* TODO: we should generate a class which enforces the location invariant. @@ -209,53 +207,58 @@ That would ensure that we stay up to date as the AST changes. *) method! longident_loc x siblings = - if x.loc.loc_ghost then - siblings - else - Non_intersecting_ranges.insert ~node_name:"ident" x.loc siblings + if x.loc.loc_ghost then siblings + else Non_intersecting_ranges.insert ~node_name:"ident" x.loc siblings method! row_field x siblings_locs = - if should_ignore x.prf_loc x.prf_attributes then - siblings_locs + if should_ignore x.prf_loc x.prf_attributes then siblings_locs else let childrens_locs = super#row_field x Non_intersecting_ranges.empty in do_check ~node_name:"row field" x.prf_loc childrens_locs siblings_locs method! object_field x siblings_locs = - if should_ignore x.pof_loc x.pof_attributes then - siblings_locs + if should_ignore x.pof_loc x.pof_attributes then siblings_locs else - let childrens_locs = super#object_field x Non_intersecting_ranges.empty in - do_check ~node_name:"object field" x.pof_loc childrens_locs siblings_locs + let childrens_locs = + super#object_field x Non_intersecting_ranges.empty + in + do_check ~node_name:"object field" x.pof_loc childrens_locs + siblings_locs method! binding_op x siblings_locs = let childrens_locs = super#binding_op x Non_intersecting_ranges.empty in - do_check ~node_name:"binding operator" x.pbop_loc childrens_locs siblings_locs + do_check ~node_name:"binding operator" x.pbop_loc childrens_locs + siblings_locs method! value_description x siblings_locs = - if should_ignore x.pval_loc x.pval_attributes then - siblings_locs + if should_ignore x.pval_loc x.pval_attributes then siblings_locs else - let childrens_locs = super#value_description x Non_intersecting_ranges.empty in - do_check ~node_name:"value description" x.pval_loc childrens_locs siblings_locs + let childrens_locs = + super#value_description x Non_intersecting_ranges.empty + in + do_check ~node_name:"value description" x.pval_loc childrens_locs + siblings_locs method! type_declaration x siblings_locs = - if should_ignore x.ptype_loc x.ptype_attributes then - siblings_locs + if should_ignore x.ptype_loc x.ptype_attributes then siblings_locs else - let childrens_locs = super#type_declaration x Non_intersecting_ranges.empty in - do_check ~node_name:"type declaration" x.ptype_loc childrens_locs siblings_locs + let childrens_locs = + super#type_declaration x Non_intersecting_ranges.empty + in + do_check ~node_name:"type declaration" x.ptype_loc childrens_locs + siblings_locs method! label_declaration x siblings_locs = - if should_ignore x.pld_loc x.pld_attributes then - siblings_locs + if should_ignore x.pld_loc x.pld_attributes then siblings_locs else - let childrens_locs = super#label_declaration x Non_intersecting_ranges.empty in - do_check ~node_name:"label declaration" x.pld_loc childrens_locs siblings_locs + let childrens_locs = + super#label_declaration x Non_intersecting_ranges.empty + in + do_check ~node_name:"label declaration" x.pld_loc childrens_locs + siblings_locs method! constructor_declaration x siblings_locs = - if should_ignore x.pcd_loc x.pcd_attributes then - siblings_locs + if should_ignore x.pcd_loc x.pcd_attributes then siblings_locs else let childrens_locs = super#constructor_declaration x Non_intersecting_ranges.empty @@ -264,111 +267,130 @@ siblings_locs method! type_extension x siblings_locs = - if should_ignore x.ptyext_loc x.ptyext_attributes then - siblings_locs + if should_ignore x.ptyext_loc x.ptyext_attributes then siblings_locs else - let childrens_locs = super#type_extension x Non_intersecting_ranges.empty in - do_check ~node_name:"type extension" x.ptyext_loc childrens_locs siblings_locs + let childrens_locs = + super#type_extension x Non_intersecting_ranges.empty + in + do_check ~node_name:"type extension" x.ptyext_loc childrens_locs + siblings_locs method! extension_constructor x siblings_locs = - if should_ignore x.pext_loc x.pext_attributes then - siblings_locs + if should_ignore x.pext_loc x.pext_attributes then siblings_locs else - let childrens_locs = super#extension_constructor x Non_intersecting_ranges.empty in - do_check ~node_name:"extension constructor" x.pext_loc childrens_locs siblings_locs + let childrens_locs = + super#extension_constructor x Non_intersecting_ranges.empty + in + do_check ~node_name:"extension constructor" x.pext_loc childrens_locs + siblings_locs method! class_type x siblings_locs = - if should_ignore x.pcty_loc x.pcty_attributes then - siblings_locs + if should_ignore x.pcty_loc x.pcty_attributes then siblings_locs else let childrens_locs = super#class_type x Non_intersecting_ranges.empty in do_check ~node_name:"class type" x.pcty_loc childrens_locs siblings_locs method! class_type_field x siblings_locs = - if should_ignore x.pctf_loc x.pctf_attributes then - siblings_locs + if should_ignore x.pctf_loc x.pctf_attributes then siblings_locs else - let childrens_locs = super#class_type_field x Non_intersecting_ranges.empty in - do_check ~node_name:"class type field" x.pctf_loc childrens_locs siblings_locs + let childrens_locs = + super#class_type_field x Non_intersecting_ranges.empty + in + do_check ~node_name:"class type field" x.pctf_loc childrens_locs + siblings_locs method! class_infos f x siblings_locs = - if should_ignore x.pci_loc x.pci_attributes then - siblings_locs + if should_ignore x.pci_loc x.pci_attributes then siblings_locs else - let childrens_locs = super#class_infos f x Non_intersecting_ranges.empty in + let childrens_locs = + super#class_infos f x Non_intersecting_ranges.empty + in do_check ~node_name:"class" x.pci_loc childrens_locs siblings_locs method! class_expr x siblings_locs = - if should_ignore x.pcl_loc x.pcl_attributes then - siblings_locs + if should_ignore x.pcl_loc x.pcl_attributes then siblings_locs else let childrens_locs = super#class_expr x Non_intersecting_ranges.empty in - do_check ~node_name:"class expression" x.pcl_loc childrens_locs siblings_locs + do_check ~node_name:"class expression" x.pcl_loc childrens_locs + siblings_locs method! class_field x siblings_locs = - if should_ignore x.pcf_loc x.pcf_attributes then - siblings_locs + if should_ignore x.pcf_loc x.pcf_attributes then siblings_locs else - let childrens_locs = super#class_field x Non_intersecting_ranges.empty in + let childrens_locs = + super#class_field x Non_intersecting_ranges.empty + in do_check ~node_name:"class field" x.pcf_loc childrens_locs siblings_locs method! signature_item x siblings_locs = - if should_ignore x.psig_loc [] then - siblings_locs + if should_ignore x.psig_loc [] then siblings_locs else - let childrens_locs = super#signature_item x Non_intersecting_ranges.empty in - do_check ~node_name:"signature item" x.psig_loc childrens_locs siblings_locs + let childrens_locs = + super#signature_item x Non_intersecting_ranges.empty + in + do_check ~node_name:"signature item" x.psig_loc childrens_locs + siblings_locs method! module_declaration x siblings_locs = - if should_ignore x.pmd_loc x.pmd_attributes then - siblings_locs + if should_ignore x.pmd_loc x.pmd_attributes then siblings_locs else - let childrens_locs = super#module_declaration x Non_intersecting_ranges.empty in - do_check ~node_name:"module declaration" x.pmd_loc childrens_locs siblings_locs + let childrens_locs = + super#module_declaration x Non_intersecting_ranges.empty + in + do_check ~node_name:"module declaration" x.pmd_loc childrens_locs + siblings_locs method! module_substitution x siblings_locs = - if should_ignore x.pms_loc x.pms_attributes then - siblings_locs + if should_ignore x.pms_loc x.pms_attributes then siblings_locs else - let childrens_locs = super#module_substitution x Non_intersecting_ranges.empty in - do_check ~node_name:"module substitution" x.pms_loc childrens_locs siblings_locs + let childrens_locs = + super#module_substitution x Non_intersecting_ranges.empty + in + do_check ~node_name:"module substitution" x.pms_loc childrens_locs + siblings_locs method! module_type_declaration x siblings_locs = - if should_ignore x.pmtd_loc x.pmtd_attributes then - siblings_locs + if should_ignore x.pmtd_loc x.pmtd_attributes then siblings_locs else let childrens_locs = super#module_type_declaration x Non_intersecting_ranges.empty in - do_check ~node_name:"module type declaration" x.pmtd_loc childrens_locs siblings_locs + do_check ~node_name:"module type declaration" x.pmtd_loc childrens_locs + siblings_locs method! open_infos f x siblings_locs = - if should_ignore x.popen_loc x.popen_attributes then - siblings_locs + if should_ignore x.popen_loc x.popen_attributes then siblings_locs else - let childrens_locs = super#open_infos f x Non_intersecting_ranges.empty in + let childrens_locs = + super#open_infos f x Non_intersecting_ranges.empty + in do_check ~node_name:"open" x.popen_loc childrens_locs siblings_locs method! include_infos f x siblings_locs = - if should_ignore x.pincl_loc x.pincl_attributes then - siblings_locs + if should_ignore x.pincl_loc x.pincl_attributes then siblings_locs else - let childrens_locs = super#include_infos f x Non_intersecting_ranges.empty in + let childrens_locs = + super#include_infos f x Non_intersecting_ranges.empty + in do_check ~node_name:"include" x.pincl_loc childrens_locs siblings_locs method! structure_item x siblings_locs = - if should_ignore x.pstr_loc [] then - siblings_locs + if should_ignore x.pstr_loc [] then siblings_locs else - let childrens_locs = super#structure_item x Non_intersecting_ranges.empty in - do_check ~node_name:"structure item" x.pstr_loc childrens_locs siblings_locs + let childrens_locs = + super#structure_item x Non_intersecting_ranges.empty + in + do_check ~node_name:"structure item" x.pstr_loc childrens_locs + siblings_locs method! module_binding x siblings_locs = - if should_ignore x.pmb_loc x.pmb_attributes then - siblings_locs + if should_ignore x.pmb_loc x.pmb_attributes then siblings_locs else - let childrens_locs = super#module_binding x Non_intersecting_ranges.empty in - do_check ~node_name:"module binding" x.pmb_loc childrens_locs siblings_locs + let childrens_locs = + super#module_binding x Non_intersecting_ranges.empty + in + do_check ~node_name:"module binding" x.pmb_loc childrens_locs + siblings_locs (******************************************) (* The following is special cased because *) @@ -376,29 +398,29 @@ (******************************************) method! value_binding x siblings_locs = - if should_ignore x.pvb_loc x.pvb_attributes then - siblings_locs + if should_ignore x.pvb_loc x.pvb_attributes then siblings_locs else let childrens_locs = - match x.pvb_pat.ppat_desc, extract_constraint x.pvb_expr with - | (* let x : type a b c. ct = e *) - Ppat_constraint (pvb_pat, { ptyp_desc = Ptyp_poly (_ :: _, ctp); _ }), - Some (pvb_expr, cte) - | (* let x : ct = e - let x :> ct = e *) - Ppat_constraint (pvb_pat, { ptyp_desc = Ptyp_poly ([], ctp); _ }), - Some (pvb_expr, cte) + match (x.pvb_pat.ppat_desc, extract_constraint x.pvb_expr) with + (* let x : type a b c. ct = e *) + | ( Ppat_constraint + (pvb_pat, { ptyp_desc = Ptyp_poly (_ :: _, ctp); _ }), + Some (pvb_expr, cte) ) + (* let x : ct = e + let x :> ct = e *) + | ( Ppat_constraint (pvb_pat, { ptyp_desc = Ptyp_poly ([], ctp); _ }), + Some (pvb_expr, cte) ) when Location.compare ctp.ptyp_loc cte.ptyp_loc = 0 -> - let acc = Non_intersecting_ranges.empty in - let acc = self#pattern pvb_pat acc in - let _acc = self#core_type ctp acc in - let acc = self#expression pvb_expr acc in - let acc = self#attributes x.pvb_attributes acc in - acc - | _ -> - super#value_binding x Non_intersecting_ranges.empty + let acc = Non_intersecting_ranges.empty in + let acc = self#pattern pvb_pat acc in + let _acc = self#core_type ctp acc in + let acc = self#expression pvb_expr acc in + let acc = self#attributes x.pvb_attributes acc in + acc + | _ -> super#value_binding x Non_intersecting_ranges.empty in - do_check ~node_name:"value binding" x.pvb_loc childrens_locs siblings_locs + do_check ~node_name:"value binding" x.pvb_loc childrens_locs + siblings_locs (**********************************************) (* The following is special cased because of: *) @@ -412,19 +434,21 @@ (**********************************************) method! module_type x siblings_locs = - if should_ignore x.pmty_loc x.pmty_attributes then - siblings_locs + if should_ignore x.pmty_loc x.pmty_attributes then siblings_locs else let x = reloc_pmty_functors x in let childrens_locs = if all_payloads_inside_parent ~loc:x.pmty_loc x.pmty_attributes then super#module_type x Non_intersecting_ranges.empty else - let acc = self#module_type_desc x.pmty_desc Non_intersecting_ranges.empty in + let acc = + self#module_type_desc x.pmty_desc Non_intersecting_ranges.empty + in let _ = self#attributes x.pmty_attributes acc in acc in - do_check ~node_name:"module type" x.pmty_loc childrens_locs siblings_locs + do_check ~node_name:"module type" x.pmty_loc childrens_locs + siblings_locs (**********************************************) (* The following is special cased because of: *) @@ -438,33 +462,36 @@ (**********************************************) method! module_expr x siblings_locs = - if should_ignore x.pmod_loc x.pmod_attributes then - siblings_locs + if should_ignore x.pmod_loc x.pmod_attributes then siblings_locs else let x = reloc_pmod_functors x in let childrens_locs = if all_payloads_inside_parent ~loc:x.pmod_loc x.pmod_attributes then super#module_expr x Non_intersecting_ranges.empty else - let acc = self#module_expr_desc x.pmod_desc Non_intersecting_ranges.empty in + let acc = + self#module_expr_desc x.pmod_desc Non_intersecting_ranges.empty + in let _ = self#attributes x.pmod_attributes acc in acc in - do_check ~node_name:"module expression" x.pmod_loc childrens_locs siblings_locs + do_check ~node_name:"module expression" x.pmod_loc childrens_locs + siblings_locs (*********************) (* Same as above ... *) (*********************) method! core_type x siblings_locs = - if should_ignore x.ptyp_loc x.ptyp_attributes then - siblings_locs + if should_ignore x.ptyp_loc x.ptyp_attributes then siblings_locs else let childrens_locs = if all_payloads_inside_parent ~loc:x.ptyp_loc x.ptyp_attributes then super#core_type x Non_intersecting_ranges.empty else - let acc = self#core_type_desc x.ptyp_desc Non_intersecting_ranges.empty in + let acc = + self#core_type_desc x.ptyp_desc Non_intersecting_ranges.empty + in let _ = self#attributes x.ptyp_attributes acc in acc in @@ -475,14 +502,15 @@ (*****************) method! expression x siblings_locs = - if should_ignore x.pexp_loc x.pexp_attributes then - siblings_locs + if should_ignore x.pexp_loc x.pexp_attributes then siblings_locs else let childrens_locs = if all_payloads_inside_parent ~loc:x.pexp_loc x.pexp_attributes then super#expression x Non_intersecting_ranges.empty else - let acc = self#expression_desc x.pexp_desc Non_intersecting_ranges.empty in + let acc = + self#expression_desc x.pexp_desc Non_intersecting_ranges.empty + in let _ = self#attributes x.pexp_attributes acc in acc in @@ -493,20 +521,20 @@ (*****************) method! pattern x siblings_locs = - if should_ignore x.ppat_loc x.ppat_attributes then - siblings_locs + if should_ignore x.ppat_loc x.ppat_attributes then siblings_locs else let childrens_locs = if all_payloads_inside_parent ~loc:x.ppat_loc x.ppat_attributes then super#pattern x Non_intersecting_ranges.empty else - let acc = self#pattern_desc x.ppat_desc Non_intersecting_ranges.empty in + let acc = + self#pattern_desc x.ppat_desc Non_intersecting_ranges.empty + in let _ = self#attributes x.ppat_attributes acc in acc in do_check ~node_name:"pattern" x.ppat_loc childrens_locs siblings_locs - (***********************************************************) (* The following is special cased because the location of *) (* the construct equals the location of the type_exception *) @@ -514,31 +542,30 @@ (***********************************************************) method! type_exception x siblings_locs = - if should_ignore x.ptyexn_loc x.ptyexn_attributes then - siblings_locs + if should_ignore x.ptyexn_loc x.ptyexn_attributes then siblings_locs else let init = Non_intersecting_ranges.empty in - let childs_locs = self#extension_constructor x.ptyexn_constructor init in + let childs_locs = + self#extension_constructor x.ptyexn_constructor init + in let attrs_locs = self#attributes x.ptyexn_attributes init in - ignore (do_check ~node_name:"exception" x.ptyexn_loc attrs_locs siblings_locs); + ignore + (do_check ~node_name:"exception" x.ptyexn_loc attrs_locs siblings_locs); do_check ~node_name:"exception" x.ptyexn_loc childs_locs siblings_locs - (******************************************) - (* The following is overriden because the *) - (* lhs is sometimes included in the rhs. *) - (******************************************) + (*******************************************) + (* The following is overridden because the *) + (* lhs is sometimes included in the rhs. *) + (*******************************************) method! with_constraint x siblings_loc = match x with - | Pwith_type (_, tdecl) - | Pwith_typesubst (_, tdecl) -> - self#type_declaration tdecl siblings_loc - | _ -> - super#with_constraint x siblings_loc - + | Pwith_type (_, tdecl) | Pwith_typesubst (_, tdecl) -> + self#type_declaration tdecl siblings_loc + | _ -> super#with_constraint x siblings_loc (******************************************) - (* The following is overriden because of: *) + (* The following is overridden because of:*) (* - Foo.{ bar; ... } *) (* - Foo.[ bar; ... ] *) (* - Foo.( bar; ... ) *) @@ -554,60 +581,65 @@ method! expression_desc x acc = match x with | Pexp_record (labels, expr_o) -> - let acc = - self#list - (fun (lid, e) acc-> - if Location.compare_pos lid.loc.loc_start e.pexp_loc.loc_start = 0 then - if Location.compare lid.loc e.pexp_loc = 0 then - (* punning. *) - self#longident_loc lid acc - else - match e.pexp_desc with - | Pexp_constraint (e, c) -> - (* { foo : int } and { foo : int = x } ... *) - let _ = self#core_type c acc in - self#expression e acc - | _ -> - (* No idea what's going on there. *) - self#expression e acc - else - let acc = self#longident_loc lid acc in - let acc = self#expression e acc in acc) labels acc - in - self#option self#expression expr_o acc - | Pexp_open ({ popen_expr = { pmod_desc = Pmod_ident lid; _ }; _ } as opn, e) + let acc = + self#list + (fun (lid, e) acc -> + if + Location.compare_pos lid.loc.loc_start e.pexp_loc.loc_start + = 0 + then + if Location.compare lid.loc e.pexp_loc = 0 then + (* punning. *) + self#longident_loc lid acc + else + match e.pexp_desc with + | Pexp_constraint (e, c) -> + (* { foo : int } and { foo : int = x } ... *) + let _ = self#core_type c acc in + self#expression e acc + | _ -> + (* No idea what's going on there. *) + self#expression e acc + else + let acc = self#longident_loc lid acc in + let acc = self#expression e acc in + acc) + labels acc + in + self#option self#expression expr_o acc + | Pexp_open + (({ popen_expr = { pmod_desc = Pmod_ident lid; _ }; _ } as opn), e) when Location.compare_pos lid.loc.loc_start e.pexp_loc.loc_start = 0 - && Location.compare_pos lid.loc.loc_end e.pexp_loc.loc_end <> 0 -> - (* let's relocate ... *) - let e_loc = { e.pexp_loc with loc_start = lid.loc.loc_end } in - super#expression_desc (Pexp_open (opn, { e with pexp_loc = e_loc })) acc - | Pexp_poly (e, Some { ptyp_desc = Ptyp_poly (_, ct); _ }) -> - begin match extract_constraint e with - | Some (e, cte) when Location.compare cte.ptyp_loc ct.ptyp_loc = 0 -> - let acc = self#expression e acc in - let acc = self#core_type ct acc in - acc - | _ -> - super#expression_desc x acc - end - | Pexp_apply ({ pexp_desc = Pexp_ident { txt = lid; _ }; _ }, args) -> - begin match Longident.last_exn lid with - | id when String.is_prefix id ~prefix:"." - && (String.is_suffix id ~suffix:"()" || - String.is_suffix id ~suffix:"()<-" || - String.is_suffix id ~suffix:"[]" || - String.is_suffix id ~suffix:"[]<-" || - String.is_suffix id ~suffix:"{}" || - String.is_suffix id ~suffix:"{}<-") -> - self#list (fun (_, e) -> self#expression e) args acc - | exception _ -> super#expression_desc x acc - | _ -> super#expression_desc x acc - end - | _ -> - super#expression_desc x acc + && Location.compare_pos lid.loc.loc_end e.pexp_loc.loc_end <> 0 -> + (* let's relocate ... *) + let e_loc = { e.pexp_loc with loc_start = lid.loc.loc_end } in + super#expression_desc + (Pexp_open (opn, { e with pexp_loc = e_loc })) + acc + | Pexp_poly (e, Some { ptyp_desc = Ptyp_poly (_, ct); _ }) -> ( + match extract_constraint e with + | Some (e, cte) when Location.compare cte.ptyp_loc ct.ptyp_loc = 0 -> + let acc = self#expression e acc in + let acc = self#core_type ct acc in + acc + | _ -> super#expression_desc x acc) + | Pexp_apply ({ pexp_desc = Pexp_ident { txt = lid; _ }; _ }, args) -> ( + match Longident.last_exn lid with + | id + when String.is_prefix id ~prefix:"." + && (String.is_suffix id ~suffix:"()" + || String.is_suffix id ~suffix:"()<-" + || String.is_suffix id ~suffix:"[]" + || String.is_suffix id ~suffix:"[]<-" + || String.is_suffix id ~suffix:"{}" + || String.is_suffix id ~suffix:"{}<-") -> + self#list (fun (_, e) -> self#expression e) args acc + | exception _ -> super#expression_desc x acc + | _ -> super#expression_desc x acc) + | _ -> super#expression_desc x acc (*******************************************************) - (* The following is overriden because of: *) + (* The following is overridden because of: *) (* - punning. *) (* - record field with type constraint. *) (* - unpack locations being incorrect when constrained *) @@ -616,64 +648,66 @@ method! pattern_desc x acc = match x with | Ppat_record (labels, _) -> - self#list - (fun (lid, pat) acc -> - if Location.compare_pos lid.loc.loc_start pat.ppat_loc.loc_start = 0 then - if Location.compare lid.loc pat.ppat_loc = 0 then - (* simple punning! *) - self#longident_loc lid acc - else - match pat.ppat_desc with - | Ppat_constraint (p, c) -> - (* { foo : int } and { foo : int = x } ... *) - let _ = self#core_type c acc in - self#pattern p acc - | _ -> - (* No idea what's going on there. *) - self#pattern pat acc - else - let acc = self#longident_loc lid acc in - let acc = self#pattern pat acc in acc) labels acc + self#list + (fun (lid, pat) acc -> + if + Location.compare_pos lid.loc.loc_start pat.ppat_loc.loc_start + = 0 + then + if Location.compare lid.loc pat.ppat_loc = 0 then + (* simple punning! *) + self#longident_loc lid acc + else + match pat.ppat_desc with + | Ppat_constraint (p, c) -> + (* { foo : int } and { foo : int = x } ... *) + let _ = self#core_type c acc in + self#pattern p acc + | _ -> + (* No idea what's going on there. *) + self#pattern pat acc + else + let acc = self#longident_loc lid acc in + let acc = self#pattern pat acc in + acc) + labels acc | Ppat_constraint ({ ppat_desc = Ppat_unpack a; _ }, b) -> - let acc = self#loc (self#option self#string) a acc in - self#core_type b acc - | _ -> - super#pattern_desc x acc + let acc = self#loc (self#option self#string) a acc in + self#core_type b acc + | _ -> super#pattern_desc x acc - (**********************************************************) - (* The following is overriden because the location of the *) - (* fake structure for a generative argument covers the *) - (* location of the functor. *) - (**********************************************************) + (***********************************************************) + (* The following is overridden because the location of the *) + (* fake structure for a generative argument covers the *) + (* location of the functor. *) + (***********************************************************) method! module_expr_desc x acc = match x with | Pmod_apply (m, { pmod_desc = Pmod_structure []; pmod_loc; _ }) when Location.compare_pos m.pmod_loc.loc_start pmod_loc.loc_start = 0 -> - super#module_expr m acc - | _ -> - super#module_expr_desc x acc + super#module_expr m acc + | _ -> super#module_expr_desc x acc - (**********************************************************) - (* The following is overriden because the location of the *) - (* open_infos for Pcl_open only covers the "open" keyword *) - (* and not the module opened. *) - (**********************************************************) + (***********************************************************) + (* The following is overridden because the location of the *) + (* open_infos for Pcl_open only covers the "open" keyword *) + (* and not the module opened. *) + (***********************************************************) method! class_expr_desc x acc = match x with | Pcl_open (od, ce) -> - (* inline of open_description (which effectively makes that node - disappear) *) - let acc = self#longident_loc od.popen_expr acc in - let acc = self#override_flag od.popen_override acc in - let acc = self#location od.popen_loc acc in - let acc = self#attributes od.popen_attributes acc in - (* continue *) - let acc = self#class_expr ce acc in - acc - | _ -> - super#class_expr_desc x acc + (* inline of open_description (which effectively makes that node + disappear) *) + let acc = self#longident_loc od.popen_expr acc in + let acc = self#override_flag od.popen_override acc in + let acc = self#location od.popen_loc acc in + let acc = self#attributes od.popen_attributes acc in + (* continue *) + let acc = self#class_expr ce acc in + acc + | _ -> super#class_expr_desc x acc (*********************) (* Same as above ... *) @@ -682,28 +716,24 @@ method! class_type_desc x acc = match x with | Pcty_open (od, ct) -> - (* inline of open_description (which effectively makes that node - disappear) *) - let acc = self#longident_loc od.popen_expr acc in - let acc = self#override_flag od.popen_override acc in - let acc = self#location od.popen_loc acc in - let acc = self#attributes od.popen_attributes acc in - (* continue *) - let acc = self#class_type ct acc in - acc - | _ -> - super#class_type_desc x acc + (* inline of open_description (which effectively makes that node + disappear) *) + let acc = self#longident_loc od.popen_expr acc in + let acc = self#override_flag od.popen_override acc in + let acc = self#location od.popen_loc acc in + let acc = self#attributes od.popen_attributes acc in + (* continue *) + let acc = self#class_type ct acc in + acc + | _ -> super#class_type_desc x acc (**********************************************************) - (* The following is overriden because docstrings have the *) - (* same location as the item they get attached to. *) + (* The following is overridden because docstrings have *) + (* the same location as the item they get attached to. *) (**********************************************************) method! attribute x acc = match x.attr_name.txt with - | "ocaml.doc" - | "ocaml.text" -> - acc + | "ocaml.doc" | "ocaml.text" -> acc | _ -> super#attribute x acc - end diff -Nru ppxlib-0.15.0/src/location_check.mli ppxlib-0.24.0/src/location_check.mli --- ppxlib-0.15.0/src/location_check.mli 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/location_check.mli 2021-12-08 21:53:37.000000000 +0000 @@ -3,6 +3,7 @@ (** {2 What?} The invariants are as follow: + - AST nodes are requested to be well nested wrt. locations - the locations of "sibling" AST nodes should not overlap @@ -25,28 +26,27 @@ when manipulating the AST. The intended way to deal with locations is this: + - AST nodes that exist in the source should keep their original location - new nodes should be given a "ghost" location (i.e. - [{ some_loc with loc_ghost = true }]) to indicate that the node doesn't - exist in the sources. + [{ some_loc with loc_ghost = true }]) to indicate that the node doesn't + exist in the sources. Both the new check and merlin will happily traverse these ghost nodes as if - they didn't exist. - Note: this comes into play when deciding which nodes are "siblings", for - instance if your AST is: + they didn't exist. Note: this comes into play when deciding which nodes are + "siblings", for instance if your AST is: + {v A (B1(C, D), B2(X, Y)) v} + but [B2] has a ghost location, then [B1], [X] and [Y] are considered siblings. - - Additionally, there is an attribute [[@merlin.hide]] that you can add on + Additionally, there is an attribute [\[@merlin.hide\]] that you can add on nodes to tell merlin (and the check) to ignore this node and all of its - children. - Some helpers for this are provided in {!Merlin_helpers}. -*) + children. Some helpers for this are provided in {!Merlin_helpers}. *) open! Import @@ -56,4 +56,5 @@ val empty : t end -val enforce_invariants : string option -> Non_intersecting_ranges.t Ast_traverse.fold +val enforce_invariants : + string option -> Non_intersecting_ranges.t Ast_traverse.fold diff -Nru ppxlib-0.15.0/src/location.ml ppxlib-0.24.0/src/location.ml --- ppxlib-0.15.0/src/location.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/location.ml 2021-12-08 21:53:37.000000000 +0000 @@ -1,48 +1,46 @@ open Import +module L = Astlib.Location -module L = Ocaml_common.Location - -type t = location = - { loc_start : Lexing.position - ; loc_end : Lexing.position - ; loc_ghost : bool - } +type t = location = { + loc_start : Lexing.position; + loc_end : Lexing.position; + loc_ghost : bool; +} let in_file name = - let loc = - { pos_fname = name - ; pos_lnum = 1 - ; pos_bol = 0 - ; pos_cnum = -1 - } - in - { loc_start = loc - ; loc_end = loc - ; loc_ghost = true - } + let loc = { pos_fname = name; pos_lnum = 1; pos_bol = 0; pos_cnum = -1 } in + { loc_start = loc; loc_end = loc; loc_ghost = true } + +let set_filename loc fn = + let loc_start = { loc.loc_start with pos_fname = fn } in + let loc_end = { loc.loc_end with pos_fname = fn } in + { loc with loc_start; loc_end } let none = in_file "_none_" +let init lexbuf fname = + let open Lexing in + lexbuf.lex_curr_p <- + { pos_fname = fname; pos_lnum = 1; pos_bol = 0; pos_cnum = 0 } + let raise_errorf ?loc fmt = L.raise_errorf ?loc fmt + let report_exception = L.report_exception let of_lexbuf (lexbuf : Lexing.lexbuf) = - { loc_start = lexbuf.lex_start_p - ; loc_end = lexbuf.lex_curr_p - ; loc_ghost = false + { + loc_start = lexbuf.lex_start_p; + loc_end = lexbuf.lex_curr_p; + loc_ghost = false; } let print ppf t = Caml.Format.fprintf ppf "File \"%s\", line %d, characters %d-%d:" - t.loc_start.pos_fname - t.loc_start.pos_lnum + t.loc_start.pos_fname t.loc_start.pos_lnum (t.loc_start.pos_cnum - t.loc_start.pos_bol) - (t.loc_end.pos_cnum - t.loc_start.pos_bol) + (t.loc_end.pos_cnum - t.loc_start.pos_bol) -type nonrec 'a loc = 'a loc = - { txt : 'a - ; loc : t - } +type nonrec 'a loc = 'a loc = { txt : 'a; loc : t } let compare_pos p1 p2 = let open Lexing in @@ -57,11 +55,9 @@ | 0 -> Int.compare (column p1) (column p2) | n -> n -let min_pos p1 p2 = - if compare_pos p1 p2 <= 0 then p1 else p2 +let min_pos p1 p2 = if compare_pos p1 p2 <= 0 then p1 else p2 -let max_pos p1 p2 = - if compare_pos p1 p2 >= 0 then p1 else p2 +let max_pos p1 p2 = if compare_pos p1 p2 >= 0 then p1 else p2 let compare loc1 loc2 = match compare_pos loc1.loc_start loc2.loc_start with @@ -69,26 +65,12 @@ | n -> n module Error = struct - module Helpers = Selected_ast.Ast.Ast_mapper - - type t = Helpers.location_error - - let make = Helpers.make_error_of_message - let createf ~loc fmt = - Printf.ksprintf - (fun str -> Helpers.make_error_of_message ~loc ~sub:[] str) fmt - - let message = Helpers.get_error_message - let set_message = Helpers.set_error_message - - let register_error_of_exn = Helpers.register_error_of_exn - - let of_exn = Helpers.error_of_exn + include Ppxlib_ast.Location_error - let to_extension = Helpers.extension_of_error + let createf ~loc fmt = Format.kasprintf (fun str -> make ~loc ~sub:[] str) fmt end -exception Error of Error.t +exception Error = L.Error let () = Caml.Printexc.register_printer (function diff -Nru ppxlib-0.15.0/src/location.mli ppxlib-0.24.0/src/location.mli --- ppxlib-0.15.0/src/location.mli 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/location.mli 2021-12-08 21:53:37.000000000 +0000 @@ -1,65 +1,87 @@ (** Overrides the Location module of OCaml *) -(** There are less functions in this module. However the API should be more stable than - the Location module of OCaml. *) +(** There are less functions in this module. However the API should be more + stable than the Location module of OCaml. *) open! Import -type t = location = - { loc_start : Lexing.position - ; loc_end : Lexing.position - ; loc_ghost : bool - } +type t = location = { + loc_start : Lexing.position; + loc_end : Lexing.position; + loc_ghost : bool; +} -(** Return an empty ghost range located in a given file. *) val in_file : string -> t +(** Return an empty ghost range located in a given file. *) + +val set_filename : t -> string -> t +(** Set the [pos_fname] both in [loc_start] and [loc_end]. Leave the rest as is. *) -(** An arbitrary value of type [t]; describes an empty ghost range. *) val none : t +(** An arbitrary value of type [t]; describes an empty ghost range. *) +val init : Lexing.lexbuf -> string -> unit +(** Set the file name and line number of the [lexbuf] to be the start of the + named file. *) + +val raise_errorf : ?loc:t -> ('a, Caml.Format.formatter, unit, 'b) format4 -> 'a (** Raise a located error. The exception is caught by driver and handled appropriately *) -val raise_errorf : ?loc:t -> ('a, Caml.Format.formatter, unit, 'b) format4 -> 'a -(** Return the location corresponding to the last matched regular expression *) val of_lexbuf : Lexing.lexbuf -> t +(** Return the location corresponding to the last matched regular expression *) -(** Report an exception on the given formatter *) val report_exception : Caml.Format.formatter -> exn -> unit +(** Report an exception on the given formatter *) -(** Prints [File "...", line ..., characters ...-...:] *) val print : Caml.Format.formatter -> t -> unit +(** Prints [File "...", line ..., characters ...-...:] *) -type nonrec 'a loc = 'a loc = - { txt : 'a - ; loc : t - } +type nonrec 'a loc = 'a loc = { txt : 'a; loc : t } val compare_pos : Lexing.position -> Lexing.position -> int + val min_pos : Lexing.position -> Lexing.position -> Lexing.position + val max_pos : Lexing.position -> Lexing.position -> Lexing.position val compare : t -> t -> int module Error : sig type location = t + type t val make : loc:location -> string -> sub:(location * string) list -> t - val createf : loc:location -> ('a, unit, string, t) format4 -> 'a + + val createf : + loc:location -> ('a, Caml.Format.formatter, unit, t) format4 -> 'a val message : t -> string + val set_message : t -> string -> t - (** Register an exception handler. Exception registered this way will be properly - displayed by [report_exception]. *) - val register_error_of_exn: (exn -> t option) -> unit + val register_error_of_exn : (exn -> t option) -> unit + (** Register an exception handler. Exception registered this way will be + properly displayed by [report_exception]. *) val of_exn : exn -> t option - (** Convert an error to an extension point. The compiler recognizes this and displays - the error properly. *) val to_extension : t -> extension -end with type location := t + (** Convert an error to an extension point. The compiler recognizes this and + displays the error properly. *) + + val raise : t -> 'a + (** Raise a compiler [Parsing.Location.Error] exception. The composition of + [Location.Error.createf] with [Location.Error.raise] is the same as + [Location.raise_errorf]. *) + + val update_loc : t -> location -> t + (** Update where the error is located. The old location will be overwritten. *) + + val get_location : t -> location + (** Find out where the error is located. *) +end +with type location := t exception Error of Error.t diff -Nru ppxlib-0.15.0/src/loc.ml ppxlib-0.24.0/src/loc.ml --- ppxlib-0.15.0/src/loc.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/loc.ml 2021-12-08 21:53:37.000000000 +0000 @@ -1,12 +1,11 @@ open! Import -type 'a t = 'a loc = - { txt : 'a - ; loc : Location.t - } +type 'a t = 'a loc = { txt : 'a; loc : Location.t } let txt t = t.txt + let loc t = t.loc let make ~loc txt = { loc; txt } + let map t ~f = { t with txt = f t.txt } diff -Nru ppxlib-0.15.0/src/loc.mli ppxlib-0.24.0/src/loc.mli --- ppxlib-0.15.0/src/loc.mli 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/loc.mli 2021-12-08 21:53:37.000000000 +0000 @@ -2,12 +2,10 @@ open! Import -type 'a t = 'a loc = - { txt : 'a - ; loc : Location.t - } +type 'a t = 'a loc = { txt : 'a; loc : Location.t } val txt : 'a t -> 'a + val loc : _ t -> Location.t val make : loc:Location.t -> 'a -> 'a t diff -Nru ppxlib-0.15.0/src/longident.ml ppxlib-0.24.0/src/longident.ml --- ppxlib-0.15.0/src/longident.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/longident.ml 2021-12-08 21:53:37.000000000 +0000 @@ -1,10 +1,7 @@ open! Import module T = struct - type t = longident = - Lident of string - | Ldot of t * string - | Lapply of t * t + type t = longident = Lident of string | Ldot of t * string | Lapply of t * t let compare : t -> t -> int = Poly.compare @@ -13,15 +10,11 @@ | _ -> false let is_normal_ident = function - | "asr" | "land" | "lor" | "lsl" | "lsr" | "lxor" | "mod" | "or" -> - false - | string -> - String.for_all string ~f:is_normal_ident_char + | "asr" | "land" | "lor" | "lsl" | "lsr" | "lxor" | "mod" | "or" -> false + | string -> String.for_all string ~f:is_normal_ident_char let short_name string = - if is_normal_ident string - then string - else "( " ^ string ^ " )" + if is_normal_ident string then string else "( " ^ string ^ " )" let rec name = function | Lident s -> short_name s @@ -30,22 +23,22 @@ let sexp_of_t t = Sexp.Atom (name t) end + include T let rec flat accu = function - Lident s -> s :: accu - | Ldot(lid, s) -> flat (s :: accu) lid - | Lapply(_, _) -> invalid_arg "Ppxlib.Longident.flatten" + | Lident s -> s :: accu + | Ldot (lid, s) -> flat (s :: accu) lid + | Lapply (_, _) -> invalid_arg "Ppxlib.Longident.flatten" let flatten_exn lid = flat [] lid let last_exn = function - Lident s -> s - | Ldot(_, s) -> s - | Lapply(_, _) -> invalid_arg "Ppxlib.Longident.flatten" + | Lident s -> s + | Ldot (_, s) -> s + | Lapply (_, _) -> invalid_arg "Ppxlib.Longident.flatten" -let unflatten ~init l = - List.fold_left l ~init ~f:(fun acc s -> Ldot (acc, s)) +let unflatten ~init l = List.fold_left l ~init ~f:(fun acc s -> Ldot (acc, s)) (* for cases without dotted operators (e.g. [parse "A.B.C"]) *) let parse_simple s = @@ -58,21 +51,22 @@ let invalid () = invalid_arg (Printf.sprintf "Ppxlib.Longident.parse: %S" s) in - match String.index_opt s '(', String.rindex_opt s ')' with - | None, None -> parse_simple s + match (String.index_opt s '(', String.rindex_opt s ')') with + | None, None -> parse_simple s | None, _ | _, None -> invalid () - | Some l, Some r -> - if Int.( r <> String.length s - 1 ) then invalid (); - let group = if Int.(r = l + 1) then "()" else - String.trim (String.sub s ~pos:(l+1) ~len:(r-l-1)) + | Some l, Some r -> ( + if Int.(r <> String.length s - 1) then invalid (); + let group = + if Int.(r = l + 1) then "()" + else String.trim (String.sub s ~pos:(l + 1) ~len:(r - l - 1)) in if Int.(l = 0) then Lident group else if Char.(s.[l - 1] <> '.') then invalid () else - let before = String.sub s ~pos:0 ~len:(l-1) in + let before = String.sub s ~pos:0 ~len:(l - 1) in match String.split_on_char before ~sep:'.' with | [] -> assert false - | s :: l -> Ldot(unflatten ~init:(Lident s) l, group) + | s :: l -> Ldot (unflatten ~init:(Lident s) l, group)) module Map = Map.Make (T) module Set = Set.Make (T) diff -Nru ppxlib-0.15.0/src/longident.mli ppxlib-0.24.0/src/longident.mli --- ppxlib-0.15.0/src/longident.mli 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/longident.mli 2021-12-08 21:53:37.000000000 +0000 @@ -2,24 +2,23 @@ open! Import -type t = longident = - Lident of string - | Ldot of t * string - | Lapply of t * t +type t = longident = Lident of string | Ldot of t * string | Lapply of t * t val compare : t -> t -> int + val sexp_of_t : t -> Sexp.t val flatten_exn : t -> string list + val last_exn : t -> string -(** Parses the given string as a longident, properly handling infix operators - which may contain '.'. - Note that it does not parse [Lapply _] longidents and will raise - [Invalid_argument _] if passed values such as ["A(B)"]. *) val parse : string -> t +(** Parses the given string as a longident, properly handling infix operators + which may contain '.'. Note that it does not parse [Lapply _] longidents and + will raise [Invalid_argument _] if passed values such as ["A(B)"]. *) val name : t -> string module Map : Map.S with type key = t + module Set : Set.S with type elt = t diff -Nru ppxlib-0.15.0/src/merlin_helpers.ml ppxlib-0.24.0/src/merlin_helpers.ml --- ppxlib-0.15.0/src/merlin_helpers.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/merlin_helpers.ml 2021-12-08 21:53:37.000000000 +0000 @@ -2,15 +2,18 @@ let mk_attr_noloc txt = Ast_helper.Attr.mk Location.{ txt; loc = none } -let hide_attribute : attribute = mk_attr_noloc "merlin.hide" (PStr []) +let hide_attribute : attribute = mk_attr_noloc "merlin.hide" (PStr []) + let focus_attribute : attribute = mk_attr_noloc "merlin.focus" (PStr []) -let hide_pattern ({ ppat_attributes ; _ } as p) = +let hide_pattern ({ ppat_attributes; _ } as p) = { p with ppat_attributes = hide_attribute :: ppat_attributes } -let focus_pattern ({ ppat_attributes ; _ } as p) = + +let focus_pattern ({ ppat_attributes; _ } as p) = { p with ppat_attributes = focus_attribute :: ppat_attributes } -let hide_expression ({ pexp_attributes ; _ } as e) = +let hide_expression ({ pexp_attributes; _ } as e) = { e with pexp_attributes = hide_attribute :: pexp_attributes } -let focus_expression ({ pexp_attributes ; _ } as e) = + +let focus_expression ({ pexp_attributes; _ } as e) = { e with pexp_attributes = focus_attribute :: pexp_attributes } diff -Nru ppxlib-0.15.0/src/merlin_helpers.mli ppxlib-0.24.0/src/merlin_helpers.mli --- ppxlib-0.15.0/src/merlin_helpers.mli 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/merlin_helpers.mli 2021-12-08 21:53:37.000000000 +0000 @@ -1,26 +1,28 @@ -(** Some helpers to annotate the AST so merlin can decide which branches to look at and - which branches to ignore. *) +(** Some helpers to annotate the AST so merlin can decide which branches to look + at and which branches to ignore. *) open! Import (** {2 Annotations merlin understand} *) -(** Adding this [[@merlin.hide]] attribute on a piece of AST "hides" it from merlin: it - tells merlin not to consider that branch if another piece of AST with the same - location exist. *) -val hide_attribute : attribute +val hide_attribute : attribute +(** Adding this [\[@merlin.hide\]] attribute on a piece of AST "hides" it from + merlin: it tells merlin not to consider that branch if another piece of AST + with the same location exist. *) -(** Adding this [[@merlin.focus]] attribute on a piece of AST tells merlin to prefer it to - any other piece of AST when several have the same location. *) val focus_attribute : attribute +(** Adding this [\[@merlin.focus\]] attribute on a piece of AST tells merlin to + prefer it to any other piece of AST when several have the same location. *) (** {2 Helpers} - The following functions add the corresponding attribute (defined above) to specific - pieces of AST. *) + The following functions add the corresponding attribute (defined above) to + specific pieces of AST. *) + +val hide_pattern : pattern -> pattern -val hide_pattern : pattern -> pattern val focus_pattern : pattern -> pattern -val hide_expression : expression -> expression +val hide_expression : expression -> expression + val focus_expression : expression -> expression diff -Nru ppxlib-0.15.0/src/name.ml ppxlib-0.24.0/src/name.ml --- ppxlib-0.15.0/src/name.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/name.ml 2021-12-08 21:53:37.000000000 +0000 @@ -1,60 +1,44 @@ open! Import - module Format = Caml.Format let fold_dot_suffixes name ~init:acc ~f = let rec collapse_after_at = function | [] -> [] | part :: parts -> - if not (String.is_empty part) && Char.equal part.[0] '@' then - [String.concat (String.drop_prefix part 1 :: parts) ~sep:"."] - else - part :: collapse_after_at parts + if (not (String.is_empty part)) && Char.equal part.[0] '@' then + [ String.concat (String.drop_prefix part 1 :: parts) ~sep:"." ] + else part :: collapse_after_at parts in let rec loop acc parts = match parts with | [] -> acc | part :: parts -> - loop (f (String.concat (part :: parts) ~sep:".") acc) parts + loop (f (String.concat (part :: parts) ~sep:".") acc) parts in - String.split_on_char name ~sep:'.' - |> collapse_after_at - |> loop acc -;; + String.split_on_char name ~sep:'.' |> collapse_after_at |> loop acc let dot_suffixes name = fold_dot_suffixes name ~init:[] ~f:(fun x acc -> x :: acc) let split_path = let rec loop s i = - if i = String.length s then - (s, None) - else - match s.[i] with - | '.' -> after_dot s (i + 1) - | _ -> loop s (i + 1) + if i = String.length s then (s, None) + else match s.[i] with '.' -> after_dot s (i + 1) | _ -> loop s (i + 1) and after_dot s i = - if i = String.length s then - (s, None) + if i = String.length s then (s, None) else match s.[i] with - | 'A'..'Z' -> - (String.prefix s (i - 1), Some (String.drop_prefix s i)) + | 'A' .. 'Z' -> (String.prefix s (i - 1), Some (String.drop_prefix s i)) | '.' -> after_dot s (i + 1) | _ -> loop s (i + 1) in fun s -> loop s 0 module Pattern = struct - type t = - { name : string - ; dot_suffixes : String.Set.t - } + type t = { name : string; dot_suffixes : String.Set.t } let make name = - { name - ; dot_suffixes = String.Set.of_list (dot_suffixes name) - } + { name; dot_suffixes = String.Set.of_list (dot_suffixes name) } let name t = t.name @@ -75,40 +59,40 @@ Sadly, the compiler silently ignores them if they are misplaced... *) - let create_set fully_qualified_names = + let create_set fully_qualified_names = List.fold_left ~f:(fun acc name -> fold_dot_suffixes name ~init:acc ~f:(fun x acc -> String.Set.add x acc)) - ~init:String.Set.empty - fully_qualified_names + ~init:String.Set.empty fully_qualified_names - let attributes = - create_set - [ "ocaml.alert" - ; "ocaml.boxed" - ; "ocaml.deprecated" - ; "ocaml.deprecated_mutable" - ; "ocaml.doc" - ; "ocaml.extension_constructor" - ; "ocaml.immediate" - ; "ocaml.immediate64" - ; "ocaml.inline" - ; "ocaml.inlined" - ; "ocaml.local" - ; "ocaml.noalloc" - ; "ocaml.ppwarning" - ; "ocaml.remove_aliases" - ; "ocaml.specialise" - ; "ocaml.specialised" - ; "ocaml.tailcall" - ; "ocaml.text" - ; "ocaml.unboxed" - ; "ocaml.unroll" - ; "ocaml.unrolled" - ; "ocaml.untagged" - ; "ocaml.warn_on_literal_pattern" - ; "ocaml.warnerror" - ; "ocaml.warning" + let attributes = + create_set + [ + "ocaml.alert"; + "ocaml.boxed"; + "ocaml.deprecated"; + "ocaml.deprecated_mutable"; + "ocaml.doc"; + "ocaml.extension_constructor"; + "ocaml.immediate"; + "ocaml.immediate64"; + "ocaml.inline"; + "ocaml.inlined"; + "ocaml.local"; + "ocaml.noalloc"; + "ocaml.ppwarning"; + "ocaml.remove_aliases"; + "ocaml.specialise"; + "ocaml.specialised"; + "ocaml.tailcall"; + "ocaml.text"; + "ocaml.unboxed"; + "ocaml.unroll"; + "ocaml.unrolled"; + "ocaml.untagged"; + "ocaml.warn_on_literal_pattern"; + "ocaml.warnerror"; + "ocaml.warning"; ] (* White list the following extensions. @@ -117,11 +101,7 @@ at the level of a ppx rewriter that they have been properly interpreted, so we just accept them anywhere. *) - let extensions = - create_set - [ "ocaml.error" - ; "ocaml.extension_constructor" - ] + let extensions = create_set [ "ocaml.error"; "ocaml.extension_constructor" ] let is_whitelisted ~kind name = match kind with @@ -129,6 +109,7 @@ | `Extension -> String.Set.mem name extensions let get_attribute_list () = String.Set.elements attributes + let get_extension_list () = String.Set.elements extensions end @@ -138,9 +119,13 @@ let reserve ns = Hashtbl.add_exn tbl ~key:ns ~data:() let () = reserve "merlin" + let () = reserve "reason" + let () = reserve "refmt" + let () = reserve "metaocaml" + let () = reserve "ocamlformat" let is_in_reserved_namespaces name = @@ -151,145 +136,144 @@ let check_not_reserved ~kind name = let kind, list = match kind with - | `Attribute -> "attribute", Whitelisted.attributes - | `Extension -> "extension", Whitelisted.extensions + | `Attribute -> ("attribute", Whitelisted.attributes) + | `Extension -> ("extension", Whitelisted.extensions) in if String.Set.mem name list then Printf.ksprintf failwith - "Cannot register %s with name '%s' as it matches an \ - %s reserved by the compiler" + "Cannot register %s with name '%s' as it matches an %s reserved by the \ + compiler" kind name kind else if is_in_reserved_namespaces name then Printf.ksprintf failwith - "Cannot register %s with name '%s' as its namespace \ - is marked as reserved" + "Cannot register %s with name '%s' as its namespace is marked as \ + reserved" kind name - end let ignore_checks name = - Reserved_namespaces.is_in_reserved_namespaces name || - String.is_prefix name ~prefix:"_" + Reserved_namespaces.is_in_reserved_namespaces name + || String.is_prefix name ~prefix:"_" module Registrar = struct - type element = - { fully_qualified_name : string - ; declared_at : Caller_id.t - } + type element = { fully_qualified_name : string; declared_at : Caller_id.t } type all_for_context = { mutable all : element String.Map.t } - type 'a t = - { all_by_context : ('a, all_for_context) Hashtbl.t - ; skip : string list - ; kind : string - ; string_of_context : 'a -> string option - } + type 'a t = { + all_by_context : ('a, all_for_context) Hashtbl.t; + skip : string list; + kind : string; + string_of_context : 'a -> string option; + } let create ~kind ~current_file ~string_of_context = - { all_by_context = Hashtbl.create 16 - ; skip = [current_file; __FILE__] - ; kind - ; string_of_context + { + all_by_context = Hashtbl.create 16; + skip = [ current_file; __FILE__ ]; + kind; + string_of_context; } let get_all_for_context t context = Hashtbl.find_or_add t.all_by_context context ~default:(fun () -> - { all = String.Map.empty }) - ;; + { all = String.Map.empty }) + + let check_collisions_local ~caller ~all_for_context t context name = + match String.Map.find_opt name all_for_context.all with + | None -> () + | Some e -> + let declared_at = function + | None -> "" + | Some (loc : Caml.Printexc.location) -> + Printf.sprintf " declared at %s:%d" loc.filename loc.line_number + in + let context = + match t.string_of_context context with + | None -> "" + | Some s -> " on " ^ s ^ "s" + in + Printf.ksprintf failwith + "Some ppx-es tried to register conflicting transformations: %s \ + '%s'%s%s matches %s '%s'%s" + (String.capitalize_ascii t.kind) + name context (declared_at caller) t.kind e.fully_qualified_name + (declared_at e.declared_at) + + let check_collisions t context name = + let caller = Caller_id.get ~skip:t.skip in + let all_for_context = get_all_for_context t context in + check_collisions_local ~caller ~all_for_context t context name let register ~kind t context name = Reserved_namespaces.check_not_reserved ~kind name; let caller = Caller_id.get ~skip:t.skip in let all = get_all_for_context t context in - (match String.Map.find_opt name all.all with - | None -> () - | Some e -> - let declared_at = function - | None -> "" - | Some (loc : Caml.Printexc.location) -> - Printf.sprintf " declared at %s:%d" loc.filename loc.line_number - in - let context = - match t.string_of_context context with - | None -> "" - | Some s -> " on " ^ s ^ "s" - in - Printf.ksprintf - failwith "%s '%s'%s%s matches %s '%s'%s" - (String.capitalize_ascii t.kind) name context (declared_at caller) - t.kind e.fully_qualified_name (declared_at e.declared_at) - ); - let t = - { fully_qualified_name = name - ; declared_at = caller - } - in - all.all <- fold_dot_suffixes name ~init:all.all ~f:(fun name acc -> - String.Map.add name t acc); - ;; + check_collisions_local ~caller ~all_for_context:all t context name; + let t = { fully_qualified_name = name; declared_at = caller } in + all.all <- + fold_dot_suffixes name ~init:all.all ~f:(fun name acc -> + String.Map.add name t acc) - let spellcheck t context ?(white_list=[]) name = + let spellcheck t context ?(white_list = []) name = let all = let all = get_all_for_context t context in String.Map.fold (fun key _ acc -> key :: acc) all.all [] in match Spellcheck.spellcheck (all @ white_list) name with | Some _ as x -> x - | None -> - let other_contexts = - Hashtbl.fold (fun ctx { all } acc -> - if Poly.(<>) context ctx && String.Map.mem name all then - match t.string_of_context ctx with - | None -> acc - | Some s -> (s ^ "s") :: acc - else - acc) - t.all_by_context - [] - in - let pp_text = Format.pp_print_text in - let current_context ppf = - match t.string_of_context context with - | None | Some "" -> () - | Some s -> - let a_or_an = - match s.[0] with - | 'a' | 'e' | 'i' | 'o' | 'u' | 'y' -> "an" - | _ -> "a" - in - Format.fprintf ppf "@ but@ is@ used@ here@ in@ the@ context@ of@ %s@ %a" - a_or_an pp_text s - in - match List.sort ~cmp:(fun x y -> - (String.compare x y)) other_contexts with - | [] -> None - | [c] -> - Some - (Format.asprintf - "@[Hint:@ `%s'@ is@ available@ for@ %a%t.@]@\n\ - Did you put it at the wrong level?" - name pp_text c current_context) - | last :: rev_others -> - let others = List.rev rev_others in - Some - (Format.asprintf - "@[Hint:@ `%s'@ is@ available@ for@ %a@ and@ %a%t.@]@\n\ - Did you put it at the wrong level?" - name - (Format.pp_print_list pp_text - ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ ")) - others pp_text last current_context) - ;; + | None -> ( + let other_contexts = + Hashtbl.fold + (fun ctx { all } acc -> + if Poly.( <> ) context ctx && String.Map.mem name all then + match t.string_of_context ctx with + | None -> acc + | Some s -> (s ^ "s") :: acc + else acc) + t.all_by_context [] + in + let pp_text = Format.pp_print_text in + let current_context ppf = + match t.string_of_context context with + | None | Some "" -> () + | Some s -> + let a_or_an = + match s.[0] with + | 'a' | 'e' | 'i' | 'o' | 'u' | 'y' -> "an" + | _ -> "a" + in + Format.fprintf ppf + "@ but@ is@ used@ here@ in@ the@ context@ of@ %s@ %a" a_or_an + pp_text s + in + match + List.sort ~cmp:(fun x y -> -String.compare x y) other_contexts + with + | [] -> None + | [ c ] -> + Some + (Format.asprintf + "@[Hint:@ `%s'@ is@ available@ for@ %a%t.@]@\n\ + Did you put it at the wrong level?" name pp_text c + current_context) + | last :: rev_others -> + let others = List.rev rev_others in + Some + (Format.asprintf + "@[Hint:@ `%s'@ is@ available@ for@ %a@ and@ %a%t.@]@\n\ + Did you put it at the wrong level?" name + (Format.pp_print_list pp_text ~pp_sep:(fun ppf () -> + Format.fprintf ppf ",@ ")) + others pp_text last current_context)) (* TODO: hint spelling errors regarding reserved namespaces names and white listed names instead of taking an optional [white_list] parameter. *) let raise_errorf t context ?white_list fmt (name : string Loc.t) = - Printf.ksprintf (fun msg -> - match spellcheck t context name.txt ?white_list with - | None -> - Location.raise_errorf ~loc:name.loc "%s" msg - | Some s -> - Location.raise_errorf ~loc:name.loc "%s.\n%s" msg s) + Printf.ksprintf + (fun msg -> + match spellcheck t context name.txt ?white_list with + | None -> Location.raise_errorf ~loc:name.loc "%s" msg + | Some s -> Location.raise_errorf ~loc:name.loc "%s.\n%s" msg s) fmt name.txt - ;; end diff -Nru ppxlib-0.15.0/src/name.mli ppxlib-0.24.0/src/name.mli --- ppxlib-0.15.0/src/name.mli 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/name.mli 2021-12-08 21:53:37.000000000 +0000 @@ -3,89 +3,89 @@ module Pattern : sig type t - (** Uses the rules described in [Attribute] *) val make : string -> t + (** Uses the rules described in [Attribute] *) val name : t -> string + val matches : t -> string -> bool (** [matches ~pattern name] returns [true] iff [name] matches [pattern]. For instance, the exact set of names such that [matches (make "foo.bar.@blah.x") name] is: + - "foo.bar.blah.x" - - "bar.blah.x" - - "blah.x" - *) - val matches : t -> string -> bool + - "bar.blah.x" + - "blah.x" *) end +val split_path : string -> string * string option (** Split the path part of a name: - [split_path "a.b.C.D" = "a.b", Some "C.D"] -*) -val split_path : string -> string * string option + [split_path "a.b.C.D" = "a.b", Some "C.D"] *) +val dot_suffixes : string -> string list (** [fold_dot_suffixes "foo.@bar.blah" ~init ~f] is - {[ - ["bar.blah"; "foo.bar.blah"] - ]} -*) -val dot_suffixes : string -> string list + {[ [ "bar.blah"; "foo.bar.blah" ] ]} *) module Registrar : sig - (** Names are organized by context. For instance contexts can be: expressions, patterns, - types, ... *) type 'context t + (** Names are organized by context. For instance contexts can be: expressions, + patterns, types, ... *) - (** - [kind] is a description of the things registered. For instance: "extension", - "attribute", ... + val create : + kind:string -> + current_file:string (* must be [__FILE__] *) -> + string_of_context:('context -> string option) -> + 'context t + (** - [kind] is a description of the things registered. For instance: + "extension", "attribute", ... - [current_file] is where this function is called. Must be [__FILE__]. - - [string_of_context]: human readable description of a context - *) - val create - : kind:string - -> current_file:string (* must be [__FILE__] *) - -> string_of_context:('context -> string option) - -> 'context t + - [string_of_context]: human readable description of a context *) - val register : kind:[ `Attribute | `Extension ] -> 'context t -> 'context -> string -> unit + val register : + kind:[ `Attribute | `Extension ] -> 'context t -> 'context -> string -> unit + + val check_collisions : 'context t -> 'context -> string -> unit val spellcheck : 'context t -> 'context -> ?white_list:string list -> string -> string option - val raise_errorf - : 'context t - -> 'context - -> ?white_list:string list - -> (string -> 'a, unit, string, 'c) format4 - -> string Loc.t - -> 'a + val raise_errorf : + 'context t -> + 'context -> + ?white_list:string list -> + (string -> 'a, unit, string, 'c) format4 -> + string Loc.t -> + 'a end module Whitelisted : sig val get_attribute_list : unit -> string list + val get_extension_list : unit -> string list val is_whitelisted : kind:[ `Attribute | `Extension ] -> string -> bool end module Reserved_namespaces : sig + val reserve : string -> unit (** [reserve "foo"] has two implications: - - one can't then declare an attribute inside this namespace - - attributes within this namespace won't be reported by [check_unused] + + - one can't then declare an attribute inside this namespace + - attributes within this namespace won't be reported by [check_unused] This is here to insure that the rewriter cohabits well with other rewriter or tools (e.g. merlin) which might leave attribute on the AST. N.B. the "merlin" namespace is reserved by default. *) - val reserve : string -> unit val is_in_reserved_namespaces : string -> bool end -(** Returns [true] if checks should be ignored for the following name, - for instance if it is reserved or starts with an underscore. *) val ignore_checks : string -> bool +(** Returns [true] if checks should be ignored for the following name, for + instance if it is reserved or starts with an underscore. *) diff -Nru ppxlib-0.15.0/src/options.ml ppxlib-0.24.0/src/options.ml --- ppxlib-0.15.0/src/options.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/options.ml 2021-12-08 21:53:37.000000000 +0000 @@ -1,9 +1,13 @@ let perform_checks = false + (* The checks on extensions are only to get better error messages since the compiler will choke on unknown extensions. We disable them externally to make it easier to use non ppxlib based rewriters with ppxlib *) let perform_checks_on_extensions = false + let perform_locations_check = false + let fail_on_duplicate_derivers = false + let diff_command = None diff -Nru ppxlib-0.15.0/src/ppxlib.ml ppxlib-0.24.0/src/ppxlib.ml --- ppxlib-0.15.0/src/ppxlib.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/ppxlib.ml 2021-12-08 21:53:37.000000000 +0000 @@ -1,58 +1,72 @@ (** Standard library for ppx rewriters *) -(** Make sure code using Ppxlib doesn't refer to compiler-libs without being explicit - about it *) +(** Make sure code using Ppxlib doesn't refer to compiler-libs without being + explicit about it *) include struct [@@@warning "-3"] + open Ocaml_shadow - include (Ocaml_shadow : module type of struct include Ocaml_shadow end - with module Ast_helper := Ast_helper - with module Asttypes := Asttypes - with module Docstrings := Docstrings - with module Identifiable := Identifiable - with module Lexer := Lexer - with module Location := Location - with module Longident := Longident - with module Parse := Parse - with module Parser := Parser - with module Parsetree := Parsetree - with module Pprintast := Pprintast - with module Syntaxerr := Syntaxerr - ) -end (** @inline *) - -(** Includes the overrides from Ppxlib_ast, as well as all the Ast definitions since we - need them in every single ppx *) -include Ppxlib_ast + include ( + Ocaml_shadow : + module type of struct + include Ocaml_shadow + end + with module Ast_helper := Ast_helper + with module Asttypes := Asttypes + with module Docstrings := Docstrings + with module Identifiable := Identifiable + with module Lexer := Lexer + with module Location := Location + with module Longident := Longident + with module Parse := Parse + with module Parsetree := Parsetree + with module Pprintast := Pprintast + with module Syntaxerr := Syntaxerr) +end +(** @inline *) + +module Ast = Ppxlib_ast.Ast +(** Expose some modules from Ppxlib_ast; in particular, overwrite some of the + modules above *) + +module Ast_helper = Ppxlib_ast.Ast_helper +module Asttypes = Ppxlib_ast.Asttypes +module Parse = Ppxlib_ast.Parse +module Parsetree = Ppxlib_ast.Parsetree +module Pprintast = Ppxlib_ast.Pprintast +module Selected_ast = Ppxlib_ast.Selected_ast + include Ast +(** Include all the Ast definitions since we need them in every single ppx *) -module Ast_builder = Ast_builder -module Ast_pattern = Ast_pattern -module Ast_traverse = Ast_traverse -module Attribute = Attribute -module Code_path = Code_path -module Caller_id = Caller_id -module Context_free = Context_free -module Deriving = Deriving -module Driver = Driver -module Expansion_context = Expansion_context -module Extension = Extension -module File_path = File_path -module Loc = Loc -module Location = Location -module Longident = Longident -module Merlin_helpers = Merlin_helpers +module Ast_builder = Ast_builder +module Ast_pattern = Ast_pattern +module Ast_traverse = Ast_traverse +module Attribute = Attribute +module Code_path = Code_path +module Caller_id = Caller_id +module Context_free = Context_free +module Deriving = Deriving +module Driver = Driver +module Expansion_context = Expansion_context +module Extension = Extension +module File_path = File_path +module Keyword = Keyword +module Loc = Loc +module Location = Location +module Longident = Longident +module Merlin_helpers = Merlin_helpers module Reserved_namespaces = Name.Reserved_namespaces -module Spellcheck = Spellcheck -module Quoter = Quoter - +module Spellcheck = Spellcheck +module Quoter = Quoter +module Ast_io = Utils.Ast_io.Read_bin include Common (**/**) -(* For tests and Ppx_core compatiblity layer *) +(* For tests and Ppx_core compatibility layer *) module Ppxlib_private = struct module Common = Common - module Name = Name + module Name = Name end diff -Nru ppxlib-0.15.0/src/quoter.ml ppxlib-0.24.0/src/quoter.ml --- ppxlib-0.15.0/src/quoter.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/quoter.ml 2021-12-08 21:53:37.000000000 +0000 @@ -1,21 +1,18 @@ open Import -type t = - { mutable next_id : int - ; mutable bindings : Parsetree.value_binding list - } +type t = { + mutable next_id : int; + mutable bindings : Parsetree.value_binding list; +} -let create () = - { next_id = 0 - ; bindings = [] - } +let create () = { next_id = 0; bindings = [] } let sanitize t e = match t.bindings with | [] -> e | bindings -> - let (module Ast) = Ast_builder.make e.pexp_loc in - Ast.pexp_let Recursive bindings e + let (module Ast) = Ast_builder.make e.pexp_loc in + Ast.pexp_let Recursive bindings e let quote t (e : expression) = let loc = e.pexp_loc in diff -Nru ppxlib-0.15.0/src/quoter.mli ppxlib-0.24.0/src/quoter.mli --- ppxlib-0.15.0/src/quoter.mli 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/quoter.mli 2021-12-08 21:53:37.000000000 +0000 @@ -1,10 +1,9 @@ (** Generate expressions in a hygienic way. - The idea is that whenever we want to refer to an expression in - generated code we first quote it. The result will be an identifier - that is guaranteed to refer to the expression it was created - from. This way it is impossible for quoted fragments to refer to - newly introduced expressions. *) + The idea is that whenever we want to refer to an expression in generated + code we first quote it. The result will be an identifier that is guaranteed + to refer to the expression it was created from. This way it is impossible + for quoted fragments to refer to newly introduced expressions. *) open Import diff -Nru ppxlib-0.15.0/src/reconcile.ml ppxlib-0.24.0/src/reconcile.ml --- ppxlib-0.15.0/src/reconcile.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/reconcile.ml 2021-12-08 21:53:37.000000000 +0000 @@ -3,88 +3,84 @@ module Context = struct type 'a t = - | Extension of 'a Extension.Context.t + | Extension of 'a Extension.Context.t | Floating_attribute of 'a Attribute.Floating.Context.t - let paren pp ppf x = - Caml.Format.fprintf ppf "(%a)" pp x + let paren pp ppf x = Caml.Format.fprintf ppf "(%a)" pp x - let printer - : type a. a t -> Caml.Format.formatter -> a -> unit = + let printer : type a. a t -> Caml.Format.formatter -> a -> unit = let open Extension.Context in let open Attribute.Floating.Context in function - | Extension Class_expr -> Pprintast.class_expr - | Extension Class_field -> Pprintast.class_field - | Extension Class_type -> Pprintast.class_type + | Extension Class_expr -> Pprintast.class_expr + | Extension Class_field -> Pprintast.class_field + | Extension Class_type -> Pprintast.class_type | Extension Class_type_field -> Pprintast.class_type_field - | Extension Core_type -> paren Pprintast.core_type - | Extension Expression -> paren Pprintast.expression - | Extension Module_expr -> Pprintast.module_expr - | Extension Module_type -> Pprintast.module_type - | Extension Pattern -> paren Pprintast.pattern - | Extension Signature_item -> Pprintast.signature_item - | Extension Structure_item -> Pprintast.structure_item - - | Floating_attribute Structure_item -> Pprintast.structure_item - | Floating_attribute Signature_item -> Pprintast.signature_item - | Floating_attribute Class_field -> Pprintast.class_field + | Extension Core_type -> paren Pprintast.core_type + | Extension Expression -> paren Pprintast.expression + | Extension Module_expr -> Pprintast.module_expr + | Extension Module_type -> Pprintast.module_type + | Extension Pattern -> paren Pprintast.pattern + | Extension Signature_item -> Pprintast.signature_item + | Extension Structure_item -> Pprintast.structure_item + | Extension Ppx_import -> Pprintast.type_declaration + | Floating_attribute Structure_item -> Pprintast.structure_item + | Floating_attribute Signature_item -> Pprintast.signature_item + | Floating_attribute Class_field -> Pprintast.class_field | Floating_attribute Class_type_field -> Pprintast.class_type_field end module Replacement = struct type data = - | Values : 'a Context.t * 'a Context_free.Generated_code_hook.single_or_many -> data + | Values : + 'a Context.t * 'a Context_free.Generated_code_hook.single_or_many + -> data | Text of string - type t = - { start : Lexing.position - ; stop : Lexing.position - ; data : data - } + type t = { start : Lexing.position; stop : Lexing.position; data : data } let make ~context ~start ~stop ~repl () = { start; stop; data = Values (context, repl) } - let make_text ~start ~stop ~repl () = - { start; stop; data = Text repl } + let make_text ~start ~stop ~repl () = { start; stop; data = Text repl } let text block = match block.data with | Text s -> s | Values (context, generated) -> - let s = - let printer = Context.printer context in - match generated with - | Single x -> - Caml.Format.asprintf "%a" printer x - | Many l -> - Caml.Format.asprintf "%a" - (fun ppf l -> - List.iter l ~f:(fun x -> - printer ppf x; - Caml.Format.pp_print_newline ppf ())) - l - in - let is_ws = function (' '|'\t'|'\r') -> true | _ -> false in - let strip_ws s i len = - let len = ref len in - while (!len > 0 && is_ws s.[i + !len - 1]) do len := !len - 1 done; - String.sub s ~pos:i ~len:!len - in - let rec loop s pos = - if pos >= String.length s - then [] - else - let idx = - match String.index_from_opt s pos '\n' with - | Some i -> i - | None -> String.length s - in - strip_ws s pos (idx - pos) :: "\n" :: loop s (idx + 1) - in - String.concat ~sep:"" (loop s 0) + let s = + let printer = Context.printer context in + match generated with + | Single x -> Caml.Format.asprintf "%a" printer x + | Many l -> + Caml.Format.asprintf "%a" + (fun ppf l -> + List.iter l ~f:(fun x -> + printer ppf x; + Caml.Format.pp_print_newline ppf ())) + l + in + let is_ws = function ' ' | '\t' | '\r' -> true | _ -> false in + let strip_ws s i len = + let len = ref len in + while !len > 0 && is_ws s.[i + !len - 1] do + len := !len - 1 + done; + String.sub s ~pos:i ~len:!len + in + let rec loop s pos = + if pos >= String.length s then [] + else + let idx = + match String.index_from_opt s pos '\n' with + | Some i -> i + | None -> String.length s + in + strip_ws s pos (idx - pos) :: "\n" :: loop s (idx + 1) + in + String.concat ~sep:"" (loop s 0) end + open Replacement module Replacements = struct @@ -94,203 +90,199 @@ result is sorted from the beginning of the file to the end. *) let check_and_sort ~input_filename ~input_name repls = List.iter repls ~f:(fun repl -> - if String.(<>) repl.start.pos_fname input_name || - String.(<>) repl.stop .pos_fname input_name then - Location.raise_errorf ~loc:(Location.in_file input_filename) - "ppxlib_driver: the rewriting contains parts from another file.\n\ - It is too complicated to reconcile it with the source"; - assert (repl.start.pos_cnum <= repl.stop.pos_cnum)); + if + String.( <> ) repl.start.pos_fname input_name + || String.( <> ) repl.stop.pos_fname input_name + then + Location.raise_errorf + ~loc:(Location.in_file input_filename) + "ppxlib_driver: the rewriting contains parts from another file.\n\ + It is too complicated to reconcile it with the source: %s or %s \ + and %s" + repl.start.pos_fname repl.stop.pos_fname input_name; + assert (repl.start.pos_cnum <= repl.stop.pos_cnum)); let repls = - List.sort repls ~cmp:(fun a b -> - let d = compare a.start.pos_cnum b.stop.pos_cnum in - if d = 0 then - (* Put the largest first, so that the following [filter] functions always picks up - the lartest first when several generated repls start at the same position *) - compare b.stop.pos_cnum a.stop.pos_cnum - else - d) + List.sort repls ~cmp:(fun a b -> + let d = compare a.start.pos_cnum b.stop.pos_cnum in + if d = 0 then + (* Put the largest first, so that the following [filter] functions always picks up + the lartest first when several generated repls start at the same position *) + compare b.stop.pos_cnum a.stop.pos_cnum + else d) in let rec filter prev repls ~acc = match repls with | [] -> List.rev (prev :: acc) | repl :: repls -> - if prev.stop.pos_cnum > repl.start.pos_cnum then begin - if prev.stop.pos_cnum >= repl.stop.pos_cnum then - (* [repl] is included in [prev] => skip [repl] *) - filter prev repls ~acc - else - Location.raise_errorf - "ppxlib_driver: locations of generated code are overlapping, cannot reconcile" - ~loc:{ loc_start = repl.start; loc_end = prev.stop; loc_ghost = false }; - end else - filter repl repls ~acc:(prev :: acc) + if prev.stop.pos_cnum > repl.start.pos_cnum then + if prev.stop.pos_cnum >= repl.stop.pos_cnum then + (* [repl] is included in [prev] => skip [repl] *) + filter prev repls ~acc + else + Location.raise_errorf + "ppxlib_driver: locations of generated code are overlapping, \ + cannot reconcile" + ~loc: + { + loc_start = repl.start; + loc_end = prev.stop; + loc_ghost = false; + } + else filter repl repls ~acc:(prev :: acc) in - match repls with - | [] -> [] - | repl :: repls -> - filter repl repls ~acc:[] - ;; + match repls with [] -> [] | repl :: repls -> filter repl repls ~acc:[] end let count_newlines s = let n = ref 0 in - String.iter s ~f:(function - | '\n' -> n := !n + 1 - | _ -> ()); + String.iter s ~f:(function '\n' -> n := !n + 1 | _ -> ()); !n let generated_code_begin = "(* -----{ GENERATED CODE BEGIN }------------------------------------- *)" + let generated_code_end = "(* -----{ GENERATED CODE END }------------------------------------- *)" -type mode = - | Using_line_directives - | Delimiting_generated_blocks - -type target = - | Output of mode - | Corrected +type mode = Using_line_directives | Delimiting_generated_blocks + +type target = Output of mode | Corrected let skip_blank_eol contents (pos : Lexing.position) = let rec loop cnum = - if cnum = String.length contents then - { pos with pos_cnum = cnum } + if cnum = String.length contents then { pos with pos_cnum = cnum } else match contents.[cnum] with | ' ' | '\t' | '\r' -> loop (cnum + 1) | '\n' -> - { pos with - pos_cnum = cnum + 1 - ; pos_lnum = pos.pos_lnum + 1 - ; pos_bol = cnum + 1 - } + { + pos with + pos_cnum = cnum + 1; + pos_lnum = pos.pos_lnum + 1; + pos_bol = cnum + 1; + } | _ -> pos in loop pos.pos_cnum -let with_output ~styler ~(kind:Kind.t) fn ~f = +let with_output ~styler ~(kind : Kind.t) fn ~f = match styler with | None -> with_output fn ~binary:false ~f | Some cmd -> - let tmp_fn, oc = - Caml.Filename.open_temp_file "ppxlib_driver" - (match kind with Impl -> ".ml" | Intf -> ".mli") - in - let cmd = - Printf.sprintf "%s %s%s" cmd (Caml.Filename.quote tmp_fn) - (match fn with - | None -> "" - | Some fn -> " > " ^ Caml.Filename.quote fn) - in - let n = - Exn.protectx tmp_fn ~finally:Caml.Sys.remove ~f:(fun _ -> - Exn.protectx oc ~finally:close_out ~f:f; - Caml.Sys.command cmd) - in - if n <> 0 then begin - Printf.eprintf "command exited with code %d: %s\n" n cmd; - Caml.exit 1 - end + let tmp_fn, oc = + Caml.Filename.open_temp_file "ppxlib_driver" + (match kind with Impl -> ".ml" | Intf -> ".mli") + in + let cmd = + Printf.sprintf "%s %s%s" cmd + (Caml.Filename.quote tmp_fn) + (match fn with + | None -> "" + | Some fn -> " > " ^ Caml.Filename.quote fn) + in + let n = + Exn.protectx tmp_fn ~finally:Caml.Sys.remove ~f:(fun _ -> + Exn.protectx oc ~finally:close_out ~f; + Caml.Sys.command cmd) + in + if n <> 0 then ( + Printf.eprintf "command exited with code %d: %s\n" n cmd; + Caml.exit 1) let reconcile ?styler (repls : Replacements.t) ~kind ~contents ~input_filename - ~output ~input_name ~target = + ~output ~input_name ~target = let repls = Replacements.check_and_sort ~input_filename ~input_name repls in - let output_name = - match output with - | None -> "" - | Some fn -> fn - in + let output_name = match output with None -> "" | Some fn -> fn in with_output output ~styler ~kind ~f:(fun oc -> - let copy_input pos ~up_to ~line ~last_is_text ~is_text = - let pos = if last_is_text then pos else skip_blank_eol contents pos in - if pos.pos_cnum < up_to then begin + let copy_input pos ~up_to ~line ~last_is_text ~is_text = + let pos = if last_is_text then pos else skip_blank_eol contents pos in + if pos.pos_cnum < up_to then ( + (match target with + | Output Using_line_directives -> + Printf.fprintf oc "# %d %S\n%*s" pos.pos_lnum input_name + (pos.pos_cnum - pos.pos_bol) + "" + | Output Delimiting_generated_blocks | Corrected -> ()); + output_substring oc contents ~pos:pos.pos_cnum + ~len:(up_to - pos.pos_cnum); + let line = ref (line + 1) in + for i = pos.pos_cnum to up_to - 1 do + if Char.equal contents.[i] '\n' then line := !line + 1 + done; + let line = !line in + if (not is_text) && Char.( <> ) contents.[up_to - 1] '\n' then ( + output_char oc '\n'; + line + 1) + else line) + else line + in + let rec loop line (pos : Lexing.position) repls ~last_is_text = + match repls with + | [] -> + ignore + (copy_input pos ~up_to:(String.length contents) ~line + ~last_is_text ~is_text:false + : int) + | repl :: repls -> + let is_text = + match repl.data with Text _ -> true | Values _ -> false + in + let line = + copy_input pos ~up_to:repl.start.pos_cnum ~line ~last_is_text + ~is_text + in + let s = Replacement.text repl in + let line = + match target with + | Output Using_line_directives -> + Printf.fprintf oc "# %d %S\n" (line + 1) output_name; + line + 1 + | Output Delimiting_generated_blocks -> + Printf.fprintf oc "%s\n" generated_code_begin; + line + 1 + | Corrected -> line + in + output_string oc s; + let line = line + count_newlines s in + loop_consecutive_repls line repl.stop repls ~last_is_text:is_text + and loop_consecutive_repls line (pos : Lexing.position) repls + ~last_is_text = + match repls with + | [] -> end_consecutive_repls line pos repls ~last_is_text + | repl :: repls' -> + let pos = + if last_is_text then pos else skip_blank_eol contents pos + in + if pos.pos_cnum < repl.start.pos_cnum then + end_consecutive_repls line pos repls ~last_is_text + else + let s = Replacement.text repl in + output_string oc s; + let line = line + count_newlines s in + let last_is_text = + match repl.data with Text _ -> true | Values _ -> false + in + loop_consecutive_repls line repl.stop repls' ~last_is_text + and end_consecutive_repls line pos repls ~last_is_text = (match target with - | Output Using_line_directives -> - Printf.fprintf oc "# %d %S\n%*s" pos.pos_lnum input_name - (pos.pos_cnum - pos.pos_bol) "" - | Output Delimiting_generated_blocks | Corrected -> ()); - output_substring oc contents ~pos:pos.pos_cnum ~len:(up_to - pos.pos_cnum); - let line = ref (line + 1) in - for i = pos.pos_cnum to up_to - 1 do - if Char.equal contents.[i] '\n' then line := !line + 1 - done; - let line = !line in - if not is_text && Char.(<>) contents.[up_to - 1] '\n' then - (output_char oc '\n'; line + 1) - else - line - end else - line - in - let rec loop line (pos : Lexing.position) repls ~last_is_text = + | Output Using_line_directives | Corrected -> () + | Output Delimiting_generated_blocks -> + Printf.fprintf oc "%s\n" generated_code_end); + loop line pos repls ~last_is_text + in + let pos = + { + Lexing.pos_fname = input_name; + pos_lnum = 1; + pos_bol = 0; + pos_cnum = 0; + } + in match repls with - | [] -> - ignore (copy_input pos ~up_to:(String.length contents) ~line - ~last_is_text ~is_text:false : int) - | repl :: repls -> - let is_text = - match repl.data with - | Text _ -> true - | Values _ -> false - in - let line = - copy_input pos ~up_to:repl.start.pos_cnum ~line ~last_is_text ~is_text - in - let s = Replacement.text repl in - let line = - match target with - | Output Using_line_directives -> - Printf.fprintf oc "# %d %S\n" (line + 1) output_name; - line + 1 + | { start = { pos_cnum = 0; _ }; _ } :: _ -> + (match target with + | Output Using_line_directives | Corrected -> () | Output Delimiting_generated_blocks -> - Printf.fprintf oc "%s\n" generated_code_begin; - line + 1 - | Corrected -> - line - in - output_string oc s; - let line = line + count_newlines s in - loop_consecutive_repls line repl.stop repls ~last_is_text:is_text - and loop_consecutive_repls line (pos : Lexing.position) repls ~last_is_text = - match repls with - | [] -> end_consecutive_repls line pos repls ~last_is_text - | repl :: repls' -> - let pos = if last_is_text then pos else skip_blank_eol contents pos in - if pos.pos_cnum < repl.start.pos_cnum then - end_consecutive_repls line pos repls ~last_is_text - else begin - let s = Replacement.text repl in - output_string oc s; - let line = line + count_newlines s in - let last_is_text = - match repl.data with - | Text _ -> true - | Values _ -> false - in - loop_consecutive_repls line repl.stop repls' ~last_is_text - end - and end_consecutive_repls line pos repls ~last_is_text = - (match target with - | Output Using_line_directives | Corrected -> () - | Output Delimiting_generated_blocks -> - Printf.fprintf oc "%s\n" generated_code_end); - loop line pos repls ~last_is_text - in - let pos = - { Lexing. - pos_fname = input_name - ; pos_lnum = 1 - ; pos_bol = 0 - ; pos_cnum = 0 - } - in - match repls with - | { start = { pos_cnum = 0; _ }; _ } :: _ -> - (match target with - | Output Using_line_directives | Corrected -> () - | Output Delimiting_generated_blocks -> - Printf.fprintf oc "%s\n" generated_code_begin); - loop_consecutive_repls 1 pos repls ~last_is_text:false - | _ -> - loop 1 pos repls ~last_is_text:false) + Printf.fprintf oc "%s\n" generated_code_begin); + loop_consecutive_repls 1 pos repls ~last_is_text:false + | _ -> loop 1 pos repls ~last_is_text:false) diff -Nru ppxlib-0.15.0/src/reconcile.mli ppxlib-0.24.0/src/reconcile.mli --- ppxlib-0.15.0/src/reconcile.mli 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/reconcile.mli 2021-12-08 21:53:37.000000000 +0000 @@ -3,44 +3,36 @@ module Context : sig type 'a t = - | Extension of 'a Extension.Context.t + | Extension of 'a Extension.Context.t | Floating_attribute of 'a Attribute.Floating.Context.t end module Replacement : sig type t - val make - : context:'a Context.t - -> start:Lexing.position - -> stop:Lexing.position - -> repl:'a Context_free.Generated_code_hook.single_or_many - -> unit - -> t - - val make_text - : start:Lexing.position - -> stop:Lexing.position - -> repl:string - -> unit - -> t + val make : + context:'a Context.t -> + start:Lexing.position -> + stop:Lexing.position -> + repl:'a Context_free.Generated_code_hook.single_or_many -> + unit -> + t + + val make_text : + start:Lexing.position -> stop:Lexing.position -> repl:string -> unit -> t end -type mode = - | Using_line_directives - | Delimiting_generated_blocks - -type target = - | Output of mode - | Corrected - -val reconcile - : ?styler:string - -> Replacement.t list - -> kind:Kind.t - -> contents:string - -> input_filename:string - -> output:string option - -> input_name:string - -> target:target - -> unit +type mode = Using_line_directives | Delimiting_generated_blocks + +type target = Output of mode | Corrected + +val reconcile : + ?styler:string -> + Replacement.t list -> + kind:Kind.t -> + contents:string -> + input_filename:string -> + output:string option -> + input_name:string -> + target:target -> + unit diff -Nru ppxlib-0.15.0/src/skip_hash_bang.mli ppxlib-0.24.0/src/skip_hash_bang.mli --- ppxlib-0.15.0/src/skip_hash_bang.mli 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/src/skip_hash_bang.mli 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1 @@ +val skip_hash_bang : Lexing.lexbuf -> unit diff -Nru ppxlib-0.15.0/src/skip_hash_bang.mll ppxlib-0.24.0/src/skip_hash_bang.mll --- ppxlib-0.15.0/src/skip_hash_bang.mll 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/src/skip_hash_bang.mll 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,17 @@ +{ +open Lexing + +let update_loc lexbuf lines_to_skip = + let pos = lexbuf.lex_curr_p in + lexbuf.lex_curr_p <- { pos with + pos_lnum = pos.pos_lnum + lines_to_skip; + pos_bol = pos.pos_cnum; + } +} + +rule skip_hash_bang = parse + | "#!" [^ '\n']* '\n' [^ '\n']* "\n!#\n" + { update_loc lexbuf 3 } + | "#!" [^ '\n']* '\n' + { update_loc lexbuf 1 } + | "" { () } diff -Nru ppxlib-0.15.0/src/spellcheck.ml ppxlib-0.24.0/src/spellcheck.ml --- ppxlib-0.15.0/src/spellcheck.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/spellcheck.ml 2021-12-08 21:53:37.000000000 +0000 @@ -1,5 +1,51 @@ open! Import +exception Cutoff_met + +(* As found here http://rosettacode.org/wiki/Levenshtein_distance#OCaml *) +let levenshtein_distance s t cutoff = + let m = String.length s and n = String.length t in + if cutoff = 0 || abs (m - n) >= cutoff then None + else + (* for all i and j, d.(i).(j) will hold the Levenshtein distance between the + first i characters of s and the first j characters of t *) + let d = Array.make_matrix ~dimx:(m + 1) ~dimy:(n + 1) 0 in + for i = 0 to m do + (* the distance of any first string to an empty second string *) + d.(i).(0) <- i + done; + for j = 0 to n do + (* the distance of any second string to an empty first string *) + d.(0).(j) <- j + done; + (* the minimum of each line together with the column index will be used + to notice cutoff exceeding and return early in that case *) + let line_min = ref 0 in + let distance = + try + for j = 1 to n do + if !line_min >= cutoff - 1 && j >= cutoff - 1 then raise Cutoff_met; + line_min := max m n; + for i = 1 to m do + let value = + if Char.equal s.[i - 1] t.[j - 1] then d.(i - 1).(j - 1) + (* no operation required *) + else + min + (d.(i - 1).(j) + 1) (* a deletion *) + (min + (d.(i).(j - 1) + 1) (* an insertion *) + (d.(i - 1).(j - 1) + 1) (* a substitution *)) + in + d.(i).(j) <- value; + line_min := min !line_min value + done + done; + if d.(m).(n) < cutoff then Some d.(m).(n) else None + with Cutoff_met -> None + in + distance + let spellcheck names name = let cutoff = match String.length name with @@ -10,23 +56,20 @@ in let _, suggestions = List.fold_left names ~init:(Int.max_int, []) - ~f:(fun ((best_distance, names_at_best_distance) as acc) registered_name -> - match Ocaml_common.Misc.edit_distance name registered_name cutoff with + ~f:(fun ((best_distance, names_at_best_distance) as acc) registered_name + -> + match levenshtein_distance name registered_name cutoff with | None -> acc | Some dist -> - if dist < best_distance then - (dist, [registered_name]) - else if dist > best_distance then - acc - else - (dist, registered_name :: names_at_best_distance)) + if dist < best_distance then (dist, [ registered_name ]) + else if dist > best_distance then acc + else (dist, registered_name :: names_at_best_distance)) in - match List.rev suggestions |> List.filter ~f:(String.(<>) name) with + match List.rev suggestions |> List.filter ~f:(String.( <> ) name) with | [] -> None | last :: rev_rest -> - Some - (Printf.sprintf "Hint: Did you mean %s%s%s?" - (String.concat ~sep:", " (List.rev rev_rest)) - (if List.is_empty rev_rest then "" else " or ") - last) -;; + Some + (Printf.sprintf "Hint: Did you mean %s%s%s?" + (String.concat ~sep:", " (List.rev rev_rest)) + (if List.is_empty rev_rest then "" else " or ") + last) diff -Nru ppxlib-0.15.0/src/utils.ml ppxlib-0.24.0/src/utils.ml --- ppxlib-0.15.0/src/utils.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/src/utils.ml 2021-12-08 21:53:37.000000000 +0000 @@ -4,113 +4,222 @@ match fn with | None | Some "-" -> f stdout | Some fn -> Out_channel.with_file fn ~binary ~f -;; module Kind = struct type t = Intf | Impl let of_filename fn : t option = - if Caml.Filename.check_suffix fn ".ml" then - Some Impl - else if Caml.Filename.check_suffix fn ".mli" then - Some Intf - else - None - ;; - - let describe = function - | Impl -> "implementation" - | Intf -> "interface" - ;; + if Caml.Filename.check_suffix fn ".ml" then Some Impl + else if Caml.Filename.check_suffix fn ".mli" then Some Intf + else None - let equal : t -> t -> bool = Poly.equal -end + let describe = function Impl -> "implementation" | Intf -> "interface" -module Some_intf_or_impl = struct - type t = - | Intf of Migrate_parsetree.Driver.some_signature - | Impl of Migrate_parsetree.Driver.some_structure - - let to_ast_io (ast : t) ~add_ppx_context = - let open Migrate_parsetree in - match ast with - | Intf (Migrate_parsetree.Driver.Sig ((module Ver), sg)) -> - let sg = - (Migrate_parsetree.Versions.migrate - (module Ver) - (module Versions.OCaml_current)).copy_signature sg - in - let sg = - if add_ppx_context then - Ocaml_common.Ast_mapper.add_ppx_context_sig ~tool_name:"ppxlib_driver" sg - else - sg - in - Ast_io.Intf ((module Versions.OCaml_current), sg) - | Impl (Migrate_parsetree.Driver.Str ((module Ver), st)) -> - let st = - (Migrate_parsetree.Versions.migrate - (module Ver) - (module Versions.OCaml_current)).copy_structure st - in - let st = - if add_ppx_context then - Ocaml_common.Ast_mapper.add_ppx_context_str ~tool_name:"ppxlib_driver" st - else - st - in - Ast_io.Impl ((module Versions.OCaml_current), st) + let equal : t -> t -> bool = Poly.equal end module Intf_or_impl = struct - type t = - | Intf of signature - | Impl of structure + type t = Intf of signature | Impl of structure let map t (map : Ast_traverse.map) = match t with | Impl x -> Impl (map#structure x) | Intf x -> Intf (map#signature x) - ;; let map_with_context t (map : _ Ast_traverse.map_with_context) ctx = match t with | Impl x -> Impl (map#structure ctx x) | Intf x -> Intf (map#signature ctx x) - ;; - let kind : _ -> Kind.t = function - | Intf _ -> Intf - | Impl _ -> Impl + let kind : _ -> Kind.t = function Intf _ -> Intf | Impl _ -> Impl +end - let of_some_intf_or_impl ast : t = - let open Some_intf_or_impl in - match ast with - | Intf (Migrate_parsetree.Driver.Sig ((module Ver), sg)) -> - Intf ((Migrate_parsetree.Versions.migrate (module Ver) - (module Ppxlib_ast.Selected_ast)).copy_signature sg) - | Impl (Migrate_parsetree.Driver.Str ((module Ver), st)) -> - Impl ((Migrate_parsetree.Versions.migrate (module Ver) - (module Ppxlib_ast.Selected_ast)).copy_structure st) +module Ast_io = struct + type input_version = (module OCaml_version) - let of_ast_io ast : t = - let open Migrate_parsetree in + let fall_back_input_version = (module Compiler_version : OCaml_version) + (* This should only be used when the input version can't be determined due to + loading or preprocessing errors *) + + type t = { + input_name : string; + input_version : input_version; + ast : Intf_or_impl.t; + } + + type read_error = + | Not_a_binary_ast + | Unknown_version of string * input_version + | Source_parse_error of Location.Error.t * input_version + | System_error of Location.Error.t * input_version + + type input_source = Stdin | File of string + + type input_kind = Possibly_source of Kind.t * string | Necessarily_binary + + let read_error_to_string (error : read_error) = + match error with + | Not_a_binary_ast -> "Error: Not a binary ast" + | Unknown_version (s, _) -> "Error: Unknown version " ^ s + | Source_parse_error (loc, _) -> + "Source parse error:" ^ Location.Error.message loc + | System_error (loc, _) -> "System error: " ^ Location.Error.message loc + + let parse_source_code ~(kind : Kind.t) ~input_name ~prefix_read_from_source ic + = + (* The input version is determined by the fact that the input will get parsed by + the current compiler Parse module *) + let input_version = (module Compiler_version : OCaml_version) in + try + (* To test if a file is an AST file, we have to read the first few bytes of the + file. If it is not, we have to parse these bytes and the rest of the file as + source code. + + The compiler just does [seek_on 0] in this case, however this doesn't work when + the input is a pipe. + + What we do instead is create a lexing buffer from the input channel and pre-fill + it with what we read to do the test. *) + let lexbuf = Lexing.from_channel ic in + let len = String.length prefix_read_from_source in + Bytes.blit_string ~src:prefix_read_from_source ~src_pos:0 + ~dst:lexbuf.lex_buffer ~dst_pos:0 ~len; + lexbuf.lex_buffer_len <- len; + lexbuf.lex_curr_p <- + { pos_fname = input_name; pos_lnum = 1; pos_bol = 0; pos_cnum = 0 }; + Skip_hash_bang.skip_hash_bang lexbuf; + let ast : Intf_or_impl.t = + match kind with + | Intf -> Intf (Parse.interface lexbuf) + | Impl -> Impl (Parse.implementation lexbuf) + in + Ok { input_name; input_version; ast } + with exn -> ( + match Location.Error.of_exn exn with + | None -> raise exn + | Some error -> Error (Source_parse_error (error, input_version))) + + let magic_length = String.length Astlib.Config.ast_impl_magic_number + + let read_magic ic = + let buf = Bytes.create magic_length in + let len = input ic buf 0 magic_length in + let s = Bytes.sub_string buf ~pos:0 ~len in + if len = magic_length then Ok s else Error s + + let from_channel ch ~input_kind = + let handle_non_binary prefix_read_from_source = + match input_kind with + | Possibly_source (kind, input_name) -> + parse_source_code ~kind ~input_name ~prefix_read_from_source ch + | Necessarily_binary -> Error Not_a_binary_ast + in + match read_magic ch with + | Error s -> handle_non_binary s + | Ok s -> ( + match Find_version.from_magic s with + | Intf (module Input_version : OCaml_version) -> + let input_name : string = input_value ch in + let ast = input_value ch in + let module Input_to_ppxlib = Convert (Input_version) (Js) in + let ast = Intf_or_impl.Intf (Input_to_ppxlib.copy_signature ast) in + Ok + { + input_name; + input_version = (module Input_version : OCaml_version); + ast; + } + | Impl (module Input_version : OCaml_version) -> + let input_name : string = input_value ch in + let ast = input_value ch in + let module Input_to_ppxlib = Convert (Input_version) (Js) in + let ast = Intf_or_impl.Impl (Input_to_ppxlib.copy_structure ast) in + Ok + { + input_name; + input_version = (module Input_version : OCaml_version); + ast; + } + | Unknown -> + if + String.equal + (String.sub s ~pos:0 ~len:9) + (String.sub Astlib.Config.ast_impl_magic_number ~pos:0 ~len:9) + || String.equal + (String.sub s ~pos:0 ~len:9) + (String.sub Astlib.Config.ast_intf_magic_number ~pos:0 ~len:9) + then Error (Unknown_version (s, fall_back_input_version)) + else handle_non_binary s) + + let read input_source ~input_kind = + try + match input_source with + | Stdin -> from_channel stdin ~input_kind + | File fn -> In_channel.with_file fn ~f:(from_channel ~input_kind) + with exn -> ( + match Location.Error.of_exn exn with + | None -> raise exn + | Some error -> Error (System_error (error, fall_back_input_version))) + + let write oc { input_name; input_version = (module Input_version); ast } + ~add_ppx_context = + let module Ppxlib_to_input = Convert (Js) (Input_version) in + let module Ocaml_to_input = Convert (Compiler_version) (Input_version) in match ast with - | Ast_io.Intf ((module Ver), sg) -> - let module C = Versions.Convert(Ver)(Ppxlib_ast.Selected_ast) in - Intf (C.copy_signature sg) - | Ast_io.Impl ((module Ver), st) -> - let module C = Versions.Convert(Ver)(Ppxlib_ast.Selected_ast) in - Impl (C.copy_structure st) + | Intf sg -> + let sg = + if add_ppx_context then + Selected_ast.To_ocaml.copy_signature sg + |> Astlib.Ast_metadata.add_ppx_context_sig ~tool_name:"ppx_driver" + |> Ocaml_to_input.copy_signature + else Ppxlib_to_input.copy_signature sg + in + output_string oc Input_version.Ast.Config.ast_intf_magic_number; + output_value oc input_name; + output_value oc sg + | Impl st -> + let st = + if add_ppx_context then + Selected_ast.To_ocaml.copy_structure st + |> Astlib.Ast_metadata.add_ppx_context_str ~tool_name:"ppx_driver" + |> Ocaml_to_input.copy_structure + else Ppxlib_to_input.copy_structure st + in + output_string oc Input_version.Ast.Config.ast_impl_magic_number; + output_value oc input_name; + output_value oc st + + module Read_bin = struct + type ast = Intf of signature | Impl of structure + + type t = { ast : ast; input_name : string } + + let read_binary fn = + match + In_channel.with_file fn ~f:(from_channel ~input_kind:Necessarily_binary) + with + | Ok { ast; input_name; _ } -> + let ast = + match ast with + | Impl structure -> Impl structure + | Intf signature -> Intf signature + in + Ok { ast; input_name } + | Error e -> Error (read_error_to_string e) + + let get_ast t = t.ast + + let get_input_name t = t.input_name + end +end + +module System = struct + let run_preprocessor ~pp ~input ~output = + let command = + Printf.sprintf "%s %s > %s" pp + (if String.equal input "-" then "" else Caml.Filename.quote input) + (Caml.Filename.quote output) + in + if Caml.Sys.command command = 0 then Ok () + else Error (command, Ast_io.fall_back_input_version) end -(* -let map_impl x ~(f : _ Intf_or_impl.t -> _ Intf_or_impl.t) = - match f (Impl x) with - | Impl x -> x - | Intf _ -> assert false - -let map_intf x ~(f : _ Intf_or_impl.t -> _ Intf_or_impl.t) = - match f (Intf x) with - | Intf x -> x - | Impl _ -> assert false -*) diff -Nru ppxlib-0.15.0/src/utils.mli ppxlib-0.24.0/src/utils.mli --- ppxlib-0.15.0/src/utils.mli 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/src/utils.mli 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,69 @@ +open Import + +val with_output : label option -> binary:bool -> f:(out_channel -> 'a) -> 'a + +module Kind : sig + type t = Intf | Impl + + val of_filename : string -> t option + + val describe : t -> string + + val equal : t -> t -> bool +end + +module Intf_or_impl : sig + type t = Intf of signature | Impl of structure + + val map : t -> Ast_traverse.map -> t + + val map_with_context : t -> 'a Ast_traverse.map_with_context -> 'a -> t + + val kind : t -> Kind.t +end + +module Ast_io : sig + type input_version + + type t = { + input_name : string; + input_version : input_version; + ast : Intf_or_impl.t; + } + + type read_error = + | Not_a_binary_ast + | Unknown_version of string * input_version + (* The input contains a binary AST for an unknown version of + OCaml. The first argument is the unknown magic number. *) + | Source_parse_error of Location.Error.t * input_version + | System_error of Location.Error.t * input_version + + type input_source = Stdin | File of string + + type input_kind = Possibly_source of Kind.t * string | Necessarily_binary + + val read : input_source -> input_kind:input_kind -> (t, read_error) result + + val write : out_channel -> t -> add_ppx_context:bool -> unit + + module Read_bin : sig + type ast = Intf of signature | Impl of structure + + type t + + val read_binary : string -> (t, string) result + + val get_ast : t -> ast + + val get_input_name : t -> string + end +end + +module System : sig + val run_preprocessor : + pp:string -> + input:string -> + output:string -> + (unit, string * Ast_io.input_version) result +end diff -Nru ppxlib-0.15.0/stdppx/dune ppxlib-0.24.0/stdppx/dune --- ppxlib-0.15.0/stdppx/dune 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/stdppx/dune 2021-12-08 21:53:37.000000000 +0000 @@ -1,8 +1,6 @@ (library (name stdppx) (public_name ppxlib.stdppx) - (libraries - ocaml-compiler-libs.shadow - sexplib0 - stdlib-shims) - (flags (:standard -open Ocaml_shadow -safe-string))) + (libraries sexplib0 stdlib-shims) + (flags + (:standard -safe-string))) diff -Nru ppxlib-0.15.0/stdppx/stdppx.ml ppxlib-0.24.0/stdppx/stdppx.ml --- ppxlib-0.15.0/stdppx/stdppx.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/stdppx/stdppx.ml 2021-12-08 21:53:37.000000000 +0000 @@ -1,8 +1,6 @@ module Caml = Stdlib - open Caml open StdLabels - module Sexp = Sexplib0.Sexp module Sexpable = Sexplib0.Sexpable include Sexplib0.Sexp_conv @@ -11,27 +9,45 @@ type t val compare : t -> t -> int + val equal : t -> t -> bool + val ( = ) : t -> t -> bool + val ( < ) : t -> t -> bool + val ( > ) : t -> t -> bool + val ( <> ) : t -> t -> bool + val ( <= ) : t -> t -> bool + val ( >= ) : t -> t -> bool + val min : t -> t -> t + val max : t -> t -> t end module Poly = struct let compare = compare + let equal = ( = ) + let ( = ) = ( = ) + let ( < ) = ( < ) + let ( > ) = ( > ) + let ( <> ) = ( <> ) + let ( <= ) = ( <= ) + let ( >= ) = ( >= ) + let min = min + let max = max end @@ -48,6 +64,8 @@ module Bytes = struct include Bytes + let sub_string t ~pos ~len = Stdlib.Bytes.sub_string t pos len + let blit_string ~src ~src_pos ~dst ~dst_pos ~len = Stdlib.Bytes.blit_string src src_pos dst dst_pos len end @@ -61,8 +79,12 @@ module Exn = struct let protectx x ~f ~finally = match f x with - | y -> finally x; y - | exception exn -> finally x; raise exn + | y -> + finally x; + y + | exception exn -> + finally x; + raise exn end module Float = struct @@ -85,46 +107,39 @@ add t key data let add t ~key ~data = - if mem t key - then Error (Invalid_argument "Hashtbl.add_exn") - else (add t key data; Ok ()) + if mem t key then Error (Invalid_argument "Hashtbl.add_exn") + else ( + add t key data; + Ok ()) let add_exn t ~key ~data = - match add t ~key ~data with - | Ok () -> () - | Error exn -> raise exn + match add t ~key ~data with Ok () -> () | Error exn -> raise exn let find_opt t key = - match find t key with - | data -> Some data - | exception Not_found -> None + match find t key with data -> Some data | exception Not_found -> None let find_or_add t key ~default = match find_opt t key with | Some data -> data | None -> - let data = default () in - add_exn t ~key ~data; - data + let data = default () in + add_exn t ~key ~data; + data let rec add_alist t alist = match alist with | [] -> Ok () - | (key, data) :: tail -> - match add t ~key ~data with - | Ok () -> add_alist t tail - | Error (_ : exn) -> Error key + | (key, data) :: tail -> ( + match add t ~key ~data with + | Ok () -> add_alist t tail + | Error (_ : exn) -> Error key) let of_alist ?size alist = let size = - match size with - | Some size -> size - | None -> List.length alist + match size with Some size -> size | None -> List.length alist in let t = create size in - match add_alist t alist with - | Ok () -> Ok t - | Error _ as error -> error + match add_alist t alist with Ok () -> Ok t | Error _ as error -> error let of_alist_exn ?size alist = match of_alist ?size alist with @@ -134,7 +149,7 @@ module In_channel = struct let create ?(binary = true) file = - let flags = [Open_rdonly] in + let flags = [ Open_rdonly ] in let flags = if binary then Open_binary :: flags else flags in open_in_gen flags 0o000 file @@ -145,15 +160,16 @@ let input_all t = let rec read_all_into t buf = match input_char t with - | char -> Buffer.add_char buf char; read_all_into t buf + | char -> + Buffer.add_char buf char; + read_all_into t buf | exception End_of_file -> () in let buf = Buffer.create 64 in read_all_into t buf; Buffer.contents buf - let read_all filename = - with_file filename ~f:input_all + let read_all filename = with_file filename ~f:input_all end module Int = struct @@ -167,9 +183,12 @@ module List = struct include List - include struct (* shadow non-tail-recursive functions *) + include struct + (* shadow non-tail-recursive functions *) let merge = `not_tail_recursive + let remove_assoc = `not_tail_recursive + let remove_assq = `not_tail_recursive let rev_mapi list ~f = @@ -184,12 +203,14 @@ fold_left2 (rev list1) (rev list2) ~init ~f:(fun acc x y -> f x y acc) let map list ~f = rev (rev_map list ~f) + let mapi list ~f = rev (rev_mapi list ~f) let fold_right list ~init ~f = fold_left (List.rev list) ~init ~f:(fun acc x -> f x acc) let append x y = rev_append (rev x) y + let concat list = fold_right list ~init:[] ~f:append let rev_combine list1 list2 = @@ -198,7 +219,8 @@ let combine list1 list2 = rev (rev_combine list1 list2) let split list = - fold_right list ~init:([], []) ~f:(fun (x, y) (xs, ys) -> (x :: xs, y :: ys)) + fold_right list ~init:([], []) ~f:(fun (x, y) (xs, ys) -> + (x :: xs, y :: ys)) let map2 list1 list2 ~f = rev (fold_left2 list1 list2 ~init:[] ~f:(fun acc x y -> f x y :: acc)) @@ -206,21 +228,16 @@ let init ~len ~f = let rec loop ~len ~pos ~f ~acc = - if pos >= len - then List.rev acc + if pos >= len then List.rev acc else loop ~len ~pos:(pos + 1) ~f ~acc:(f pos :: acc) in loop ~len ~pos:0 ~f ~acc:[] - let is_empty = function - | [] -> true - | _ :: _ -> false + let is_empty = function [] -> true | _ :: _ -> false let rev_filter_opt list = fold_left list ~init:[] ~f:(fun tail option -> - match option with - | None -> tail - | Some head -> head :: tail) + match option with None -> tail | Some head -> head :: tail) let filter_opt list = rev (rev_filter_opt list) @@ -231,26 +248,22 @@ let rec find_map list ~f = match list with | [] -> None - | head :: tail -> - match f head with - | Some _ as some -> some - | None -> find_map tail ~f + | head :: tail -> ( + match f head with Some _ as some -> some | None -> find_map tail ~f) let find_map_exn list ~f = - match find_map list ~f with - | Some x -> x - | None -> raise Not_found + match find_map list ~f with Some x -> x | None -> raise Not_found let rec last = function | [] -> None - | [x] -> Some x - | _ :: ((_ :: _) as rest) -> last rest + | [ x ] -> Some x + | _ :: (_ :: _ as rest) -> last rest let split_while list ~f = let rec split_while_into list ~f ~acc = match list with | head :: tail when f head -> split_while_into tail ~f ~acc:(head :: acc) - | _ :: _ | [] -> List.rev acc, list + | _ :: _ | [] -> (List.rev acc, list) in split_while_into list ~f ~acc:[] @@ -265,48 +278,35 @@ match list with | [] -> None | head :: tail -> - if Elt_set.mem head set - then Some head - else find_a_dup_in tail ~set:(Elt_set.add head set) + if Elt_set.mem head set then Some head + else find_a_dup_in tail ~set:(Elt_set.add head set) in find_a_dup_in list ~set:Elt_set.empty let assoc_opt key alist = - match assoc key alist with - | x -> Some x - | exception Not_found -> None + match assoc key alist with x -> Some x | exception Not_found -> None (* reorders arguments to improve type inference *) let iter list ~f = iter list ~f end module Option = struct - let is_some = function - | None -> false - | Some _ -> true - - let iter t ~f = - match t with - | None -> () - | Some x -> f x + let is_some = function None -> false | Some _ -> true - let map t ~f = - match t with - | None -> None - | Some x -> Some (f x) + let iter t ~f = match t with None -> () | Some x -> f x - let value t ~default = - match t with - | None -> default - | Some x -> x + let map t ~f = match t with None -> None | Some x -> Some (f x) + + let value t ~default = match t with None -> default | Some x -> x end module Out_channel = struct - let create ?(binary = true) ?(append = false) ?(fail_if_exists = false) ?(perm = 0o666) file = - let flags = [Open_wronly; Open_creat] in + let create ?(binary = true) ?(append = false) ?(fail_if_exists = false) + ?(perm = 0o666) file = + let flags = [ Open_wronly; Open_creat ] in let flags = (if binary then Open_binary else Open_text) :: flags in let flags = (if append then Open_append else Open_trunc) :: flags in - let flags = (if fail_if_exists then Open_excl :: flags else flags) in + let flags = if fail_if_exists then Open_excl :: flags else flags in open_out_gen flags perm file let with_file ?binary ?append ?fail_if_exists ?perm file ~f = @@ -323,28 +323,30 @@ let is_empty (t : t) = length t = 0 let prefix t len = sub t ~pos:0 ~len + let suffix t len = sub t ~pos:(length t - len) ~len let drop_prefix t len = sub t ~pos:len ~len:(length t - len) + let drop_suffix t len = sub t ~pos:0 ~len:(length t - len) let is_prefix t ~prefix = let rec is_prefix_from t ~prefix ~pos ~len = pos >= len - || (Char.equal (get t pos) (get prefix pos) - && is_prefix_from t ~prefix ~pos:(pos + 1) ~len) + || Char.equal (get t pos) (get prefix pos) + && is_prefix_from t ~prefix ~pos:(pos + 1) ~len in - length t >= length prefix && is_prefix_from t ~prefix ~pos:0 ~len:(length prefix) + length t >= length prefix + && is_prefix_from t ~prefix ~pos:0 ~len:(length prefix) let is_suffix t ~suffix = let rec is_suffix_up_to t ~suffix ~pos ~suffix_offset = pos < 0 - || (Char.equal (get t (suffix_offset + pos)) (get suffix pos) - && is_suffix_up_to t ~suffix ~pos:(pos - 1) ~suffix_offset) + || Char.equal (get t (suffix_offset + pos)) (get suffix pos) + && is_suffix_up_to t ~suffix ~pos:(pos - 1) ~suffix_offset in length t >= length suffix - && is_suffix_up_to t - ~suffix + && is_suffix_up_to t ~suffix ~pos:(length suffix - 1) ~suffix_offset:(length t - length suffix) @@ -361,19 +363,13 @@ for_all_at t ~f ~pos:0 ~len:(length t) let index_opt t char = - match index t char with - | i -> Some i - | exception Not_found -> None + match index t char with i -> Some i | exception Not_found -> None let rindex_opt t char = - match rindex t char with - | i -> Some i - | exception Not_found -> None + match rindex t char with i -> Some i | exception Not_found -> None let index_from_opt t char pos = - match index_from t char pos with - | i -> Some i - | exception Not_found -> None + match index_from t char pos with i -> Some i | exception Not_found -> None let rindex_from_opt t char pos = match rindex_from t char pos with @@ -383,10 +379,13 @@ let lsplit2 t ~on = match index_opt t on with | None -> None - | Some i -> Some (sub t ~pos:0 ~len:i, sub t ~pos:(i + 1) ~len:(length t - i - 1)) + | Some i -> + Some (sub t ~pos:0 ~len:i, sub t ~pos:(i + 1) ~len:(length t - i - 1)) let capitalize_ascii = Stdlib.String.capitalize_ascii + let lowercase_ascii = Stdlib.String.lowercase_ascii + let uncapitalize_ascii = Stdlib.String.uncapitalize_ascii let split_on_char t ~sep = Stdlib.String.split_on_char sep t @@ -397,9 +396,7 @@ include Map.Make (String) let find_opt key t = - match find key t with - | x -> Some x - | exception Not_found -> None + match find key t with x -> Some x | exception Not_found -> None end module Set = Set.Make (String) @@ -408,4 +405,5 @@ let ( @ ) = List.append let output oc bytes ~pos ~len = output oc bytes pos len + let output_substring oc string ~pos ~len = output_substring oc string pos len diff -Nru ppxlib-0.15.0/test/base/dune ppxlib-0.24.0/test/base/dune --- ppxlib-0.15.0/test/base/dune 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/test/base/dune 2021-12-08 21:53:37.000000000 +0000 @@ -1,9 +1,13 @@ -(alias - (name runtest) +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} "4.09.0")) (deps (:test test.ml) (package ppxlib)) - (action (chdir %{project_root} - (progn - (run expect-test %{test}) - (diff? %{test} %{test}.corrected))))) + (action + (chdir + %{project_root} + (progn + (run expect-test %{test}) + (diff? %{test} %{test}.corrected))))) diff -Nru ppxlib-0.15.0/test/base/test.ml ppxlib-0.24.0/test/base/test.ml --- ppxlib-0.15.0/test/base/test.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/test/base/test.ml 2021-12-08 21:53:37.000000000 +0000 @@ -149,3 +149,32 @@ [%%expect{| - : string = "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 * string = ("__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 -Nru ppxlib-0.15.0/test/code_path/dune ppxlib-0.24.0/test/code_path/dune --- ppxlib-0.15.0/test/code_path/dune 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/test/code_path/dune 2021-12-08 21:53:37.000000000 +0000 @@ -1,9 +1,13 @@ -(alias - (name runtest) +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} "4.08.0")) (deps (:test test.ml) (package ppxlib)) - (action (chdir %{project_root} - (progn - (run expect-test %{test}) - (diff? %{test} %{test}.corrected))))) + (action + (chdir + %{project_root} + (progn + (run expect-test %{test}) + (diff? %{test} %{test}.corrected))))) diff -Nru ppxlib-0.15.0/test/deriving/dune ppxlib-0.24.0/test/deriving/dune --- ppxlib-0.15.0/test/deriving/dune 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/test/deriving/dune 2021-12-08 21:53:37.000000000 +0000 @@ -1,9 +1,13 @@ -(alias - (name runtest) +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} "4.10.0")) (deps (:test test.ml) (package ppxlib)) - (action (chdir %{project_root} - (progn - (run expect-test %{test}) - (diff? %{test} %{test}.corrected))))) + (action + (chdir + %{project_root} + (progn + (run expect-test %{test}) + (diff? %{test} %{test}.corrected))))) diff -Nru ppxlib-0.15.0/test/deriving/inline/example/dune ppxlib-0.24.0/test/deriving/inline/example/dune --- ppxlib-0.15.0/test/deriving/inline/example/dune 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/test/deriving/inline/example/dune 2021-12-08 21:53:37.000000000 +0000 @@ -1,9 +1,8 @@ (library - (name ppx_deriving_example) - (preprocess (pps ppxlib ppx_foo_deriver ppxlib.runner)) -) + (name ppx_deriving_example) + (preprocess + (pps ppx_foo_deriver))) (alias - (name runtest) - (deps ppx_deriving_example.cma) - ) + (name runtest) + (deps ppx_deriving_example.cma)) diff -Nru ppxlib-0.15.0/test/deriving/inline/example/ppx_deriving_example.ml ppxlib-0.24.0/test/deriving/inline/example/ppx_deriving_example.ml --- ppxlib-0.15.0/test/deriving/inline/example/ppx_deriving_example.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/test/deriving/inline/example/ppx_deriving_example.ml 2021-12-08 21:53:37.000000000 +0000 @@ -1,4 +1,13 @@ type t = A [@@deriving_inline foo] -let _ = fun (_ : t) -> () -let _ = [%foo ] + +include struct + [@@@ocaml.warning "-60"] + + let _ = fun (_ : t) -> () + + module Foo = struct end + + let _ = [%foo] +end [@@ocaml.doc "@inline"] + [@@@deriving.end] diff -Nru ppxlib-0.15.0/test/deriving/inline/foo-deriver/dune ppxlib-0.24.0/test/deriving/inline/foo-deriver/dune --- ppxlib-0.15.0/test/deriving/inline/foo-deriver/dune 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/test/deriving/inline/foo-deriver/dune 2021-12-08 21:53:37.000000000 +0000 @@ -1,5 +1,4 @@ (library - (kind ppx_deriver) - (name ppx_foo_deriver) - (libraries ppxlib) -) + (kind ppx_deriver) + (name ppx_foo_deriver) + (libraries ppxlib)) diff -Nru ppxlib-0.15.0/test/deriving/inline/foo-deriver/ppx_foo_deriver.ml ppxlib-0.24.0/test/deriving/inline/foo-deriver/ppx_foo_deriver.ml --- ppxlib-0.15.0/test/deriving/inline/foo-deriver/ppx_foo_deriver.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/test/deriving/inline/foo-deriver/ppx_foo_deriver.ml 2021-12-08 21:53:37.000000000 +0000 @@ -11,62 +11,79 @@ let add_deriver () = let str_type_decl = - Deriving.Generator.make_noarg ( - fun ~loc ~path:_ _ -> - let expr desc : expression= - { pexp_desc = desc; + Deriving.Generator.make_noarg + (fun ~loc ~path:_ _ -> + let expr desc : expression = + { + pexp_desc = desc; pexp_loc = loc; pexp_attributes = []; pexp_loc_stack = []; } in [ - {pstr_loc = loc; - pstr_desc = - (Pstr_value (Nonrecursive, [{ - pvb_pat = - { ppat_desc = Ppat_any; - ppat_loc = loc; - ppat_attributes = []; - ppat_loc_stack = []; - } - ; - pvb_expr = expr ( - Pexp_extension ({loc; txt = "foo"}, PStr [])); - pvb_attributes = []; - pvb_loc = loc; - }])); - } - ] - ) + { + pstr_loc = loc; + pstr_desc = + Pstr_module + { + pmb_loc = loc; + pmb_name = { loc; txt = Some "Foo" }; + pmb_expr = + { + pmod_loc = loc; + pmod_desc = Pmod_structure []; + pmod_attributes = []; + }; + pmb_attributes = []; + }; + }; + { + pstr_loc = loc; + pstr_desc = + Pstr_value + ( Nonrecursive, + [ + { + pvb_pat = + { + ppat_desc = Ppat_any; + ppat_loc = loc; + ppat_attributes = []; + ppat_loc_stack = []; + }; + pvb_expr = + expr (Pexp_extension ({ loc; txt = "foo" }, PStr [])); + pvb_attributes = []; + pvb_loc = loc; + }; + ] ); + }; + ]) ~attributes:[] in let sig_type_decl = - Deriving.Generator.make_noarg ( - fun ~loc ~path decl -> + Deriving.Generator.make_noarg (fun ~loc ~path decl -> ignore loc; ignore path; ignore decl; - [ - ] - ) + []) in - Deriving.add "foo" - ~str_type_decl - ~sig_type_decl + Deriving.add "foo" ~str_type_decl ~sig_type_decl let () = Driver.register_transformation "foo" - ~rules:[ - Context_free.Rule.extension - (Extension.declare "foo" - Expression Ast_pattern.__ - (fun ~loc ~path:_ _payload -> - { pexp_desc = Pexp_constant (Pconst_string ("foo", None)); - pexp_loc = loc; - pexp_attributes = []; - pexp_loc_stack = []; - })) - ] + ~rules: + [ + Context_free.Rule.extension + (Extension.declare "foo" Expression Ast_pattern.__ + (fun ~loc ~path:_ _payload -> + { + pexp_desc = Pexp_constant (Pconst_string ("foo", loc, None)); + pexp_loc = loc; + pexp_attributes = []; + pexp_loc_stack = []; + })); + ] let (_ : Deriving.t) = add_deriver () diff -Nru ppxlib-0.15.0/test/driver/attributes/dune ppxlib-0.24.0/test/driver/attributes/dune --- ppxlib-0.15.0/test/driver/attributes/dune 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/test/driver/attributes/dune 2021-12-08 21:53:37.000000000 +0000 @@ -1,9 +1,13 @@ -(alias - (name runtest) +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} "4.08.0")) (deps (:test test.ml) (package ppxlib)) - (action (chdir %{project_root} - (progn - (run expect-test %{test}) - (diff? %{test} %{test}.corrected))))) + (action + (chdir + %{project_root} + (progn + (run expect-test %{test}) + (diff? %{test} %{test}.corrected))))) diff -Nru ppxlib-0.15.0/test/driver/error_embedding/dune ppxlib-0.24.0/test/driver/error_embedding/dune --- ppxlib-0.15.0/test/driver/error_embedding/dune 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/error_embedding/dune 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,6 @@ +(executables + (names raiser pp) + (libraries ppxlib)) + +(cram + (deps raiser.exe pp.exe)) diff -Nru ppxlib-0.15.0/test/driver/error_embedding/pp.ml ppxlib-0.24.0/test/driver/error_embedding/pp.ml --- ppxlib-0.15.0/test/driver/error_embedding/pp.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/error_embedding/pp.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1 @@ +let () = Ppxlib.Location.raise_errorf "Raising inside the preprocessor" diff -Nru ppxlib-0.15.0/test/driver/error_embedding/raiser.ml ppxlib-0.24.0/test/driver/error_embedding/raiser.ml --- ppxlib-0.15.0/test/driver/error_embedding/raiser.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/error_embedding/raiser.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,14 @@ +open Ppxlib + +let rule = + let expand ~loc ~path:_ = + Location.raise_errorf ~loc "Raising inside the rewriter" + in + Extension.declare "raise" Extension.Context.expression + Ast_pattern.(pstr nil) + expand + |> Context_free.Rule.extension + +let () = Driver.register_transformation ~rules:[ rule ] "test" + +let () = Driver.standalone () diff -Nru ppxlib-0.15.0/test/driver/error_embedding/test.t/run.t ppxlib-0.24.0/test/driver/error_embedding/test.t/run.t --- ppxlib-0.15.0/test/driver/error_embedding/test.t/run.t 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/error_embedding/test.t/run.t 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,54 @@ +Keep the error output short in order to avoid different error output between +different compiler versions in the subsequent tests + + $ export OCAML_ERROR_STYLE=short + +With the `-embed-errors` options, if a PPX raises, the first such exception +is caught and packed into an output AST + + $ echo "let _ = [%raise]" > impl.ml + $ ../raiser.exe -embed-errors impl.ml + [%%ocaml.error "Raising inside the rewriter"] + +The same is true when using the `-as-ppx` mode (note that the error is reported +by ocaml itself) + + $ ocaml -ppx '../raiser.exe -as-ppx' impl.ml + File "./impl.ml", line 1, characters 8-16: + Error: Raising inside the rewriter + [2] + +Also exceptions raised in a preprocessor get embedded into an AST(while the +error from the preprocessor's stderr also gets reported on the driver's stderr) + + $ touch file.ml + $ ../raiser.exe -embed-errors -pp ../pp.exe file.ml | sed "s/> '.*'/> tmpfile/" + Fatal error: exception Raising inside the preprocessor + [%%ocaml.error + "Error while running external preprocessor\nCommand line: ../pp.exe 'file.ml' > tmpfile\n"] + +Also `unknown version` errors are embedded into an AST when using the +main standalone + + $ ../raiser.exe -embed-errors -intf unknown_version_binary_ast + [%%ocaml.error + "File is a binary ast for an unknown version of OCaml with magic number 'Caml1999N012'"] + +... but the `-as-ppx` standalone raises them + + $ ../raiser.exe -as-ppx unknown_version_binary_ast output + File "unknown_version_binary_ast", line 1: + Error: The input is a binary ast for an unknown version of OCaml with magic number 'Caml1999N012' + [1] + +Similar for 'input doesn't exist' errors: they get embedded by the main standalone... + + $ ../raiser.exe -embed-errors -impl non_existing_file + [%%ocaml.error "I/O error: non_existing_file: No such file or directory"] + +... but not by the `-as-ppx` standalone + + $ ../raiser.exe -as-ppx non_existing_file output + File "non_existing_file", line 1: + Error: I/O error: non_existing_file: No such file or directory + [1] Binary files /tmp/tmp846rjmsk/GiyumyOLPF/ppxlib-0.15.0/test/driver/error_embedding/test.t/unknown_version_binary_ast and /tmp/tmp846rjmsk/f6JOSjOot5/ppxlib-0.24.0/test/driver/error_embedding/test.t/unknown_version_binary_ast differ diff -Nru ppxlib-0.15.0/test/driver/exception_handling/deriver.ml ppxlib-0.24.0/test/driver/exception_handling/deriver.ml --- ppxlib-0.15.0/test/driver/exception_handling/deriver.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/exception_handling/deriver.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,39 @@ +open Ppxlib + +let generate_impl_extension_node ~ctxt (_rec_flag, _type_declarations) = + let loc = Expansion_context.Deriver.derived_item_loc ctxt in + let extension_node = + Location.Error.( + make ~loc "An error message in an extension node" ~sub:[] |> to_extension) + in + [ Ast_builder.Default.pstr_extension ~loc extension_node [] ] + +let generate_impl_located_error ~ctxt (_rec_flag, _type_declarations) = + let loc = Expansion_context.Deriver.derived_item_loc ctxt in + Location.raise_errorf ~loc "A raised located error" + +let generate_impl_raised_exception ~ctxt:_ (_rec_flag, _type_declarations) = + failwith "A raised exception" + +let impl_generator_extension_node = + Deriving.Generator.V2.make_noarg generate_impl_extension_node + +let impl_generator_located_error = + Deriving.Generator.V2.make_noarg generate_impl_located_error + +let impl_generator_raised_exception = + Deriving.Generator.V2.make_noarg generate_impl_raised_exception + +let my_deriver_extension_node = + Deriving.add "deriver_extension_node" + ~str_type_decl:impl_generator_extension_node + +let my_deriver_located_error = + Deriving.add "deriver_located_error" + ~str_type_decl:impl_generator_located_error + +let my_deriver_raised_exception = + Deriving.add "deriver_raised_exception" + ~str_type_decl:impl_generator_raised_exception + +let () = Driver.standalone () diff -Nru ppxlib-0.15.0/test/driver/exception_handling/dune ppxlib-0.24.0/test/driver/exception_handling/dune --- ppxlib-0.15.0/test/driver/exception_handling/dune 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/exception_handling/dune 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,8 @@ +(executables + (names whole_file_exception whole_file_extension_point + whole_file_located_error extender deriver) + (libraries ppxlib)) + +(cram + (deps extender.exe whole_file_exception.exe whole_file_located_error.exe + deriver.exe whole_file_extension_point.exe)) diff -Nru ppxlib-0.15.0/test/driver/exception_handling/extender.ml ppxlib-0.24.0/test/driver/exception_handling/extender.ml --- ppxlib-0.15.0/test/driver/exception_handling/extender.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/exception_handling/extender.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,41 @@ +open Ppxlib + +let expand_into_extension_node ~ctxt = + let loc = Expansion_context.Extension.extension_point_loc ctxt in + let extension_node = + Location.Error.( + make ~loc "An error message in an extension node" ~sub:[] |> to_extension) + in + Ast_builder.Default.pexp_extension ~loc extension_node + +let expand_raise_exception ~ctxt:_ = failwith "A raised exception" + +let expand_raise_located_error ~ctxt = + let loc = Expansion_context.Extension.extension_point_loc ctxt in + Location.raise_errorf ~loc "A raised located error" + +let extension_point_extension = + Extension.V3.declare "gen_ext_node" Extension.Context.expression + Ast_pattern.(pstr nil) + expand_into_extension_node + +let raise_exception_extension = + Extension.V3.declare "gen_raise_exc" Extension.Context.expression + Ast_pattern.(pstr nil) + expand_raise_exception + +let raise_located_error_extension = + Extension.V3.declare "gen_raise_located_error" Extension.Context.expression + Ast_pattern.(pstr nil) + expand_raise_located_error + +let rule1 = Ppxlib.Context_free.Rule.extension extension_point_extension + +let rule2 = Ppxlib.Context_free.Rule.extension raise_exception_extension + +let rule3 = Ppxlib.Context_free.Rule.extension raise_located_error_extension + +let () = + Driver.register_transformation ~rules:[ rule1; rule2; rule3 ] "gen_errors" + +let () = Driver.standalone () diff -Nru ppxlib-0.15.0/test/driver/exception_handling/run.t ppxlib-0.24.0/test/driver/exception_handling/run.t --- ppxlib-0.15.0/test/driver/exception_handling/run.t 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/exception_handling/run.t 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,123 @@ +In this test we verify the behavior of ppxlib with regard to rewriters +error generations. We test both extenders, derivers and whole file +rewriters. + +There is mainly three way for ppxs to handle errors, from best to +worst practice: + +1. Putting an "error extension node" in the AST. In this test, the AST +is rewritten to contain two of these nodes. + + In the case of extenders + + $ echo "let _ = [%gen_ext_node] + [%gen_ext_node]" > impl.ml + $ ./extender.exe impl.ml + let _ = + ([%ocaml.error "An error message in an extension node"]) + + ([%ocaml.error "An error message in an extension node"]) + + In the case of derivers + + $ echo "type a = int [@@deriving deriver_extension_node]" > impl.ml + $ ./deriver.exe impl.ml + type a = int[@@deriving deriver_extension_node] + include + struct + let _ = fun (_ : a) -> () + [%%ocaml.error "An error message in an extension node"] + end[@@ocaml.doc "@inline"][@@merlin.hide ] + + In the case of whole file transformations: + + $ echo "let x = 1+1. " > impl.ml + $ ./whole_file_extension_point.exe impl.ml + [%%ocaml.error "An error message in an extension node"] + +(Note that Merlin will notify all errors, while the compiler only +notifies the first.) + +2. Raising a located error. In these tests, such an error is raised +during the rewritting of the AST. By default, the exception is not +caught, so no AST is produced. + + In the case of extenders: + + $ echo "let x = 1+1. " > impl.ml + $ echo "let _ = [%gen_raise_located_error]" >> impl.ml + $ export OCAML_ERROR_STYLE=short + $ ./extender.exe impl.ml + File "impl.ml", line 2, characters 8-34: + Error: A raised located error + [1] + + In the case of derivers + + $ echo "type a = int" > impl.ml + $ echo "type b = int [@@deriving deriver_located_error]" >> impl.ml + $ ./deriver.exe impl.ml + File "impl.ml", line 2, characters 0-47: + Error: A raised located error + [1] + + In the case of whole file transformations: + + $ echo "let x = 1+1. " > impl.ml + $ ./whole_file_located_error.exe impl.ml + File "impl.ml", line 1, characters 0-12: + Error: A located error in a whole file transform + [1] + +When the argument `-embed-errors` is added, the exception is caught +and the whole AST is replaced with a single error extension node. The +first line `let x = 1+1.` is thus not present in the AST, and no error +can be reported about it. + + In the case of extenders: + + $ echo "let x = 1+1. " > impl.ml + $ echo "let _ = [%gen_raise_located_error]" >> impl.ml + $ ./extender.exe -embed-errors impl.ml + [%%ocaml.error "A raised located error"] + + In the case of derivers + + $ echo "let x = 1+1. " > impl.ml + $ echo "type a = int" > impl.ml + $ echo "type b = int [@@deriving deriver_located_error]" >> impl.ml + $ ./deriver.exe -embed-errors impl.ml + [%%ocaml.error "A raised located error"] + + In the case of whole file transformations: + + $ echo "let x = 1+1. " > impl.ml + $ ./whole_file_located_error.exe -embed-errors impl.ml + [%%ocaml.error "A located error in a whole file transform"] + +3. Raising an exception. The exception is not caught by the driver. + + In the case of extensions: + + $ echo "let _ = [%gen_raise_exc] + [%gen_raise_exc]" > impl.ml + $ ./extender.exe impl.ml + Fatal error: exception (Failure "A raised exception") + [2] + $ ./extender.exe -embed-errors impl.ml + Fatal error: exception (Failure "A raised exception") + [2] + + In the case of derivers + + $ echo "type a = int" > impl.ml + $ echo "type b = int [@@deriving deriver_raised_exception]" >> impl.ml + $ ./deriver.exe -embed-errors impl.ml + Fatal error: exception (Failure "A raised exception") + [2] + + In the case of whole file transformations: + + $ ./whole_file_exception.exe impl.ml + Fatal error: exception (Failure "An exception in a whole file transform") + [2] + $ ./whole_file_exception.exe -embed-errors impl.ml + Fatal error: exception (Failure "An exception in a whole file transform") + [2] diff -Nru ppxlib-0.15.0/test/driver/exception_handling/whole_file_exception.ml ppxlib-0.24.0/test/driver/exception_handling/whole_file_exception.ml --- ppxlib-0.15.0/test/driver/exception_handling/whole_file_exception.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/exception_handling/whole_file_exception.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,9 @@ +open Ppxlib + +let () = + Driver.V2.( + register_transformation + ~impl:(fun _ _ -> failwith "An exception in a whole file transform") + "raise_exc") + +let () = Ppxlib.Driver.standalone () diff -Nru ppxlib-0.15.0/test/driver/exception_handling/whole_file_extension_point.ml ppxlib-0.24.0/test/driver/exception_handling/whole_file_extension_point.ml --- ppxlib-0.15.0/test/driver/exception_handling/whole_file_extension_point.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/exception_handling/whole_file_extension_point.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,20 @@ +open Ppxlib + +let () = + Driver.V2.( + register_transformation + ~impl:(fun ctxt str -> + let loc = + match str with + | [] -> Location.in_file (Expansion_context.Base.input_name ctxt) + | hd :: _ -> hd.pstr_loc + in + let extension_node = + Location.Error.( + make ~loc "An error message in an extension node" ~sub:[] + |> to_extension) + in + [ Ast_builder.Default.pstr_extension ~loc extension_node [] ]) + "raise_exc") + +let () = Ppxlib.Driver.standalone () diff -Nru ppxlib-0.15.0/test/driver/exception_handling/whole_file_located_error.ml ppxlib-0.24.0/test/driver/exception_handling/whole_file_located_error.ml --- ppxlib-0.15.0/test/driver/exception_handling/whole_file_located_error.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/exception_handling/whole_file_located_error.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,15 @@ +open Ppxlib + +let () = + Driver.V2.( + register_transformation + ~impl:(fun ctxt str -> + let loc = + match str with + | [] -> Location.in_file (Expansion_context.Base.input_name ctxt) + | hd :: _ -> hd.pstr_loc + in + Location.raise_errorf ~loc "A located error in a whole file transform") + "raise_exc") + +let () = Ppxlib.Driver.standalone () diff -Nru ppxlib-0.15.0/test/driver/flag_cookie/dune ppxlib-0.24.0/test/driver/flag_cookie/dune --- ppxlib-0.15.0/test/driver/flag_cookie/dune 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/flag_cookie/dune 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,8 @@ +(executable + (name print_cookie_driver) + (libraries ppxlib) + (preprocess + (pps ppxlib.metaquot))) + +(cram + (deps print_cookie_driver.exe)) diff -Nru ppxlib-0.15.0/test/driver/flag_cookie/print_cookie_driver.ml ppxlib-0.24.0/test/driver/flag_cookie/print_cookie_driver.ml --- ppxlib-0.15.0/test/driver/flag_cookie/print_cookie_driver.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/flag_cookie/print_cookie_driver.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,33 @@ +open Ppxlib + +let value_x = ref "" + +let f = function + | Some value_of_x -> + value_x := Printf.sprintf "Value of cookie x: %i" value_of_x + | None -> value_x := "Cookie x isn't set." + +let () = Ppxlib.Driver.Cookies.(add_simple_handler ~f "x" Ast_pattern.(eint __)) + +let print_cookie_x = + object + inherit Ast_traverse.map as super + + method! structure str = + let new_str = + List.fold_left + (fun acc str_item -> + match str_item with + | [%stri [@@@print_cookie_x]] -> + let _ = print_endline !value_x in + acc + | _ -> str_item :: acc) + [] str + in + super#structure (List.rev new_str) + end + +let () = + Driver.register_transformation ~impl:print_cookie_x#structure "test_cookies" + +let () = Ppxlib.Driver.standalone () diff -Nru ppxlib-0.15.0/test/driver/flag_cookie/run.t ppxlib-0.24.0/test/driver/flag_cookie/run.t --- ppxlib-0.15.0/test/driver/flag_cookie/run.t 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/flag_cookie/run.t 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,10 @@ +The cookie flag is taken into account, both by the main standalone + + $ echo "[@@@print_cookie_x]" > impl.ml + $ ./print_cookie_driver.exe -cookie x=1 impl.ml + Value of cookie x: 1 + +...and by the `-as-ppx` standalone + + $ ocaml -ppx './print_cookie_driver.exe --as-ppx -cookie x=1' impl.ml + Value of cookie x: 1 diff -Nru ppxlib-0.15.0/test/driver/instrument/dune ppxlib-0.24.0/test/driver/instrument/dune --- ppxlib-0.15.0/test/driver/instrument/dune 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/instrument/dune 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,13 @@ +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} "4.08.0")) + (deps + (:test test.ml) + (package ppxlib)) + (action + (chdir + %{project_root} + (progn + (run expect-test %{test}) + (diff? %{test} %{test}.corrected))))) diff -Nru ppxlib-0.15.0/test/driver/instrument/test.ml ppxlib-0.24.0/test/driver/instrument/test.ml --- ppxlib-0.15.0/test/driver/instrument/test.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/instrument/test.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,36 @@ +open Ppxlib + +let extend_list_by name = object + inherit Ast_traverse.map as super + + method! expression e = + match e.pexp_desc with + | Pexp_construct ({txt = Lident "[]"; _}, None) -> Ast_builder.Default.elist ~loc:e.pexp_loc [Ast_builder.Default.estring ~loc:e.pexp_loc name] + | _ -> super#expression e +end +[%%expect{| +val extend_list_by : string -> Ast_traverse.map = +|}] + +let () = + let name = "a: instr pos=Before" in + let transform = extend_list_by name in + Driver.(register_transformation ~instrument:(Instrument.make ~position:Before transform#structure) name) + +let () = + let name = "b: instr pos=After" in + let transform = extend_list_by name in + Driver.(register_transformation ~instrument:(Instrument.make ~position:After transform#structure) name) + +let () = + let name = "c: impl" in + let transform = extend_list_by name in + Driver.register_transformation ~impl:transform#structure name + +(* The order of the list should only depend on how the rewriters got registered, + not on the alphabetic order of the names they got registered with. *) +let x = [] +[%%expect{| +val x : string list = + ["a: instr pos=Before"; "c: impl"; "b: instr pos=After"] +|}] diff -Nru ppxlib-0.15.0/test/driver/non-compressible-suffix/dune ppxlib-0.24.0/test/driver/non-compressible-suffix/dune --- ppxlib-0.15.0/test/driver/non-compressible-suffix/dune 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/test/driver/non-compressible-suffix/dune 2021-12-08 21:53:37.000000000 +0000 @@ -1,9 +1,13 @@ -(alias - (name runtest) +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} "4.08.0")) (deps (:test test.ml) (package ppxlib)) - (action (chdir %{project_root} - (progn - (run expect-test %{test}) - (diff? %{test} %{test}.corrected))))) + (action + (chdir + %{project_root} + (progn + (run expect-test %{test}) + (diff? %{test} %{test}.corrected))))) diff -Nru ppxlib-0.15.0/test/driver/omp-integration/omp-ppx/dune ppxlib-0.24.0/test/driver/omp-integration/omp-ppx/dune --- ppxlib-0.15.0/test/driver/omp-integration/omp-ppx/dune 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/test/driver/omp-integration/omp-ppx/dune 1970-01-01 00:00:00.000000000 +0000 @@ -1,5 +0,0 @@ -(library - (name ppxlib_driver_omp_test_ppx) - (kind ppx_rewriter) - (flags (:standard -safe-string)) - (libraries ocaml-migrate-parsetree)) diff -Nru ppxlib-0.15.0/test/driver/omp-integration/omp-ppx/main.ml ppxlib-0.24.0/test/driver/omp-integration/omp-ppx/main.ml --- ppxlib-0.15.0/test/driver/omp-integration/omp-ppx/main.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/test/driver/omp-integration/omp-ppx/main.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,18 +0,0 @@ -open Migrate_parsetree -open Ast_403 - -let mapper = - let super = Ast_mapper.default_mapper in - let expr self (e : Parsetree.expression) = - match e.pexp_desc with - | Pexp_extension ({ txt = "omp_test"; _ }, _) -> - { e with pexp_desc = Pexp_constant (Pconst_integer ("42", None)) } - | _ -> - super.expr self e - in - { super with expr } - -let () = - Driver.register ~name:"omp_test" - (module OCaml_403) - (fun _ _ -> mapper) diff -Nru ppxlib-0.15.0/test/driver/omp-integration/ppxlib-ppx/dune ppxlib-0.24.0/test/driver/omp-integration/ppxlib-ppx/dune --- ppxlib-0.15.0/test/driver/omp-integration/ppxlib-ppx/dune 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/test/driver/omp-integration/ppxlib-ppx/dune 1970-01-01 00:00:00.000000000 +0000 @@ -1,5 +0,0 @@ -(library - (name ppxlib_ppx) - (kind ppx_rewriter) - (flags (:standard -safe-string)) - (libraries ppxlib)) \ No newline at end of file diff -Nru ppxlib-0.15.0/test/driver/omp-integration/ppxlib-ppx/ppxlib_ppx.ml ppxlib-0.24.0/test/driver/omp-integration/ppxlib-ppx/ppxlib_ppx.ml --- ppxlib-0.15.0/test/driver/omp-integration/ppxlib-ppx/ppxlib_ppx.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/test/driver/omp-integration/ppxlib-ppx/ppxlib_ppx.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,14 +0,0 @@ -open Ppxlib - -let () = - Driver.register_transformation "plop" - ~rules:[ - Context_free.Rule.extension - (Extension.declare_with_path_arg "plop" - Expression - Ast_pattern.(pstr nil) - (fun ~loc ~path:_ ~arg -> - let open Ast_builder.Default in - match arg with - | None -> estring ~loc "-" - | Some { loc; txt } -> estring ~loc (Longident.name txt)))] diff -Nru ppxlib-0.15.0/test/driver/omp-integration/test/dune ppxlib-0.24.0/test/driver/omp-integration/test/dune --- ppxlib-0.15.0/test/driver/omp-integration/test/dune 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/test/driver/omp-integration/test/dune 1970-01-01 00:00:00.000000000 +0000 @@ -1,4 +0,0 @@ -(test - (name test) - (flags (:standard -safe-string)) - (preprocess (pps ppxlib_driver_omp_test_ppx ppxlib_ppx))) diff -Nru ppxlib-0.15.0/test/driver/omp-integration/test/test.expected ppxlib-0.24.0/test/driver/omp-integration/test/test.expected --- ppxlib-0.15.0/test/driver/omp-integration/test/test.expected 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/test/driver/omp-integration/test/test.expected 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -Foobar 42 diff -Nru ppxlib-0.15.0/test/driver/omp-integration/test/test.ml ppxlib-0.24.0/test/driver/omp-integration/test/test.ml --- ppxlib-0.15.0/test/driver/omp-integration/test/test.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/test/driver/omp-integration/test/test.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,2 +0,0 @@ -let () = - Printf.printf "%s %d\n" [%plop.Foobar] [%omp_test] diff -Nru ppxlib-0.15.0/test/driver/parse_error_locations/dune ppxlib-0.24.0/test/driver/parse_error_locations/dune --- ppxlib-0.15.0/test/driver/parse_error_locations/dune 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/parse_error_locations/dune 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,6 @@ +(executable + (name identity_standalone) + (libraries ppxlib)) + +(cram + (deps identity_standalone.exe)) diff -Nru ppxlib-0.15.0/test/driver/parse_error_locations/identity_standalone.ml ppxlib-0.24.0/test/driver/parse_error_locations/identity_standalone.ml --- ppxlib-0.15.0/test/driver/parse_error_locations/identity_standalone.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/parse_error_locations/identity_standalone.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1 @@ +let _ = Ppxlib.Driver.standalone () diff -Nru ppxlib-0.15.0/test/driver/parse_error_locations/run.t ppxlib-0.24.0/test/driver/parse_error_locations/run.t --- ppxlib-0.15.0/test/driver/parse_error_locations/run.t 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/parse_error_locations/run.t 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,15 @@ +Keep the error output short in order to avoid different error output between +different compiler versions in the subsequent test + + $ export OCAML_ERROR_STYLE=short + +Syntax errors in files parsed by ppxlib are reported correctly + + $ cat > test.ml << EOF + > let x = 5 + > let let + > EOF + $ ./identity_standalone.exe -impl test.ml + File "test.ml", line 2, characters 4-7: + Error: Syntax error + [1] diff -Nru ppxlib-0.15.0/test/driver/run_as_ppx_rewriter/dune ppxlib-0.24.0/test/driver/run_as_ppx_rewriter/dune --- ppxlib-0.15.0/test/driver/run_as_ppx_rewriter/dune 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/run_as_ppx_rewriter/dune 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,14 @@ +(executable + (name print_greetings) + (libraries ppxlib) + (modules print_greetings) + (preprocess + (pps ppxlib.metaquot))) + +(executable + (name print_magic_number) + (libraries astlib) + (modules print_magic_number)) + +(cram + (deps print_greetings.exe print_magic_number.exe)) diff -Nru ppxlib-0.15.0/test/driver/run_as_ppx_rewriter/print_greetings.ml ppxlib-0.24.0/test/driver/run_as_ppx_rewriter/print_greetings.ml --- ppxlib-0.15.0/test/driver/run_as_ppx_rewriter/print_greetings.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/run_as_ppx_rewriter/print_greetings.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,22 @@ +open Ppxlib + +let hi_rule = + let expand ~loc ~path:_ = [%expr print_endline "hi"] in + Extension.declare "print_hi" Extension.Context.expression + Ast_pattern.(pstr nil) + expand + |> Context_free.Rule.extension + +let bye_rule = + let expand ~loc ~path:_ = [%expr print_endline "bye"] in + Extension.declare "print_bye" Extension.Context.expression + Ast_pattern.(pstr nil) + expand + |> Context_free.Rule.extension + +(* the two rules need to be registered separately in order to test the `-apply` flag in run.t *) +let () = Driver.register_transformation ~rules:[ hi_rule ] "print_hi" + +let () = Driver.register_transformation ~rules:[ bye_rule ] "print_bye" + +let () = Ppxlib.Driver.run_as_ppx_rewriter () diff -Nru ppxlib-0.15.0/test/driver/run_as_ppx_rewriter/print_magic_number.ml ppxlib-0.24.0/test/driver/run_as_ppx_rewriter/print_magic_number.ml --- ppxlib-0.15.0/test/driver/run_as_ppx_rewriter/print_magic_number.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/run_as_ppx_rewriter/print_magic_number.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,9 @@ +let magic_length = String.length Astlib.Config.ast_impl_magic_number + +let buf = Bytes.create magic_length + +let len = input stdin buf 0 magic_length + +let s = Bytes.sub_string buf 0 len + +let () = Printf.printf "Magic number: %s" s Binary files /tmp/tmp846rjmsk/GiyumyOLPF/ppxlib-0.15.0/test/driver/run_as_ppx_rewriter/test.t/406_binary_ast and /tmp/tmp846rjmsk/f6JOSjOot5/ppxlib-0.24.0/test/driver/run_as_ppx_rewriter/test.t/406_binary_ast differ diff -Nru ppxlib-0.15.0/test/driver/run_as_ppx_rewriter/test.t/run.t ppxlib-0.24.0/test/driver/run_as_ppx_rewriter/test.t/run.t --- ppxlib-0.15.0/test/driver/run_as_ppx_rewriter/test.t/run.t 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/run_as_ppx_rewriter/test.t/run.t 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,97 @@ +Keep the error output short in order to avoid different error output between +different compiler versions in the subsequent tests + + $ export OCAML_ERROR_STYLE=short + +The registered rewriters get applied when using `run_as_ppx_rewriter` as entry point + + $ cat > file.ml << EOF + > let () = [%print_hi] + > let () = [%print_bye] + > EOF + $ ocaml -ppx '../print_greetings.exe' file.ml + hi + bye + +The driver's `shared_args` are taken into account, such as `-apply`... + + $ ocaml -ppx '../print_greetings.exe -apply print_hi' file.ml + hi + File "./file.ml", line 2, characters 11-20: + Error: Uninterpreted extension 'print_bye'. + [2] + +... and `-check` + + $ echo "[@@@attr non_registered_attr]" > attribute_file.ml + $ ocaml -ppx '../print_greetings.exe -check' attribute_file.ml + File "./attribute_file.ml", line 1, characters 4-8: + Error: Attribute `attr' was not used + [2] + + +If a non-compatible file gets fed, the file name is reported correctly + + $ touch no_binary_ast.ml + $ ../print_greetings.exe no_binary_ast.ml some_output + File "no_binary_ast.ml", line 1: + Error: Expected a binary AST as input + [1] + +The only possible usage is [extra_args] ... + + $ ../print_greetings.exe some_input + Usage: print_greetings.exe [extra_args] + [2] + +...in particular the order between the flags and the input/output matters. + + $ touch some_output + $ ../print_greetings.exe some_input some_output -check + ../print_greetings.exe: anonymous arguments not accepted. + print_greetings.exe [extra_args] + -loc-filename File name to use in locations + -reserve-namespace Mark the given namespace as reserved + -no-check Disable checks (unsafe) + -check Enable checks + -no-check-on-extensions Disable checks on extension point only + -check-on-extensions Enable checks on extension point only + -no-locations-check Disable locations check only + -locations-check Enable locations check only + -apply Apply these transformations in order (comma-separated list) + -dont-apply Exclude these transformations + -no-merge Do not merge context free transformations (better for debugging rewriters) + -cookie NAME=EXPR Set the cookie NAME to EXPR + --cookie Same as -cookie + -help Display this list of options + --help Display this list of options + [2] + +The only exception is consulting help + + $ ../print_greetings.exe -help + print_greetings.exe [extra_args] + -loc-filename File name to use in locations + -reserve-namespace Mark the given namespace as reserved + -no-check Disable checks (unsafe) + -check Enable checks + -no-check-on-extensions Disable checks on extension point only + -check-on-extensions Enable checks on extension point only + -no-locations-check Disable locations check only + -locations-check Enable locations check only + -apply Apply these transformations in order (comma-separated list) + -dont-apply Exclude these transformations + -no-merge Do not merge context free transformations (better for debugging rewriters) + -cookie NAME=EXPR Set the cookie NAME to EXPR + --cookie Same as -cookie + -help Display this list of options + --help Display this list of options + +Binary AST's of any by ppxlib supported OCaml version are supported. +The version is preserved. + + $ cat 406_binary_ast | ../print_magic_number.exe + Magic number: Caml1999N022 + + $ ../print_greetings.exe 406_binary_ast /dev/stdout | ../print_magic_number.exe + Magic number: Caml1999N022 diff -Nru ppxlib-0.15.0/test/driver/skip-hash-bang/dune ppxlib-0.24.0/test/driver/skip-hash-bang/dune --- ppxlib-0.15.0/test/driver/skip-hash-bang/dune 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/test/driver/skip-hash-bang/dune 2021-12-08 21:53:37.000000000 +0000 @@ -1,4 +1,11 @@ -(test - (name test) - (flags (:standard -safe-string)) - (preprocess (pps ppxlib.runner))) \ No newline at end of file +(library + (name empty_rewriter) + (modules empty_rewriter) + (kind ppx_rewriter) + (libraries ppxlib)) + +(tests + (names test test2) + (modules test test2) + (preprocess + (pps empty_rewriter))) diff -Nru ppxlib-0.15.0/test/driver/skip-hash-bang/test2.expected ppxlib-0.24.0/test/driver/skip-hash-bang/test2.expected --- ppxlib-0.15.0/test/driver/skip-hash-bang/test2.expected 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/skip-hash-bang/test2.expected 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1 @@ +OK diff -Nru ppxlib-0.15.0/test/driver/skip-hash-bang/test2.ml ppxlib-0.24.0/test/driver/skip-hash-bang/test2.ml --- ppxlib-0.15.0/test/driver/skip-hash-bang/test2.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/skip-hash-bang/test2.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,3 @@ +#!ignored line + +let () = print_endline "OK" diff -Nru ppxlib-0.15.0/test/driver/standalone_run_as_ppx/dune ppxlib-0.24.0/test/driver/standalone_run_as_ppx/dune --- ppxlib-0.15.0/test/driver/standalone_run_as_ppx/dune 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/standalone_run_as_ppx/dune 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,6 @@ +(executable + (name print_stuff) + (libraries ppxlib)) + +(cram + (deps print_stuff.exe)) diff -Nru ppxlib-0.15.0/test/driver/standalone_run_as_ppx/print_stuff.ml ppxlib-0.24.0/test/driver/standalone_run_as_ppx/print_stuff.ml --- ppxlib-0.15.0/test/driver/standalone_run_as_ppx/print_stuff.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/standalone_run_as_ppx/print_stuff.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,45 @@ +open Ppxlib + +let mk_expression ~loc pexp_desc = + { pexp_desc; pexp_loc_stack = []; pexp_loc = loc; pexp_attributes = [] } + +let print_string s ~loc = + let print_exp = + mk_expression ~loc (Pexp_ident { txt = Lident "print_endline"; loc }) + in + let string_exp = + mk_expression ~loc (Pexp_constant (Pconst_string (s, loc, None))) + in + mk_expression ~loc (Pexp_apply (print_exp, [ (Nolabel, string_exp) ])) + +let hi_rule = + let expand ~loc ~path:_ = print_string "hi" ~loc in + Extension.declare "print_hi" Extension.Context.expression + Ast_pattern.(pstr nil) + expand + |> Context_free.Rule.extension + +let tool_name_rule = + let expand ~ctxt = + let loc = Expansion_context.Extension.extension_point_loc ctxt in + let tool_name = Expansion_context.Extension.tool_name ctxt in + print_string tool_name ~loc + in + Extension.V3.declare "print_tool_name" Extension.Context.expression + Ast_pattern.(pstr nil) + expand + |> Context_free.Rule.extension + +let fname_rule = + let expand ~loc ~path:_ = print_string ~loc loc.loc_start.pos_fname in + Extension.declare "print_fname" Extension.Context.expression + Ast_pattern.(pstr nil) + expand + |> Context_free.Rule.extension + +let () = + Driver.register_transformation + ~rules:[ hi_rule; tool_name_rule; fname_rule ] + "test" + +let () = Ppxlib.Driver.standalone () diff -Nru ppxlib-0.15.0/test/driver/standalone_run_as_ppx/run.t ppxlib-0.24.0/test/driver/standalone_run_as_ppx/run.t --- ppxlib-0.15.0/test/driver/standalone_run_as_ppx/run.t 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/standalone_run_as_ppx/run.t 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,37 @@ +Keep the error output short in order to avoid different error output between different compiler versions in the subsequent tests + + $ export OCAML_ERROR_STYLE=short + +The rewriter gets applied when using `--as-ppx` + + $ echo "let _ = [%print_hi]" > impl.ml + $ ocaml -ppx './print_stuff.exe --as-ppx' impl.ml + hi + +If a non-compatible file gets fed, the file name is reported correctly + + $ touch no_binary_ast.ml + $ ./print_stuff.exe --as-ppx no_binary_ast.ml some_output + File "no_binary_ast.ml", line 1: + Error: Expected a binary AST as input + [1] + +The ocaml.ppx.context attribute gets parsed correctly; in particular, the tool name gets set correctly + + $ echo "let _ = [%print_tool_name]" > impl.ml + $ ocaml -ppx './print_stuff.exe --as-ppx' impl.ml + ocaml + +The driver's `shared_args` arguments are taken into account. For example, `-loc-filename` + + $ echo "let _ = [%print_fname]" > impl.ml + $ ocaml -ppx './print_stuff.exe --as-ppx -loc-filename new_fn.ml' impl.ml + new_fn.ml + +or `dont-apply` + + $ echo "let _ = [%print_hi]" > impl.ml + $ ocaml -ppx './print_stuff.exe --as-ppx -dont-apply test' impl.ml + File "./impl.ml", line 1, characters 10-18: + Error: Uninterpreted extension 'print_hi'. + [2] diff -Nru ppxlib-0.15.0/test/driver/stdin_input/dune ppxlib-0.24.0/test/driver/stdin_input/dune --- ppxlib-0.15.0/test/driver/stdin_input/dune 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/stdin_input/dune 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,6 @@ +(executable + (name identity_driver) + (libraries ppxlib)) + +(cram + (deps identity_driver.exe)) diff -Nru ppxlib-0.15.0/test/driver/stdin_input/identity_driver.ml ppxlib-0.24.0/test/driver/stdin_input/identity_driver.ml --- ppxlib-0.15.0/test/driver/stdin_input/identity_driver.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/stdin_input/identity_driver.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1 @@ +let () = Ppxlib.Driver.standalone () Binary files /tmp/tmp846rjmsk/GiyumyOLPF/ppxlib-0.15.0/test/driver/stdin_input/test.t/binary_ast and /tmp/tmp846rjmsk/f6JOSjOot5/ppxlib-0.24.0/test/driver/stdin_input/test.t/binary_ast differ diff -Nru ppxlib-0.15.0/test/driver/stdin_input/test.t/run.t ppxlib-0.24.0/test/driver/stdin_input/test.t/run.t --- ppxlib-0.15.0/test/driver/stdin_input/test.t/run.t 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/driver/stdin_input/test.t/run.t 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,12 @@ +The driver can read from stdin. Both when the input is source code... + + + $ ../identity_driver.exe -impl - << EOF + > let a = 1 + > EOF + let a = 1 + +...and when the input is a binary AST. + + $ cat binary_ast | ../identity_driver.exe -impl - + let b = 2 diff -Nru ppxlib-0.15.0/test/driver/transformations/dune ppxlib-0.24.0/test/driver/transformations/dune --- ppxlib-0.15.0/test/driver/transformations/dune 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/test/driver/transformations/dune 2021-12-08 21:53:37.000000000 +0000 @@ -1,9 +1,15 @@ -(alias - (name runtest) +(rule + (alias runtest) + (enabled_if + (and + (>= %{ocaml_version} "4.08.0") + (< %{ocaml_version} "4.12.0"))) (deps (:test test.ml) (package ppxlib)) - (action (chdir %{project_root} - (progn - (run expect-test %{test}) - (diff? %{test} %{test}.corrected))))) + (action + (chdir + %{project_root} + (progn + (run expect-test %{test}) + (diff? %{test} %{test}.corrected))))) diff -Nru ppxlib-0.15.0/test/expansion_context/dune ppxlib-0.24.0/test/expansion_context/dune --- ppxlib-0.15.0/test/expansion_context/dune 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/expansion_context/dune 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,18 @@ +(library + (name register_print_ctxt) + (modules register_print_ctxt) + (kind ppx_rewriter) + (libraries ppxlib)) + +(executable + (name standalone_print_ctxt) + (modules standalone_print_ctxt) + (libraries ppxlib register_print_ctxt)) + +(executable + (name map_structure_print_ctxt) + (modules map_structure_print_ctxt) + (libraries ppxlib register_print_ctxt)) + +(cram + (deps standalone_print_ctxt.exe map_structure_print_ctxt.exe)) diff -Nru ppxlib-0.15.0/test/expansion_context/map_structure_print_ctxt.ml ppxlib-0.24.0/test/expansion_context/map_structure_print_ctxt.ml --- ppxlib-0.15.0/test/expansion_context/map_structure_print_ctxt.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/expansion_context/map_structure_print_ctxt.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,9 @@ +open Ppxlib + +let set_filename (lexbuf : Lexing.lexbuf) ~filename = + { lexbuf with lex_curr_p = { lexbuf.lex_curr_p with pos_fname = filename } } + +let _ = + Lexing.from_channel stdin + |> set_filename ~filename:"lexbuf_pos_fname" + |> Parse.implementation |> Driver.map_structure diff -Nru ppxlib-0.15.0/test/expansion_context/register_print_ctxt.ml ppxlib-0.24.0/test/expansion_context/register_print_ctxt.ml --- ppxlib-0.15.0/test/expansion_context/register_print_ctxt.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/expansion_context/register_print_ctxt.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,28 @@ +open Ppxlib + +let pprint_ctxt ctxt = + let tool_name = Expansion_context.Base.tool_name ctxt in + let input_name = Expansion_context.Base.input_name ctxt in + let file_path = + Code_path.file_path @@ Expansion_context.Base.code_path @@ ctxt + in + Printf.printf "tool_name: %s\ninput_name: %s\nfile_path: %s\n" tool_name + input_name file_path + +let side_print_ctxt = + object + inherit Ast_traverse.map_with_expansion_context as super + + method! structure ctxt st = + pprint_ctxt ctxt; + super#structure ctxt st + + method! signature ctxt sg = + pprint_ctxt ctxt; + super#signature ctxt sg + end + +let () = + Driver.V2.( + register_transformation ~impl:side_print_ctxt#structure + ~intf:side_print_ctxt#signature "print_ctxt") diff -Nru ppxlib-0.15.0/test/expansion_context/run.t ppxlib-0.24.0/test/expansion_context/run.t --- ppxlib-0.15.0/test/expansion_context/run.t 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/expansion_context/run.t 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,39 @@ +The three context fields can be accessed in a rewriter, both from within an implementation file + + $ echo "let x = 0" > file.ml + $ ./standalone_print_ctxt.exe file.ml | egrep 'tool_name|input_name|file_path' + tool_name: ppx_driver + input_name: file.ml + file_path: file.ml + +and from within an interface file + + $ echo "val x : int" > file.mli + $ ./standalone_print_ctxt.exe file.mli | egrep 'tool_name|input_name|file_path' + tool_name: ppx_driver + input_name: file.mli + file_path: file.mli + +In most cases, the input name and the file path coincide. But there are some exceptions, such as +1. empty files + + $ touch empty_file.ml + $ ./standalone_print_ctxt.exe empty_file.ml | egrep 'input_name|file_path' + input_name: empty_file.ml + file_path: + +2. files with directives pointing to other files + + $ cat > directive.ml << EOF + > # 1 "file.ml" + > let y = 0 + > EOF + $ ./standalone_print_ctxt.exe directive.ml | egrep 'input_name|file_path' + input_name: directive.ml + file_path: file.ml + +3. using `map_structure` (or `map_signature`) + + $ echo "let x = 0" | ./map_structure_print_ctxt.exe | egrep 'input_name|file_path' + input_name: _none_ + file_path: lexbuf_pos_fname diff -Nru ppxlib-0.15.0/test/expansion_context/standalone_print_ctxt.ml ppxlib-0.24.0/test/expansion_context/standalone_print_ctxt.ml --- ppxlib-0.15.0/test/expansion_context/standalone_print_ctxt.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/expansion_context/standalone_print_ctxt.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1 @@ +let () = Ppxlib.Driver.standalone () diff -Nru ppxlib-0.15.0/test/expansion_inside_payloads/dune ppxlib-0.24.0/test/expansion_inside_payloads/dune --- ppxlib-0.15.0/test/expansion_inside_payloads/dune 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/expansion_inside_payloads/dune 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,13 @@ +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} "4.10.0")) + (deps + (:test test.ml) + (package ppxlib)) + (action + (chdir + %{project_root} + (progn + (run expect-test %{test}) + (diff? %{test} %{test}.corrected))))) diff -Nru ppxlib-0.15.0/test/expansion_inside_payloads/test.ml ppxlib-0.24.0/test/expansion_inside_payloads/test.ml --- ppxlib-0.15.0/test/expansion_inside_payloads/test.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/expansion_inside_payloads/test.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,230 @@ +open Ppxlib + +(* --------------------------- Test Setup ----------------------------------- *) + +(* These tests check that the inside of payloads is properly expanded or not + expanded by the driver. *) + +let expr_description ~loc ~error expr = + match expr.pexp_desc with + | Pexp_constant (Pconst_integer _) -> + Ast_builder.Default.estring ~loc "Payload is an integer" + | Pexp_extension _ -> + Ast_builder.Default.estring ~loc "Payload is an extension point" + | _ -> error () + +[%%expect{| +val expr_description : + loc:location -> error:(unit -> expression) -> expression -> expression = + +|}] + +let payload_description ~loc ~transformation_name payload = + let error () = + Location.raise_errorf ~loc "Invalid %s payload!" transformation_name + in + (match payload with + | PStr [{ pstr_desc = Pstr_eval (expr, _attr); _ }] -> + expr_description ~loc ~error expr + | _ -> error ()) + +[%%expect{| +val payload_description : + loc:location -> transformation_name:string -> payload -> expression = +|}] + +(* A legacy transformation, rewriting [%legacy_add_one ...] as + a string, describing the kind of the payload. Only accepts integer and + extensions as payloads. *) +let legacy_describe_payload = + object + inherit Ast_traverse.map as super + + method! expression expr = + match expr.pexp_desc with + | Pexp_extension ({txt = "legacy_describe_payload"; _}, payload) -> + let loc = expr.pexp_loc in + payload_description ~loc ~transformation_name:"legacy_describe_payload" + payload + | _ -> super#expression expr + end + +let () = + Driver.register_transformation + ~impl:legacy_describe_payload#structure + "legacy_describe_payload" + +[%%expect{| +val legacy_describe_payload : Ast_traverse.map = +|}] + +(* A legacy attribute-based generator implemented as a whole AST transformation. + [type _ = _ [@@gen_x payload]] generates an extra [let x = ] where + [] is a descriptiong of the kind of [payload]. Only accepts integer + and extensions as payloads. *) +let legacy_deriver = + let get_gen_x attrs = + List.find_map + (function + | {attr_name = {txt = "gen_x"; _}; attr_payload; attr_loc} -> + Some (attr_payload, attr_loc) + | _ -> None) + attrs + in + object(self) + inherit Ast_traverse.map + + method! structure str = + List.concat_map + (fun stri -> + match stri.pstr_desc with + | Pstr_type (_, [{ptype_attributes = (_::_ as attrs); _}]) -> + (match get_gen_x attrs with + | Some (payload, loc) -> + let value = + payload_description ~loc ~transformation_name:"gen_x" payload + in + let stri = self#structure_item stri in + let x_binding = [%stri let x = [%e value]] in + [stri; x_binding] + | None -> [self#structure_item stri]) + | _ -> [self#structure_item stri]) + str + end + +let () = + Driver.register_transformation + ~impl:legacy_deriver#structure + "legacy_deriver" + +[%%expect{| +val legacy_deriver : Ast_traverse.map = +|}] + +(* An expression extension that simply expands to its payload. + I.e. [[%id 1]] expands to [1]. *) +let id = + Extension.V3.declare + "id" + Extension.Context.expression + Ast_pattern.(single_expr_payload __) + (fun ~ctxt:_ expr -> expr) + |> Context_free.Rule.extension + +let () = Driver.register_transformation ~rules:[id] "id" + +[%%expect{| +val id : Context_free.Rule.t = +|}] + +(* ------------------------- Actual Test ----------------------------------- *) + +(* Context free transformations are applied inside payload of extensions or + attributes that aren't themselves expanded by context-free rules + + The examples below are expected to display that their paylaod is an integer + as the extension inside the payload should be expanded during the + context-free rule pass, that happens before whole AST transformations. *) +let x = [%legacy_describe_payload [%id 1]] + +[%%expect{| +val x : string = "Payload is an integer" +|}] + +type t = unit +[@@gen_x [%id 1]] + +[%%expect{| +type t = unit +val x : string = "Payload is an integer" +|}] + +(* --------------------------- Test Setup ----------------------------------- *) + +(* The same transformation as [legacy_describe_payload] but written as a + context-free rule *) +let describe_payload = + Extension.V3.declare + "describe_payload" + Extension.Context.expression + Ast_pattern.__ + (fun ~ctxt payload -> + let loc = Expansion_context.Extension.extension_point_loc ctxt in + payload_description ~loc ~transformation_name:"describe_payload" payload) + |> Context_free.Rule.extension + +let () = Driver.register_transformation ~rules:[describe_payload] "describe_payload" + +[%%expect{| +val describe_payload : Context_free.Rule.t = +|}] + +(* A deriver that accepts a [payload] argument. It generates a value binding + to a string describing the nature of its payload. + E.g. [type t = _ [@@deriving x ~payload:1]] will derive + [let x = "Payload is an integer"]. + The value argument only accepts integer and extensions. *) +let deriver = + let expand ~ctxt _type_decl payload = + let loc = Expansion_context.Deriver.derived_item_loc ctxt in + let value = + match payload with + | None -> Location.raise_errorf ~loc "payload argument is mandatory" + | Some expr -> + let error () = + Location.raise_errorf ~loc "Invalid 'deriving x' payload!" + in + expr_description ~loc ~error expr + in + [%str let x = [%e value]] + in + let args = + let open Deriving.Args in + let payload = arg "payload" Ast_pattern.__ in + empty +> payload + in + let str_type_decl = + Deriving.Generator.V2.make args expand + in + Deriving.add ~str_type_decl "x" + +[%%expect{| +val deriver : Deriving.t = +|}] + +(* ------------------------- Actual Test ----------------------------------- *) + +(* Context-free transformations cannot be applied inside the payload of + extensions that are themselves expanded by a context-free rule, + simply because the outermost extension is expanded first. + + The example below should describe their payload to be an extension + because the extension inside their payload should NOT be expanded when they + run. + + This is an expected and relatively sane behaviour. As Carl Eastlund pointed + out, it might make sense at some point to allow expander to ask ppxlib to + expand a node explicitly via a callback but it shouldn't be done by default. + *) +let y = [%describe_payload [%id 1]] + +[%%expect{| +val y : string = "Payload is an extension point" +|}] + +(* Context-free transformations should not be applied inside the payload of + attributes interpreted by other context-free rules. This is a bug introduced + in https://github.com/ocaml-ppx/ppxlib/pull/279. + + The example below should report the payload as being an extension point as + the [value] argument in the paylaod should NOT be expanded. + + Here, just as in extensions, we might eventually provide a callback to expand + nodes explicitly. *) +type u = unit +[@@deriving x ~payload:[%id 1]] + +[%%expect{| +type u = t +val x : string = "Payload is an extension point" +|}] diff -Nru ppxlib-0.15.0/test/expect/dune ppxlib-0.24.0/test/expect/dune --- ppxlib-0.15.0/test/expect/dune 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/test/expect/dune 2021-12-08 21:53:37.000000000 +0000 @@ -1,13 +1,21 @@ (executable (name expect_test) + (enabled_if + (>= %{ocaml_version} "4.08.0")) (link_flags (-linkall)) (modes byte) - (libraries unix compiler-libs.toplevel ppxlib ppxlib.metaquot ppxlib.traverse - findlib.top - ;; We don't actually use findlib.dynload, however it is a - ;; special library that causes to record the various - ;; libraries statically linked in with findlib so that - ;; they are not loaded dynamically at runtime - findlib.dynload )) + (libraries + unix + compiler-libs.toplevel + ppxlib + ppxlib.metaquot + ppxlib.traverse + findlib.top + ppxlib_ast + ;; We don't actually use findlib.dynload, however it is a + ;; special library that causes to record the various + ;; libraries statically linked in with findlib so that + ;; they are not loaded dynamically at runtime + findlib.dynload)) (ocamllex expect_lexer) diff -Nru ppxlib-0.15.0/test/expect/expect_lexer.mli ppxlib-0.24.0/test/expect/expect_lexer.mli --- ppxlib-0.15.0/test/expect/expect_lexer.mli 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/test/expect/expect_lexer.mli 2021-12-08 21:53:37.000000000 +0000 @@ -1,4 +1,2 @@ -val split_file - : file_contents:string - -> Lexing.lexbuf - -> (Lexing.position * string) list +val split_file : + file_contents:string -> Lexing.lexbuf -> (Lexing.position * string) list diff -Nru ppxlib-0.15.0/test/expect/expect_test.ml ppxlib-0.24.0/test/expect/expect_test.ml --- ppxlib-0.15.0/test/expect/expect_test.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/test/expect/expect_test.ml 2021-12-08 21:53:37.000000000 +0000 @@ -11,23 +11,18 @@ let file_contents = read_file file in let lexbuf = Lexing.from_string file_contents in lexbuf.lex_curr_p <- - { pos_fname = file - ; pos_cnum = 0 - ; pos_lnum = 1 - ; pos_bol = 0 - }; + { pos_fname = file; pos_cnum = 0; pos_lnum = 1; pos_bol = 0 }; let expected = f file_contents lexbuf in let corrected_file = file ^ ".corrected" in - if file_contents <> expected then begin + if file_contents <> expected then ( let oc = open_out_bin corrected_file in output_string oc expected; - close_out oc; - end else begin + close_out oc) + else ( if Sys.file_exists corrected_file then Sys.remove corrected_file; - exit 0 - end + exit 0) let print_loc _ _ ppf (loc : Location.t) = let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in @@ -39,69 +34,67 @@ let report_printer () = let printer = Location.default_report_printer () in - { printer with Location. pp_main_loc = print_loc; pp_submsg_loc = print_loc; } + { printer with Location.pp_main_loc = print_loc; pp_submsg_loc = print_loc } let setup_printers ppf = Location.formatter_for_warnings := ppf; Location.warning_reporter := Location.default_warning_reporter; - Location.report_printer := report_printer; - Location.alert_reporter := Location.default_alert_reporter + Location.report_printer := report_printer; + Location.alert_reporter := Location.default_alert_reporter -let apply_rewriters : (Parsetree.toplevel_phrase -> Parsetree.toplevel_phrase) = function +let apply_rewriters : Parsetree.toplevel_phrase -> Parsetree.toplevel_phrase = + function | Ptop_dir _ as x -> x | Ptop_def s -> - let s = Ppxlib.Selected_ast.of_ocaml Structure s in - let s' = Ppxlib.Driver.map_structure s in - Ptop_def (Ppxlib.Selected_ast.to_ocaml Structure s') + let s = Ppxlib.Selected_ast.of_ocaml Structure s in + let s' = Ppxlib.Driver.map_structure s in + Ptop_def (Ppxlib.Selected_ast.to_ocaml Structure s') let main () = run_expect_test Sys.argv.(1) ~f:(fun file_contents lexbuf -> - let chunks = Expect_lexer.split_file ~file_contents lexbuf in + let chunks = Expect_lexer.split_file ~file_contents lexbuf in - let buf = Buffer.create (String.length file_contents + 1024) in - let ppf = Format.formatter_of_buffer buf in - setup_printers ppf; - Topfind.log := ignore; - - Warnings.parse_options false "@a-4-29-40-41-42-44-45-48-58"; - Clflags.real_paths := false; - Toploop.initialize_toplevel_env (); - - (* Findlib stuff *) - let preds = ["toploop"] in - let preds = - match Sys.backend_type with - | Native -> "native" :: preds - | Bytecode -> "byte" :: preds - | Other _ -> preds - in - Topfind.add_predicates preds; - (* This just adds the include directories since the [ppx] library - is statically linked in *) - Topfind.load_deeply ["ppxlib"]; - - List.iter chunks ~f:(fun (pos, s) -> - Format.fprintf ppf "%s[%%%%expect{|@." s; - let lexbuf = Lexing.from_string s in - lexbuf.lex_curr_p <- { pos with pos_lnum = 1; }; - let phrases = !Toploop.parse_use_file lexbuf in - List.iter phrases ~f:(function - | Parsetree.Ptop_def [] -> () - | phr -> - try - let phr = apply_rewriters phr in - if !Clflags.dump_source then - Format.fprintf ppf "%a@?" Pprintast.top_phrase phr; - ignore (Toploop.execute_phrase true ppf phr : bool) - with exn -> - Location.report_exception ppf exn - ); - Format.fprintf ppf "@?|}]@."); - Buffer.contents buf) + let buf = Buffer.create (String.length file_contents + 1024) in + let ppf = Format.formatter_of_buffer buf in + setup_printers ppf; + Topfind.log := ignore; + + let _ = Warnings.parse_options false "@a-4-29-40-41-42-44-45-48-58" in + Clflags.real_paths := false; + Toploop.initialize_toplevel_env (); + + (* Findlib stuff *) + let preds = [ "toploop" ] in + let preds = + match Sys.backend_type with + | Native -> "native" :: preds + | Bytecode -> "byte" :: preds + | Other _ -> preds + in + Topfind.add_predicates preds; + (* This just adds the include directories since the [ppx] library + is statically linked in *) + Topfind.load_deeply [ "ppxlib" ]; + + List.iter chunks ~f:(fun (pos, s) -> + Format.fprintf ppf "%s[%%%%expect{|@." s; + let lexbuf = Lexing.from_string s in + lexbuf.lex_curr_p <- { pos with pos_lnum = 1 }; + let phrases = !Toploop.parse_use_file lexbuf in + List.iter phrases ~f:(function + | Parsetree.Ptop_def [] -> () + | phr -> ( + try + let phr = apply_rewriters phr in + if !Clflags.dump_source then + Format.fprintf ppf "%a@?" Pprintast.top_phrase phr; + ignore (Toploop.execute_phrase true ppf phr : bool) + with exn -> Location.report_exception ppf exn)); + Format.fprintf ppf "@?|}]@."); + Buffer.contents buf) let () = - try - main () + try main () with exn -> Location.report_exception Format.err_formatter exn; exit 1 diff -Nru ppxlib-0.15.0/test/extensions_and_deriving/dune ppxlib-0.24.0/test/extensions_and_deriving/dune --- ppxlib-0.15.0/test/extensions_and_deriving/dune 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/extensions_and_deriving/dune 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,13 @@ +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} "4.10.0")) + (deps + (:test test.ml) + (package ppxlib)) + (action + (chdir + %{project_root} + (progn + (run expect-test %{test}) + (diff? %{test} %{test}.corrected))))) diff -Nru ppxlib-0.15.0/test/extensions_and_deriving/test.ml ppxlib-0.24.0/test/extensions_and_deriving/test.ml --- ppxlib-0.15.0/test/extensions_and_deriving/test.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/extensions_and_deriving/test.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,142 @@ +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 -Nru ppxlib-0.15.0/test/location/exception/dune ppxlib-0.24.0/test/location/exception/dune --- ppxlib-0.15.0/test/location/exception/dune 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/location/exception/dune 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,13 @@ +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} "4.08.0")) + (deps + (:test test.ml) + (package ppxlib)) + (action + (chdir + %{project_root} + (progn + (run expect-test %{test}) + (diff? %{test} %{test}.corrected))))) diff -Nru ppxlib-0.15.0/test/location/exception/test.ml ppxlib-0.24.0/test/location/exception/test.ml --- ppxlib-0.15.0/test/location/exception/test.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/location/exception/test.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,17 @@ +open Ppxlib.Location + +let catch_as_compiler_exception = + try raise_errorf ~loc:none "foo" with + | Ocaml_common.Location.Error _ -> "caught" + | _ -> "uncaught" +[%%expect{| +val catch_as_compiler_exception : string = "caught" +|}] + +let catch_as_ppxlib_exception = + try raise_errorf ~loc:none "foo" with + | Error _ -> "caught" + | _ -> "uncaught" +[%%expect{| +val catch_as_ppxlib_exception : string = "caught" +|}] diff -Nru ppxlib-0.15.0/test/ppx_import_support/dune ppxlib-0.24.0/test/ppx_import_support/dune --- ppxlib-0.15.0/test/ppx_import_support/dune 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/ppx_import_support/dune 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,13 @@ +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} "4.10.0")) + (deps + (:test test.ml) + (package ppxlib)) + (action + (chdir + %{project_root} + (progn + (run expect-test %{test}) + (diff? %{test} %{test}.corrected))))) diff -Nru ppxlib-0.15.0/test/ppx_import_support/test.ml ppxlib-0.24.0/test/ppx_import_support/test.ml --- ppxlib-0.15.0/test/ppx_import_support/test.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/ppx_import_support/test.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,113 @@ +(* Test for the ppx_import old syntax compat support *) + +open Ppxlib + +let id = + Extension.__declare_ppx_import + "id" + (fun ~ctxt:_ td -> + match td.ptype_manifest with + | Some {ptyp_desc = Ptyp_extension (_, PTyp wrapped_manifest); _} -> + {td with ptype_manifest = Some wrapped_manifest} + | _ -> assert false) +[%%expect{| +val id : Extension.t = +|}] + +Driver.register_transformation + ~rules:[Context_free.Rule.extension id] + "id" +[%%expect{| +- : unit = () +|}] + +(* The expander receives the type decl with the extension point removed, it should preserve + attibutes *) +type t = [%id: int] +[%%expect{| +type t = int +|}] + +(* It also should work in signatures by default *) +module type T = sig + type t = [%id: int] +end +[%%expect{| +module type T = sig type t = int end +|}] + +let foo = + let check_interpreted (_, type_decls) = + let {ptype_manifest; _} = List.hd type_decls in + match ptype_manifest with + | Some {ptyp_desc = Ptyp_extension _; _} -> + failwith "Extension should be intepreted before attributes" + | _ -> () + in + Deriving.add "foo" + ~str_type_decl:(Deriving.Generator.make_noarg + (fun ~loc ~path:_ type_decl -> + check_interpreted type_decl; + [%str let foo = 42])) + ~sig_type_decl:(Deriving.Generator.make_noarg + (fun ~loc ~path:_ type_decl -> + check_interpreted type_decl; + [%sig: val foo : int])) +[%%expect{| +val foo : Deriving.t = +|}] + +(* It should properly compose with [@@deriving] *) +type t = [%id: int] +[@@deriving foo] +[%%expect{| +type t = int +val foo : t = 42 +|}] + +module type T = sig + type t = [%id: int] + [@@deriving foo] +end +[%%expect{| +module type T = sig type t = int val foo : t end +|}] + +(* It should be properly interpreted if it's the result of the expansion of a + previous node as well *) +let gen_id = + Extension.V3.declare + "gen_id" + Extension.Context.structure_item + Ast_pattern.(pstr nil) + (fun ~ctxt -> + let loc = Expansion_context.Extension.extension_point_loc ctxt in + [%stri type t = [%id: int]]) +[%%expect{| +val gen_id : Extension.t = +|}] + +Driver.register_transformation + ~rules:[Context_free.Rule.extension gen_id] + "gen_id" +[%%expect{| +- : unit = () +|}] + +[%%gen_id] +[%%expect{| +type t = int +|}] + +(* One can't have ppx_import-like and core_type extensions with the same name *) +let id_for_core_types = + Extension.V3.declare + "id" + Extension.Context.core_type + Ast_pattern.(ptyp __) + (fun ~ctxt:_ core_type -> core_type) +[%%expect{| +Exception: +(Failure + "Some ppx-es tried to register conflicting transformations: Extension 'id' on type declarations matches extension 'id'") +|}] diff -Nru ppxlib-0.15.0/test/quoter/dune ppxlib-0.24.0/test/quoter/dune --- ppxlib-0.15.0/test/quoter/dune 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/test/quoter/dune 2021-12-08 21:53:37.000000000 +0000 @@ -1,9 +1,13 @@ -(alias - (name runtest) +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} "4.08.0")) (deps (:test test.ml) (package ppxlib)) - (action (chdir %{project_root} - (progn - (run expect-test %{test}) - (diff? %{test} %{test}.corrected))))) + (action + (chdir + %{project_root} + (progn + (run expect-test %{test}) + (diff? %{test} %{test}.corrected))))) diff -Nru ppxlib-0.15.0/test/traverse/dune ppxlib-0.24.0/test/traverse/dune --- ppxlib-0.15.0/test/traverse/dune 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/test/traverse/dune 2021-12-08 21:53:37.000000000 +0000 @@ -1,9 +1,13 @@ -(alias - (name runtest) +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} "4.08.0")) (deps (:test test.ml) (package ppxlib)) - (action (chdir %{project_root} - (progn - (run expect-test %{test}) - (diff? %{test} %{test}.corrected))))) + (action + (chdir + %{project_root} + (progn + (run expect-test %{test}) + (diff? %{test} %{test}.corrected))))) diff -Nru ppxlib-0.15.0/test/type_is_recursive/dune ppxlib-0.24.0/test/type_is_recursive/dune --- ppxlib-0.15.0/test/type_is_recursive/dune 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/type_is_recursive/dune 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,13 @@ +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} "4.10.0")) + (deps + (:test test.ml) + (package ppxlib)) + (action + (chdir + %{project_root} + (progn + (run expect-test %{test}) + (diff? %{test} %{test}.corrected))))) diff -Nru ppxlib-0.15.0/test/type_is_recursive/test.ml ppxlib-0.24.0/test/type_is_recursive/test.ml --- ppxlib-0.15.0/test/type_is_recursive/test.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.24.0/test/type_is_recursive/test.ml 2021-12-08 21:53:37.000000000 +0000 @@ -0,0 +1,76 @@ +open Ppxlib + +let test_is_recursive stri = + match stri.pstr_desc with + | Pstr_type (rf, tds) -> really_recursive rf tds + | _ -> assert false + +[%%expect{| +val test_is_recursive : structure_item -> rec_flag = +|}] + +let loc = Location.none + +[%%expect{| +val loc : location = + {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} +|}] + +(* Should be Nonrecursive *) +let base_type = test_is_recursive [%stri type t = int] + +[%%expect{| +val base_type : rec_flag = Ppxlib__.Import.Nonrecursive +|}] + +(* Should be Nonrecursive *) +let looks_recursive_but_is_not = test_is_recursive [%stri type nonrec t = t] + +[%%expect{| +val looks_recursive_but_is_not : rec_flag = Ppxlib__.Import.Nonrecursive +|}] + +(* Should be Nonrecursive *) +let variant_non_rec = test_is_recursive [%stri type t = A of int | B of string] + +[%%expect{| +val variant_non_rec : rec_flag = Ppxlib__.Import.Nonrecursive +|}] + +(* Should be Nonrecursive *) +let record_non_rec = test_is_recursive [%stri type t = {a: int; b: string}] + +[%%expect{| +val record_non_rec : rec_flag = Ppxlib__.Import.Nonrecursive +|}] + +(* Should be Recursive *) +let actually_recursive = test_is_recursive [%stri type t = A of int | T of t] + +[%%expect{| +val actually_recursive : rec_flag = Ppxlib__.Import.Recursive +|}] + +(* Should be Nonrecursive *) +let ignore_attributes = test_is_recursive [%stri type t = int [@attr: t]] + +[%%expect{| +val ignore_attributes : rec_flag = Ppxlib__.Import.Nonrecursive +|}] + +(* Should be Recursive + + This is subject to debate. @ceastlund's intuition is that we should + traverse extensions so we'll stick to this for now. + + It's less of a problem as it is likely that when [really_recursive] is called + those will have been expanded anyway. *) +let extension_points = test_is_recursive [%stri type t = [%ext: t]] + +[%%expect{| +val extension_points : rec_flag = Ppxlib__.Import.Recursive +|}] diff -Nru ppxlib-0.15.0/traverse/dune ppxlib-0.24.0/traverse/dune --- ppxlib-0.15.0/traverse/dune 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/traverse/dune 2021-12-08 21:53:37.000000000 +0000 @@ -1,7 +1,9 @@ (library - (name ppxlib_traverse) + (name ppxlib_traverse) (public_name ppxlib.traverse) - (kind ppx_rewriter) - (flags (:standard -safe-string)) - (libraries ppxlib) - (preprocess (pps ppxlib_metaquot ppxlib.runner))) + (kind ppx_deriver) + (flags + (:standard -safe-string)) + (libraries ppxlib ppxlib_ast ppxlib_traverse_builtins stdppx stdlib-shims) + (preprocess + (pps ppxlib_metaquot))) diff -Nru ppxlib-0.15.0/traverse/ppxlib_traverse.ml ppxlib-0.24.0/traverse/ppxlib_traverse.ml --- ppxlib-0.15.0/traverse/ppxlib_traverse.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/traverse/ppxlib_traverse.ml 2021-12-08 21:53:37.000000000 +0000 @@ -3,169 +3,185 @@ open Ast_builder.Default let alphabet = - Array.init (Char.code 'z' - Char.code 'a' + 1) + Array.init + (Char.code 'z' - Char.code 'a' + 1) ~f:(fun i -> String.make 1 (Char.chr (i + Char.code 'a'))) -;; let vars_of_list ~get_loc l = List.mapi l ~f:(fun i x -> { txt = alphabet.(i); loc = get_loc x }) let evar_of_var { txt; loc } = evar ~loc txt + let pvar_of_var { txt; loc } = pvar ~loc txt + let tvar_of_var { txt; loc } = ptyp_var ~loc txt let evars_of_vars = List.map ~f:evar_of_var + let pvars_of_vars = List.map ~f:pvar_of_var + let tvars_of_vars = List.map ~f:tvar_of_var module Backends = struct - class reconstructors = object - method record ~loc flds = pexp_record ~loc flds None - method construct ~loc id args = - pexp_construct ~loc id - (match args with - | [] -> None - | _ -> Some (pexp_tuple ~loc args)) - method tuple ~loc es = pexp_tuple ~loc es - end + class reconstructors = + object + method record ~loc flds = pexp_record ~loc flds None - class type what = object - method name : string + method construct ~loc id args = + pexp_construct ~loc id + (match args with [] -> None | _ -> Some (pexp_tuple ~loc args)) - inherit reconstructors + method tuple ~loc es = pexp_tuple ~loc es + end - method class_params : loc:Location.t -> (core_type * variance) list + class type what = + object + method name : string - method apply - : loc:Location.t - -> expression - -> expression list - -> expression - - method abstract - : loc:Location.t - -> pattern - -> expression - -> expression - - (* Basic combinator type *) - method typ : loc:Location.t -> core_type -> core_type - - method any : loc:Location.t -> expression - - method combine - : loc:Location.t - -> (string loc * expression) list - -> reconstruct:expression - -> expression - end + inherit reconstructors - let mapper : what = object - method name = "map" + method class_params : + loc:Location.t -> (core_type * (variance * injectivity)) list - inherit reconstructors + method apply : + loc:Location.t -> expression -> expression list -> expression - method class_params ~loc:_ = [] + method abstract : loc:Location.t -> pattern -> expression -> expression - method apply ~loc expr args = eapply ~loc expr args - method abstract ~loc patt expr = pexp_fun ~loc Nolabel None patt expr + (* Basic combinator type *) + method typ : loc:Location.t -> core_type -> core_type - method typ ~loc ty = ptyp_arrow ~loc Nolabel ty ty + method any : loc:Location.t -> expression - method any ~loc = [%expr fun x -> x] + method combine : + loc:Location.t -> + (string loc * expression) list -> + reconstruct:expression -> + expression + end - method combine ~loc combinators ~reconstruct = - List.fold_right combinators ~init:reconstruct ~f:(fun (v, expr) acc -> - pexp_let ~loc Nonrecursive [value_binding ~loc ~pat:(pvar_of_var v) ~expr] acc) - end + let mapper : what = + object + method name = "map" - let iterator : what = object - method name = "iter" + inherit reconstructors - inherit reconstructors + method class_params ~loc:_ = [] - method class_params ~loc:_ = [] + method apply ~loc expr args = eapply ~loc expr args - method apply ~loc expr args = eapply ~loc expr args - method abstract ~loc patt expr = pexp_fun ~loc Nolabel None patt expr + method abstract ~loc patt expr = pexp_fun ~loc Nolabel None patt expr - method typ ~loc ty = [%type: [%t ty] -> unit] + method typ ~loc ty = ptyp_arrow ~loc Nolabel ty ty - method any ~loc = [%expr fun _ -> ()] + method any ~loc = [%expr fun x -> x] - method combine ~loc combinators ~reconstruct:_ = - match List.rev combinators with - | [] -> [%expr ()] - | (_, expr) :: rest -> - List.fold_left rest ~init:expr ~f:(fun acc (_v, expr) -> - pexp_sequence ~loc expr acc) - end + method combine ~loc combinators ~reconstruct = + List.fold_right combinators ~init:reconstruct ~f:(fun (v, expr) acc -> + pexp_let ~loc Nonrecursive + [ value_binding ~loc ~pat:(pvar_of_var v) ~expr ] + acc) + end - let folder : what = object - method name = "fold" + let iterator : what = + object + method name = "iter" - inherit reconstructors + inherit reconstructors - method class_params ~loc = [(ptyp_var ~loc "acc", Invariant)] + method class_params ~loc:_ = [] - method apply ~loc expr args = eapply ~loc expr (args @ [evar ~loc "acc"]) - method abstract ~loc patt expr = - eabstract ~loc [patt; pvar ~loc "acc"] expr + method apply ~loc expr args = eapply ~loc expr args - method typ ~loc ty = [%type: [%t ty] -> 'acc -> 'acc] + method abstract ~loc patt expr = pexp_fun ~loc Nolabel None patt expr - method any ~loc = [%expr fun _ acc -> acc] + method typ ~loc ty = [%type: [%t ty] -> unit] - method combine ~loc combinators ~reconstruct:_ = - match combinators with - | [(_, expr)] -> expr - | _ -> - List.fold_right combinators ~init:[%expr acc] ~f:(fun (_v, expr) acc -> - [%expr - let acc = [%e expr] in - [%e acc] - ]) - end + method any ~loc = [%expr fun _ -> ()] - let fold_mapper : what = object - method name = "fold_map" + method combine ~loc combinators ~reconstruct:_ = + match List.rev combinators with + | [] -> [%expr ()] + | (_, expr) :: rest -> + List.fold_left rest ~init:expr ~f:(fun acc (_v, expr) -> + pexp_sequence ~loc expr acc) + end - inherit reconstructors + let folder : what = + object + method name = "fold" + + inherit reconstructors - method class_params ~loc = [(ptyp_var ~loc "acc", Invariant)] + method class_params ~loc = + [ (ptyp_var ~loc "acc", (NoVariance, NoInjectivity)) ] - method apply ~loc expr args = eapply ~loc expr (args @ [evar ~loc "acc"]) - method abstract ~loc patt expr = eabstract ~loc [patt; pvar ~loc "acc"] expr + method apply ~loc expr args = eapply ~loc expr (args @ [ evar ~loc "acc" ]) - method typ ~loc ty = [%type: [%t ty] -> 'acc -> [%t ty] * 'acc] + method abstract ~loc patt expr = + eabstract ~loc [ patt; pvar ~loc "acc" ] expr - method any ~loc = [%expr fun x acc -> (x, acc)] + method typ ~loc ty = [%type: [%t ty] -> 'acc -> 'acc] - method combine ~loc combinators ~reconstruct = - List.fold_right combinators ~init:[%expr ([%e reconstruct], acc)] - ~f:(fun (v, expr) acc -> - [%expr - let ([%p pvar_of_var v], acc) = [%e expr] in - [%e acc] - ]) - end + method any ~loc = [%expr fun _ acc -> acc] + + method combine ~loc combinators ~reconstruct:_ = + match combinators with + | [ (_, expr) ] -> expr + | _ -> + List.fold_right combinators ~init:[%expr acc] + ~f:(fun (_v, expr) acc -> + [%expr + let acc = [%e expr] in + [%e acc]]) + end + + let fold_mapper : what = + object + method name = "fold_map" + + inherit reconstructors + + method class_params ~loc = + [ (ptyp_var ~loc "acc", (NoVariance, NoInjectivity)) ] + + method apply ~loc expr args = eapply ~loc expr (args @ [ evar ~loc "acc" ]) + + method abstract ~loc patt expr = + eabstract ~loc [ patt; pvar ~loc "acc" ] expr + + method typ ~loc ty = [%type: [%t ty] -> 'acc -> [%t ty] * 'acc] + + method any ~loc = [%expr fun x acc -> (x, acc)] + + method combine ~loc combinators ~reconstruct = + List.fold_right combinators + ~init:[%expr [%e reconstruct], acc] + ~f:(fun (v, expr) acc -> + [%expr + let [%p pvar_of_var v], acc = [%e expr] in + [%e acc]]) + end exception Found + let uses_var var = - let iter = object - inherit Ast_traverse.iter as super - method! expression_desc = function - | Pexp_ident { txt = Lident id; _ } when String.equal id var -> - raise_notrace Found - | e -> super#expression_desc e - end in + let iter = + object + inherit Ast_traverse.iter as super + + method! expression_desc = + function + | Pexp_ident { txt = Lident id; _ } when String.equal id var -> + raise_notrace Found + | e -> super#expression_desc e + end + in fun e -> try iter#expression e; false - with Found -> - true - ;; + with Found -> true let mapper_with_context : what = let uses_ctx = uses_var "ctx" in @@ -174,81 +190,85 @@ inherit reconstructors - method class_params ~loc = [(ptyp_var ~loc "ctx", Invariant)] + method class_params ~loc = + [ (ptyp_var ~loc "ctx", (NoVariance, NoInjectivity)) ] method apply ~loc expr args = eapply ~loc expr (evar ~loc "ctx" :: args) + method abstract ~loc patt expr = - if uses_ctx expr then - eabstract ~loc [pvar ~loc "ctx"; patt] expr - else - eabstract ~loc [pvar ~loc "_ctx"; patt] expr + if uses_ctx expr then eabstract ~loc [ pvar ~loc "ctx"; patt ] expr + else eabstract ~loc [ pvar ~loc "_ctx"; patt ] expr method typ ~loc ty = [%type: 'ctx -> [%t ty] -> [%t ty]] method any ~loc = [%expr fun _ctx x -> x] method combine ~loc combinators ~reconstruct = - List.fold_right combinators ~init:reconstruct - ~f:(fun (v, expr) acc -> + List.fold_right combinators ~init:reconstruct ~f:(fun (v, expr) acc -> [%expr let [%p pvar_of_var v] = [%e expr] in - [%e acc] - ]) + [%e acc]]) end let string_of_lid id = String.concat ~sep:"." (Longident.flatten_exn id) - let lifter : what = object - method name = "lift" + let lifter : what = + object + method name = "lift" - method class_params ~loc = [(ptyp_var ~loc "res", Invariant)] + method class_params ~loc = + [ (ptyp_var ~loc "res", (NoVariance, NoInjectivity)) ] - method apply ~loc expr args = eapply ~loc expr args - method abstract ~loc patt expr = pexp_fun ~loc Nolabel None patt expr + method apply ~loc expr args = eapply ~loc expr args - method typ ~loc ty = [%type: [%t ty] -> 'res] - - method any ~loc = [%expr self#other] - - method combine ~loc combinators ~reconstruct = - List.fold_right combinators ~init:reconstruct ~f:(fun (v, expr) acc -> - pexp_let ~loc Nonrecursive [value_binding ~loc ~pat:(pvar_of_var v) ~expr] acc) - - method record ~loc flds = - let flds = - elist ~loc - (List.map flds ~f:(fun (lab, e) -> - pexp_tuple ~loc:{ lab.loc with loc_end = e.pexp_loc.loc_end } - [ estring ~loc:lab.loc (string_of_lid lab.txt) - ; e - ])) - in - [%expr self#record [%e flds]] - method construct ~loc id args = - let args = elist ~loc args in - [%expr self#constr [%e estring ~loc:id.loc (string_of_lid id.txt)] [%e args]] - method tuple ~loc es = - [%expr self#tuple [%e elist ~loc es]] - end + method abstract ~loc patt expr = pexp_fun ~loc Nolabel None patt expr + + method typ ~loc ty = [%type: [%t ty] -> 'res] + + method any ~loc = [%expr self#other] + + method combine ~loc combinators ~reconstruct = + List.fold_right combinators ~init:reconstruct ~f:(fun (v, expr) acc -> + pexp_let ~loc Nonrecursive + [ value_binding ~loc ~pat:(pvar_of_var v) ~expr ] + acc) + + method record ~loc flds = + let flds = + elist ~loc + (List.map flds ~f:(fun (lab, e) -> + pexp_tuple + ~loc:{ lab.loc with loc_end = e.pexp_loc.loc_end } + [ estring ~loc:lab.loc (string_of_lid lab.txt); e ])) + in + [%expr self#record [%e flds]] + + method construct ~loc id args = + let args = elist ~loc args in + [%expr + self#constr [%e estring ~loc:id.loc (string_of_lid id.txt)] [%e args]] - let all = [mapper; iterator; folder; fold_mapper; mapper_with_context; lifter] + method tuple ~loc es = [%expr self#tuple [%e elist ~loc es]] + end + + let all = + [ mapper; iterator; folder; fold_mapper; mapper_with_context; lifter ] end + type what = Backends.what -let mapper_type ~(what:what) ~loc type_name params = +let mapper_type ~(what : what) ~loc type_name params = let vars = vars_of_list params ~get_loc:(fun t -> t.ptyp_loc) in let params = tvars_of_vars vars in let ty = ptyp_constr ~loc type_name params in let ty = - List.fold_right params ~init:(what#typ ~loc ty) - ~f:(fun param ty -> + List.fold_right params ~init:(what#typ ~loc ty) ~f:(fun param ty -> let loc = param.ptyp_loc in ptyp_arrow ~loc Nolabel (what#typ ~loc param) ty) in ptyp_poly ~loc vars ty -;; -let constrained_mapper ~(what:what) ?(is_gadt=false) mapper td = +let constrained_mapper ~(what : what) ?(is_gadt = false) mapper td = let vars = vars_of_list td.ptype_params ~get_loc:(fun (t, _) -> t.ptyp_loc) in let make_type params = let loc = td.ptype_loc in @@ -265,57 +285,56 @@ let mapper = if false || is_gadt then let typs = - List.map vars ~f:(fun v -> ptyp_constr ~loc:v.loc (Loc.map v ~f:lident) []) + List.map vars ~f:(fun v -> + ptyp_constr ~loc:v.loc (Loc.map v ~f:lident) []) in List.fold_right vars ~init:(pexp_constraint ~loc:mapper.pexp_loc mapper (make_type typs)) ~f:(fun v e -> pexp_newtype ~loc:v.loc v e) - else - mapper + else mapper in pexp_poly ~loc:mapper.pexp_loc mapper (Some typ) -;; let mangle_type_name lid = let rec mangled_parts lid ~suffix = match lid with | Lident s -> String.lowercase_ascii s :: suffix | Ldot (lid, s) -> - mangled_parts lid ~suffix:("__" :: String.lowercase_ascii s :: suffix) + mangled_parts lid ~suffix:("__" :: String.lowercase_ascii s :: suffix) | Lapply (a, b) -> - mangled_parts a ~suffix:("_'" :: mangled_parts b ~suffix:("'" :: suffix)) + mangled_parts a ~suffix:("_'" :: mangled_parts b ~suffix:("'" :: suffix)) in mangled_parts lid ~suffix:[] |> String.concat ~sep:"" -let rec type_expr_mapper ~(what:what) te = +let rec type_expr_mapper ~(what : what) te = let loc = te.ptyp_loc in match te.ptyp_desc with | Ptyp_var s -> evar ~loc ("_" ^ s) | Ptyp_tuple tes -> - let vars = vars_of_list tes ~get_loc:(fun t -> t.ptyp_loc) in - let deconstruct = ppat_tuple ~loc (pvars_of_vars vars) in - let reconstruct = what#tuple ~loc (evars_of_vars vars) in - let mappers = map_variables ~what vars tes in - what#abstract ~loc deconstruct (what#combine ~loc mappers ~reconstruct) - | Ptyp_constr (path, params) -> - let map = pexp_send ~loc (evar ~loc "self") (Loc.map path ~f:mangle_type_name) in - (match params with - | [] -> map - | _ -> - eapply ~loc map - (List.map params - ~f:(fun te -> - type_expr_mapper ~what te))) + let vars = vars_of_list tes ~get_loc:(fun t -> t.ptyp_loc) in + let deconstruct = ppat_tuple ~loc (pvars_of_vars vars) in + let reconstruct = what#tuple ~loc (evars_of_vars vars) in + let mappers = map_variables ~what vars tes in + what#abstract ~loc deconstruct (what#combine ~loc mappers ~reconstruct) + | Ptyp_constr (path, params) -> ( + let map = + pexp_send ~loc (evar ~loc "self") (Loc.map path ~f:mangle_type_name) + in + match params with + | [] -> map + | _ -> + eapply ~loc map + (List.map params ~f:(fun te -> type_expr_mapper ~what te))) | _ -> what#any ~loc -and map_variables ~(what:what) vars tes = +and map_variables ~(what : what) vars tes = List.map2 tes vars ~f:(fun te var -> - (var, - what#apply ~loc:te.ptyp_loc (type_expr_mapper ~what te) - [evar_of_var var])) -;; + ( var, + what#apply ~loc:te.ptyp_loc + (type_expr_mapper ~what te) + [ evar_of_var var ] )) -let gen_record' ~(what:what) ~loc lds = +let gen_record' ~(what : what) ~loc lds = let vars = List.map lds ~f:(fun ld -> ld.pld_name) in let deconstruct = ppat_record ~loc @@ -327,216 +346,216 @@ (List.map vars ~f:(fun v -> (Loc.map v ~f:lident, evar_of_var v))) in let mappers = - map_variables ~what - vars - (List.map lds ~f:(fun ld -> ld.pld_type)) - in - deconstruct, reconstruct, mappers -;; - -let gen_record ~(what:what) ~loc lds = - let deconstruct, reconstruct, mappers = - gen_record' ~what lds ~loc + map_variables ~what vars (List.map lds ~f:(fun ld -> ld.pld_type)) in + (deconstruct, reconstruct, mappers) + +let gen_record ~(what : what) ~loc lds = + let deconstruct, reconstruct, mappers = gen_record' ~what lds ~loc in what#abstract ~loc deconstruct (what#combine ~loc mappers ~reconstruct) -;; let is_constant_constructor cd = - match cd.pcd_args with - | Pcstr_tuple [] -> true - | _ -> false - -let erase_type_variables = object - inherit Ast_traverse.map as super - - method! core_type_desc = function - | Ptyp_var _ -> Ptyp_any - | x -> super#core_type_desc x -end + match cd.pcd_args with Pcstr_tuple [] -> true | _ -> false -let gen_variant ~(what:what) ~loc cds = - if String.(<>) what#name "lift" && - List.for_all cds ~f:is_constant_constructor then - what#any ~loc +let erase_type_variables = + object + inherit Ast_traverse.map as super + + method! core_type_desc = + function Ptyp_var _ -> Ptyp_any | x -> super#core_type_desc x + end + +let gen_variant ~(what : what) ~loc cds = + if + String.( <> ) what#name "lift" + && List.for_all cds ~f:is_constant_constructor + then what#any ~loc else let cases = List.map cds ~f:(fun cd -> - let cstr = Loc.map cd.pcd_name ~f:lident in - let loc = cd.pcd_loc in - let args = - match cd.pcd_res with - | None -> cd.pcd_args - | Some _ -> - (* This is a big sur-approximation but it's enough for our only use of GADTs - in ppx_custom_format *) - erase_type_variables#constructor_arguments cd.pcd_args - in - match args with - | Pcstr_tuple args -> - let vars = vars_of_list args ~get_loc:(fun t -> t.ptyp_loc) in - let deconstruct = - ppat_construct cstr ~loc - (match vars with - | [] -> None - | _ -> Some (ppat_tuple ~loc (pvars_of_vars vars))) - in - let reconstruct = - what#construct cstr ~loc (evars_of_vars vars) - in - let mappers = - map_variables ~what vars args + let cstr = Loc.map cd.pcd_name ~f:lident in + let loc = cd.pcd_loc in + let args = + match cd.pcd_res with + | None -> cd.pcd_args + | Some _ -> + (* This is a big sur-approximation but it's enough for our only use of GADTs + in ppx_custom_format *) + erase_type_variables#constructor_arguments cd.pcd_args in - case ~lhs:deconstruct ~rhs:(what#combine ~loc mappers ~reconstruct) ~guard:None - | Pcstr_record labels -> - let deconstruct, reconstruct, mappers = - gen_record' ~loc ~what labels - in - let deconstruct = ppat_construct ~loc cstr (Some deconstruct) in - let reconstruct = what#construct ~loc cstr [reconstruct] in - case ~lhs:deconstruct ~rhs:(what#combine ~loc mappers ~reconstruct) ~guard:None) + match args with + | Pcstr_tuple args -> + let vars = vars_of_list args ~get_loc:(fun t -> t.ptyp_loc) in + let deconstruct = + ppat_construct cstr ~loc + (match vars with + | [] -> None + | _ -> Some (ppat_tuple ~loc (pvars_of_vars vars))) + in + let reconstruct = what#construct cstr ~loc (evars_of_vars vars) in + let mappers = map_variables ~what vars args in + case ~lhs:deconstruct + ~rhs:(what#combine ~loc mappers ~reconstruct) + ~guard:None + | Pcstr_record labels -> + let deconstruct, reconstruct, mappers = + gen_record' ~loc ~what labels + in + let deconstruct = ppat_construct ~loc cstr (Some deconstruct) in + let reconstruct = what#construct ~loc cstr [ reconstruct ] in + case ~lhs:deconstruct + ~rhs:(what#combine ~loc mappers ~reconstruct) + ~guard:None) in what#abstract ~loc (pvar ~loc "x") (pexp_match ~loc (evar ~loc "x") cases) -let gen_mapper ~(what:what) td = +let gen_mapper ~(what : what) td = let body = let loc = td.ptype_loc in match td.ptype_kind with | Ptype_open -> what#any ~loc - | Ptype_record lds -> gen_record ~what lds ~loc + | Ptype_record lds -> gen_record ~what lds ~loc | Ptype_variant cds -> gen_variant ~what cds ~loc - | Ptype_abstract -> - match td.ptype_manifest with - | None -> what#any ~loc - | Some te -> type_expr_mapper ~what te + | Ptype_abstract -> ( + match td.ptype_manifest with + | None -> what#any ~loc + | Some te -> type_expr_mapper ~what te) in List.fold_right td.ptype_params ~init:body ~f:(fun (ty, _) acc -> - let loc = ty.ptyp_loc in - match ty.ptyp_desc with - | Ptyp_var s -> - pexp_fun ~loc Nolabel None (pvar ~loc ("_" ^ s)) acc - | _ -> - pexp_fun ~loc Nolabel None (ppat_any ~loc) acc) -;; + let loc = ty.ptyp_loc in + match ty.ptyp_desc with + | Ptyp_var s -> pexp_fun ~loc Nolabel None (pvar ~loc ("_" ^ s)) acc + | _ -> pexp_fun ~loc Nolabel None (ppat_any ~loc) acc) let type_deps = - let collect = object - inherit [int Longident.Map.t] Ast_traverse.fold as super - method! core_type t acc = - let acc = - match t.ptyp_desc with - | Ptyp_constr (id, vars) -> Longident.Map.add id.txt (List.length vars) acc - | _ -> acc - in - super#core_type t acc - end in + let collect = + object + inherit [int Longident.Map.t] Ast_traverse.fold as super + + method! core_type t acc = + let acc = + match t.ptyp_desc with + | Ptyp_constr (id, vars) -> + Longident.Map.add id.txt (List.length vars) acc + | _ -> acc + in + super#core_type t acc + end + in fun tds -> let empty = Longident.Map.empty in let map = List.fold_left tds ~init:empty ~f:(fun map td -> - let map = collect#type_kind td.ptype_kind map in - match td.ptype_kind, td.ptype_manifest with - | Ptype_abstract, Some ty -> collect#core_type ty map - | _ -> map) + let map = collect#type_kind td.ptype_kind map in + match (td.ptype_kind, td.ptype_manifest) with + | Ptype_abstract, Some ty -> collect#core_type ty map + | _ -> map) in let map = List.fold_left tds ~init:map ~f:(fun map td -> - Longident.Map.remove (Lident td.ptype_name.txt) map) + Longident.Map.remove (Lident td.ptype_name.txt) map) in Longident.Map.bindings map let lift_virtual_methods ~loc methods = - let collect = object - inherit [String.Set.t] Ast_traverse.fold as super + let collect = + object + inherit [String.Set.t] Ast_traverse.fold as super - method! expression_desc x acc = - match x with - | Pexp_send (_, ({ txt = "tuple"|"record"|"constr"|"other" as s; loc = _; })) -> - String.Set.add s acc - | _ -> super#expression_desc x acc - end in + method! expression_desc x acc = + match x with + | Pexp_send + ( _, + { txt = ("tuple" | "record" | "constr" | "other") as s; loc = _ } + ) -> + String.Set.add s acc + | _ -> super#expression_desc x acc + end + in let used = collect#list collect#class_field methods String.Set.empty in let all_virtual_methods = match [%stri - class virtual blah = object - method virtual record : (string * 'res) list -> 'res - method virtual constr : string -> 'res list -> 'rest - method virtual tuple : 'res list -> 'res - method virtual other : 'a. 'a -> 'res - end - ] + class virtual blah = + object + method virtual record : (string * 'res) list -> 'res + + method virtual constr : string -> 'res list -> 'res + + method virtual tuple : 'res list -> 'res + + method virtual other : 'a. 'a -> 'res + end] with - | { pstr_desc = - Pstr_class - [ { pci_expr = - { pcl_desc = - Pcl_structure { pcstr_fields = l; _ } - ; _ } - ; _ } ] - ; _ } -> l + | { + pstr_desc = + Pstr_class + [ + { + pci_expr = { pcl_desc = Pcl_structure { pcstr_fields = l; _ }; _ }; + _; + }; + ]; + _; + } -> + l | _ -> assert false in List.filter all_virtual_methods ~f:(fun m -> - match m.pcf_desc with - | Pcf_method (s, _, _) -> String.Set.mem s.txt used - | _ -> false) + match m.pcf_desc with + | Pcf_method (s, _, _) -> String.Set.mem s.txt used + | _ -> false) -let gen_class ~(what:what) ~loc tds = +let gen_class ~(what : what) ~loc tds = let class_params = what#class_params ~loc in let virtual_methods = List.map (type_deps tds) ~f:(fun (id, arity) -> - pcf_method ~loc - ({ txt = mangle_type_name id; loc }, - Public, - Cfk_virtual (mapper_type ~what ~loc {txt = id; loc} - (List.init ~len:arity ~f:(fun _ -> ptyp_any ~loc))))) + pcf_method ~loc + ( { txt = mangle_type_name id; loc }, + Public, + Cfk_virtual + (mapper_type ~what ~loc { txt = id; loc } + (List.init ~len:arity ~f:(fun _ -> ptyp_any ~loc))) )) in let methods = List.map tds ~f:(fun td -> - let loc = td.ptype_loc in - let mapper = gen_mapper ~what td in - let is_gadt = - match td.ptype_kind with - | Ptype_variant cds -> List.exists cds ~f:(fun cd -> Option.is_some cd.pcd_res) - | _ -> false - in - let mapper = constrained_mapper ~what ~is_gadt mapper td in - pcf_method ~loc - (td.ptype_name, - Public, - Cfk_concrete (Fresh, mapper))) + let loc = td.ptype_loc in + let mapper = gen_mapper ~what td in + let is_gadt = + match td.ptype_kind with + | Ptype_variant cds -> + List.exists cds ~f:(fun cd -> Option.is_some cd.pcd_res) + | _ -> false + in + let mapper = constrained_mapper ~what ~is_gadt mapper td in + pcf_method ~loc (td.ptype_name, Public, Cfk_concrete (Fresh, mapper))) in let virtual_methods = if String.equal what#name "lift" then lift_virtual_methods ~loc methods @ virtual_methods - else - virtual_methods + else virtual_methods in let virt = if List.is_empty virtual_methods then Concrete else Virtual in - class_infos - ~loc - ~virt - ~params:class_params - ~name:{ loc; txt = what#name } - ~expr:(pcl_structure ~loc - (class_structure - ~self:(ppat_var ~loc { txt = "self"; loc }) - ~fields:(virtual_methods @ methods))) + class_infos ~loc ~virt ~params:class_params ~name:{ loc; txt = what#name } + ~expr: + (pcl_structure ~loc + (class_structure + ~self:(ppat_var ~loc { txt = "self"; loc }) + ~fields:(virtual_methods @ methods))) -let gen_str ~(what:what)~loc ~path:_ (rf, tds) = +let gen_str ~(what : what) ~loc ~path:_ (rf, tds) = (match rf with - | Nonrecursive -> - (* The method name would clash... *) - Location.raise_errorf ~loc "ppxlib_traverse doesn't support nonrec" - | Recursive -> ()); + | Nonrecursive -> + (* The method name would clash... *) + Location.raise_errorf ~loc "ppxlib_traverse doesn't support nonrec" + | Recursive -> ()); let cl = gen_class ~loc ~what tds in - [ pstr_class ~loc:cl.pci_loc [cl] ] + [ pstr_class ~loc:cl.pci_loc [ cl ] ] let () = let derivers = List.map Backends.all ~f:(fun what -> - Deriving.add ("traverse_" ^ what#name) - ~str_type_decl:(Deriving.Generator.make_noarg (gen_str ~what))) + Deriving.add ("traverse_" ^ what#name) + ~str_type_decl:(Deriving.Generator.make_noarg (gen_str ~what))) in - Deriving.add_alias "traverse" (List.rev derivers) - |> Deriving.ignore + Deriving.add_alias "traverse" (List.rev derivers) |> Deriving.ignore diff -Nru ppxlib-0.15.0/traverse_builtins/dune ppxlib-0.24.0/traverse_builtins/dune --- ppxlib-0.15.0/traverse_builtins/dune 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/traverse_builtins/dune 2021-12-08 21:53:37.000000000 +0000 @@ -1,4 +1,5 @@ (library - (name ppxlib_traverse_builtins) + (name ppxlib_traverse_builtins) (public_name ppxlib.traverse_builtins) - (flags (:standard -safe-string))) + (flags + (:standard -safe-string))) diff -Nru ppxlib-0.15.0/traverse_builtins/ppxlib_traverse_builtins.ml ppxlib-0.24.0/traverse_builtins/ppxlib_traverse_builtins.ml --- ppxlib-0.15.0/traverse_builtins/ppxlib_traverse_builtins.ml 2020-08-05 09:59:54.000000000 +0000 +++ ppxlib-0.24.0/traverse_builtins/ppxlib_traverse_builtins.ml 2021-12-08 21:53:37.000000000 +0000 @@ -1,104 +1,119 @@ module T = struct type 'a map = 'a -> 'a + type 'a iter = 'a -> unit + type ('a, 'acc) fold = 'a -> 'acc -> 'acc - type ('a, 'acc) fold_map = 'a -> 'acc -> ('a * 'acc) + + type ('a, 'acc) fold_map = 'a -> 'acc -> 'a * 'acc + type ('ctx, 'a) map_with_context = 'ctx -> 'a -> 'a + type ('a, 'res) lift = 'a -> 'res end class map = let any x = x in object - method int : int T.map = any + method int : int T.map = any + method string : string T.map = any - method bool : bool T.map = any - method char : char T.map = any - method option : 'a. 'a T.map -> 'a option T.map = fun f x -> - match x with - | None -> None - | Some x -> Some (f x) + method bool : bool T.map = any + + method char : char T.map = any + + method option : 'a. 'a T.map -> 'a option T.map = + fun f x -> match x with None -> None | Some x -> Some (f x) + method list : 'a. 'a T.map -> 'a list T.map = List.map + method array : 'a. 'a T.map -> 'a array T.map = Array.map end class iter = let any = ignore in object - method int : int T.iter = any + method int : int T.iter = any + method string : string T.iter = any - method bool : bool T.iter = any - method char : char T.iter = any - method option : 'a. 'a T.iter -> 'a option T.iter = fun f x -> - match x with - | None -> () - | Some x -> f x + method bool : bool T.iter = any + + method char : char T.iter = any + + method option : 'a. 'a T.iter -> 'a option T.iter = + fun f x -> match x with None -> () | Some x -> f x + method list : 'a. 'a T.iter -> 'a list T.iter = List.iter + method array : 'a. 'a T.iter -> 'a array T.iter = Array.iter end class ['acc] fold = let any _ acc = acc in object - method int : (int , 'acc) T.fold = any - method string : (string , 'acc) T.fold = any - method bool : (bool , 'acc) T.fold = any - method char : (char , 'acc) T.fold = any - - method option : 'a. ('a, 'acc) T.fold -> ('a option, 'acc) T.fold = fun f x acc -> - match x with - | None -> acc - | Some x -> f x acc + method int : (int, 'acc) T.fold = any + + method string : (string, 'acc) T.fold = any + + method bool : (bool, 'acc) T.fold = any + + method char : (char, 'acc) T.fold = any + + method option : 'a. ('a, 'acc) T.fold -> ('a option, 'acc) T.fold = + fun f x acc -> match x with None -> acc | Some x -> f x acc method list : 'a. ('a, 'acc) T.fold -> ('a list, 'acc) T.fold = let rec loop f l acc = - match l with - | [] -> acc - | x :: l -> loop f l (f x acc) + match l with [] -> acc | x :: l -> loop f l (f x acc) in loop - method array : 'a. ('a, 'acc) T.fold -> ('a array, 'acc) T.fold = fun f a acc -> - let r = ref acc in - for i = 0 to Array.length a - 1 do - r := f (Array.unsafe_get a i) !r - done; - !r + method array : 'a. ('a, 'acc) T.fold -> ('a array, 'acc) T.fold = + fun f a acc -> + let r = ref acc in + for i = 0 to Array.length a - 1 do + r := f (Array.unsafe_get a i) !r + done; + !r end class ['acc] fold_map = let any x acc = (x, acc) in object - method int : (int , 'acc) T.fold_map = any - method string : (string , 'acc) T.fold_map = any - method bool : (bool , 'acc) T.fold_map = any - method char : (char , 'acc) T.fold_map = any + method int : (int, 'acc) T.fold_map = any + + method string : (string, 'acc) T.fold_map = any + + method bool : (bool, 'acc) T.fold_map = any - method option : 'a. ('a, 'acc) T.fold_map -> ('a option, 'acc) T.fold_map - = fun f x acc -> + method char : (char, 'acc) T.fold_map = any + + method option : 'a. ('a, 'acc) T.fold_map -> ('a option, 'acc) T.fold_map = + fun f x acc -> match x with | None -> (None, acc) - | Some x -> let x, acc = f x acc in (Some x, acc) + | Some x -> + let x, acc = f x acc in + (Some x, acc) method list : 'a. ('a, 'acc) T.fold_map -> ('a list, 'acc) T.fold_map = let rec loop f l acc = match l with | [] -> ([], acc) | x :: l -> - let x, acc = f x acc in - let l, acc = loop f l acc in - (x :: l, acc) + let x, acc = f x acc in + let l, acc = loop f l acc in + (x :: l, acc) in loop - method array : 'a. ('a, 'acc) T.fold_map -> ('a array, 'acc) T.fold_map - = fun f a acc -> + method array : 'a. ('a, 'acc) T.fold_map -> ('a array, 'acc) T.fold_map = + fun f a acc -> let len = Array.length a in - if len = 0 then - (a, acc) - else begin + if len = 0 then (a, acc) + else let x, acc = f (Array.unsafe_get a 0) acc in let a' = Array.make len x in let r = ref acc in @@ -108,78 +123,110 @@ r := acc done; (a', !r) - end end class ['ctx] map_with_context = let any _ x = x in object - method int : ('ctx, int ) T.map_with_context = any + method int : ('ctx, int) T.map_with_context = any + method string : ('ctx, string) T.map_with_context = any - method bool : ('ctx, bool ) T.map_with_context = any - method char : ('ctx, char ) T.map_with_context = any + + method bool : ('ctx, bool) T.map_with_context = any + + method char : ('ctx, char) T.map_with_context = any method option - : 'a. ('ctx, 'a) T.map_with_context -> ('ctx, 'a option) T.map_with_context - = fun f ctx x -> - match x with - | None -> None - | Some x -> Some (f ctx x) + : 'a. + ('ctx, 'a) T.map_with_context -> ('ctx, 'a option) T.map_with_context + = + fun f ctx x -> match x with None -> None | Some x -> Some (f ctx x) method list - : 'a. ('ctx, 'a) T.map_with_context -> ('ctx, 'a list) T.map_with_context - = fun f ctx l -> List.map (f ctx) l + : 'a. + ('ctx, 'a) T.map_with_context -> ('ctx, 'a list) T.map_with_context = + fun f ctx l -> List.map (f ctx) l method array - : 'a. ('ctx, 'a) T.map_with_context -> ('ctx, 'a array) T.map_with_context - = fun f ctx a -> Array.map (f ctx) a + : 'a. + ('ctx, 'a) T.map_with_context -> ('ctx, 'a array) T.map_with_context = + fun f ctx a -> Array.map (f ctx) a end class virtual ['res] lift = - object(self) - method virtual other : 'a. ('a, 'res) T.lift - method virtual int : (int , 'res) T.lift - method virtual string : (string, 'res) T.lift - method virtual bool : (bool , 'res) T.lift - method virtual char : (char , 'res) T.lift - method virtual array : 'a. ('a, 'res) T.lift -> ('a array, 'res) T.lift - method virtual float : (float, 'res) T.lift - method virtual int32 : (int32, 'res) T.lift - method virtual int64 : (int64, 'res) T.lift - method virtual nativeint : (nativeint, 'res) T.lift - method virtual unit : (unit, 'res) T.lift + object (self) + method virtual other : 'a. ('a, 'res) T.lift + + method virtual int : (int, 'res) T.lift + + method virtual string : (string, 'res) T.lift + + method virtual bool : (bool, 'res) T.lift + + method virtual char : (char, 'res) T.lift + + method virtual array : 'a. ('a, 'res) T.lift -> ('a array, 'res) T.lift + + method virtual float : (float, 'res) T.lift + + method virtual int32 : (int32, 'res) T.lift + + method virtual int64 : (int64, 'res) T.lift + + method virtual nativeint : (nativeint, 'res) T.lift + + method virtual unit : (unit, 'res) T.lift method virtual record : (string * 'res) list -> 'res + method virtual constr : string -> 'res list -> 'res + method virtual tuple : 'res list -> 'res - method option : 'a. ('a, 'res) T.lift -> ('a option, 'res) T.lift = fun f x -> - match x with - | None -> self#constr "None" [] - | Some x -> self#constr "Some" [f x] - - method list : 'a. ('a, 'res) T.lift -> ('a list, 'res) T.lift = fun f l -> - match l with - | [] -> self#constr "[]" [] - | x :: l -> self#constr "::" [f x; self#list f l] + method option : 'a. ('a, 'res) T.lift -> ('a option, 'res) T.lift = + fun f x -> + match x with + | None -> self#constr "None" [] + | Some x -> self#constr "Some" [ f x ] + + method list : 'a. ('a, 'res) T.lift -> ('a list, 'res) T.lift = + fun f l -> + match l with + | [] -> self#constr "[]" [] + | x :: l -> self#constr "::" [ f x; self#list f l ] end class type ['res] std_lifters = object - method other : 'a. ('a, 'res) T.lift - method int : (int , 'res) T.lift - method string : (string, 'res) T.lift - method bool : (bool , 'res) T.lift - method char : (char , 'res) T.lift - method array : 'a. ('a, 'res) T.lift -> ('a array, 'res) T.lift - method record : (string * 'res) list -> 'res - method constr : string -> 'res list -> 'res - method tuple : 'res list -> 'res - method float : (float, 'res) T.lift - method int32 : (int32, 'res) T.lift - method int64 : (int64, 'res) T.lift + method other : 'a. ('a, 'res) T.lift + + method int : (int, 'res) T.lift + + method string : (string, 'res) T.lift + + method bool : (bool, 'res) T.lift + + method char : (char, 'res) T.lift + + method array : 'a. ('a, 'res) T.lift -> ('a array, 'res) T.lift + + method record : (string * 'res) list -> 'res + + method constr : string -> 'res list -> 'res + + method tuple : 'res list -> 'res + + method float : (float, 'res) T.lift + + method int32 : (int32, 'res) T.lift + + method int64 : (int64, 'res) T.lift + method nativeint : (nativeint, 'res) T.lift - method unit : (unit, 'res) T.lift - method option : 'a. ('a, 'res) T.lift -> ('a option, 'res) T.lift - method list : 'a. ('a, 'res) T.lift -> ('a list, 'res) T.lift + + method unit : (unit, 'res) T.lift + + method option : 'a. ('a, 'res) T.lift -> ('a option, 'res) T.lift + + method list : 'a. ('a, 'res) T.lift -> ('a list, 'res) T.lift end