diff options
| author | Stephane Glondu <steph@glondu.net> | 2020-07-25 07:44:39 +0200 |
|---|---|---|
| committer | Stephane Glondu <steph@glondu.net> | 2020-07-25 07:44:39 +0200 |
| commit | 8daec26e8db4256424282b8d328fd9369da3827e (patch) | |
| tree | 53c5c94642e5b002b4ba9495b06af1132d72ec92 | |
| parent | 907bdd90dff056832510829869e1301e974f402c (diff) | |
New upstream version 5.3.0
| -rw-r--r-- | .travis.yml | 2 | ||||
| -rw-r--r-- | README.md | 98 | ||||
| -rw-r--r-- | ast_convenience_410.ml | 124 | ||||
| -rw-r--r-- | ast_convenience_410.mli | 112 | ||||
| -rw-r--r-- | ast_lifter_410.ml | 1598 | ||||
| -rw-r--r-- | ast_mapper_class_410.ml | 658 | ||||
| -rw-r--r-- | ast_mapper_class_410.mli | 62 | ||||
| -rw-r--r-- | dune.inc | 13 | ||||
| -rw-r--r-- | gen/update_dune.ml | 2 | ||||
| -rw-r--r-- | pkg/pkg.ml | 2 | ||||
| -rw-r--r-- | ppx_metaquot_410.ml | 285 | ||||
| -rw-r--r-- | ppx_tools_410.ml | 2 | ||||
| -rw-r--r-- | ppx_tools_versioned.opam | 2 |
13 files changed, 2858 insertions, 102 deletions
diff --git a/.travis.yml b/.travis.yml index ee5d7b0..649cd62 100644 --- a/.travis.yml +++ b/.travis.yml @@ -17,3 +17,5 @@ env: - OCAML_VERSION=4.06.1 - OCAML_VERSION=4.07.1 - OCAML_VERSION=4.08.0 + - OCAML_VERSION=4.09.0 + - OCAML_VERSION=4.10.0 @@ -15,15 +15,7 @@ Main contributors: - Peter Zotov (whitequark) - Gabriel Radanne (Drup) -Master : [](https://travis-ci.org/alainfrisch/ppx_tools) - -4.05 : [](https://travis-ci.org/alainfrisch/ppx_tools) - -4.04 : [](https://travis-ci.org/alainfrisch/ppx_tools) - -4.03 : [](https://travis-ci.org/alainfrisch/ppx_tools) - -4.02 : [](https://travis-ci.org/alainfrisch/ppx_tools) +[](https://travis-ci.org/ocaml-ppx/ppx_tools_versioned) ppx_metaquot ------------ @@ -39,21 +31,6 @@ Usage: ocamlfind ocamlc -c -package ppx_tools.metaquot my_ppx_code.ml -rewriter --------- - -An utility to help testing ppx rewriters that runs the rewriter on -user-provided code and returns the result. - -Usage: - - ocamlfind ppx_tools/rewriter ./my_ppx_rewriter sample.ml - -See the integrated help message for more details: - - ocamlfind ppx_tools/rewriter -help - - Ast_mapper_class ---------------- @@ -63,76 +40,3 @@ implemeting a deep identity copy, which can be customized with a custom behavior for each syntactic category. The difference with Ast_mapper is that Ast_mapper_class implements the open recursion using a class. - - -dumpast -------- - -This tool parses fragments of OCaml code (or entire source files) and -dump the resulting internal Parsetree representation. Intended uses: - - - Help to learn about the OCaml Parsetree structure and how it - corresponds to OCaml source syntax. - - - Create fragments of Parsetree to be copy-pasted into the source - code of syntax-manipulating programs (such as ppx rewriters). - -Usage: - - ocamlfind ppx_tools/dumpast -e "1 + 2" - -The tool can be used to show the Parsetree representation of small -fragments of syntax passed on the command line (-e for expressions, -p -for patterns, -t for type expressions) or for entire .ml/mli files. -The standard -pp and -ppx options are supported, but only applied on -whole files. The tool has further option to control how location and -attribute fields in the Parsetree should be displayed. - - -genlifter ---------- - -This tool generates a virtual "lifter" class for one or several OCaml -type constructors. It does so by loading the .cmi files which define -those types. The generated lifter class exposes one method to "reify" -type constructors passed on the command-line and other type -constructors accessible from them. The class is parametrized over the -target type of the reification, and it must provide method to deal -with basic types (int, string, char, int32, int64, nativeint) and data -type builders (record, constr, tuple, list, array). As an example, -calling: - - ocamlfind ppx_tools/genlifter -I +compiler-libs Location.t - -produces the following class: - - class virtual ['res] lifter = - object (this) - method lift_Location_t : Location.t -> 'res= - fun - { Location.loc_start = loc_start; Location.loc_end = loc_end; - Location.loc_ghost = loc_ghost } - -> - this#record "Location.t" - [("loc_start", (this#lift_Lexing_position loc_start)); - ("loc_end", (this#lift_Lexing_position loc_end)); - ("loc_ghost", (this#lift_bool loc_ghost))] - method lift_bool : bool -> 'res= - function - | false -> this#constr "bool" ("false", []) - | true -> this#constr "bool" ("true", []) - method lift_Lexing_position : Lexing.position -> 'res= - fun - { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } - -> - this#record "Lexing.position" - [("pos_fname", (this#string pos_fname)); - ("pos_lnum", (this#int pos_lnum)); - ("pos_bol", (this#int pos_bol)); - ("pos_cnum", (this#int pos_cnum))] - end - -_dumpast_ is a direct example of using _genlifter_ applied on the -OCaml Parsetree definition itself. ppx_metaquot is another -similar example. diff --git a/ast_convenience_410.ml b/ast_convenience_410.ml new file mode 100644 index 0000000..b417e73 --- /dev/null +++ b/ast_convenience_410.ml @@ -0,0 +1,124 @@ +open Migrate_parsetree.Ast_410 + +(* This file is part of the ppx_tools package. It is released *) +(* under the terms of the MIT license (see LICENSE file). *) +(* Copyright 2013 Alain Frisch and LexiFi *) + +open Parsetree +open Asttypes +open Location +open Ast_helper + + +module Label = struct + + type t = Asttypes.arg_label + + type desc = Asttypes.arg_label = + Nolabel + | Labelled of string + | Optional of string + + let explode x = x + + let nolabel = Nolabel + let labelled x = Labelled x + let optional x = Optional x + +end + +module Constant = struct + type t = Parsetree.constant = + Pconst_integer of string * char option + | Pconst_char of char + | Pconst_string of string * string option + | Pconst_float of string * char option + + let of_constant x = x + + let to_constant x = x + +end + +let may_tuple ?loc tup = function + | [] -> None + | [x] -> Some x + | l -> Some (tup ?loc ?attrs:None l) + +let lid ?(loc = !default_loc) s = mkloc (Longident.parse s) loc +let constr ?loc ?attrs s args = Exp.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Exp.tuple args) +let nil ?loc ?attrs () = constr ?loc ?attrs "[]" [] +let unit ?loc ?attrs () = constr ?loc ?attrs "()" [] +let tuple ?loc ?attrs = function + | [] -> unit ?loc ?attrs () + | [x] -> x + | xs -> Exp.tuple ?loc ?attrs xs +let cons ?loc ?attrs hd tl = constr ?loc ?attrs "::" [hd; tl] +let list ?loc ?attrs l = List.fold_right (cons ?loc ?attrs) l (nil ?loc ?attrs ()) +let str ?loc ?attrs s = Exp.constant ?loc ?attrs (Pconst_string (s, None)) +let int ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (string_of_int x, None)) +let int32 ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (Int32.to_string x, Some 'l')) +let int64 ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (Int64.to_string x, Some 'L')) +let char ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_char x) +let float ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_float (string_of_float x, None)) +let record ?loc ?attrs ?over l = + Exp.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.pexp_loc s, e)) l) over +let func ?loc ?attrs l = Exp.function_ ?loc ?attrs (List.map (fun (p, e) -> Exp.case p e) l) +let lam ?loc ?attrs ?(label = Label.nolabel) ?default pat exp = Exp.fun_ ?loc ?attrs label default pat exp +let app ?loc ?attrs f l = if l = [] then f else Exp.apply ?loc ?attrs f (List.map (fun a -> Label.nolabel, a) l) +let evar ?loc ?attrs s = Exp.ident ?loc ?attrs (lid ?loc s) +let let_in ?loc ?attrs ?(recursive = false) b body = + Exp.let_ ?loc ?attrs (if recursive then Recursive else Nonrecursive) b body + +let sequence ?loc ?attrs = function + | [] -> unit ?loc ?attrs () + | hd :: tl -> List.fold_left (fun e1 e2 -> Exp.sequence ?loc ?attrs e1 e2) hd tl + +let pvar ?(loc = !default_loc) ?attrs s = Pat.var ~loc ?attrs (mkloc s loc) +let pconstr ?loc ?attrs s args = Pat.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Pat.tuple args) +let precord ?loc ?attrs ?(closed = Open) l = + Pat.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.ppat_loc s, e)) l) closed +let pnil ?loc ?attrs () = pconstr ?loc ?attrs "[]" [] +let pcons ?loc ?attrs hd tl = pconstr ?loc ?attrs "::" [hd; tl] +let punit ?loc ?attrs () = pconstr ?loc ?attrs "()" [] +let ptuple ?loc ?attrs = function + | [] -> punit ?loc ?attrs () + | [x] -> x + | xs -> Pat.tuple ?loc ?attrs xs +let plist ?loc ?attrs l = List.fold_right (pcons ?loc ?attrs) l (pnil ?loc ?attrs ()) + +let pstr ?loc ?attrs s = Pat.constant ?loc ?attrs (Pconst_string (s, None)) +let pint ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_integer (string_of_int x, None)) +let pchar ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_char x) +let pfloat ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_float (string_of_float x, None)) + +let tconstr ?loc ?attrs c l = Typ.constr ?loc ?attrs (lid ?loc c) l + +let get_str = function + | {pexp_desc=Pexp_constant (Pconst_string (s, _)); _} -> Some s + | _ -> None + +let get_str_with_quotation_delimiter = function + | {pexp_desc=Pexp_constant (Pconst_string (s, d)); _} -> Some (s, d) + | _ -> None + +let get_lid = function + | {pexp_desc=Pexp_ident{txt=id;_};_} -> + Some (String.concat "." (Longident.flatten id)) + | _ -> None + +let find_attr s attrs = + try Some ((List.find (fun {attr_name=x;_} -> x.txt = s) attrs).attr_payload) + with Not_found -> None + +let expr_of_payload = function + | PStr [{pstr_desc=Pstr_eval(e, _); _}] -> Some e + | _ -> None + +let find_attr_expr s attrs = + match find_attr s attrs with + | Some e -> expr_of_payload e + | None -> None + +let has_attr s attrs = + find_attr s attrs <> None diff --git a/ast_convenience_410.mli b/ast_convenience_410.mli new file mode 100644 index 0000000..b2e6137 --- /dev/null +++ b/ast_convenience_410.mli @@ -0,0 +1,112 @@ +open Migrate_parsetree.Ast_410 + +(* This file is part of the ppx_tools package. It is released *) +(* under the terms of the MIT license (see LICENSE file). *) +(* Copyright 2013 Alain Frisch and LexiFi *) + +(** {1 Convenience functions to help build and deconstruct AST fragments.} *) + +open Asttypes +open Ast_helper +open Parsetree + +(** {2 Compatibility modules} *) + +module Label : sig + type t = Asttypes.arg_label + + type desc = Asttypes.arg_label = + Nolabel + | Labelled of string + | Optional of string + + val explode : t -> desc + + val nolabel : t + val labelled : string -> t + val optional : string -> t + +end + +(** {2 Provides a unified abstraction over differences in Parsetree.constant and Asttypes.constant + * types defined in ocaml 4.03 and 4.02 respectively}*) +module Constant : sig + type t = Parsetree.constant = + Pconst_integer of string * char option + | Pconst_char of char + | Pconst_string of string * string option + | Pconst_float of string * char option + + (** Convert Asttypes.constant to Constant.t *) + val of_constant : Parsetree.constant -> t + + (** Convert Constant.t to Asttypes.constant *) + val to_constant : t -> Parsetree.constant + +end + +(** {2 Misc} *) + +val lid: ?loc:loc -> string -> lid + +(** {2 Expressions} *) + +val evar: ?loc:loc -> ?attrs:attrs -> string -> expression +val let_in: ?loc:loc -> ?attrs:attrs -> ?recursive:bool -> value_binding list -> expression -> expression + +val constr: ?loc:loc -> ?attrs:attrs -> string -> expression list -> expression +val record: ?loc:loc -> ?attrs:attrs -> ?over:expression -> (string * expression) list -> expression +val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression + +val nil: ?loc:loc -> ?attrs:attrs -> unit -> expression +val cons: ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression +val list: ?loc:loc -> ?attrs:attrs -> expression list -> expression + +val unit: ?loc:loc -> ?attrs:attrs -> unit -> expression + +val func: ?loc:loc -> ?attrs:attrs -> (pattern * expression) list -> expression +val lam: ?loc:loc -> ?attrs:attrs -> ?label:Label.t -> ?default:expression -> pattern -> expression -> expression +val app: ?loc:loc -> ?attrs:attrs -> expression -> expression list -> expression + +val str: ?loc:loc -> ?attrs:attrs -> string -> expression +val int: ?loc:loc -> ?attrs:attrs -> int -> expression +val int32: ?loc:loc -> ?attrs:attrs -> int32 -> expression +val int64: ?loc:loc -> ?attrs:attrs -> int64 -> expression +val char: ?loc:loc -> ?attrs:attrs -> char -> expression +val float: ?loc:loc -> ?attrs:attrs -> float -> expression + +val sequence: ?loc:loc -> ?attrs:attrs -> expression list -> expression +(** Return [()] if the list is empty. Tail rec. *) + +(** {2 Patterns} *) + +val pvar: ?loc:loc -> ?attrs:attrs -> string -> pattern +val pconstr: ?loc:loc -> ?attrs:attrs -> string -> pattern list -> pattern +val precord: ?loc:loc -> ?attrs:attrs -> ?closed:closed_flag -> (string * pattern) list -> pattern +val ptuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern + +val pnil: ?loc:loc -> ?attrs:attrs -> unit -> pattern +val pcons: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern +val plist: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern + +val pstr: ?loc:loc -> ?attrs:attrs -> string -> pattern +val pint: ?loc:loc -> ?attrs:attrs -> int -> pattern +val pchar: ?loc:loc -> ?attrs:attrs -> char -> pattern +val pfloat: ?loc:loc -> ?attrs:attrs -> float -> pattern + +val punit: ?loc:loc -> ?attrs:attrs -> unit -> pattern + + +(** {2 Types} *) + +val tconstr: ?loc:loc -> ?attrs:attrs -> string -> core_type list -> core_type + +(** {2 AST deconstruction} *) + +val get_str: expression -> string option +val get_str_with_quotation_delimiter: expression -> (string * string option) option +val get_lid: expression -> string option + +val has_attr: string -> attributes -> bool +val find_attr: string -> attributes -> payload option +val find_attr_expr: string -> attributes -> expression option diff --git a/ast_lifter_410.ml b/ast_lifter_410.ml new file mode 100644 index 0000000..1d80ef8 --- /dev/null +++ b/ast_lifter_410.ml @@ -0,0 +1,1598 @@ +open Migrate_parsetree.Ast_410 + +class virtual ['res] lifter = + object (this) + method lift_Parsetree_expression : Parsetree.expression -> 'res= + (fun + { Parsetree.pexp_desc = pexp_desc; + Parsetree.pexp_loc = pexp_loc; + Parsetree.pexp_loc_stack = pexp_loc_stack; + Parsetree.pexp_attributes = pexp_attributes } + -> + this#record "Ast_410.Parsetree.expression" + [("pexp_desc", (this#lift_Parsetree_expression_desc pexp_desc)); + ("pexp_loc", (this#lift_Location_t pexp_loc)); + ("pexp_loc_stack", (this#lift_loc_stack pexp_loc_stack)); + ("pexp_attributes", + (this#lift_Parsetree_attributes pexp_attributes))] : Parsetree.expression + -> + 'res) + method lift_Parsetree_expression_desc : + Parsetree.expression_desc -> 'res= + (function + | Parsetree.Pexp_ident x0 -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_ident", [this#lift_loc this#lift_Longident_t x0]) + | Parsetree.Pexp_constant x0 -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_constant", [this#lift_Parsetree_constant x0]) + | Parsetree.Pexp_let (x0, x1, x2) -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_let", + [this#lift_rec_flag x0; + this#list (List.map this#lift_Parsetree_value_binding x1); + this#lift_Parsetree_expression x2]) + | Parsetree.Pexp_function x0 -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_function", [this#lift_Parsetree_cases x0]) + | Parsetree.Pexp_fun (x0, x1, x2, x3) -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_fun", + [this#lift_arg_label x0; + this#lift_option this#lift_Parsetree_expression x1; + this#lift_Parsetree_pattern x2; + this#lift_Parsetree_expression x3]) + | Parsetree.Pexp_apply (x0, x1) -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_apply", + [this#lift_Parsetree_expression x0; + this#list + (List.map + (fun x -> + let (x0, x1) = x in + this#tuple + [this#lift_arg_label x0; + this#lift_Parsetree_expression x1]) x1)]) + | Parsetree.Pexp_match (x0, x1) -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_match", + [this#lift_Parsetree_expression x0; + this#lift_Parsetree_cases x1]) + | Parsetree.Pexp_try (x0, x1) -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_try", + [this#lift_Parsetree_expression x0; + this#lift_Parsetree_cases x1]) + | Parsetree.Pexp_tuple x0 -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_tuple", + [this#list (List.map this#lift_Parsetree_expression x0)]) + | Parsetree.Pexp_construct (x0, x1) -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_construct", + [this#lift_loc this#lift_Longident_t x0; + this#lift_option this#lift_Parsetree_expression x1]) + | Parsetree.Pexp_variant (x0, x1) -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_variant", + [this#lift_label x0; + this#lift_option this#lift_Parsetree_expression x1]) + | Parsetree.Pexp_record (x0, x1) -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_record", + [this#list + (List.map + (fun x -> + let (x0, x1) = x in + this#tuple + [this#lift_loc this#lift_Longident_t x0; + this#lift_Parsetree_expression x1]) x0); + this#lift_option this#lift_Parsetree_expression x1]) + | Parsetree.Pexp_field (x0, x1) -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_field", + [this#lift_Parsetree_expression x0; + this#lift_loc this#lift_Longident_t x1]) + | Parsetree.Pexp_setfield (x0, x1, x2) -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_setfield", + [this#lift_Parsetree_expression x0; + this#lift_loc this#lift_Longident_t x1; + this#lift_Parsetree_expression x2]) + | Parsetree.Pexp_array x0 -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_array", + [this#list (List.map this#lift_Parsetree_expression x0)]) + | Parsetree.Pexp_ifthenelse (x0, x1, x2) -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_ifthenelse", + [this#lift_Parsetree_expression x0; + this#lift_Parsetree_expression x1; + this#lift_option this#lift_Parsetree_expression x2]) + | Parsetree.Pexp_sequence (x0, x1) -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_sequence", + [this#lift_Parsetree_expression x0; + this#lift_Parsetree_expression x1]) + | Parsetree.Pexp_while (x0, x1) -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_while", + [this#lift_Parsetree_expression x0; + this#lift_Parsetree_expression x1]) + | Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_for", + [this#lift_Parsetree_pattern x0; + this#lift_Parsetree_expression x1; + this#lift_Parsetree_expression x2; + this#lift_direction_flag x3; + this#lift_Parsetree_expression x4]) + | Parsetree.Pexp_constraint (x0, x1) -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_constraint", + [this#lift_Parsetree_expression x0; + this#lift_Parsetree_core_type x1]) + | Parsetree.Pexp_coerce (x0, x1, x2) -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_coerce", + [this#lift_Parsetree_expression x0; + this#lift_option this#lift_Parsetree_core_type x1; + this#lift_Parsetree_core_type x2]) + | Parsetree.Pexp_send (x0, x1) -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_send", + [this#lift_Parsetree_expression x0; + this#lift_loc this#lift_label x1]) + | Parsetree.Pexp_new x0 -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_new", [this#lift_loc this#lift_Longident_t x0]) + | Parsetree.Pexp_setinstvar (x0, x1) -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_setinstvar", + [this#lift_loc this#lift_label x0; + this#lift_Parsetree_expression x1]) + | Parsetree.Pexp_override x0 -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_override", + [this#list + (List.map + (fun x -> + let (x0, x1) = x in + this#tuple + [this#lift_loc this#lift_label x0; + this#lift_Parsetree_expression x1]) x0)]) + | Parsetree.Pexp_letmodule (x0, x1, x2) -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_letmodule", + [this#lift_loc (this#lift_option this#string) x0; + this#lift_Parsetree_module_expr x1; + this#lift_Parsetree_expression x2]) + | Parsetree.Pexp_letexception (x0, x1) -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_letexception", + [this#lift_Parsetree_extension_constructor x0; + this#lift_Parsetree_expression x1]) + | Parsetree.Pexp_assert x0 -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_assert", [this#lift_Parsetree_expression x0]) + | Parsetree.Pexp_lazy x0 -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_lazy", [this#lift_Parsetree_expression x0]) + | Parsetree.Pexp_poly (x0, x1) -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_poly", + [this#lift_Parsetree_expression x0; + this#lift_option this#lift_Parsetree_core_type x1]) + | Parsetree.Pexp_object x0 -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_object", [this#lift_Parsetree_class_structure x0]) + | Parsetree.Pexp_newtype (x0, x1) -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_newtype", + [this#lift_loc this#string x0; + this#lift_Parsetree_expression x1]) + | Parsetree.Pexp_pack x0 -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_pack", [this#lift_Parsetree_module_expr x0]) + | Parsetree.Pexp_open (x0, x1) -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_open", + [this#lift_Parsetree_open_declaration x0; + this#lift_Parsetree_expression x1]) + | Parsetree.Pexp_letop x0 -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_letop", [this#lift_Parsetree_letop x0]) + | Parsetree.Pexp_extension x0 -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_extension", [this#lift_Parsetree_extension x0]) + | Parsetree.Pexp_unreachable -> + this#constr "Ast_410.Parsetree.expression_desc" + ("Pexp_unreachable", []) : Parsetree.expression_desc -> + 'res) + method lift_Parsetree_letop : Parsetree.letop -> 'res= + (fun + { Parsetree.let_ = let_; Parsetree.ands = ands; + Parsetree.body = body } + -> + this#record "Ast_410.Parsetree.letop" + [("let_", (this#lift_Parsetree_binding_op let_)); + ("ands", + (this#list (List.map this#lift_Parsetree_binding_op ands))); + ("body", (this#lift_Parsetree_expression body))] : Parsetree.letop + -> 'res) + method lift_Parsetree_binding_op : Parsetree.binding_op -> 'res= + (fun + { Parsetree.pbop_op = pbop_op; + Parsetree.pbop_pat = pbop_pat; + Parsetree.pbop_exp = pbop_exp; + Parsetree.pbop_loc = pbop_loc } + -> + this#record "Ast_410.Parsetree.binding_op" + [("pbop_op", (this#lift_loc this#string pbop_op)); + ("pbop_pat", (this#lift_Parsetree_pattern pbop_pat)); + ("pbop_exp", (this#lift_Parsetree_expression pbop_exp)); + ("pbop_loc", (this#lift_Location_t pbop_loc))] : Parsetree.binding_op + -> 'res) + method lift_direction_flag : + Migrate_parsetree__Ast_410.Asttypes.direction_flag -> 'res= + (function + | Migrate_parsetree__Ast_410.Asttypes.Upto -> + this#constr "Migrate_parsetree__Ast_410.Asttypes.direction_flag" + ("Upto", []) + | Migrate_parsetree__Ast_410.Asttypes.Downto -> + this#constr "Migrate_parsetree__Ast_410.Asttypes.direction_flag" + ("Downto", []) : Migrate_parsetree__Ast_410.Asttypes.direction_flag + -> 'res) + method lift_Parsetree_cases : Parsetree.case list -> 'res= + (fun x -> this#list (List.map this#lift_Parsetree_case x) : Parsetree.case list + -> + 'res) + method lift_Parsetree_case : Parsetree.case -> 'res= + (fun + { Parsetree.pc_lhs = pc_lhs; + Parsetree.pc_guard = pc_guard; + Parsetree.pc_rhs = pc_rhs } + -> + this#record "Ast_410.Parsetree.case" + [("pc_lhs", (this#lift_Parsetree_pattern pc_lhs)); + ("pc_guard", + (this#lift_option this#lift_Parsetree_expression pc_guard)); + ("pc_rhs", (this#lift_Parsetree_expression pc_rhs))] : Parsetree.case + -> + 'res) + method lift_Parsetree_value_binding : + Parsetree.value_binding -> 'res= + (fun + { Parsetree.pvb_pat = pvb_pat; + Parsetree.pvb_expr = pvb_expr; + Parsetree.pvb_attributes = pvb_attributes; + Parsetree.pvb_loc = pvb_loc } + -> + this#record "Ast_410.Parsetree.value_binding" + [("pvb_pat", (this#lift_Parsetree_pattern pvb_pat)); + ("pvb_expr", (this#lift_Parsetree_expression pvb_expr)); + ("pvb_attributes", + (this#lift_Parsetree_attributes pvb_attributes)); + ("pvb_loc", (this#lift_Location_t pvb_loc))] : Parsetree.value_binding + -> 'res) + method lift_Parsetree_pattern : Parsetree.pattern -> 'res= + (fun + { Parsetree.ppat_desc = ppat_desc; + Parsetree.ppat_loc = ppat_loc; + Parsetree.ppat_loc_stack = ppat_loc_stack; + Parsetree.ppat_attributes = ppat_attributes } + -> + this#record "Ast_410.Parsetree.pattern" + [("ppat_desc", (this#lift_Parsetree_pattern_desc ppat_desc)); + ("ppat_loc", (this#lift_Location_t ppat_loc)); + ("ppat_loc_stack", (this#lift_loc_stack ppat_loc_stack)); + ("ppat_attributes", + (this#lift_Parsetree_attributes ppat_attributes))] : Parsetree.pattern + -> + 'res) + method lift_Parsetree_pattern_desc : + Parsetree.pattern_desc -> 'res= + (function + | Parsetree.Ppat_any -> + this#constr "Ast_410.Parsetree.pattern_desc" ("Ppat_any", []) + | Parsetree.Ppat_var x0 -> + this#constr "Ast_410.Parsetree.pattern_desc" + ("Ppat_var", [this#lift_loc this#string x0]) + | Parsetree.Ppat_alias (x0, x1) -> + this#constr "Ast_410.Parsetree.pattern_desc" + ("Ppat_alias", + [this#lift_Parsetree_pattern x0; this#lift_loc this#string x1]) + | Parsetree.Ppat_constant x0 -> + this#constr "Ast_410.Parsetree.pattern_desc" + ("Ppat_constant", [this#lift_Parsetree_constant x0]) + | Parsetree.Ppat_interval (x0, x1) -> + this#constr "Ast_410.Parsetree.pattern_desc" + ("Ppat_interval", + [this#lift_Parsetree_constant x0; + this#lift_Parsetree_constant x1]) + | Parsetree.Ppat_tuple x0 -> + this#constr "Ast_410.Parsetree.pattern_desc" + ("Ppat_tuple", + [this#list (List.map this#lift_Parsetree_pattern x0)]) + | Parsetree.Ppat_construct (x0, x1) -> + this#constr "Ast_410.Parsetree.pattern_desc" + ("Ppat_construct", + [this#lift_loc this#lift_Longident_t x0; + this#lift_option this#lift_Parsetree_pattern x1]) + | Parsetree.Ppat_variant (x0, x1) -> + this#constr "Ast_410.Parsetree.pattern_desc" + ("Ppat_variant", + [this#lift_label x0; + this#lift_option this#lift_Parsetree_pattern x1]) + | Parsetree.Ppat_record (x0, x1) -> + this#constr "Ast_410.Parsetree.pattern_desc" + ("Ppat_record", + [this#list + (List.map + (fun x -> + let (x0, x1) = x in + this#tuple + [this#lift_loc this#lift_Longident_t x0; + this#lift_Parsetree_pattern x1]) x0); + this#lift_closed_flag x1]) + | Parsetree.Ppat_array x0 -> + this#constr "Ast_410.Parsetree.pattern_desc" + ("Ppat_array", + [this#list (List.map this#lift_Parsetree_pattern x0)]) + | Parsetree.Ppat_or (x0, x1) -> + this#constr "Ast_410.Parsetree.pattern_desc" + ("Ppat_or", + [this#lift_Parsetree_pattern x0; + this#lift_Parsetree_pattern x1]) + | Parsetree.Ppat_constraint (x0, x1) -> + this#constr "Ast_410.Parsetree.pattern_desc" + ("Ppat_constraint", + [this#lift_Parsetree_pattern x0; + this#lift_Parsetree_core_type x1]) + | Parsetree.Ppat_type x0 -> + this#constr "Ast_410.Parsetree.pattern_desc" + ("Ppat_type", [this#lift_loc this#lift_Longident_t x0]) + | Parsetree.Ppat_lazy x0 -> + this#constr "Ast_410.Parsetree.pattern_desc" + ("Ppat_lazy", [this#lift_Parsetree_pattern x0]) + | Parsetree.Ppat_unpack x0 -> + this#constr "Ast_410.Parsetree.pattern_desc" + ("Ppat_unpack", [this#lift_loc (this#lift_option this#string) x0]) + | Parsetree.Ppat_exception x0 -> + this#constr "Ast_410.Parsetree.pattern_desc" + ("Ppat_exception", [this#lift_Parsetree_pattern x0]) + | Parsetree.Ppat_extension x0 -> + this#constr "Ast_410.Parsetree.pattern_desc" + ("Ppat_extension", [this#lift_Parsetree_extension x0]) + | Parsetree.Ppat_open (x0, x1) -> + this#constr "Ast_410.Parsetree.pattern_desc" + ("Ppat_open", + [this#lift_loc this#lift_Longident_t x0; + this#lift_Parsetree_pattern x1]) : Parsetree.pattern_desc + -> 'res) + method lift_Parsetree_core_type : Parsetree.core_type -> 'res= + (fun + { Parsetree.ptyp_desc = ptyp_desc; + Parsetree.ptyp_loc = ptyp_loc; + Parsetree.ptyp_loc_stack = ptyp_loc_stack; + Parsetree.ptyp_attributes = ptyp_attributes } + -> + this#record "Ast_410.Parsetree.core_type" + [("ptyp_desc", (this#lift_Parsetree_core_type_desc ptyp_desc)); + ("ptyp_loc", (this#lift_Location_t ptyp_loc)); + ("ptyp_loc_stack", (this#lift_loc_stack ptyp_loc_stack)); + ("ptyp_attributes", + (this#lift_Parsetree_attributes ptyp_attributes))] : Parsetree.core_type + -> + 'res) + method lift_Parsetree_core_type_desc : + Parsetree.core_type_desc -> 'res= + (function + | Parsetree.Ptyp_any -> + this#constr "Ast_410.Parsetree.core_type_desc" ("Ptyp_any", []) + | Parsetree.Ptyp_var x0 -> + this#constr "Ast_410.Parsetree.core_type_desc" + ("Ptyp_var", [this#string x0]) + | Parsetree.Ptyp_arrow (x0, x1, x2) -> + this#constr "Ast_410.Parsetree.core_type_desc" + ("Ptyp_arrow", + [this#lift_arg_label x0; + this#lift_Parsetree_core_type x1; + this#lift_Parsetree_core_type x2]) + | Parsetree.Ptyp_tuple x0 -> + this#constr "Ast_410.Parsetree.core_type_desc" + ("Ptyp_tuple", + [this#list (List.map this#lift_Parsetree_core_type x0)]) + | Parsetree.Ptyp_constr (x0, x1) -> + this#constr "Ast_410.Parsetree.core_type_desc" + ("Ptyp_constr", + [this#lift_loc this#lift_Longident_t x0; + this#list (List.map this#lift_Parsetree_core_type x1)]) + | Parsetree.Ptyp_object (x0, x1) -> + this#constr "Ast_410.Parsetree.core_type_desc" + ("Ptyp_object", + [this#list (List.map this#lift_Parsetree_object_field x0); + this#lift_closed_flag x1]) + | Parsetree.Ptyp_class (x0, x1) -> + this#constr "Ast_410.Parsetree.core_type_desc" + ("Ptyp_class", + [this#lift_loc this#lift_Longident_t x0; + this#list (List.map this#lift_Parsetree_core_type x1)]) + | Parsetree.Ptyp_alias (x0, x1) -> + this#constr "Ast_410.Parsetree.core_type_desc" + ("Ptyp_alias", + [this#lift_Parsetree_core_type x0; this#string x1]) + | Parsetree.Ptyp_variant (x0, x1, x2) -> + this#constr "Ast_410.Parsetree.core_type_desc" + ("Ptyp_variant", + [this#list (List.map this#lift_Parsetree_row_field x0); + this#lift_closed_flag x1; + this#lift_option + (fun x -> this#list (List.map this#lift_label x)) x2]) + | Parsetree.Ptyp_poly (x0, x1) -> + this#constr "Ast_410.Parsetree.core_type_desc" + ("Ptyp_poly", + [this#list + (List.map (fun x -> this#lift_loc this#string x) x0); + this#lift_Parsetree_core_type x1]) + | Parsetree.Ptyp_package x0 -> + this#constr "Ast_410.Parsetree.core_type_desc" + ("Ptyp_package", [this#lift_Parsetree_package_type x0]) + | Parsetree.Ptyp_extension x0 -> + this#constr "Ast_410.Parsetree.core_type_desc" + ("Ptyp_extension", [this#lift_Parsetree_extension x0]) : + Parsetree.core_type_desc -> 'res) + method lift_Parsetree_package_type : + Parsetree.package_type -> 'res= + (fun x -> + let (x0, x1) = x in + this#tuple + [this#lift_loc this#lift_Longident_t x0; + this#list + (List.map + (fun x -> + let (x0, x1) = x in + this#tuple + [this#lift_loc this#lift_Longident_t x0; + this#lift_Parsetree_core_type x1]) x1)] : Parsetree.package_type + -> 'res) + method lift_Parsetree_row_field : Parsetree.row_field -> 'res= + (fun + { Parsetree.prf_desc = prf_desc; + Parsetree.prf_loc = prf_loc; + Parsetree.prf_attributes = prf_attributes } + -> + this#record "Ast_410.Parsetree.row_field" + [("prf_desc", (this#lift_Parsetree_row_field_desc prf_desc)); + ("prf_loc", (this#lift_Location_t prf_loc)); + ("prf_attributes", + (this#lift_Parsetree_attributes prf_attributes))] : Parsetree.row_field + -> + 'res) + method lift_Parsetree_row_field_desc : + Parsetree.row_field_desc -> 'res= + (function + | Parsetree.Rtag (x0, x1, x2) -> + this#constr "Ast_410.Parsetree.row_field_desc" + ("Rtag", + [this#lift_loc this#lift_label x0; + this#lift_bool x1; + this#list (List.map this#lift_Parsetree_core_type x2)]) + | Parsetree.Rinherit x0 -> + this#constr "Ast_410.Parsetree.row_field_desc" + ("Rinherit", [this#lift_Parsetree_core_type x0]) : Parsetree.row_field_desc + -> + 'res) + method lift_Parsetree_object_field : + Parsetree.object_field -> 'res= + (fun + { Parsetree.pof_desc = pof_desc; + Parsetree.pof_loc = pof_loc; + Parsetree.pof_attributes = pof_attributes } + -> + this#record "Ast_410.Parsetree.object_field" + [("pof_desc", (this#lift_Parsetree_object_field_desc pof_desc)); + ("pof_loc", (this#lift_Location_t pof_loc)); + ("pof_attributes", + (this#lift_Parsetree_attributes pof_attributes))] : Parsetree.object_field + -> + 'res) + method lift_Parsetree_attributes : Parsetree.attributes -> 'res= + (fun x -> this#list (List.map this#lift_Parsetree_attribute x) : + Parsetree.attributes -> 'res) + method lift_Parsetree_attribute : Parsetree.attribute -> 'res= + (fun + { Parsetree.attr_name = attr_name; + Parsetree.attr_payload = attr_payload; + Parsetree.attr_loc = attr_loc } + -> + this#record "Ast_410.Parsetree.attribute" + [("attr_name", (this#lift_loc this#string attr_name)); + ("attr_payload", (this#lift_Parsetree_payload attr_payload)); + ("attr_loc", (this#lift_Location_t attr_loc))] : Parsetree.attribute + -> 'res) + method lift_Parsetree_payload : Parsetree.payload -> 'res= + (function + | Parsetree.PStr x0 -> + this#constr "Ast_410.Parsetree.payload" + ("PStr", [this#lift_Parsetree_structure x0]) + | Parsetree.PSig x0 -> + this#constr "Ast_410.Parsetree.payload" + ("PSig", [this#lift_Parsetree_signature x0]) + | Parsetree.PTyp x0 -> + this#constr "Ast_410.Parsetree.payload" + ("PTyp", [this#lift_Parsetree_core_type x0]) + | Parsetree.PPat (x0, x1) -> + this#constr "Ast_410.Parsetree.payload" + ("PPat", + [this#lift_Parsetree_pattern x0; + this#lift_option this#lift_Parsetree_expression x1]) : + Parsetree.payload -> 'res) + method lift_Parsetree_structure : Parsetree.structure -> 'res= + (fun x -> this#list (List.map this#lift_Parsetree_structure_item x) : + Parsetree.structure -> 'res) + method lift_Parsetree_structure_item : + Parsetree.structure_item -> 'res= + (fun + { Parsetree.pstr_desc = pstr_desc; + Parsetree.pstr_loc = pstr_loc } + -> + this#record "Ast_410.Parsetree.structure_item" + [("pstr_desc", + (this#lift_Parsetree_structure_item_desc pstr_desc)); + ("pstr_loc", (this#lift_Location_t pstr_loc))] : Parsetree.structure_item + -> 'res) + method lift_Parsetree_structure_item_desc : + Parsetree.structure_item_desc -> 'res= + (function + | Parsetree.Pstr_eval (x0, x1) -> + this#constr "Ast_410.Parsetree.structure_item_desc" + ("Pstr_eval", + [this#lift_Parsetree_expression x0; + this#lift_Parsetree_attributes x1]) + | Parsetree.Pstr_value (x0, x1) -> + this#constr "Ast_410.Parsetree.structure_item_desc" + ("Pstr_value", + [this#lift_rec_flag x0; + this#list (List.map this#lift_Parsetree_value_binding x1)]) + | Parsetree.Pstr_primitive x0 -> + this#constr "Ast_410.Parsetree.structure_item_desc" + ("Pstr_primitive", [this#lift_Parsetree_value_description x0]) + | Parsetree.Pstr_type (x0, x1) -> + this#constr "Ast_410.Parsetree.structure_item_desc" + ("Pstr_type", + [this#lift_rec_flag x0; + this#list (List.map this#lift_Parsetree_type_declaration x1)]) + | Parsetree.Pstr_typext x0 -> + this#constr "Ast_410.Parsetree.structure_item_desc" + ("Pstr_typext", [this#lift_Parsetree_type_extension x0]) + | Parsetree.Pstr_exception x0 -> + this#constr "Ast_410.Parsetree.structure_item_desc" + ("Pstr_exception", [this#lift_Parsetree_type_exception x0]) + | Parsetree.Pstr_module x0 -> + this#constr "Ast_410.Parsetree.structure_item_desc" + ("Pstr_module", [this#lift_Parsetree_module_binding x0]) + | Parsetree.Pstr_recmodule x0 -> + this#constr "Ast_410.Parsetree.structure_item_desc" + ("Pstr_recmodule", + [this#list (List.map this#lift_Parsetree_module_binding x0)]) + | Parsetree.Pstr_modtype x0 -> + this#constr "Ast_410.Parsetree.structure_item_desc" + ("Pstr_modtype", + [this#lift_Parsetree_module_type_declaration x0]) + | Parsetree.Pstr_open x0 -> + this#constr "Ast_410.Parsetree.structure_item_desc" + ("Pstr_open", [this#lift_Parsetree_open_declaration x0]) + | Parsetree.Pstr_class x0 -> + this#constr "Ast_410.Parsetree.structure_item_desc" + ("Pstr_class", + [this#list (List.map this#lift_Parsetree_class_declaration x0)]) + | Parsetree.Pstr_class_type x0 -> + this#constr "Ast_410.Parsetree.structure_item_desc" + ("Pstr_class_type", + [this#list + (List.map this#lift_Parsetree_class_type_declaration x0)]) + | Parsetree.Pstr_include x0 -> + this#constr "Ast_410.Parsetree.structure_item_desc" + ("Pstr_include", [this#lift_Parsetree_include_declaration x0]) + | Parsetree.Pstr_attribute x0 -> + this#constr "Ast_410.Parsetree.structure_item_desc" + ("Pstr_attribute", [this#lift_Parsetree_attribute x0]) + | Parsetree.Pstr_extension (x0, x1) -> + this#constr "Ast_410.Parsetree.structure_item_desc" + ("Pstr_extension", + [this#lift_Parsetree_extension x0; + this#lift_Parsetree_attributes x1]) : Parsetree.structure_item_desc + -> 'res) + method lift_Parsetree_include_declaration : + Parsetree.include_declaration -> 'res= + (fun x -> + this#lift_Parsetree_include_infos this#lift_Parsetree_module_expr x : + Parsetree.include_declaration -> 'res) + method lift_Parsetree_class_declaration : + Parsetree.class_declaration -> 'res= + (fun x -> + this#lift_Parsetree_class_infos this#lift_Parsetree_class_expr x : + Parsetree.class_declaration -> 'res) + method lift_Parsetree_class_expr : Parsetree.class_expr -> 'res= + (fun + { Parsetree.pcl_desc = pcl_desc; + Parsetree.pcl_loc = pcl_loc; + Parsetree.pcl_attributes = pcl_attributes } + -> + this#record "Ast_410.Parsetree.class_expr" + [("pcl_desc", (this#lift_Parsetree_class_expr_desc pcl_desc)); + ("pcl_loc", (this#lift_Location_t pcl_loc)); + ("pcl_attributes", + (this#lift_Parsetree_attributes pcl_attributes))] : Parsetree.class_expr + -> + 'res) + method lift_Parsetree_class_expr_desc : + Parsetree.class_expr_desc -> 'res= + (function + | Parsetree.Pcl_constr (x0, x1) -> + this#constr "Ast_410.Parsetree.class_expr_desc" + ("Pcl_constr", + [this#lift_loc this#lift_Longident_t x0; + this#list (List.map this#lift_Parsetree_core_type x1)]) + | Parsetree.Pcl_structure x0 -> + this#constr "Ast_410.Parsetree.class_expr_desc" + ("Pcl_structure", [this#lift_Parsetree_class_structure x0]) + | Parsetree.Pcl_fun (x0, x1, x2, x3) -> + this#constr "Ast_410.Parsetree.class_expr_desc" + ("Pcl_fun", + [this#lift_arg_label x0; + this#lift_option this#lift_Parsetree_expression x1; + this#lift_Parsetree_pattern x2; + this#lift_Parsetree_class_expr x3]) + | Parsetree.Pcl_apply (x0, x1) -> + this#constr "Ast_410.Parsetree.class_expr_desc" + ("Pcl_apply", + [this#lift_Parsetree_class_expr x0; + this#list + (List.map + (fun x -> + let (x0, x1) = x in + this#tuple + [this#lift_arg_label x0; + this#lift_Parsetree_expression x1]) x1)]) + | Parsetree.Pcl_let (x0, x1, x2) -> + this#constr "Ast_410.Parsetree.class_expr_desc" + ("Pcl_let", + [this#lift_rec_flag x0; + this#list (List.map this#lift_Parsetree_value_binding x1); + this#lift_Parsetree_class_expr x2]) + | Parsetree.Pcl_constraint (x0, x1) -> + this#constr "Ast_410.Parsetree.class_expr_desc" + ("Pcl_constraint", + [this#lift_Parsetree_class_expr x0; + this#lift_Parsetree_class_type x1]) + | Parsetree.Pcl_extension x0 -> + this#constr "Ast_410.Parsetree.class_expr_desc" + ("Pcl_extension", [this#lift_Parsetree_extension x0]) + | Parsetree.Pcl_open (x0, x1) -> + this#constr "Ast_410.Parsetree.class_expr_desc" + ("Pcl_open", + [this#lift_Parsetree_open_description x0; + this#lift_Parsetree_class_expr x1]) : Parsetree.class_expr_desc + -> 'res) + method lift_Parsetree_class_structure : + Parsetree.class_structure -> 'res= + (fun + { Parsetree.pcstr_self = pcstr_self; + Parsetree.pcstr_fields = pcstr_fields } + -> + this#record "Ast_410.Parsetree.class_structure" + [("pcstr_self", (this#lift_Parsetree_pattern pcstr_self)); + ("pcstr_fields", + (this#list + (List.map this#lift_Parsetree_class_field pcstr_fields)))] : + Parsetree.class_structure -> 'res) + method lift_Parsetree_class_field : + Parsetree.class_field -> 'res= + (fun + { Parsetree.pcf_desc = pcf_desc; + Parsetree.pcf_loc = pcf_loc; + Parsetree.pcf_attributes = pcf_attributes } + -> + this#record "Ast_410.Parsetree.class_field" + [("pcf_desc", (this#lift_Parsetree_class_field_desc pcf_desc)); + ("pcf_loc", (this#lift_Location_t pcf_loc)); + ("pcf_attributes", + (this#lift_Parsetree_attributes pcf_attributes))] : Parsetree.class_field + -> + 'res) + method lift_Parsetree_class_field_desc : + Parsetree.class_field_desc -> 'res= + (function + | Parsetree.Pcf_inherit (x0, x1, x2) -> + this#constr "Ast_410.Parsetree.class_field_desc" + ("Pcf_inherit", + [this#lift_override_flag x0; + this#lift_Parsetree_class_expr x1; + this#lift_option (fun x -> this#lift_loc this#string x) x2]) + | Parsetree.Pcf_val x0 -> + this#constr "Ast_410.Parsetree.class_field_desc" + ("Pcf_val", + [(let (x0, x1, x2) = x0 in + this#tuple + [this#lift_loc this#lift_label x0; + this#lift_mutable_flag x1; + this#lift_Parsetree_class_field_kind x2])]) + | Parsetree.Pcf_method x0 -> + this#constr "Ast_410.Parsetree.class_field_desc" + ("Pcf_method", + [(let (x0, x1, x2) = x0 in + this#tuple + [this#lift_loc this#lift_label x0; + this#lift_private_flag x1; + this#lift_Parsetree_class_field_kind x2])]) + | Parsetree.Pcf_constraint x0 -> + this#constr "Ast_410.Parsetree.class_field_desc" + ("Pcf_constraint", + [(let (x0, x1) = x0 in + this#tuple + [this#lift_Parsetree_core_type x0; + this#lift_Parsetree_core_type x1])]) + | Parsetree.Pcf_initializer x0 -> + this#constr "Ast_410.Parsetree.class_field_desc" + ("Pcf_initializer", [this#lift_Parsetree_expression x0]) + | Parsetree.Pcf_attribute x0 -> + this#constr "Ast_410.Parsetree.class_field_desc" + ("Pcf_attribute", [this#lift_Parsetree_attribute x0]) + | Parsetree.Pcf_extension x0 -> + this#constr "Ast_410.Parsetree.class_field_desc" + ("Pcf_extension", [this#lift_Parsetree_extension x0]) : + Parsetree.class_field_desc -> 'res) + method lift_Parsetree_class_field_kind : + Parsetree.class_field_kind -> 'res= + (function + | Parsetree.Cfk_virtual x0 -> + this#constr "Ast_410.Parsetree.class_field_kind" + ("Cfk_virtual", [this#lift_Parsetree_core_type x0]) + | Parsetree.Cfk_concrete (x0, x1) -> + this#constr "Ast_410.Parsetree.class_field_kind" + ("Cfk_concrete", + [this#lift_override_flag x0; + this#lift_Parsetree_expression x1]) : Parsetree.class_field_kind + -> 'res) + method lift_Parsetree_open_declaration : + Parsetree.open_declaration -> 'res= + (fun x -> + this#lift_Parsetree_open_infos this#lift_Parsetree_module_expr x : + Parsetree.open_declaration -> 'res) + method lift_Parsetree_module_binding : + Parsetree.module_binding -> 'res= + (fun + { Parsetree.pmb_name = pmb_name; + Parsetree.pmb_expr = pmb_expr; + Parsetree.pmb_attributes = pmb_attributes; + Parsetree.pmb_loc = pmb_loc } + -> + this#record "Ast_410.Parsetree.module_binding" + [("pmb_name", (this#lift_loc (this#lift_option this#string) pmb_name)); + ("pmb_expr", (this#lift_Parsetree_module_expr pmb_expr)); + ("pmb_attributes", + (this#lift_Parsetree_attributes pmb_attributes)); + ("pmb_loc", (this#lift_Location_t pmb_loc))] : Parsetree.module_binding + -> 'res) + method lift_Parsetree_module_expr : + Parsetree.module_expr -> 'res= + (fun + { Parsetree.pmod_desc = pmod_desc; + Parsetree.pmod_loc = pmod_loc; + Parsetree.pmod_attributes = pmod_attributes } + -> + this#record "Ast_410.Parsetree.module_expr" + [("pmod_desc", (this#lift_Parsetree_module_expr_desc pmod_desc)); + ("pmod_loc", (this#lift_Location_t pmod_loc)); + ("pmod_attributes", + (this#lift_Parsetree_attributes pmod_attributes))] : Parsetree.module_expr + -> + 'res) + method lift_Parsetree_module_expr_desc : + Parsetree.module_expr_desc -> 'res= + (function + | Parsetree.Pmod_ident x0 -> + this#constr "Ast_410.Parsetree.module_expr_desc" + ("Pmod_ident", [this#lift_loc this#lift_Longident_t x0]) + | Parsetree.Pmod_structure x0 -> + this#constr "Ast_410.Parsetree.module_expr_desc" + ("Pmod_structure", [this#lift_Parsetree_structure x0]) + | Parsetree.Pmod_functor (x0, x1) -> + this#constr "Ast_410.Parsetree.module_expr_desc" + ("Pmod_functor", + [this#lift_Parsetree_functor_parameter x0; + this#lift_Parsetree_module_expr x1]) + | Parsetree.Pmod_apply (x0, x1) -> + this#constr "Ast_410.Parsetree.module_expr_desc" + ("Pmod_apply", + [this#lift_Parsetree_module_expr x0; + this#lift_Parsetree_module_expr x1]) + | Parsetree.Pmod_constraint (x0, x1) -> + this#constr "Ast_410.Parsetree.module_expr_desc" + ("Pmod_constraint", + [this#lift_Parsetree_module_expr x0; + this#lift_Parsetree_module_type x1]) + | Parsetree.Pmod_unpack x0 -> + this#constr "Ast_410.Parsetree.module_expr_desc" + ("Pmod_unpack", [this#lift_Parsetree_expression x0]) + | Parsetree.Pmod_extension x0 -> + this#constr "Ast_410.Parsetree.module_expr_desc" + ("Pmod_extension", [this#lift_Parsetree_extension x0]) : + Parsetree.module_expr_desc -> 'res) + method lift_Parsetree_module_type : + Parsetree.module_type -> 'res= + (fun + { Parsetree.pmty_desc = pmty_desc; + Parsetree.pmty_loc = pmty_loc; + Parsetree.pmty_attributes = pmty_attributes } + -> + this#record "Ast_410.Parsetree.module_type" + [("pmty_desc", (this#lift_Parsetree_module_type_desc pmty_desc)); + ("pmty_loc", (this#lift_Location_t pmty_loc)); + ("pmty_attributes", + (this#lift_Parsetree_attributes pmty_attributes))] : Parsetree.module_type + -> + 'res) + method lift_Parsetree_module_type_desc : + Parsetree.module_type_desc -> 'res= + (function + | Parsetree.Pmty_ident x0 -> + this#constr "Ast_410.Parsetree.module_type_desc" + ("Pmty_ident", [this#lift_loc this#lift_Longident_t x0]) + | Parsetree.Pmty_signature x0 -> + this#constr "Ast_410.Parsetree.module_type_desc" + ("Pmty_signature", [this#lift_Parsetree_signature x0]) + | Parsetree.Pmty_functor (x0, x1) -> + this#constr "Ast_410.Parsetree.module_type_desc" + ("Pmty_functor", + [this#lift_Parsetree_functor_parameter x0; + this#lift_Parsetree_module_type x1]) + | Parsetree.Pmty_with (x0, x1) -> + this#constr "Ast_410.Parsetree.module_type_desc" + ("Pmty_with", + [this#lift_Parsetree_module_type x0; + this#list (List.map this#lift_Parsetree_with_constraint x1)]) + | Parsetree.Pmty_typeof x0 -> + this#constr "Ast_410.Parsetree.module_type_desc" + ("Pmty_typeof", [this#lift_Parsetree_module_expr x0]) + | Parsetree.Pmty_extension x0 -> + this#constr "Ast_410.Parsetree.module_type_desc" + ("Pmty_extension", [this#lift_Parsetree_extension x0]) + | Parsetree.Pmty_alias x0 -> + this#constr "Ast_410.Parsetree.module_type_desc" + ("Pmty_alias", [this#lift_loc this#lift_Longident_t x0]) : + Parsetree.module_type_desc -> 'res) + method lift_Parsetree_functor_parameter : + Parsetree.functor_parameter -> 'res= + (function + | Parsetree.Unit -> + this#constr "Ast_410.Parsetree.functor_parameter" ("Unit", []) + | Parsetree.Named (x0, x1) -> + this#constr "Ast_410.Parsetree.functor_parameter" + ("Named", + [this#lift_loc (this#lift_option this#string) x0; + this#lift_Parsetree_module_type x1])) + method lift_Parsetree_with_constraint : + Parsetree.with_constraint -> 'res= + (function + | Parsetree.Pwith_type (x0, x1) -> + this#constr "Ast_410.Parsetree.with_constraint" + ("Pwith_type", + [this#lift_loc this#lift_Longident_t x0; + this#lift_Parsetree_type_declaration x1]) + | Parsetree.Pwith_module (x0, x1) -> + this#constr "Ast_410.Parsetree.with_constraint" + ("Pwith_module", + [this#lift_loc this#lift_Longident_t x0; + this#lift_loc this#lift_Longident_t x1]) + | Parsetree.Pwith_typesubst (x0, x1) -> + this#constr "Ast_410.Parsetree.with_constraint" + ("Pwith_typesubst", + [this#lift_loc this#lift_Longident_t x0; + this#lift_Parsetree_type_declaration x1]) + | Parsetree.Pwith_modsubst (x0, x1) -> + this#constr "Ast_410.Parsetree.with_constraint" + ("Pwith_modsubst", + [this#lift_loc this#lift_Longident_t x0; + this#lift_loc this#lift_Longident_t x1]) : Parsetree.with_constraint + -> 'res) + method lift_Parsetree_signature : Parsetree.signature -> 'res= + (fun x -> this#list (List.map this#lift_Parsetree_signature_item x) : + Parsetree.signature -> 'res) + method lift_Parsetree_signature_item : + Parsetree.signature_item -> 'res= + (fun + { Parsetree.psig_desc = psig_desc; + Parsetree.psig_loc = psig_loc } + -> + this#record "Ast_410.Parsetree.signature_item" + [("psig_desc", + (this#lift_Parsetree_signature_item_desc psig_desc)); + ("psig_loc", (this#lift_Location_t psig_loc))] : Parsetree.signature_item + -> 'res) + method lift_Parsetree_signature_item_desc : + Parsetree.signature_item_desc -> 'res= + (function + | Parsetree.Psig_value x0 -> + this#constr "Ast_410.Parsetree.signature_item_desc" + ("Psig_value", [this#lift_Parsetree_value_description x0]) + | Parsetree.Psig_type (x0, x1) -> + this#constr "Ast_410.Parsetree.signature_item_desc" + ("Psig_type", + [this#lift_rec_flag x0; + this#list (List.map this#lift_Parsetree_type_declaration x1)]) + | Parsetree.Psig_typesubst x0 -> + this#constr "Ast_410.Parsetree.signature_item_desc" + ("Psig_typesubst", + [this#list (List.map this#lift_Parsetree_type_declaration x0)]) + | Parsetree.Psig_typext x0 -> + this#constr "Ast_410.Parsetree.signature_item_desc" + ("Psig_typext", [this#lift_Parsetree_type_extension x0]) + | Parsetree.Psig_exception x0 -> + this#constr "Ast_410.Parsetree.signature_item_desc" + ("Psig_exception", [this#lift_Parsetree_type_exception x0]) + | Parsetree.Psig_module x0 -> + this#constr "Ast_410.Parsetree.signature_item_desc" + ("Psig_module", [this#lift_Parsetree_module_declaration x0]) + | Parsetree.Psig_modsubst x0 -> + this#constr "Ast_410.Parsetree.signature_item_desc" + ("Psig_modsubst", [this#lift_Parsetree_module_substitution x0]) + | Parsetree.Psig_recmodule x0 -> + this#constr "Ast_410.Parsetree.signature_item_desc" + ("Psig_recmodule", + [this#list + (List.map this#lift_Parsetree_module_declaration x0)]) + | Parsetree.Psig_modtype x0 -> + this#constr "Ast_410.Parsetree.signature_item_desc" + ("Psig_modtype", + [this#lift_Parsetree_module_type_declaration x0]) + | Parsetree.Psig_open x0 -> + this#constr "Ast_410.Parsetree.signature_item_desc" + ("Psig_open", [this#lift_Parsetree_open_description x0]) + | Parsetree.Psig_include x0 -> + this#constr "Ast_410.Parsetree.signature_item_desc" + ("Psig_include", [this#lift_Parsetree_include_description x0]) + | Parsetree.Psig_class x0 -> + this#constr "Ast_410.Parsetree.signature_item_desc" + ("Psig_class", + [this#list (List.map this#lift_Parsetree_class_description x0)]) + | Parsetree.Psig_class_type x0 -> + this#constr "Ast_410.Parsetree.signature_item_desc" + ("Psig_class_type", + [this#list + (List.map this#lift_Parsetree_class_type_declaration x0)]) + | Parsetree.Psig_attribute x0 -> + this#constr "Ast_410.Parsetree.signature_item_desc" + ("Psig_attribute", [this#lift_Parsetree_attribute x0]) + | Parsetree.Psig_extension (x0, x1) -> + this#constr "Ast_410.Parsetree.signature_item_desc" + ("Psig_extension", + [this#lift_Parsetree_extension x0; + this#lift_Parsetree_attributes x1]) : Parsetree.signature_item_desc + -> 'res) + method lift_Parsetree_class_type_declaration : + Parsetree.class_type_declaration -> 'res= + (fun x -> + this#lift_Parsetree_class_infos this#lift_Parsetree_class_type x : + Parsetree.class_type_declaration -> 'res) + method lift_Parsetree_class_description : + Parsetree.class_description -> 'res= + (fun x -> + this#lift_Parsetree_class_infos this#lift_Parsetree_class_type x : + Parsetree.class_description -> 'res) + method lift_Parsetree_class_type : Parsetree.class_type -> 'res= + (fun + { Parsetree.pcty_desc = pcty_desc; + Parsetree.pcty_loc = pcty_loc; + Parsetree.pcty_attributes = pcty_attributes } + -> + this#record "Ast_410.Parsetree.class_type" + [("pcty_desc", (this#lift_Parsetree_class_type_desc pcty_desc)); + ("pcty_loc", (this#lift_Location_t pcty_loc)); + ("pcty_attributes", + (this#lift_Parsetree_attributes pcty_attributes))] : Parsetree.class_type + -> + 'res) + method lift_Parsetree_class_type_desc : + Parsetree.class_type_desc -> 'res= + (function + | Parsetree.Pcty_constr (x0, x1) -> + this#constr "Ast_410.Parsetree.class_type_desc" + ("Pcty_constr", + [this#lift_loc this#lift_Longident_t x0; + this#list (List.map this#lift_Parsetree_core_type x1)]) + | Parsetree.Pcty_signature x0 -> + this#constr "Ast_410.Parsetree.class_type_desc" + ("Pcty_signature", [this#lift_Parsetree_class_signature x0]) + | Parsetree.Pcty_arrow (x0, x1, x2) -> + this#constr "Ast_410.Parsetree.class_type_desc" + ("Pcty_arrow", + [this#lift_arg_label x0; + this#lift_Parsetree_core_type x1; + this#lift_Parsetree_class_type x2]) + | Parsetree.Pcty_extension x0 -> + this#constr "Ast_410.Parsetree.class_type_desc" + ("Pcty_extension", [this#lift_Parsetree_extension x0]) + | Parsetree.Pcty_open (x0, x1) -> + this#constr "Ast_410.Parsetree.class_type_desc" + ("Pcty_open", + [this#lift_Parsetree_open_description x0; + this#lift_Parsetree_class_type x1]) : Parsetree.class_type_desc + -> 'res) + method lift_Parsetree_class_signature : + Parsetree.class_signature -> 'res= + (fun + { Parsetree.pcsig_self = pcsig_self; + Parsetree.pcsig_fields = pcsig_fields } + -> + this#record "Ast_410.Parsetree.class_signature" + [("pcsig_self", (this#lift_Parsetree_core_type pcsig_self)); + ("pcsig_fields", + (this#list + (List.map this#lift_Parsetree_class_type_field pcsig_fields)))] : + Parsetree.class_signature -> 'res) + method lift_Parsetree_class_type_field : + Parsetree.class_type_field -> 'res= + (fun + { Parsetree.pctf_desc = pctf_desc; + Parsetree.pctf_loc = pctf_loc; + Parsetree.pctf_attributes = pctf_attributes } + -> + this#record "Ast_410.Parsetree.class_type_field" + [("pctf_desc", + (this#lift_Parsetree_class_type_field_desc pctf_desc)); + ("pctf_loc", (this#lift_Location_t pctf_loc)); + ("pctf_attributes", + (this#lift_Parsetree_attributes pctf_attributes))] : Parsetree.class_type_field + -> + 'res) + method lift_Parsetree_class_type_field_desc : + Parsetree.class_type_field_desc -> 'res= + (function + | Parsetree.Pctf_inherit x0 -> + this#constr "Ast_410.Parsetree.class_type_field_desc" + ("Pctf_inherit", [this#lift_Parsetree_class_type x0]) + | Parsetree.Pctf_val x0 -> + this#constr "Ast_410.Parsetree.class_type_field_desc" + ("Pctf_val", + [(let (x0, x1, x2, x3) = x0 in + this#tuple + [this#lift_loc this#lift_label x0; + this#lift_mutable_flag x1; + this#lift_virtual_flag x2; + this#lift_Parsetree_core_type x3])]) + | Parsetree.Pctf_method x0 -> + this#constr "Ast_410.Parsetree.class_type_field_desc" + ("Pctf_method", + [(let (x0, x1, x2, x3) = x0 in + this#tuple + [this#lift_loc this#lift_label x0; + this#lift_private_flag x1; + this#lift_virtual_flag x2; + this#lift_Parsetree_core_type x3])]) + | Parsetree.Pctf_constraint x0 -> + this#constr "Ast_410.Parsetree.class_type_field_desc" + ("Pctf_constraint", + [(let (x0, x1) = x0 in + this#tuple + [this#lift_Parsetree_core_type x0; + this#lift_Parsetree_core_type x1])]) + | Parsetree.Pctf_attribute x0 -> + this#constr "Ast_410.Parsetree.class_type_field_desc" + ("Pctf_attribute", [this#lift_Parsetree_attribute x0]) + | Parsetree.Pctf_extension x0 -> + this#constr "Ast_410.Parsetree.class_type_field_desc" + ("Pctf_extension", [this#lift_Parsetree_extension x0]) : + Parsetree.class_type_field_desc -> 'res) + method lift_Parsetree_extension : Parsetree.extension -> 'res= + (fun x -> + let (x0, x1) = x in + this#tuple + [this#lift_loc this#string x0; this#lift_Parsetree_payload x1] : + Parsetree.extension -> 'res) + method lift_Parsetree_class_infos : + 'f0 . ('f0 -> 'res) -> 'f0 Parsetree.class_infos -> 'res= fun + (type f0) -> + (fun f0 -> + fun + { Parsetree.pci_virt = pci_virt; + Parsetree.pci_params = pci_params; + Parsetree.pci_name = pci_name; + Parsetree.pci_expr = pci_expr; + Parsetree.pci_loc = pci_loc; + Parsetree.pci_attributes = pci_attributes } + -> + this#record "Ast_410.Parsetree.class_infos" + [("pci_virt", (this#lift_virtual_flag pci_virt)); + ("pci_params", + (this#list + (List.map + (fun x -> + let (x0, x1) = x in + this#tuple + [this#lift_Parsetree_core_type x0; + this#lift_variance x1]) pci_params))); + ("pci_name", (this#lift_loc this#string pci_name)); + ("pci_expr", (f0 pci_expr)); + ("pci_loc", (this#lift_Location_t pci_loc)); + ("pci_attributes", + (this#lift_Parsetree_attributes pci_attributes))] : (f0 -> + 'res) -> + f0 + Parsetree.class_infos + -> + 'res) + method lift_virtual_flag : + Migrate_parsetree__Ast_410.Asttypes.virtual_flag -> 'res= + (function + | Migrate_parsetree__Ast_410.Asttypes.Virtual -> + this#constr "Migrate_parsetree__Ast_410.Asttypes.virtual_flag" + ("Virtual", []) + | Migrate_parsetree__Ast_410.Asttypes.Concrete -> + this#constr "Migrate_parsetree__Ast_410.Asttypes.virtual_flag" + ("Concrete", []) : Migrate_parsetree__Ast_410.Asttypes.virtual_flag + -> 'res) + method lift_Parsetree_include_description : + Parsetree.include_description -> 'res= + (fun x -> + this#lift_Parsetree_include_infos this#lift_Parsetree_module_type x : + Parsetree.include_description -> 'res) + method lift_Parsetree_include_infos : + 'f0 . ('f0 -> 'res) -> 'f0 Parsetree.include_infos -> 'res= fun + (type f0) -> + (fun f0 -> + fun + { Parsetree.pincl_mod = pincl_mod; + Parsetree.pincl_loc = pincl_loc; + Parsetree.pincl_attributes = pincl_attributes } + -> + this#record "Ast_410.Parsetree.include_infos" + [("pincl_mod", (f0 pincl_mod)); + ("pincl_loc", (this#lift_Location_t pincl_loc)); + ("pincl_attributes", + (this#lift_Parsetree_attributes pincl_attributes))] : + (f0 -> 'res) -> f0 Parsetree.include_infos -> 'res) + method lift_Parsetree_open_description : + Parsetree.open_description -> 'res= + (fun x -> + this#lift_Parsetree_open_infos + (fun x -> this#lift_loc this#lift_Longident_t x) x : Parsetree.open_description + -> + 'res) + method lift_Parsetree_open_infos : + 'f0 . ('f0 -> 'res) -> 'f0 Parsetree.open_infos -> 'res= fun + (type f0) -> + (fun f0 -> + fun + { Parsetree.popen_expr = popen_expr; + Parsetree.popen_override = popen_override; + Parsetree.popen_loc = popen_loc; + Parsetree.popen_attributes = popen_attributes } + -> + this#record "Ast_410.Parsetree.open_infos" + [("popen_expr", (f0 popen_expr)); + ("popen_override", (this#lift_override_flag popen_override)); + ("popen_loc", (this#lift_Location_t popen_loc)); + ("popen_attributes", + (this#lift_Parsetree_attributes popen_attributes))] : + (f0 -> 'res) -> f0 Parsetree.open_infos -> 'res) + method lift_override_flag : + Migrate_parsetree__Ast_410.Asttypes.override_flag -> 'res= + (function + | Migrate_parsetree__Ast_410.Asttypes.Override -> + this#constr "Migrate_parsetree__Ast_410.Asttypes.override_flag" + ("Override", []) + | Migrate_parsetree__Ast_410.Asttypes.Fresh -> + this#constr "Migrate_parsetree__Ast_410.Asttypes.override_flag" + ("Fresh", []) : Migrate_parsetree__Ast_410.Asttypes.override_flag + -> 'res) + method lift_Parsetree_module_type_declaration : + Parsetree.module_type_declaration -> 'res= + (fun + { Parsetree.pmtd_name = pmtd_name; + Parsetree.pmtd_type = pmtd_type; + Parsetree.pmtd_attributes = pmtd_attributes; + Parsetree.pmtd_loc = pmtd_loc } + -> + this#record "Ast_410.Parsetree.module_type_declaration" + [("pmtd_name", (this#lift_loc this#string pmtd_name)); + ("pmtd_type", + (this#lift_option this#lift_Parsetree_module_type pmtd_type)); + ("pmtd_attributes", + (this#lift_Parsetree_attributes pmtd_attributes)); + ("pmtd_loc", (this#lift_Location_t pmtd_loc))] : Parsetree.module_type_declaration + -> 'res) + method lift_Parsetree_module_substitution : + Parsetree.module_substitution -> 'res= + (fun + { Parsetree.pms_name = pms_name; + Parsetree.pms_manifest = pms_manifest; + Parsetree.pms_attributes = pms_attributes; + Parsetree.pms_loc = pms_loc } + -> + this#record "Ast_410.Parsetree.module_substitution" + [("pms_name", (this#lift_loc this#string pms_name)); + ("pms_manifest", + (this#lift_loc this#lift_Longident_t pms_manifest)); + ("pms_attributes", + (this#lift_Parsetree_attributes pms_attributes)); + ("pms_loc", (this#lift_Location_t pms_loc))] : Parsetree.module_substitution + -> 'res) + method lift_Parsetree_module_declaration : + Parsetree.module_declaration -> 'res= + (fun + { Parsetree.pmd_name = pmd_name; + Parsetree.pmd_type = pmd_type; + Parsetree.pmd_attributes = pmd_attributes; + Parsetree.pmd_loc = pmd_loc } + -> + this#record "Ast_410.Parsetree.module_declaration" + [("pmd_name", (this#lift_loc (this#lift_option this#string) pmd_name)); + ("pmd_type", (this#lift_Parsetree_module_type pmd_type)); + ("pmd_attributes", + (this#lift_Parsetree_attributes pmd_attributes)); + ("pmd_loc", (this#lift_Location_t pmd_loc))] : Parsetree.module_declaration + -> 'res) + method lift_Parsetree_type_exception : + Parsetree.type_exception -> 'res= + (fun + { Parsetree.ptyexn_constructor = ptyexn_constructor; + Parsetree.ptyexn_loc = ptyexn_loc; + Parsetree.ptyexn_attributes = ptyexn_attributes } + -> + this#record "Ast_410.Parsetree.type_exception" + [("ptyexn_constructor", + (this#lift_Parsetree_extension_constructor ptyexn_constructor)); + ("ptyexn_loc", (this#lift_Location_t ptyexn_loc)); + ("ptyexn_attributes", + (this#lift_Parsetree_attributes ptyexn_attributes))] : Parsetree.type_exception + -> + 'res) + method lift_Parsetree_type_extension : + Parsetree.type_extension -> 'res= + (fun + { Parsetree.ptyext_path = ptyext_path; + Parsetree.ptyext_params = ptyext_params; + Parsetree.ptyext_constructors = ptyext_constructors; + Parsetree.ptyext_private = ptyext_private; + Parsetree.ptyext_loc = ptyext_loc; + Parsetree.ptyext_attributes = ptyext_attributes } + -> + this#record "Ast_410.Parsetree.type_extension" + [("ptyext_path", + (this#lift_loc this#lift_Longident_t ptyext_path)); + ("ptyext_params", + (this#list + (List.map + (fun x -> + let (x0, x1) = x in + this#tuple + [this#lift_Parsetree_core_type x0; + this#lift_variance x1]) ptyext_params))); + ("ptyext_constructors", + (this#list + (List.map this#lift_Parsetree_extension_constructor + ptyext_constructors))); + ("ptyext_private", (this#lift_private_flag ptyext_private)); + ("ptyext_loc", (this#lift_Location_t ptyext_loc)); + ("ptyext_attributes", + (this#lift_Parsetree_attributes ptyext_attributes))] : Parsetree.type_extension + -> + 'res) + method lift_Parsetree_extension_constructor : + Parsetree.extension_constructor -> 'res= + (fun + { Parsetree.pext_name = pext_name; + Parsetree.pext_kind = pext_kind; + Parsetree.pext_loc = pext_loc; + Parsetree.pext_attributes = pext_attributes } + -> + this#record "Ast_410.Parsetree.extension_constructor" + [("pext_name", (this#lift_loc this#string pext_name)); + ("pext_kind", + (this#lift_Parsetree_extension_constructor_kind pext_kind)); + ("pext_loc", (this#lift_Location_t pext_loc)); + ("pext_attributes", + (this#lift_Parsetree_attributes pext_attributes))] : Parsetree.extension_constructor + -> + 'res) + method lift_Parsetree_extension_constructor_kind : + Parsetree.extension_constructor_kind -> 'res= + (function + | Parsetree.Pext_decl (x0, x1) -> + this#constr "Ast_410.Parsetree.extension_constructor_kind" + ("Pext_decl", + [this#lift_Parsetree_constructor_arguments x0; + this#lift_option this#lift_Parsetree_core_type x1]) + | Parsetree.Pext_rebind x0 -> + this#constr "Ast_410.Parsetree.extension_constructor_kind" + ("Pext_rebind", [this#lift_loc this#lift_Longident_t x0]) : + Parsetree.extension_constructor_kind -> 'res) + method lift_Parsetree_type_declaration : + Parsetree.type_declaration -> 'res= + (fun + { Parsetree.ptype_name = ptype_name; + Parsetree.ptype_params = ptype_params; + Parsetree.ptype_cstrs = ptype_cstrs; + Parsetree.ptype_kind = ptype_kind; + Parsetree.ptype_private = ptype_private; + Parsetree.ptype_manifest = ptype_manifest; + Parsetree.ptype_attributes = ptype_attributes; + Parsetree.ptype_loc = ptype_loc } + -> + this#record "Ast_410.Parsetree.type_declaration" + [("ptype_name", (this#lift_loc this#string ptype_name)); + ("ptype_params", + (this#list + (List.map + (fun x -> + let (x0, x1) = x in + this#tuple + [this#lift_Parsetree_core_type x0; + this#lift_variance x1]) ptype_params))); + ("ptype_cstrs", + (this#list + (List.map + (fun x -> + let (x0, x1, x2) = x in + this#tuple + [this#lift_Parsetree_core_type x0; + this#lift_Parsetree_core_type x1; + this#lift_Location_t x2]) ptype_cstrs))); + ("ptype_kind", (this#lift_Parsetree_type_kind ptype_kind)); + ("ptype_private", (this#lift_private_flag ptype_private)); + ("ptype_manifest", + (this#lift_option this#lift_Parsetree_core_type ptype_manifest)); + ("ptype_attributes", + (this#lift_Parsetree_attributes ptype_attributes)); + ("ptype_loc", (this#lift_Location_t ptype_loc))] : Parsetree.type_declaration + -> 'res) + method lift_private_flag : + Migrate_parsetree__Ast_410.Asttypes.private_flag -> 'res= + (function + | Migrate_parsetree__Ast_410.Asttypes.Private -> + this#constr "Migrate_parsetree__Ast_410.Asttypes.private_flag" + ("Private", []) + | Migrate_parsetree__Ast_410.Asttypes.Public -> + this#constr "Migrate_parsetree__Ast_410.Asttypes.private_flag" + ("Public", []) : Migrate_parsetree__Ast_410.Asttypes.private_flag + -> 'res) + method lift_Parsetree_type_kind : Parsetree.type_kind -> 'res= + (function + | Parsetree.Ptype_abstract -> + this#constr "Ast_410.Parsetree.type_kind" ("Ptype_abstract", []) + | Parsetree.Ptype_variant x0 -> + this#constr "Ast_410.Parsetree.type_kind" + ("Ptype_variant", + [this#list + (List.map this#lift_Parsetree_constructor_declaration x0)]) + | Parsetree.Ptype_record x0 -> + this#constr "Ast_410.Parsetree.type_kind" + ("Ptype_record", + [this#list (List.map this#lift_Parsetree_label_declaration x0)]) + | Parsetree.Ptype_open -> + this#constr "Ast_410.Parsetree.type_kind" ("Ptype_open", []) : + Parsetree.type_kind -> 'res) + method lift_Parsetree_constructor_declaration : + Parsetree.constructor_declaration -> 'res= + (fun + { Parsetree.pcd_name = pcd_name; + Parsetree.pcd_args = pcd_args; + Parsetree.pcd_res = pcd_res; + Parsetree.pcd_loc = pcd_loc; + Parsetree.pcd_attributes = pcd_attributes } + -> + this#record "Ast_410.Parsetree.constructor_declaration" + [("pcd_name", (this#lift_loc this#string pcd_name)); + ("pcd_args", (this#lift_Parsetree_constructor_arguments pcd_args)); + ("pcd_res", + (this#lift_option this#lift_Parsetree_core_type pcd_res)); + ("pcd_loc", (this#lift_Location_t pcd_loc)); + ("pcd_attributes", + (this#lift_Parsetree_attributes pcd_attributes))] : Parsetree.constructor_declaration + -> + 'res) + method lift_Parsetree_constructor_arguments : + Parsetree.constructor_arguments -> 'res= + (function + | Parsetree.Pcstr_tuple x0 -> + this#constr "Ast_410.Parsetree.constructor_arguments" + ("Pcstr_tuple", + [this#list (List.map this#lift_Parsetree_core_type x0)]) + | Parsetree.Pcstr_record x0 -> + this#constr "Ast_410.Parsetree.constructor_arguments" + ("Pcstr_record", + [this#list (List.map this#lift_Parsetree_label_declaration x0)]) : + Parsetree.constructor_arguments -> 'res) + method lift_Parsetree_label_declaration : + Parsetree.label_declaration -> 'res= + (fun + { Parsetree.pld_name = pld_name; + Parsetree.pld_mutable = pld_mutable; + Parsetree.pld_type = pld_type; + Parsetree.pld_loc = pld_loc; + Parsetree.pld_attributes = pld_attributes } + -> + this#record "Ast_410.Parsetree.label_declaration" + [("pld_name", (this#lift_loc this#string pld_name)); + ("pld_mutable", (this#lift_mutable_flag pld_mutable)); + ("pld_type", (this#lift_Parsetree_core_type pld_type)); + ("pld_loc", (this#lift_Location_t pld_loc)); + ("pld_attributes", + (this#lift_Parsetree_attributes pld_attributes))] : Parsetree.label_declaration + -> + 'res) + method lift_mutable_flag : + Migrate_parsetree__Ast_410.Asttypes.mutable_flag -> 'res= + (function + | Migrate_parsetree__Ast_410.Asttypes.Immutable -> + this#constr "Migrate_parsetree__Ast_410.Asttypes.mutable_flag" + ("Immutable", []) + | Migrate_parsetree__Ast_410.Asttypes.Mutable -> + this#constr "Migrate_parsetree__Ast_410.Asttypes.mutable_flag" + ("Mutable", []) : Migrate_parsetree__Ast_410.Asttypes.mutable_flag + -> 'res) + method lift_variance : + Migrate_parsetree__Ast_410.Asttypes.variance -> 'res= + (function + | Migrate_parsetree__Ast_410.Asttypes.Covariant -> + this#constr "Migrate_parsetree__Ast_410.Asttypes.variance" + ("Covariant", []) + | Migrate_parsetree__Ast_410.Asttypes.Contravariant -> + this#constr "Migrate_parsetree__Ast_410.Asttypes.variance" + ("Contravariant", []) + | Migrate_parsetree__Ast_410.Asttypes.Invariant -> + this#constr "Migrate_parsetree__Ast_410.Asttypes.variance" + ("Invariant", []) : Migrate_parsetree__Ast_410.Asttypes.variance + -> 'res) + method lift_Parsetree_value_description : + Parsetree.value_description -> 'res= + (fun + { Parsetree.pval_name = pval_name; + Parsetree.pval_type = pval_type; + Parsetree.pval_prim = pval_prim; + Parsetree.pval_attributes = pval_attributes; + Parsetree.pval_loc = pval_loc } + -> + this#record "Ast_410.Parsetree.value_description" + [("pval_name", (this#lift_loc this#string pval_name)); + ("pval_type", (this#lift_Parsetree_core_type pval_type)); + ("pval_prim", (this#list (List.map this#string pval_prim))); + ("pval_attributes", + (this#lift_Parsetree_attributes pval_attributes)); + ("pval_loc", (this#lift_Location_t pval_loc))] : Parsetree.value_description + -> 'res) + method lift_Parsetree_object_field_desc : + Parsetree.object_field_desc -> 'res= + (function + | Parsetree.Otag (x0, x1) -> + this#constr "Ast_410.Parsetree.object_field_desc" + ("Otag", + [this#lift_loc this#lift_label x0; + this#lift_Parsetree_core_type x1]) + | Parsetree.Oinherit x0 -> + this#constr "Ast_410.Parsetree.object_field_desc" + ("Oinherit", [this#lift_Parsetree_core_type x0]) : Parsetree.object_field_desc + -> + 'res) + method lift_arg_label : + Migrate_parsetree__Ast_410.Asttypes.arg_label -> 'res= + (function + | Migrate_parsetree__Ast_410.Asttypes.Nolabel -> + this#constr "Migrate_parsetree__Ast_410.Asttypes.arg_label" + ("Nolabel", []) + | Migrate_parsetree__Ast_410.Asttypes.Labelled x0 -> + this#constr "Migrate_parsetree__Ast_410.Asttypes.arg_label" + ("Labelled", [this#string x0]) + | Migrate_parsetree__Ast_410.Asttypes.Optional x0 -> + this#constr "Migrate_parsetree__Ast_410.Asttypes.arg_label" + ("Optional", [this#string x0]) : Migrate_parsetree__Ast_410.Asttypes.arg_label + -> 'res) + method lift_closed_flag : + Migrate_parsetree__Ast_410.Asttypes.closed_flag -> 'res= + (function + | Migrate_parsetree__Ast_410.Asttypes.Closed -> + this#constr "Migrate_parsetree__Ast_410.Asttypes.closed_flag" + ("Closed", []) + | Migrate_parsetree__Ast_410.Asttypes.Open -> + this#constr "Migrate_parsetree__Ast_410.Asttypes.closed_flag" + ("Open", []) : Migrate_parsetree__Ast_410.Asttypes.closed_flag + -> 'res) + method lift_label : Migrate_parsetree__Ast_410.Asttypes.label -> 'res= + (this#string : Migrate_parsetree__Ast_410.Asttypes.label -> 'res) + method lift_rec_flag : + Migrate_parsetree__Ast_410.Asttypes.rec_flag -> 'res= + (function + | Migrate_parsetree__Ast_410.Asttypes.Nonrecursive -> + this#constr "Migrate_parsetree__Ast_410.Asttypes.rec_flag" + ("Nonrecursive", []) + | Migrate_parsetree__Ast_410.Asttypes.Recursive -> + this#constr "Migrate_parsetree__Ast_410.Asttypes.rec_flag" + ("Recursive", []) : Migrate_parsetree__Ast_410.Asttypes.rec_flag + -> 'res) + method lift_Parsetree_constant : Parsetree.constant -> 'res= + (function + | Parsetree.Pconst_integer (x0, x1) -> + this#constr "Ast_410.Parsetree.constant" + ("Pconst_integer", + [this#string x0; this#lift_option this#char x1]) + | Parsetree.Pconst_char x0 -> + this#constr "Ast_410.Parsetree.constant" + ("Pconst_char", [this#char x0]) + | Parsetree.Pconst_string (x0, x1) -> + this#constr "Ast_410.Parsetree.constant" + ("Pconst_string", + [this#string x0; this#lift_option this#string x1]) + | Parsetree.Pconst_float (x0, x1) -> + this#constr "Ast_410.Parsetree.constant" + ("Pconst_float", + [this#string x0; this#lift_option this#char x1]) : Parsetree.constant + -> + 'res) + method lift_option : 'f0 . ('f0 -> 'res) -> 'f0 option -> 'res= fun (type + f0) -> + (fun f0 -> + function + | None -> this#constr "option" ("None", []) + | Some x0 -> this#constr "option" ("Some", [f0 x0]) : (f0 -> 'res) + -> + f0 option -> + 'res) + method lift_Longident_t : Migrate_parsetree__Ast_410.Longident.t -> 'res= + (function + | Migrate_parsetree__Ast_410.Longident.Lident x0 -> + this#constr "Migrate_parsetree__Ast_410.Longident.t" + ("Lident", [this#string x0]) + | Migrate_parsetree__Ast_410.Longident.Ldot (x0, x1) -> + this#constr "Migrate_parsetree__Ast_410.Longident.t" + ("Ldot", [this#lift_Longident_t x0; this#string x1]) + | Migrate_parsetree__Ast_410.Longident.Lapply (x0, x1) -> + this#constr "Migrate_parsetree__Ast_410.Longident.t" + ("Lapply", [this#lift_Longident_t x0; this#lift_Longident_t x1]) : + Migrate_parsetree__Ast_410.Longident.t -> 'res) + method lift_loc : + 'f0 . + ('f0 -> 'res) -> 'f0 Migrate_parsetree__Ast_410.Asttypes.loc -> 'res= + fun (type f0) -> + (fun f0 -> + fun + { Migrate_parsetree__Ast_410.Asttypes.txt = txt; + Migrate_parsetree__Ast_410.Asttypes.loc = loc } + -> + this#record "Migrate_parsetree__Ast_410.Asttypes.loc" + [("txt", (f0 txt)); ("loc", (this#lift_Location_t loc))] : + (f0 -> 'res) -> f0 Migrate_parsetree__Ast_410.Asttypes.loc -> 'res) + method lift_Location_t : Migrate_parsetree__Ast_410.Location.t -> 'res= + (fun + { Migrate_parsetree__Ast_410.Location.loc_start = loc_start; + Migrate_parsetree__Ast_410.Location.loc_end = loc_end; + Migrate_parsetree__Ast_410.Location.loc_ghost = loc_ghost } + -> + this#record "Migrate_parsetree__Ast_410.Location.t" + [("loc_start", (this#lift_position loc_start)); + ("loc_end", (this#lift_position loc_end)); + ("loc_ghost", (this#lift_bool loc_ghost))] : Migrate_parsetree__Ast_410.Location.t + -> 'res) + method lift_bool : bool -> 'res= + (function + | false -> this#constr "bool" ("false", []) + | true -> this#constr "bool" ("true", []) : bool -> 'res) + method lift_position : Lexing.position -> 'res= + (fun + { Lexing.pos_fname = pos_fname; + Lexing.pos_lnum = pos_lnum; + Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum + } + -> + this#record "Lexing.position" + [("pos_fname", (this#string pos_fname)); + ("pos_lnum", (this#int pos_lnum)); + ("pos_bol", (this#int pos_bol)); + ("pos_cnum", (this#int pos_cnum))] : Lexing.position -> + 'res) + + method lift_loc_stack : Location.t list -> 'res = + fun l -> this#list (List.map this#lift_Location_t l) + end diff --git a/ast_mapper_class_410.ml b/ast_mapper_class_410.ml new file mode 100644 index 0000000..4abfe85 --- /dev/null +++ b/ast_mapper_class_410.ml @@ -0,0 +1,658 @@ +open Migrate_parsetree.Ast_410 + +(* This file is part of the ppx_tools package. It is released *) +(* under the terms of the MIT license (see LICENSE file). *) +(* Copyright 2013 Alain Frisch and LexiFi *) + +(** Class-based customizable mapper *) + +open Parsetree +open Asttypes +open Ast_helper + +let map_fst f (x, y) = (f x, y) +let map_snd f (x, y) = (x, f y) +let map_tuple f1 f2 (x, y) = (f1 x, f2 y) +let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) +let map_opt f = function None -> None | Some x -> Some (f x) + +let map_loc sub {loc; txt} = {loc = sub # location loc; txt} + +let map_functor_parameter sub = function + | Unit -> Unit + | Named (s, mt1) -> Named (map_loc sub s, sub # module_type mt1) + +module T = struct + (* Type expressions for the core language *) + + let row_field_desc sub = function + | Rtag (l, b, tl) -> Rtag (l, b, List.map (sub # typ) tl) + | Rinherit t -> Rinherit (sub # typ t) + + let row_field sub {prf_desc = desc; prf_loc = loc; prf_attributes = attrs} = + let desc = row_field_desc sub desc in + let loc = sub # location loc in + let attrs = sub # attributes attrs in + {prf_desc = desc; prf_loc = loc; prf_attributes = attrs} + + let object_field_desc sub = function + | Otag (s, t) -> Otag (s, sub # typ t) + | Oinherit t -> Oinherit (sub # typ t) + + let object_field sub {pof_desc = desc; pof_loc = loc; pof_attributes = attrs} = + let desc = object_field_desc sub desc in + let loc = sub # location loc in + let attrs = sub # attributes attrs in + {pof_desc = desc; pof_loc = loc; pof_attributes = attrs} + + let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_loc_stack = _; ptyp_attributes = attrs} = + let open Typ in + let loc = sub # location loc in + let attrs = sub # attributes attrs in + match desc with + | Ptyp_any -> any ~loc ~attrs () + | Ptyp_var s -> var ~loc ~attrs s + | Ptyp_arrow (lab, t1, t2) -> + arrow ~loc ~attrs lab (sub # typ t1) (sub # typ t2) + | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub # typ) tyl) + | Ptyp_constr (lid, tl) -> + constr ~loc ~attrs (map_loc sub lid) (List.map (sub # typ) tl) + | Ptyp_object (l, o) -> + object_ ~loc ~attrs (List.map (object_field sub) l) o + | Ptyp_class (lid, tl) -> + class_ ~loc ~attrs (map_loc sub lid) (List.map (sub # typ) tl) + | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub # typ t) s + | Ptyp_variant (rl, b, ll) -> + variant ~loc ~attrs (List.map (row_field sub) rl) b ll + | Ptyp_poly (sl, t) -> poly ~loc ~attrs sl (sub # typ t) + | Ptyp_package (lid, l) -> + package ~loc ~attrs (map_loc sub lid) + (List.map (map_tuple (map_loc sub) (sub # typ)) l) + | Ptyp_extension x -> extension ~loc ~attrs (sub # extension x) + + let map_type_declaration sub + {ptype_name; ptype_params; ptype_cstrs; + ptype_kind; + ptype_private; + ptype_manifest; + ptype_attributes; + ptype_loc} = + Type.mk (map_loc sub ptype_name) + ~params:(List.map (map_fst (sub # typ)) ptype_params) + ~priv:ptype_private + ~cstrs:(List.map (map_tuple3 (sub # typ) (sub # typ) (sub # location)) + ptype_cstrs) + ~kind:(sub # type_kind ptype_kind) + ?manifest:(map_opt (sub # typ) ptype_manifest) + ~loc:(sub # location ptype_loc) + ~attrs:(sub # attributes ptype_attributes) + + let map_type_kind sub = function + | Ptype_abstract -> Ptype_abstract + | Ptype_variant l -> + Ptype_variant (List.map (sub # constructor_declaration) l) + | Ptype_record l -> Ptype_record (List.map (sub # label_declaration) l) + | Ptype_open -> Ptype_open + + let map_type_extension sub + {ptyext_path; ptyext_params; + ptyext_constructors; + ptyext_private; + ptyext_loc; + ptyext_attributes} = + Te.mk + (map_loc sub ptyext_path) + (List.map (sub # extension_constructor) ptyext_constructors) + ~params:(List.map (map_fst (sub # typ)) ptyext_params) + ~priv:ptyext_private + ~loc:(sub # location ptyext_loc) + ~attrs:(sub # attributes ptyext_attributes) + + let map_extension_constructor_kind sub = function + Pext_decl(ctl, cto) -> + Pext_decl(sub # constructor_arguments ctl, map_opt (sub # typ) cto) + | Pext_rebind li -> + Pext_rebind (map_loc sub li) + + let map_extension_constructor sub + {pext_name; + pext_kind; + pext_loc; + pext_attributes} = + Te.constructor + (map_loc sub pext_name) + (map_extension_constructor_kind sub pext_kind) + ~loc:(sub # location pext_loc) + ~attrs:(sub # attributes pext_attributes) + + let map_type_exception sub {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} = + Te.mk_exception + (map_extension_constructor sub ptyexn_constructor) + ~loc:(sub # location ptyexn_loc) + ~attrs:(sub # attributes ptyexn_attributes) + +end + +module CT = struct + (* Type expressions for the class language *) + + let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = + let open Cty in + let loc = sub # location loc in + match desc with + | Pcty_constr (lid, tys) -> + constr ~loc ~attrs (map_loc sub lid) (List.map (sub # typ) tys) + | Pcty_signature x -> signature ~loc ~attrs (sub # class_signature x) + | Pcty_arrow (lab, t, ct) -> + arrow ~loc ~attrs lab (sub # typ t) (sub # class_type ct) + | Pcty_extension x -> extension ~loc ~attrs (sub # extension x) + | Pcty_open (od, ct) -> + open_ ~loc ~attrs (sub # open_description od) (sub # class_type ct) + + let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} + = + let open Ctf in + let loc = sub # location loc in + match desc with + | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub # class_type ct) + | Pctf_val (s, m, v, t) -> val_ ~loc ~attrs s m v (sub # typ t) + | Pctf_method (s, p, v, t) -> method_ ~loc ~attrs s p v (sub # typ t) + | Pctf_constraint (t1, t2) -> + constraint_ ~loc ~attrs (sub # typ t1) (sub # typ t2) + | Pctf_attribute x -> attribute ~loc (sub # attribute x) + | Pctf_extension x -> extension ~loc ~attrs (sub # extension x) + + let map_signature sub {pcsig_self; pcsig_fields} = + Csig.mk + (sub # typ pcsig_self) + (List.map (sub # class_type_field) pcsig_fields) +end + +module MT = struct + (* Type expressions for the module language *) + + let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = + let open Mty in + let loc = sub # location loc in + let attrs = sub # attributes attrs in + match desc with + | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) + | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) + | Pmty_signature sg -> signature ~loc ~attrs (sub # signature sg) + | Pmty_functor (param, mt2) -> + functor_ ~loc ~attrs + (map_functor_parameter sub param) + (sub # module_type mt2) + | Pmty_with (mt, l) -> + with_ ~loc ~attrs (sub # module_type mt) + (List.map (sub # with_constraint) l) + | Pmty_typeof me -> typeof_ ~loc ~attrs (sub # module_expr me) + | Pmty_extension x -> extension ~loc ~attrs (sub # extension x) + + let map_with_constraint sub = function + | Pwith_type (lid, d) -> + Pwith_type (map_loc sub lid, sub # type_declaration d) + | Pwith_module (lid, lid2) -> + Pwith_module (map_loc sub lid, map_loc sub lid2) + | Pwith_typesubst (lid, d) -> + Pwith_typesubst (map_loc sub lid, sub # type_declaration d) + | Pwith_modsubst (lid, lid2) -> + Pwith_modsubst (map_loc sub lid, map_loc sub lid2) + + let map_signature_item sub {psig_desc = desc; psig_loc = loc} = + let open Sig in + let loc = sub # location loc in + match desc with + | Psig_value vd -> value ~loc (sub # value_description vd) + | Psig_type (rf, l) -> type_ ~loc rf (List.map (sub # type_declaration) l) + | Psig_typesubst l -> type_subst ~loc (List.map (sub # type_declaration) l) + | Psig_typext te -> type_extension ~loc (sub # type_extension te) + | Psig_exception texn -> exception_ ~loc (sub # type_exception texn) + | Psig_module x -> module_ ~loc (sub # module_declaration x) + | Psig_modsubst ms -> mod_subst ~loc (sub # module_substitution ms) + | Psig_recmodule l -> + rec_module ~loc (List.map (sub # module_declaration) l) + | Psig_modtype x -> modtype ~loc (sub # module_type_declaration x) + | Psig_open od -> open_ ~loc (sub # open_description od) + | Psig_include x -> include_ ~loc (sub # include_description x) + | Psig_class l -> class_ ~loc (List.map (sub # class_description) l) + | Psig_class_type l -> + class_type ~loc (List.map (sub # class_type_declaration) l) + | Psig_extension (x, attrs) -> + extension ~loc (sub # extension x) ~attrs:(sub # attributes attrs) + | Psig_attribute x -> attribute ~loc (sub # attribute x) +end + +module M = struct + (* Value expressions for the module language *) + + let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = + let open Mod in + let loc = sub # location loc in + let attrs = sub # attributes attrs in + match desc with + | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) + | Pmod_structure str -> structure ~loc ~attrs (sub # structure str) + | Pmod_functor (arg, body) -> + functor_ ~loc ~attrs + (map_functor_parameter sub arg) + (sub # module_expr body) + | Pmod_apply (m1, m2) -> + apply ~loc ~attrs (sub # module_expr m1) (sub # module_expr m2) + | Pmod_constraint (m, mty) -> + constraint_ ~loc ~attrs (sub # module_expr m) (sub # module_type mty) + | Pmod_unpack e -> unpack ~loc ~attrs (sub # expr e) + | Pmod_extension x -> extension ~loc ~attrs (sub # extension x) + + let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = + let open Str in + let loc = sub # location loc in + match desc with + | Pstr_eval (x, attrs) -> + eval ~loc ~attrs:(sub # attributes attrs) (sub # expr x) + | Pstr_value (r, vbs) -> value ~loc r (List.map (sub # value_binding) vbs) + | Pstr_primitive vd -> primitive ~loc (sub # value_description vd) + | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub # type_declaration) l) + | Pstr_typext te -> type_extension ~loc (sub # type_extension te) + | Pstr_exception ed -> exception_ ~loc (sub # type_exception ed) + | Pstr_module x -> module_ ~loc (sub # module_binding x) + | Pstr_recmodule l -> rec_module ~loc (List.map (sub # module_binding) l) + | Pstr_modtype x -> modtype ~loc (sub # module_type_declaration x) + | Pstr_open od -> open_ ~loc (sub # open_declaration od) + | Pstr_class l -> class_ ~loc (List.map (sub # class_declaration) l) + | Pstr_class_type l -> + class_type ~loc (List.map (sub # class_type_declaration) l) + | Pstr_include x -> include_ ~loc (sub # include_declaration x) + | Pstr_extension (x, attrs) -> + extension ~loc (sub # extension x) ~attrs:(sub # attributes attrs) + | Pstr_attribute x -> attribute ~loc (sub # attribute x) +end + +module E = struct + (* Value expressions for the core language *) + + let map_binding_op sub {pbop_op = op; pbop_pat = pat; pbop_exp = exp; pbop_loc = loc} = + let op = map_loc sub op in + let pat = sub # pat pat in + let exp = sub # expr exp in + let loc = sub # location loc in + {pbop_op = op; pbop_pat = pat; pbop_exp = exp; pbop_loc = loc} + + let map sub {pexp_loc = loc; pexp_loc_stack = _; pexp_desc = desc; pexp_attributes = attrs} = + let open Exp in + let loc = sub # location loc in + let attrs = sub # attributes attrs in + match desc with + | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) + | Pexp_constant x -> constant ~loc ~attrs x + | Pexp_let (r, vbs, e) -> + let_ ~loc ~attrs r (List.map (sub # value_binding) vbs) (sub # expr e) + | Pexp_fun (lab, def, p, e) -> + fun_ ~loc ~attrs lab (map_opt (sub # expr) def) (sub # pat p) + (sub # expr e) + | Pexp_function pel -> function_ ~loc ~attrs (sub # cases pel) + | Pexp_apply (e, l) -> + apply ~loc ~attrs (sub # expr e) (List.map (map_snd (sub # expr)) l) + | Pexp_match (e, pel) -> match_ ~loc ~attrs (sub # expr e) (sub # cases pel) + | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub # expr e) (sub # cases pel) + | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub # expr) el) + | Pexp_construct (lid, arg) -> + construct ~loc ~attrs (map_loc sub lid) (map_opt (sub # expr) arg) + | Pexp_variant (lab, eo) -> + variant ~loc ~attrs lab (map_opt (sub # expr) eo) + | Pexp_record (l, eo) -> + record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub # expr)) l) + (map_opt (sub # expr) eo) + | Pexp_field (e, lid) -> field ~loc ~attrs (sub # expr e) (map_loc sub lid) + | Pexp_setfield (e1, lid, e2) -> + setfield ~loc ~attrs (sub # expr e1) (map_loc sub lid) (sub # expr e2) + | Pexp_array el -> array ~loc ~attrs (List.map (sub # expr) el) + | Pexp_ifthenelse (e1, e2, e3) -> + ifthenelse ~loc ~attrs (sub # expr e1) (sub # expr e2) + (map_opt (sub # expr) e3) + | Pexp_sequence (e1, e2) -> + sequence ~loc ~attrs (sub # expr e1) (sub # expr e2) + | Pexp_while (e1, e2) -> while_ ~loc ~attrs (sub # expr e1) (sub # expr e2) + | Pexp_for (p, e1, e2, d, e3) -> + for_ ~loc ~attrs (sub # pat p) (sub # expr e1) (sub # expr e2) d + (sub # expr e3) + | Pexp_coerce (e, t1, t2) -> + coerce ~loc ~attrs (sub # expr e) (map_opt (sub # typ) t1) + (sub # typ t2) + | Pexp_constraint (e, t) -> + constraint_ ~loc ~attrs (sub # expr e) (sub # typ t) + | Pexp_send (e, s) -> send ~loc ~attrs (sub # expr e) s + | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid) + | Pexp_setinstvar (s, e) -> + setinstvar ~loc ~attrs (map_loc sub s) (sub # expr e) + | Pexp_override sel -> + override ~loc ~attrs + (List.map (map_tuple (map_loc sub) (sub # expr)) sel) + | Pexp_letmodule (s, me, e) -> + letmodule ~loc ~attrs (map_loc sub s) (sub # module_expr me) + (sub # expr e) + | Pexp_letexception (cd, e) -> + letexception ~loc ~attrs + (sub # extension_constructor cd) + (sub # expr e) + | Pexp_assert e -> assert_ ~loc ~attrs (sub # expr e) + | Pexp_lazy e -> lazy_ ~loc ~attrs (sub # expr e) + | Pexp_poly (e, t) -> + poly ~loc ~attrs (sub # expr e) (map_opt (sub # typ) t) + | Pexp_object cls -> object_ ~loc ~attrs (sub # class_structure cls) + | Pexp_newtype (s, e) -> newtype ~loc ~attrs s (sub # expr e) + | Pexp_pack me -> pack ~loc ~attrs (sub # module_expr me) + | Pexp_open (od, e) -> + open_ ~loc ~attrs (sub # open_declaration od) (sub # expr e) + | Pexp_letop x -> + let let_ = map_binding_op sub x.let_ in + let ands = List.map (map_binding_op sub) x.ands in + let body = sub # expr x.body in + letop ~loc ~attrs let_ ands body + | Pexp_extension x -> extension ~loc ~attrs (sub # extension x) + | Pexp_unreachable -> unreachable ~loc ~attrs () +end + +module P = struct + (* Patterns *) + + let map sub {ppat_desc = desc; ppat_loc = loc; ppat_loc_stack = _; ppat_attributes = attrs} = + let open Pat in + let loc = sub # location loc in + let attrs = sub # attributes attrs in + match desc with + | Ppat_any -> any ~loc ~attrs () + | Ppat_var s -> var ~loc ~attrs (map_loc sub s) + | Ppat_alias (p, s) -> alias ~loc ~attrs (sub # pat p) (map_loc sub s) + | Ppat_constant c -> constant ~loc ~attrs c + | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2 + | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub # pat) pl) + | Ppat_construct (l, p) -> + construct ~loc ~attrs (map_loc sub l) (map_opt (sub # pat) p) + | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub # pat) p) + | Ppat_record (lpl, cf) -> + record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub # pat)) lpl) + cf + | Ppat_array pl -> array ~loc ~attrs (List.map (sub # pat) pl) + | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub # pat p1) (sub # pat p2) + | Ppat_constraint (p, t) -> + constraint_ ~loc ~attrs (sub # pat p) (sub # typ t) + | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) + | Ppat_lazy p -> lazy_ ~loc ~attrs (sub # pat p) + | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) + | Ppat_exception p -> exception_ ~loc ~attrs (sub # pat p) + | Ppat_extension x -> extension ~loc ~attrs (sub # extension x) + | Ppat_open (l, p) -> open_ ~loc ~attrs (map_loc sub l) (sub # pat p) +end + +module CE = struct + (* Value expressions for the class language *) + + let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = + let open Cl in + let loc = sub # location loc in + match desc with + | Pcl_constr (lid, tys) -> + constr ~loc ~attrs (map_loc sub lid) (List.map (sub # typ) tys) + | Pcl_structure s -> + structure ~loc ~attrs (sub # class_structure s) + | Pcl_fun (lab, e, p, ce) -> + fun_ ~loc ~attrs lab + (map_opt (sub # expr) e) + (sub # pat p) + (sub # class_expr ce) + | Pcl_apply (ce, l) -> + apply ~loc ~attrs (sub # class_expr ce) + (List.map (map_snd (sub # expr)) l) + | Pcl_let (r, vbs, ce) -> + let_ ~loc ~attrs r (List.map (sub # value_binding) vbs) + (sub # class_expr ce) + | Pcl_constraint (ce, ct) -> + constraint_ ~loc ~attrs (sub # class_expr ce) (sub # class_type ct) + | Pcl_extension x -> extension ~loc ~attrs (sub # extension x) + | Pcl_open (od, ce) -> + open_ ~loc ~attrs (sub # open_description od) (sub # class_expr ce) + + let map_kind sub = function + | Cfk_concrete (o, e) -> Cfk_concrete (o, sub # expr e) + | Cfk_virtual t -> Cfk_virtual (sub # typ t) + + let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = + let open Cf in + let loc = sub # location loc in + match desc with + | Pcf_inherit (o, ce, s) -> inherit_ ~loc ~attrs o (sub # class_expr ce) s + | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k) + | Pcf_method (s, p, k) -> + method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k) + | Pcf_constraint (t1, t2) -> + constraint_ ~loc ~attrs (sub # typ t1) (sub # typ t2) + | Pcf_initializer e -> initializer_ ~loc ~attrs (sub # expr e) + | Pcf_attribute x -> attribute ~loc (sub # attribute x) + | Pcf_extension x -> extension ~loc ~attrs (sub # extension x) + + let map_structure sub {pcstr_self; pcstr_fields} = + { + pcstr_self = sub # pat pcstr_self; + pcstr_fields = List.map (sub # class_field) pcstr_fields; + } + + let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; + pci_loc; pci_attributes} = + Ci.mk + ~virt:pci_virt + ~params:(List.map (map_fst (sub # typ)) pl) + (map_loc sub pci_name) + (f pci_expr) + ~loc:(sub # location pci_loc) + ~attrs:(sub # attributes pci_attributes) +end + +(* Now, a generic AST mapper class, to be extended to cover all kinds + and cases of the OCaml grammar. The default behavior of the mapper + is the identity. *) + +class mapper = + object(this) + method structure l = List.map (this # structure_item) l + method structure_item si = M.map_structure_item this si + method module_expr = M.map this + + method signature l = List.map (this # signature_item) l + method signature_item si = MT.map_signature_item this si + method module_type = MT.map this + method with_constraint c = MT.map_with_constraint this c + + method class_declaration = CE.class_infos this (this # class_expr) + method class_expr = CE.map this + method class_field = CE.map_field this + method class_structure = CE.map_structure this + + method class_type = CT.map this + method class_type_field = CT.map_field this + method class_signature = CT.map_signature this + + method class_type_declaration = CE.class_infos this (this # class_type) + method class_description = CE.class_infos this (this # class_type) + + method binding_op = E.map_binding_op this + + method type_declaration = T.map_type_declaration this + method type_kind = T.map_type_kind this + method typ = T.map this + + method type_extension = T.map_type_extension this + method type_exception = T.map_type_exception this + method extension_constructor = T.map_extension_constructor this + + method value_description {pval_name; pval_type; pval_prim; pval_loc; + pval_attributes} = + Val.mk + (map_loc this pval_name) + (this # typ pval_type) + ~attrs:(this # attributes pval_attributes) + ~loc:(this # location pval_loc) + ~prim:pval_prim + + method pat = P.map this + method expr = E.map this + + method module_declaration {pmd_name; pmd_type; pmd_attributes; pmd_loc} = + Md.mk + (map_loc this pmd_name) + (this # module_type pmd_type) + ~attrs:(this # attributes pmd_attributes) + ~loc:(this # location pmd_loc) + + method module_substitution {pms_name; pms_manifest; pms_attributes; pms_loc} = + Ms.mk + (map_loc this pms_name) + (map_loc this pms_manifest) + ~attrs:(this # attributes pms_attributes) + ~loc:(this # location pms_loc) + + method module_type_declaration {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} = + Mtd.mk + (map_loc this pmtd_name) + ?typ:(map_opt (this # module_type) pmtd_type) + ~attrs:(this # attributes pmtd_attributes) + ~loc:(this # location pmtd_loc) + + method module_binding {pmb_name; pmb_expr; pmb_attributes; pmb_loc} = + Mb.mk (map_loc this pmb_name) (this # module_expr pmb_expr) + ~attrs:(this # attributes pmb_attributes) + ~loc:(this # location pmb_loc) + + method value_binding {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} = + Vb.mk + (this # pat pvb_pat) + (this # expr pvb_expr) + ~attrs:(this # attributes pvb_attributes) + ~loc:(this # location pvb_loc) + + method constructor_arguments = function + | Pcstr_tuple (tys) -> Pcstr_tuple (List.map (this # typ) tys) + | Pcstr_record (ls) -> Pcstr_record (List.map (this # label_declaration) ls) + + method constructor_declaration {pcd_name; pcd_args; pcd_res; pcd_loc; + pcd_attributes} = + Type.constructor + (map_loc this pcd_name) + ~args:(this # constructor_arguments pcd_args) + ?res:(map_opt (this # typ) pcd_res) + ~loc:(this # location pcd_loc) + ~attrs:(this # attributes pcd_attributes) + + method label_declaration {pld_name; pld_type; pld_loc; pld_mutable; + pld_attributes} = + Type.field + (map_loc this pld_name) + (this # typ pld_type) + ~mut:pld_mutable + ~loc:(this # location pld_loc) + ~attrs:(this # attributes pld_attributes) + + + method cases l = List.map (this # case) l + method case {pc_lhs; pc_guard; pc_rhs} = + { + pc_lhs = this # pat pc_lhs; + pc_guard = map_opt (this # expr) pc_guard; + pc_rhs = this # expr pc_rhs; + } + + method open_declaration + {popen_expr; popen_override; popen_attributes; popen_loc} = + Opn.mk (this # module_expr popen_expr) + ~override:popen_override + ~loc:(this # location popen_loc) + ~attrs:(this # attributes popen_attributes) + + method open_description + {popen_expr; popen_override; popen_attributes; popen_loc} = + Opn.mk (map_loc this popen_expr) + ~override:popen_override + ~loc:(this # location popen_loc) + ~attrs:(this # attributes popen_attributes) + + method include_description + {pincl_mod; pincl_attributes; pincl_loc} = + Incl.mk (this # module_type pincl_mod) + ~loc:(this # location pincl_loc) + ~attrs:(this # attributes pincl_attributes) + + method include_declaration + {pincl_mod; pincl_attributes; pincl_loc} = + Incl.mk (this # module_expr pincl_mod) + ~loc:(this # location pincl_loc) + ~attrs:(this # attributes pincl_attributes) + + method location l = l + + method extension (s, e) = (map_loc this s, this # payload e) + + method attribute a = + { + attr_name = map_loc this a.attr_name; + attr_payload = this # payload a.attr_payload; + attr_loc = this # location a.attr_loc; + } + + method attributes l = List.map (this # attribute) l + + method payload = function + | PStr x -> PStr (this # structure x) + | PTyp x -> PTyp (this # typ x) + | PPat (x, g) -> PPat (this # pat x, map_opt (this # expr) g) + | PSig x -> PSig (this # signature x) + end + + +let to_mapper this = + let open Ast_mapper in + { + attribute = (fun _ -> this # attribute); + attributes = (fun _ -> this # attributes); + binding_op = (fun _ -> this # binding_op); + case = (fun _ -> this # case); + cases = (fun _ -> this # cases); + class_declaration = (fun _ -> this # class_declaration); + class_description = (fun _ -> this # class_description); + class_expr = (fun _ -> this # class_expr); + class_field = (fun _ -> this # class_field); + class_signature = (fun _ -> this # class_signature); + class_structure = (fun _ -> this # class_structure); + class_type = (fun _ -> this # class_type); + class_type_declaration = (fun _ -> this # class_type_declaration); + class_type_field = (fun _ -> this # class_type_field); + constructor_declaration = (fun _ -> this # constructor_declaration); + expr = (fun _ -> this # expr); + extension = (fun _ -> this # extension); + extension_constructor = (fun _ -> this # extension_constructor); + include_declaration = (fun _ -> this # include_declaration); + include_description = (fun _ -> this # include_description); + label_declaration = (fun _ -> this # label_declaration); + location = (fun _ -> this # location); + module_binding = (fun _ -> this # module_binding); + module_declaration = (fun _ -> this # module_declaration); + module_expr = (fun _ -> this # module_expr); + module_substitution = (fun _ -> this # module_substitution); + module_type = (fun _ -> this # module_type); + module_type_declaration = (fun _ -> this # module_type_declaration); + open_declaration = (fun _ -> this # open_declaration); + open_description = (fun _ -> this # open_description); + pat = (fun _ -> this # pat); + payload = (fun _ -> this # payload); + signature = (fun _ -> this # signature); + signature_item = (fun _ -> this # signature_item); + structure = (fun _ -> this # structure); + structure_item = (fun _ -> this # structure_item); + typ = (fun _ -> this # typ); + type_declaration = (fun _ -> this # type_declaration); + type_exception = (fun _ -> this # type_exception); + type_extension = (fun _ -> this # type_extension); + type_kind = (fun _ -> this # type_kind); + value_binding = (fun _ -> this # value_binding); + value_description = (fun _ -> this # value_description); + with_constraint = (fun _ -> this # with_constraint); + } diff --git a/ast_mapper_class_410.mli b/ast_mapper_class_410.mli new file mode 100644 index 0000000..c092f7e --- /dev/null +++ b/ast_mapper_class_410.mli @@ -0,0 +1,62 @@ +open Migrate_parsetree.Ast_410 + +(* This file is part of the ppx_tools package. It is released *) +(* under the terms of the MIT license (see LICENSE file). *) +(* Copyright 2013 Alain Frisch and LexiFi *) + +(** Class-based customizable mapper *) + +open Parsetree + +class mapper: + object + method attribute: attribute -> attribute + method attributes: attribute list -> attribute list + method binding_op: binding_op -> binding_op + method case: case -> case + method cases: case list -> case list + method class_declaration: class_declaration -> class_declaration + method class_description: class_description -> class_description + method class_expr: class_expr -> class_expr + method class_field: class_field -> class_field + method class_signature: class_signature -> class_signature + method class_structure: class_structure -> class_structure + method class_type: class_type -> class_type + method class_type_declaration: class_type_declaration -> class_type_declaration + method class_type_field: class_type_field -> class_type_field + method constructor_arguments: constructor_arguments -> constructor_arguments + method constructor_declaration: constructor_declaration -> constructor_declaration + method expr: expression -> expression + method extension: extension -> extension + method extension_constructor: extension_constructor -> extension_constructor + method include_declaration: include_declaration -> include_declaration + method include_description: include_description -> include_description + method label_declaration: label_declaration -> label_declaration + method location: Location.t -> Location.t + method module_binding: module_binding -> module_binding + method module_declaration: module_declaration -> module_declaration + method module_substitution: module_substitution -> module_substitution + method module_expr: module_expr -> module_expr + method module_type: module_type -> module_type + method module_type_declaration: module_type_declaration -> module_type_declaration + method open_declaration: open_declaration -> open_declaration + method open_description: open_description -> open_description + method pat: pattern -> pattern + method payload: payload -> payload + method signature: signature -> signature + method signature_item: signature_item -> signature_item + method structure: structure -> structure + method structure_item: structure_item -> structure_item + method typ: core_type -> core_type + method type_declaration: type_declaration -> type_declaration + method type_exception: type_exception -> type_exception + method type_extension: type_extension -> type_extension + method type_kind: type_kind -> type_kind + method value_binding: value_binding -> value_binding + method value_description: value_description -> value_description + method with_constraint: with_constraint -> with_constraint + end + +val to_mapper: #mapper -> Ast_mapper.mapper +(** The resulting mapper is "closed", i.e. methods ignore + their first argument. *) @@ -13,7 +13,8 @@ ast_convenience_405 ast_mapper_class_405 ast_lifter_405 ppx_tools_405 ast_convenience_406 ast_mapper_class_406 ast_lifter_406 ppx_tools_406 ast_convenience_407 ast_mapper_class_407 ast_lifter_407 ppx_tools_407 ast_convenience_408 ast_mapper_class_408 ast_lifter_408 ppx_tools_408 -ast_convenience_409 ast_mapper_class_409 ast_lifter_409 ppx_tools_409)) +ast_convenience_409 ast_mapper_class_409 ast_lifter_409 ppx_tools_409 +ast_convenience_410 ast_mapper_class_410 ast_lifter_410 ppx_tools_410)) (library (name ppx_tools_versioned_metaquot_402) @@ -94,3 +95,13 @@ ast_convenience_409 ast_mapper_class_409 ast_lifter_409 ppx_tools_409)) (wrapped false) (modules ppx_metaquot_409) (flags (:standard -w +A-4-17-44-45-105-42 -safe-string))) + +(library + (name ppx_tools_versioned_metaquot_410) + (public_name ppx_tools_versioned.metaquot_410) + (synopsis "Meta-quotation: 4.10 parsetree quotation") + (libraries ocaml-migrate-parsetree ppx_tools_versioned) + (kind ppx_rewriter) + (wrapped false) + (modules ppx_metaquot_410) + (flags (:standard -w +A-4-17-44-45-105-42 -safe-string))) diff --git a/gen/update_dune.ml b/gen/update_dune.ml index 8f9c10a..0f39dd0 100644 --- a/gen/update_dune.ml +++ b/gen/update_dune.ml @@ -1,4 +1,4 @@ -let versions = ["402"; "403"; "404"; "405"; "406"; "407"; "408"; "409"] +let versions = ["402"; "403"; "404"; "405"; "406"; "407"; "408"; "409"; "410"] let flags = "(:standard -w +A-4-17-44-45-105-42 -safe-string)" diff --git a/pkg/pkg.ml b/pkg/pkg.ml deleted file mode 100644 index 1a04c2b..0000000 --- a/pkg/pkg.ml +++ /dev/null @@ -1,2 +0,0 @@ -#use "topfind" -#require "topkg-jbuilder.auto" diff --git a/ppx_metaquot_410.ml b/ppx_metaquot_410.ml new file mode 100644 index 0000000..520d3e1 --- /dev/null +++ b/ppx_metaquot_410.ml @@ -0,0 +1,285 @@ +open Migrate_parsetree.Ast_410 + +(* This file is part of the ppx_tools package. It is released *) +(* under the terms of the MIT license (see LICENSE file). *) +(* Copyright 2013 Alain Frisch and LexiFi *) + +(* A -ppx rewriter to be used to write Parsetree-generating code + (including other -ppx rewriters) using concrete syntax. + + We support the following extensions in expression position: + + [%expr ...] maps to code which creates the expression represented by ... + [%pat? ...] maps to code which creates the pattern represented by ... + [%str ...] maps to code which creates the structure represented by ... + [%stri ...] maps to code which creates the structure item represented by ... + [%sig: ...] maps to code which creates the signature represented by ... + [%sigi: ...] maps to code which creates the signature item represented by ... + [%type: ...] maps to code which creates the core type represented by ... + + Quoted code can refer to expressions representing AST fragments, + using the following extensions: + + [%e ...] where ... is an expression of type Parsetree.expression + [%t ...] where ... is an expression of type Parsetree.core_type + [%p ...] where ... is an expression of type Parsetree.pattern + [%%s ...] where ... is an expression of type Parsetree.structure + or Parsetree.signature depending on the context. + + + All locations generated by the meta quotation are by default set + to [Ast_helper.default_loc]. This can be overriden by providing a custom + expression which will be inserted whereever a location is required + in the generated AST. This expression can be specified globally + (for the current structure) as a structure item attribute: + + ;;[@@metaloc ...] + + or locally for the scope of an expression: + + e [@metaloc ...] + + + + Support is also provided to use concrete syntax in pattern + position. The location and attribute fields are currently ignored + by patterns generated from meta quotations. + + We support the following extensions in pattern position: + + [%expr ...] maps to code which creates the expression represented by ... + [%pat? ...] maps to code which creates the pattern represented by ... + [%str ...] maps to code which creates the structure represented by ... + [%type: ...] maps to code which creates the core type represented by ... + + Quoted code can refer to expressions representing AST fragments, + using the following extensions: + + [%e? ...] where ... is a pattern of type Parsetree.expression + [%t? ...] where ... is a pattern of type Parsetree.core_type + [%p? ...] where ... is a pattern of type Parsetree.pattern + +*) + +module Main : sig end = struct + open Asttypes + open Parsetree + open Ast_helper + open Ast_convenience_410 + + let prefix ty s = + let open Longident in + match parse ty with + | Ldot(m, _) -> String.concat "." (Longident.flatten m) ^ "." ^ s + | _ -> s + + let append ?loc ?attrs e e' = + let fn = Location.mknoloc (Longident.(Ldot (Lident "List", "append"))) in + Exp.apply ?loc ?attrs (Exp.ident fn) [Nolabel, e; Nolabel, e'] + + class exp_builder = + object + method record ty x = record (List.map (fun (l, e) -> prefix ty l, e) x) + method constr ty (c, args) = constr (prefix ty c) args + method list l = list l + method tuple l = tuple l + method int i = int i + method string s = str s + method char c = char c + method int32 x = Exp.constant (Const.int32 x) + method int64 x = Exp.constant (Const.int64 x) + method nativeint x = Exp.constant (Const.nativeint x) + end + + class pat_builder = + object + method record ty x = precord ~closed:Closed (List.map (fun (l, e) -> prefix ty l, e) x) + method constr ty (c, args) = pconstr (prefix ty c) args + method list l = plist l + method tuple l = ptuple l + method int i = pint i + method string s = pstr s + method char c = pchar c + method int32 x = Pat.constant (Const.int32 x) + method int64 x = Pat.constant (Const.int64 x) + method nativeint x = Pat.constant (Const.nativeint x) + end + + + let get_exp loc = function + | PStr [ {pstr_desc=Pstr_eval (e, _); _} ] -> e + | _ -> + Format.eprintf "%aError: Expression expected@." + Location.print_loc loc; + exit 2 + + let get_typ loc = function + | PTyp t -> t + | _ -> + Format.eprintf "%aError: Type expected@." + Location.print_loc loc; + exit 2 + + let get_pat loc = function + | PPat (t, None) -> t + | _ -> + Format.eprintf "%aError: Pattern expected@." + Location.print_loc loc; + exit 2 + + let exp_lifter loc map = + let map = map.Ast_mapper.expr map in + object + inherit [_] Ast_lifter_410.lifter as super + inherit exp_builder + + (* Special support for location in the generated AST *) + method! lift_Location_t _ = loc + + (* Support for antiquotations *) + method! lift_Parsetree_expression = function + | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> map (get_exp loc e) + | x -> super # lift_Parsetree_expression x + + method! lift_Parsetree_pattern = function + | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> map (get_exp loc e) + | x -> super # lift_Parsetree_pattern x + + method! lift_Parsetree_structure str = + List.fold_right + (function + | {pstr_desc=Pstr_extension(({txt="s";loc}, e), _); _} -> + append (get_exp loc e) + | x -> + cons (super # lift_Parsetree_structure_item x)) + str (nil ()) + + method! lift_Parsetree_signature sign = + List.fold_right + (function + | {psig_desc=Psig_extension(({txt="s";loc}, e), _); _} -> + append (get_exp loc e) + | x -> + cons (super # lift_Parsetree_signature_item x)) + sign (nil ()) + + method! lift_Parsetree_core_type = function + | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} -> map (get_exp loc e) + | x -> super # lift_Parsetree_core_type x + end + + let pat_lifter map = + let map = map.Ast_mapper.pat map in + object + inherit [_] Ast_lifter_410.lifter as super + inherit pat_builder + + (* Special support for location and attributes in the generated AST *) + method! lift_Location_t _ = Pat.any () + method! lift_Parsetree_attributes _ = Pat.any () + method! lift_loc_stack _ = Pat.any () + + + (* Support for antiquotations *) + method! lift_Parsetree_expression = function + | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> map (get_pat loc e) + | x -> super # lift_Parsetree_expression x + + method! lift_Parsetree_pattern = function + | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> map (get_pat loc e) + | x -> super # lift_Parsetree_pattern x + + method! lift_Parsetree_core_type = function + | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} -> map (get_pat loc e) + | x -> super # lift_Parsetree_core_type x + end + + let loc = ref (Exp.field (evar "Ast_helper.default_loc") (lid "contents")) + + let handle_attr = function + | { attr_name = {txt="metaloc";loc=l} + ; attr_payload = e + ; attr_loc = _ } -> loc := get_exp l e + | _ -> () + + let with_loc ?(attrs = []) f = + let old_loc = !loc in + List.iter handle_attr attrs; + let r = f () in + loc := old_loc; + r + + let expander _config _cookies = + let open Ast_mapper in + let super = default_mapper in + let expr this e = + with_loc ~attrs:e.pexp_attributes + (fun () -> + match e.pexp_desc with + | Pexp_extension({txt="expr";loc=l}, e) -> + (exp_lifter !loc this) # lift_Parsetree_expression (get_exp l e) + | Pexp_extension({txt="pat";loc=l}, e) -> + (exp_lifter !loc this) # lift_Parsetree_pattern (get_pat l e) + | Pexp_extension({txt="str";_}, PStr e) -> + (exp_lifter !loc this) # lift_Parsetree_structure e + | Pexp_extension({txt="stri";_}, PStr [e]) -> + (exp_lifter !loc this) # lift_Parsetree_structure_item e + | Pexp_extension({txt="sig";_}, PSig e) -> + (exp_lifter !loc this) # lift_Parsetree_signature e + | Pexp_extension({txt="sigi";_}, PSig [e]) -> + (exp_lifter !loc this) # lift_Parsetree_signature_item e + | Pexp_extension({txt="type";loc=l}, e) -> + (exp_lifter !loc this) # lift_Parsetree_core_type (get_typ l e) + | _ -> + super.expr this e + ) + and pat this p = + with_loc ~attrs:p.ppat_attributes + (fun () -> + match p.ppat_desc with + | Ppat_extension({txt="expr";loc=l}, e) -> + (pat_lifter this) # lift_Parsetree_expression (get_exp l e) + | Ppat_extension({txt="pat";loc=l}, e) -> + (pat_lifter this) # lift_Parsetree_pattern (get_pat l e) + | Ppat_extension({txt="str";_}, PStr e) -> + (pat_lifter this) # lift_Parsetree_structure e + | Ppat_extension({txt="stri";_}, PStr [e]) -> + (pat_lifter this) # lift_Parsetree_structure_item e + | Ppat_extension({txt="sig";_}, PSig e) -> + (pat_lifter this) # lift_Parsetree_signature e + | Ppat_extension({txt="sigi";_}, PSig [e]) -> + (pat_lifter this) # lift_Parsetree_signature_item e + | Ppat_extension({txt="type";loc=l}, e) -> + (pat_lifter this) # lift_Parsetree_core_type (get_typ l e) + | _ -> + super.pat this p + ) + and structure this l = + with_loc + (fun () -> super.structure this l) + + and structure_item this x = + begin match x.pstr_desc with + | Pstr_attribute x -> handle_attr x + | _ -> () + end; + super.structure_item this x + + and signature this l = + with_loc + (fun () -> super.signature this l) + + and signature_item this x = + begin match x.psig_desc with + | Psig_attribute x -> handle_attr x + | _ -> () + end; + super.signature_item this x + + in + {super with expr; pat; structure; structure_item; signature; signature_item} + + let () = + let open Migrate_parsetree in + Driver.register ~name:"metaquot_410" Versions.ocaml_410 expander +end diff --git a/ppx_tools_410.ml b/ppx_tools_410.ml new file mode 100644 index 0000000..9b5b9ec --- /dev/null +++ b/ppx_tools_410.ml @@ -0,0 +1,2 @@ +module Ast_convenience = Ast_convenience_410 +module Ast_mapper_class = Ast_mapper_class_410 diff --git a/ppx_tools_versioned.opam b/ppx_tools_versioned.opam index e707b6b..b20bc96 100644 --- a/ppx_tools_versioned.opam +++ b/ppx_tools_versioned.opam @@ -17,6 +17,6 @@ build: [ depends: [ "ocaml" {>= "4.02.0"} "dune" {build & >= "1.0"} - "ocaml-migrate-parsetree" {>= "1.4.0"} + "ocaml-migrate-parsetree" {>= "1.5.0"} ] synopsis: "A variant of ppx_tools based on ocaml-migrate-parsetree" |