diff --git a/CHANGELOG.md b/CHANGELOG.md index 980bc24bd4..60e00efb5d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -18,6 +18,7 @@ #### :house: Internal - Use latest compiler for tests. https://github.com/rescript-lang/rescript/pull/7186 +- Added infra to modernise AST: theres' Parsetree, Parsetree0 (legacy), and conversion functions to keep compatibility with PPX. https://github.com/rescript-lang/rescript/pull/7185 # 12.0.0-alpha.5 diff --git a/compiler/bsc/rescript_compiler_main.ml b/compiler/bsc/rescript_compiler_main.ml index fa84fe09c0..caa2312b1d 100644 --- a/compiler/bsc/rescript_compiler_main.ml +++ b/compiler/bsc/rescript_compiler_main.ml @@ -134,23 +134,16 @@ let ppf = Format.err_formatter (* Error messages to standard error formatter *) let anonymous ~(rev_args : string list) = - if !Js_config.as_ppx then - match rev_args with - | [output; input] -> - Ppx_apply.apply_lazy ~source:input ~target:output - Ppx_entry.rewrite_implementation Ppx_entry.rewrite_signature - | _ -> Bsc_args.bad_arg "Wrong format when use -as-ppx" - else - match rev_args with - | [filename] -> process_file filename ppf - | [] -> () - | _ -> - if !Js_config.syntax_only then - Ext_list.rev_iter rev_args (fun filename -> - Clflags.reset_dump_state (); - Warnings.reset (); - process_file filename ppf) - else Bsc_args.bad_arg "can not handle multiple files" + match rev_args with + | [filename] -> process_file filename ppf + | [] -> () + | _ -> + if !Js_config.syntax_only then + Ext_list.rev_iter rev_args (fun filename -> + Clflags.reset_dump_state (); + Warnings.reset (); + process_file filename ppf) + else Bsc_args.bad_arg "can not handle multiple files" let format_file input = let ext = @@ -295,7 +288,6 @@ let buckle_script_flags : (string * Bsc_args.spec * string) array = string_call Js_packages_state.set_package_map, "*internal* Set package map, not only set package name but also use it \ as a namespace" ); - ("-as-ppx", set Js_config.as_ppx, "*internal*As ppx for editor integration"); ( "-as-pp", unit_call (fun _ -> Js_config.as_pp := true; @@ -408,7 +400,6 @@ let buckle_script_flags : (string * Bsc_args.spec * string) array = ( "-bs-no-bin-annot", clear Clflags.binary_annotations, "*internal* Disable binary annotations (by default on)" ); - ("-modules", set Js_config.modules, "*internal* serve similar to ocamldep"); ( "-short-paths", clear Clflags.real_paths, "*internal* Shorten paths in types" ); diff --git a/compiler/common/js_config.ml b/compiler/common/js_config.ml index 6629a1278b..3801ffa7be 100644 --- a/compiler/common/js_config.ml +++ b/compiler/common/js_config.ml @@ -56,8 +56,6 @@ let js_stdout = ref true let all_module_aliases = ref false let no_stdlib = ref false let no_export = ref false -let as_ppx = ref false - let int_of_jsx_version = function | Jsx_v4 -> 4 @@ -86,4 +84,3 @@ let jsx_mode_of_string = function let customize_runtime : string option ref = ref None let as_pp = ref false let self_stack : string Stack.t = Stack.create () -let modules = ref false diff --git a/compiler/common/js_config.mli b/compiler/common/js_config.mli index ed0984624f..5f84072609 100644 --- a/compiler/common/js_config.mli +++ b/compiler/common/js_config.mli @@ -91,8 +91,6 @@ val no_stdlib : bool ref val no_export : bool ref -val as_ppx : bool ref - val int_of_jsx_version : jsx_version -> int val string_of_jsx_module : jsx_module -> string @@ -110,5 +108,3 @@ val customize_runtime : string option ref val as_pp : bool ref val self_stack : string Stack.t - -val modules : bool ref diff --git a/compiler/common/ml_binary.ml b/compiler/common/ml_binary.ml index 0d4d5cc297..ae7e441c82 100644 --- a/compiler/common/ml_binary.ml +++ b/compiler/common/ml_binary.ml @@ -24,29 +24,33 @@ type _ kind = Ml : Parsetree.structure kind | Mli : Parsetree.signature kind -(** [read_ast kind ic] assume [ic] channel is - in the right position *) -let read_ast (type t) (kind : t kind) ic : t = - let magic = - match kind with - | Ml -> Config.ast_impl_magic_number - | Mli -> Config.ast_intf_magic_number - in - let buffer = really_input_string ic (String.length magic) in - assert (buffer = magic); - (* already checked by apply_rewriter *) - Location.set_input_name (input_value ic); - input_value ic +type ast0 = Impl of Parsetree0.structure | Intf of Parsetree0.signature -let write_ast (type t) (kind : t kind) (fname : string) (pt : t) oc = - let magic = - match kind with - | Ml -> Config.ast_impl_magic_number - | Mli -> Config.ast_intf_magic_number - in - output_string oc magic; - output_value oc fname; - output_value oc pt +let magic_of_ast0 : ast0 -> string = function + | Impl _ -> Config.ast_impl_magic_number + | Intf _ -> Config.ast_intf_magic_number + +let to_ast0 : type a. a kind -> a -> ast0 = + fun kind ast -> + match kind with + | Ml -> + Impl + (Ast_mapper_to0.default_mapper.structure Ast_mapper_to0.default_mapper ast) + | Mli -> + Intf + (Ast_mapper_to0.default_mapper.signature Ast_mapper_to0.default_mapper ast) + +let ast0_to_structure : ast0 -> Parsetree.structure = function + | Impl str0 -> + Ast_mapper_from0.default_mapper.structure Ast_mapper_from0.default_mapper + str0 + | Intf _ -> assert false + +let ast0_to_signature : ast0 -> Parsetree.signature = function + | Impl _ -> assert false + | Intf sig0 -> + Ast_mapper_from0.default_mapper.signature Ast_mapper_from0.default_mapper + sig0 let magic_of_kind : type a. a kind -> string = function | Ml -> Config.ast_impl_magic_number diff --git a/compiler/common/ml_binary.mli b/compiler/common/ml_binary.mli index fd403167dc..7749e8ccec 100644 --- a/compiler/common/ml_binary.mli +++ b/compiler/common/ml_binary.mli @@ -27,8 +27,10 @@ *) type _ kind = Ml : Parsetree.structure kind | Mli : Parsetree.signature kind -val read_ast : 'a kind -> in_channel -> 'a - -val write_ast : 'a kind -> string -> 'a -> out_channel -> unit +type ast0 = Impl of Parsetree0.structure | Intf of Parsetree0.signature val magic_of_kind : 'a kind -> string +val magic_of_ast0 : ast0 -> string +val to_ast0 : 'a kind -> 'a -> ast0 +val ast0_to_structure : ast0 -> Parsetree.structure +val ast0_to_signature : ast0 -> Parsetree.signature diff --git a/compiler/core/cmd_ppx_apply.ml b/compiler/core/cmd_ppx_apply.ml index 3f1a64feaa..dc2f50d040 100644 --- a/compiler/core/cmd_ppx_apply.ml +++ b/compiler/core/cmd_ppx_apply.ml @@ -24,11 +24,13 @@ (* Note: some of the functions here should go to Ast_mapper instead, which would encapsulate the "binary AST" protocol. *) -let write_ast (type a) (kind : a Ml_binary.kind) fn (ast : a) = +let write_ast fn (ast0 : Ml_binary.ast0) = let oc = open_out_bin fn in - output_string oc (Ml_binary.magic_of_kind kind); + output_string oc (Ml_binary.magic_of_ast0 ast0); output_value oc (!Location.input_name : string); - output_value oc (ast : a); + (match ast0 with + | Ml_binary.Impl ast -> output_value oc (ast : Parsetree0.structure) + | Ml_binary.Intf ast -> output_value oc (ast : Parsetree0.signature)); close_out oc let temp_ppx_file () = @@ -53,17 +55,20 @@ let apply_rewriter kind fn_in ppx = fn_out (* This is a fatal error, no need to protect it *) -let read_ast (type a) (kind : a Ml_binary.kind) fn : a = +let read_ast (type a) (kind : a Ml_binary.kind) fn : Ml_binary.ast0 = let ic = open_in_bin fn in let magic = Ml_binary.magic_of_kind kind in let buffer = really_input_string ic (String.length magic) in assert (buffer = magic); (* already checked by apply_rewriter *) Location.set_input_name @@ (input_value ic : string); - let ast = (input_value ic : a) in + let ast0 = + match kind with + | Ml_binary.Ml -> Ml_binary.Impl (input_value ic : Parsetree0.structure) + | Ml_binary.Mli -> Ml_binary.Intf (input_value ic : Parsetree0.signature) + in close_in ic; - - ast + ast0 (** [ppxs] are a stack, [-ppx1 -ppx2 -ppx3] @@ -71,7 +76,8 @@ let read_ast (type a) (kind : a Ml_binary.kind) fn : a = [fold_right] happens to process the first one *) let rewrite kind ppxs ast = let fn_in = temp_ppx_file () in - write_ast kind fn_in ast; + let ast0 = Ml_binary.to_ast0 kind ast in + write_ast fn_in ast0; let temp_files = List.fold_right (fun ppx fns -> @@ -93,7 +99,7 @@ let apply_rewriters_str ?(restore = true) ~tool_name ast = | ppxs -> ast |> Ast_mapper.add_ppx_context_str ~tool_name - |> rewrite Ml ppxs + |> rewrite Ml ppxs |> Ml_binary.ast0_to_structure |> Ast_mapper.drop_ppx_context_str ~restore let apply_rewriters_sig ?(restore = true) ~tool_name ast = @@ -102,7 +108,7 @@ let apply_rewriters_sig ?(restore = true) ~tool_name ast = | ppxs -> ast |> Ast_mapper.add_ppx_context_sig ~tool_name - |> rewrite Mli ppxs + |> rewrite Mli ppxs |> Ml_binary.ast0_to_signature |> Ast_mapper.drop_ppx_context_sig ~restore let apply_rewriters ?restore ~tool_name (type a) (kind : a Ml_binary.kind) diff --git a/compiler/core/js_implementation.ml b/compiler/core/js_implementation.ml index e097d6141a..9adcf8d0d0 100644 --- a/compiler/core/js_implementation.ml +++ b/compiler/core/js_implementation.ml @@ -30,26 +30,12 @@ let print_if_pipe ppf flag printer arg = let print_if ppf flag printer arg = if !flag then fprintf ppf "%a@." printer arg -let output_deps_set name set = - output_string stdout name; - output_string stdout ": "; - Depend.StringSet.iter - (fun s -> - if s <> "" && s.[0] <> '*' then ( - output_string stdout s; - output_string stdout " ")) - set; - output_string stdout "\n" - let process_with_gentype cmt_file = if !Clflags.bs_gentype then GenTypeMain.process_cmt_file cmt_file let after_parsing_sig ppf outputprefix ast = if !Clflags.only_parse = false then ( Ast_config.process_sig ast; - if !Js_config.modules then - output_deps_set !Location.input_name - (Ast_extract.read_parse_and_extract Mli ast); (if !Js_config.binary_ast then let sourcefile = !Location.input_name in Binary_ast.write_ast Mli ~sourcefile @@ -133,9 +119,6 @@ let after_parsing_impl ppf outputprefix (ast : Parsetree.structure) = !Clflags.assume_no_mli = Mli_non_exists && all_module_alias ast; Ast_config.process_str ast; let ast = if !Js_config.no_export then no_export ast else ast in - if !Js_config.modules then - output_deps_set !Location.input_name - (Ast_extract.read_parse_and_extract Ml ast); (if !Js_config.binary_ast then let sourcefile = !Location.input_name in Binary_ast.write_ast ~sourcefile Ml diff --git a/compiler/frontend/bs_ast_mapper.ml b/compiler/frontend/bs_ast_mapper.ml index a0ff1a7fc0..e37436ff95 100644 --- a/compiler/frontend/bs_ast_mapper.ml +++ b/compiler/frontend/bs_ast_mapper.ml @@ -107,7 +107,6 @@ module T = struct constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) | Ptyp_object (l, o) -> object_ ~loc ~attrs (List.map (object_field sub) l) o - | Ptyp_class () -> assert false | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s | Ptyp_variant (rl, b, ll) -> variant ~loc ~attrs (List.map (row_field sub) rl) b ll diff --git a/compiler/frontend/ppx_apply.ml b/compiler/frontend/ppx_apply.ml deleted file mode 100644 index 4a3570fef9..0000000000 --- a/compiler/frontend/ppx_apply.ml +++ /dev/null @@ -1,49 +0,0 @@ -(* Copyright (C) 2020- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let apply_lazy ~source ~target - (impl : Parsetree.structure -> Parsetree.structure) - (iface : Parsetree.signature -> Parsetree.signature) = - let ic = open_in_bin source in - let magic = - really_input_string ic (String.length Config.ast_impl_magic_number) - in - if - magic <> Config.ast_impl_magic_number - && magic <> Config.ast_intf_magic_number - then failwith "Bs_ast_mapper: OCaml version mismatch or malformed input"; - Location.set_input_name @@ input_value ic; - let ast = input_value ic in - close_in ic; - - let ast = - if magic = Config.ast_impl_magic_number then - Obj.magic (impl (Obj.magic ast)) - else Obj.magic (iface (Obj.magic ast)) - in - let oc = open_out_bin target in - output_string oc magic; - output_value oc !Location.input_name; - output_value oc ast; - close_out oc diff --git a/compiler/gentype/TranslateCoreType.ml b/compiler/gentype/TranslateCoreType.ml index f9e9ef7174..e6ec268ce6 100644 --- a/compiler/gentype/TranslateCoreType.ml +++ b/compiler/gentype/TranslateCoreType.ml @@ -269,7 +269,7 @@ and translateCoreType_ ~config ~type_vars_gen type_; } | None -> {dependencies = []; type_ = unknown}) - | Ttyp_any | Ttyp_class _ -> {dependencies = []; type_ = unknown} + | Ttyp_any -> {dependencies = []; type_ = unknown} and translateCoreTypes_ ~config ~type_vars_gen ~type_env type_exprs : translation list = diff --git a/compiler/ml/ast_helper.ml b/compiler/ml/ast_helper.ml index 37f1542baf..9406274366 100644 --- a/compiler/ml/ast_helper.ml +++ b/compiler/ml/ast_helper.ml @@ -90,7 +90,6 @@ module Typ = struct | Ptyp_constr (longident, lst) -> Ptyp_constr (longident, List.map loop lst) | Ptyp_object (lst, o) -> Ptyp_object (List.map loop_object_field lst, o) - | Ptyp_class () -> assert false | Ptyp_alias (core_type, string) -> check_variable var_names t.ptyp_loc string; Ptyp_alias (loop core_type, string) diff --git a/compiler/ml/ast_helper0.ml b/compiler/ml/ast_helper0.ml new file mode 100644 index 0000000000..db575477b3 --- /dev/null +++ b/compiler/ml/ast_helper0.ml @@ -0,0 +1,369 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Helpers to produce Parsetree fragments *) + +open Asttypes +open Parsetree0 + +type lid = Longident.t loc +type str = string loc +type loc = Location.t +type attrs = attribute list + +let default_loc = ref Location.none + +let with_default_loc l f = + let old = !default_loc in + default_loc := l; + try + let r = f () in + default_loc := old; + r + with exn -> + default_loc := old; + raise exn + +module Const = struct + let integer ?suffix i = Pconst_integer (i, suffix) + let int ?suffix i = integer ?suffix (string_of_int i) + let int32 ?(suffix = 'l') i = integer ~suffix (Int32.to_string i) + let int64 ?(suffix = 'L') i = integer ~suffix (Int64.to_string i) + let nativeint ?(suffix = 'n') i = integer ~suffix (Nativeint.to_string i) + let float ?suffix f = Pconst_float (f, suffix) + let char c = Pconst_char (Char.code c) + let string ?quotation_delimiter s = Pconst_string (s, quotation_delimiter) +end + +module Typ = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + {ptyp_desc = d; ptyp_loc = loc; ptyp_attributes = attrs} + let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]} + + let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any + let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) + let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c)) + let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) + let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) + let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) + let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b)) + let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c)) + let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b)) + let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b)) + let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a) + + let force_poly t = + match t.ptyp_desc with + | Ptyp_poly _ -> t + | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *) + + let varify_constructors var_names t = + let check_variable vl loc v = + if List.mem v vl then raise Syntaxerr.(Error (Variable_in_scope (loc, v))) + in + let var_names = List.map (fun v -> v.txt) var_names in + let rec loop t = + let desc = + match t.ptyp_desc with + | Ptyp_any -> Ptyp_any + | Ptyp_var x -> + check_variable var_names t.ptyp_loc x; + Ptyp_var x + | Ptyp_arrow (label, core_type, core_type') -> + Ptyp_arrow (label, loop core_type, loop core_type') + | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) + | Ptyp_constr ({txt = Longident.Lident s}, []) when List.mem s var_names + -> + Ptyp_var s + | Ptyp_constr (longident, lst) -> + Ptyp_constr (longident, List.map loop lst) + | Ptyp_object (lst, o) -> Ptyp_object (List.map loop_object_field lst, o) + | Ptyp_class () -> assert false + | Ptyp_alias (core_type, string) -> + check_variable var_names t.ptyp_loc string; + Ptyp_alias (loop core_type, string) + | Ptyp_variant (row_field_list, flag, lbl_lst_option) -> + Ptyp_variant + (List.map loop_row_field row_field_list, flag, lbl_lst_option) + | Ptyp_poly (string_lst, core_type) -> + List.iter + (fun v -> check_variable var_names t.ptyp_loc v.txt) + string_lst; + Ptyp_poly (string_lst, loop core_type) + | Ptyp_package (longident, lst) -> + Ptyp_package (longident, List.map (fun (n, typ) -> (n, loop typ)) lst) + | Ptyp_extension (s, arg) -> Ptyp_extension (s, arg) + in + {t with ptyp_desc = desc} + and loop_row_field = function + | Rtag (label, attrs, flag, lst) -> + Rtag (label, attrs, flag, List.map loop lst) + | Rinherit t -> Rinherit (loop t) + and loop_object_field = function + | Otag (label, attrs, t) -> Otag (label, attrs, loop t) + | Oinherit t -> Oinherit (loop t) + in + loop t +end + +module Pat = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + {ppat_desc = d; ppat_loc = loc; ppat_attributes = attrs} + let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]} + + let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any + let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a) + let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b)) + let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a) + let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b)) + let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) + let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) + let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) + let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) + let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a) + let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) + let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b)) + let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a) + let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a) + let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a) + let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b)) + let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a) + let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a) +end + +module Exp = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + {pexp_desc = d; pexp_loc = loc; pexp_attributes = attrs} + let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]} + + let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) + let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) + let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) + let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d)) + let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) + let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) + let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) + let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) + let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) + let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) + let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) + let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) + let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) + let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) + let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a) + let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c)) + let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b)) + let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b)) + let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e)) + let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b)) + let coerce ?loc ?attrs a c = mk ?loc ?attrs (Pexp_coerce (a, (), c)) + let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) + let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a) + let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b)) + let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a) + let letmodule ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_letmodule (a, b, c)) + let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) + let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) + let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a) + let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b)) + let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b)) + let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) + let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_open (a, b, c)) + let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) + let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable + + let case lhs ?guard rhs = {pc_lhs = lhs; pc_guard = guard; pc_rhs = rhs} +end + +module Mty = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs} + let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]} + + let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) + let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) + let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a) + let functor_ ?loc ?attrs a b c = mk ?loc ?attrs (Pmty_functor (a, b, c)) + let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b)) + let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a) + let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a) +end + +module Mod = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} + let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]} + + let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) + let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) + let functor_ ?loc ?attrs arg arg_ty body = + mk ?loc ?attrs (Pmod_functor (arg, arg_ty, body)) + let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) + let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) + let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) + let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a) +end + +module Sig = struct + let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc} + + let value ?loc a = mk ?loc (Psig_value a) + let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a)) + let type_extension ?loc a = mk ?loc (Psig_typext a) + let exception_ ?loc a = mk ?loc (Psig_exception a) + let module_ ?loc a = mk ?loc (Psig_module a) + let rec_module ?loc a = mk ?loc (Psig_recmodule a) + let modtype ?loc a = mk ?loc (Psig_modtype a) + let open_ ?loc a = mk ?loc (Psig_open a) + let include_ ?loc a = mk ?loc (Psig_include a) + + let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs)) + let attribute ?loc a = mk ?loc (Psig_attribute a) +end + +module Str = struct + let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc} + + let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs)) + let value ?loc a b = mk ?loc (Pstr_value (a, b)) + let primitive ?loc a = mk ?loc (Pstr_primitive a) + let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a)) + let type_extension ?loc a = mk ?loc (Pstr_typext a) + let exception_ ?loc a = mk ?loc (Pstr_exception a) + let module_ ?loc a = mk ?loc (Pstr_module a) + let rec_module ?loc a = mk ?loc (Pstr_recmodule a) + let modtype ?loc a = mk ?loc (Pstr_modtype a) + let open_ ?loc a = mk ?loc (Pstr_open a) + let include_ ?loc a = mk ?loc (Pstr_include a) + let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs)) + let attribute ?loc a = mk ?loc (Pstr_attribute a) +end + +module Val = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?(prim = []) name typ = + { + pval_name = name; + pval_type = typ; + pval_attributes = attrs; + pval_loc = loc; + pval_prim = prim; + } +end + +module Md = struct + let mk ?(loc = !default_loc) ?(attrs = []) name typ = + {pmd_name = name; pmd_type = typ; pmd_attributes = attrs; pmd_loc = loc} +end + +module Mtd = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?typ name = + {pmtd_name = name; pmtd_type = typ; pmtd_attributes = attrs; pmtd_loc = loc} +end + +module Mb = struct + let mk ?(loc = !default_loc) ?(attrs = []) name expr = + {pmb_name = name; pmb_expr = expr; pmb_attributes = attrs; pmb_loc = loc} +end + +module Opn = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?(override = Fresh) lid = + { + popen_lid = lid; + popen_override = override; + popen_loc = loc; + popen_attributes = attrs; + } +end + +module Incl = struct + let mk ?(loc = !default_loc) ?(attrs = []) mexpr = + {pincl_mod = mexpr; pincl_loc = loc; pincl_attributes = attrs} +end + +module Vb = struct + let mk ?(loc = !default_loc) ?(attrs = []) pat expr = + {pvb_pat = pat; pvb_expr = expr; pvb_attributes = attrs; pvb_loc = loc} +end + +module Type = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?(params = []) ?(cstrs = []) + ?(kind = Ptype_abstract) ?(priv = Public) ?manifest name = + { + ptype_name = name; + ptype_params = params; + ptype_cstrs = cstrs; + ptype_kind = kind; + ptype_private = priv; + ptype_manifest = manifest; + ptype_attributes = attrs; + ptype_loc = loc; + } + + let constructor ?(loc = !default_loc) ?(attrs = []) ?(args = Pcstr_tuple []) + ?res name = + { + pcd_name = name; + pcd_args = args; + pcd_res = res; + pcd_loc = loc; + pcd_attributes = attrs; + } + + let field ?(loc = !default_loc) ?(attrs = []) ?(mut = Immutable) name typ = + { + pld_name = name; + pld_mutable = mut; + pld_type = typ; + pld_loc = loc; + pld_attributes = attrs; + } +end + +(** Type extensions *) +module Te = struct + let mk ?(attrs = []) ?(params = []) ?(priv = Public) path constructors = + { + ptyext_path = path; + ptyext_params = params; + ptyext_constructors = constructors; + ptyext_private = priv; + ptyext_attributes = attrs; + } + + let constructor ?(loc = !default_loc) ?(attrs = []) name kind = + { + pext_name = name; + pext_kind = kind; + pext_loc = loc; + pext_attributes = attrs; + } + + let decl ?(loc = !default_loc) ?(attrs = []) ?(args = Pcstr_tuple []) ?res + name = + { + pext_name = name; + pext_kind = Pext_decl (args, res); + pext_loc = loc; + pext_attributes = attrs; + } + + let rebind ?(loc = !default_loc) ?(attrs = []) name lid = + { + pext_name = name; + pext_kind = Pext_rebind lid; + pext_loc = loc; + pext_attributes = attrs; + } +end diff --git a/compiler/ml/ast_iterator.ml b/compiler/ml/ast_iterator.ml index d0dc295fd2..4a136d983b 100644 --- a/compiler/ml/ast_iterator.ml +++ b/compiler/ml/ast_iterator.ml @@ -104,7 +104,6 @@ module T = struct iter_loc sub lid; List.iter (sub.typ sub) tl | Ptyp_object (ol, _o) -> List.iter (object_field sub) ol - | Ptyp_class () -> () | Ptyp_alias (t, _) -> sub.typ sub t | Ptyp_variant (rl, _b, _ll) -> List.iter (row_field sub) rl | Ptyp_poly (_, t) -> sub.typ sub t diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index 6e9f022d28..40ee034a57 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -99,7 +99,6 @@ module T = struct constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) | Ptyp_object (l, o) -> object_ ~loc ~attrs (List.map (object_field sub) l) o - | Ptyp_class () -> assert false | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s | Ptyp_variant (rl, b, ll) -> variant ~loc ~attrs (List.map (row_field sub) rl) b ll diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml new file mode 100644 index 0000000000..867ec9714d --- /dev/null +++ b/compiler/ml/ast_mapper_from0.ml @@ -0,0 +1,484 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* A generic Parsetree mapping class *) + +(* +[@@@warning "+9"] + (* Ensure that record patterns don't miss any field. *) +*) + +open Parsetree0 +open Ast_helper +open Location +module Pt = Parsetree + +type mapper = { + attribute: mapper -> attribute -> Pt.attribute; + attributes: mapper -> attribute list -> Pt.attribute list; + case: mapper -> case -> Pt.case; + cases: mapper -> case list -> Pt.case list; + constructor_declaration: + mapper -> constructor_declaration -> Pt.constructor_declaration; + expr: mapper -> expression -> Pt.expression; + extension: mapper -> extension -> Pt.extension; + extension_constructor: + mapper -> extension_constructor -> Pt.extension_constructor; + include_declaration: mapper -> include_declaration -> Pt.include_declaration; + include_description: mapper -> include_description -> Pt.include_description; + label_declaration: mapper -> label_declaration -> Pt.label_declaration; + location: mapper -> Location.t -> Location.t; + module_binding: mapper -> module_binding -> Pt.module_binding; + module_declaration: mapper -> module_declaration -> Pt.module_declaration; + module_expr: mapper -> module_expr -> Pt.module_expr; + module_type: mapper -> module_type -> Pt.module_type; + module_type_declaration: + mapper -> module_type_declaration -> Pt.module_type_declaration; + open_description: mapper -> open_description -> Pt.open_description; + pat: mapper -> pattern -> Pt.pattern; + payload: mapper -> payload -> Pt.payload; + signature: mapper -> signature -> Pt.signature; + signature_item: mapper -> signature_item -> Pt.signature_item; + structure: mapper -> structure -> Pt.structure; + structure_item: mapper -> structure_item -> Pt.structure_item; + typ: mapper -> core_type -> Pt.core_type; + type_declaration: mapper -> type_declaration -> Pt.type_declaration; + type_extension: mapper -> type_extension -> Pt.type_extension; + type_kind: mapper -> type_kind -> Pt.type_kind; + value_binding: mapper -> value_binding -> Pt.value_binding; + value_description: mapper -> value_description -> Pt.value_description; + with_constraint: mapper -> with_constraint -> Pt.with_constraint; +} + +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_constant = function + | Pconst_integer (s, suffix) -> Pt.Pconst_integer (s, suffix) + | Pconst_char c -> Pconst_char c + | Pconst_string (s, q) -> Pconst_string (s, q) + | Pconst_float (s, suffix) -> Pconst_float (s, suffix) + +let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} + +module T = struct + (* Type expressions for the core language *) + + let row_field sub = function + | Rtag (l, attrs, b, tl) -> + Pt.Rtag + (map_loc sub l, sub.attributes sub attrs, b, List.map (sub.typ sub) tl) + | Rinherit t -> Rinherit (sub.typ sub t) + + let object_field sub = function + | Otag (l, attrs, t) -> + Pt.Otag (map_loc sub l, sub.attributes sub attrs, sub.typ sub t) + | Oinherit t -> Oinherit (sub.typ sub t) + + let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = + let open Typ in + let loc = sub.location sub loc in + let attrs = sub.attributes sub 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 sub t1) (sub.typ sub t2) + | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) + | Ptyp_constr (lid, tl) -> + constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) + | Ptyp_object (l, o) -> + object_ ~loc ~attrs (List.map (object_field sub) l) o + | Ptyp_class () -> assert false + | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub 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 (List.map (map_loc sub) sl) (sub.typ sub t) + | Ptyp_package (lid, l) -> + package ~loc ~attrs (map_loc sub lid) + (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) + | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub 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 sub)) ptype_params) + ~priv:ptype_private + ~cstrs: + (List.map + (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) + ptype_cstrs) + ~kind:(sub.type_kind sub ptype_kind) + ?manifest:(map_opt (sub.typ sub) ptype_manifest) + ~loc:(sub.location sub ptype_loc) + ~attrs:(sub.attributes sub ptype_attributes) + + let map_type_kind sub = function + | Ptype_abstract -> Pt.Ptype_abstract + | Ptype_variant l -> + Ptype_variant (List.map (sub.constructor_declaration sub) l) + | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) + | Ptype_open -> Ptype_open + + let map_constructor_arguments sub = function + | Pcstr_tuple l -> Pt.Pcstr_tuple (List.map (sub.typ sub) l) + | Pcstr_record l -> Pt.Pcstr_record (List.map (sub.label_declaration sub) l) + + let map_type_extension sub + { + ptyext_path; + ptyext_params; + ptyext_constructors; + ptyext_private; + ptyext_attributes; + } = + Te.mk (map_loc sub ptyext_path) + (List.map (sub.extension_constructor sub) ptyext_constructors) + ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) + ~priv:ptyext_private + ~attrs:(sub.attributes sub ptyext_attributes) + + let map_extension_constructor_kind sub = function + | Pext_decl (ctl, cto) -> + Pt.Pext_decl (map_constructor_arguments sub ctl, map_opt (sub.typ sub) 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 sub pext_loc) + ~attrs:(sub.attributes sub pext_attributes) +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 sub loc in + let attrs = sub.attributes sub 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 sub sg) + | Pmty_functor (s, mt1, mt2) -> + functor_ ~loc ~attrs (map_loc sub s) + (Misc.may_map (sub.module_type sub) mt1) + (sub.module_type sub mt2) + | Pmty_with (mt, l) -> + with_ ~loc ~attrs (sub.module_type sub mt) + (List.map (sub.with_constraint sub) l) + | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me) + | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x) + + let map_with_constraint sub = function + | Pwith_type (lid, d) -> + Pt.Pwith_type (map_loc sub lid, sub.type_declaration sub 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 sub d) + | Pwith_modsubst (s, lid) -> Pwith_modsubst (map_loc sub s, map_loc sub lid) + + let map_signature_item sub {psig_desc = desc; psig_loc = loc} = + let open Sig in + let loc = sub.location sub loc in + match desc with + | Psig_value vd -> value ~loc (sub.value_description sub vd) + | Psig_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) + | Psig_typext te -> type_extension ~loc (sub.type_extension sub te) + | Psig_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) + | Psig_module x -> module_ ~loc (sub.module_declaration sub x) + | Psig_recmodule l -> + rec_module ~loc (List.map (sub.module_declaration sub) l) + | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) + | Psig_open x -> open_ ~loc (sub.open_description sub x) + | Psig_include x -> include_ ~loc (sub.include_description sub x) + | Psig_class _ -> assert false + | Psig_class_type _ -> assert false + | Psig_extension (x, attrs) -> + extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) + | Psig_attribute x -> attribute ~loc (sub.attribute sub 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 sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) + | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) + | Pmod_functor (arg, arg_ty, body) -> + functor_ ~loc ~attrs (map_loc sub arg) + (Misc.may_map (sub.module_type sub) arg_ty) + (sub.module_expr sub body) + | Pmod_apply (m1, m2) -> + apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) + | Pmod_constraint (m, mty) -> + constraint_ ~loc ~attrs (sub.module_expr sub m) (sub.module_type sub mty) + | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) + | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) + + let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = + let open Str in + let loc = sub.location sub loc in + match desc with + | Pstr_eval (x, attrs) -> + eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x) + | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) + | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) + | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) + | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) + | Pstr_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) + | Pstr_module x -> module_ ~loc (sub.module_binding sub x) + | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) + | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) + | Pstr_open x -> open_ ~loc (sub.open_description sub x) + | Pstr_class () -> {pstr_loc = loc; pstr_desc = Pstr_class ()} + | Pstr_class_type () -> {pstr_loc = loc; pstr_desc = Pstr_class_type ()} + | Pstr_include x -> include_ ~loc (sub.include_declaration sub x) + | Pstr_extension (x, attrs) -> + extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) + | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) +end + +module E = struct + (* Value expressions for the core language *) + + let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = + let open Exp in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) + | Pexp_constant x -> constant ~loc ~attrs (map_constant x) + | Pexp_let (r, vbs, e) -> + let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) (sub.expr sub e) + | Pexp_fun (lab, def, p, e) -> + fun_ ~loc ~attrs lab + (map_opt (sub.expr sub) def) + (sub.pat sub p) (sub.expr sub e) + | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel) + | Pexp_apply (e, l) -> + apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) + | Pexp_match (e, pel) -> + match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) + | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) + | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) + | Pexp_construct (lid, arg) -> + construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) + | Pexp_variant (lab, eo) -> + variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) + | Pexp_record (l, eo) -> + record ~loc ~attrs + (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) + (map_opt (sub.expr sub) eo) + | Pexp_field (e, lid) -> + field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) + | Pexp_setfield (e1, lid, e2) -> + setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) (sub.expr sub e2) + | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el) + | Pexp_ifthenelse (e1, e2, e3) -> + ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) + (map_opt (sub.expr sub) e3) + | Pexp_sequence (e1, e2) -> + sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) + | Pexp_while (e1, e2) -> + while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) + | Pexp_for (p, e1, e2, d, e3) -> + for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d + (sub.expr sub e3) + | Pexp_coerce (e, (), t2) -> + coerce ~loc ~attrs (sub.expr sub e) (sub.typ sub t2) + | Pexp_constraint (e, t) -> + constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) + | Pexp_send (e, s) -> send ~loc ~attrs (sub.expr sub e) (map_loc sub s) + | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid) + | Pexp_setinstvar (s, e) -> + setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e) + | Pexp_override sel -> + override ~loc ~attrs + (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel) + | Pexp_letmodule (s, me, e) -> + letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) + (sub.expr sub e) + | Pexp_letexception (cd, e) -> + letexception ~loc ~attrs + (sub.extension_constructor sub cd) + (sub.expr sub e) + | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) + | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e) + | Pexp_poly (e, t) -> + poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t) + | Pexp_object () -> assert false + | Pexp_newtype (s, e) -> + newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) + | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) + | Pexp_open (ovf, lid, e) -> + open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e) + | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) + | Pexp_unreachable -> unreachable ~loc ~attrs () +end + +module P = struct + (* Patterns *) + + let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = + let open Pat in + let loc = sub.location sub loc in + let attrs = sub.attributes sub 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 sub p) (map_loc sub s) + | Ppat_constant c -> constant ~loc ~attrs (map_constant c) + | Ppat_interval (c1, c2) -> + interval ~loc ~attrs (map_constant c1) (map_constant c2) + | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) + | Ppat_construct (l, p) -> + construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p) + | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) + | Ppat_record (lpl, cf) -> + record ~loc ~attrs + (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) + cf + | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) + | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) + | Ppat_constraint (p, t) -> + constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) + | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) + | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p) + | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) + | Ppat_open (lid, p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p) + | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) + | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) +end + +(* Now, a generic AST mapper, to be extended to cover all kinds and + cases of the OCaml grammar. The default behavior of the mapper is + the identity. *) + +let default_mapper = + { + structure = (fun this l -> List.map (this.structure_item this) l); + structure_item = M.map_structure_item; + module_expr = M.map; + signature = (fun this l -> List.map (this.signature_item this) l); + signature_item = MT.map_signature_item; + module_type = MT.map; + with_constraint = MT.map_with_constraint; + type_declaration = T.map_type_declaration; + type_kind = T.map_type_kind; + typ = T.map; + type_extension = T.map_type_extension; + extension_constructor = T.map_extension_constructor; + value_description = + (fun this {pval_name; pval_type; pval_prim; pval_loc; pval_attributes} -> + Val.mk (map_loc this pval_name) (this.typ this pval_type) + ~attrs:(this.attributes this pval_attributes) + ~loc:(this.location this pval_loc) + ~prim:pval_prim); + pat = P.map; + expr = E.map; + module_declaration = + (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> + Md.mk (map_loc this pmd_name) + (this.module_type this pmd_type) + ~attrs:(this.attributes this pmd_attributes) + ~loc:(this.location this pmd_loc)); + module_type_declaration = + (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> + Mtd.mk (map_loc this pmtd_name) + ?typ:(map_opt (this.module_type this) pmtd_type) + ~attrs:(this.attributes this pmtd_attributes) + ~loc:(this.location this pmtd_loc)); + module_binding = + (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> + Mb.mk (map_loc this pmb_name) + (this.module_expr this pmb_expr) + ~attrs:(this.attributes this pmb_attributes) + ~loc:(this.location this pmb_loc)); + open_description = + (fun this {popen_lid; popen_override; popen_attributes; popen_loc} -> + Opn.mk (map_loc this popen_lid) ~override:popen_override + ~loc:(this.location this popen_loc) + ~attrs:(this.attributes this popen_attributes)); + include_description = + (fun this {pincl_mod; pincl_attributes; pincl_loc} -> + Incl.mk + (this.module_type this pincl_mod) + ~loc:(this.location this pincl_loc) + ~attrs:(this.attributes this pincl_attributes)); + include_declaration = + (fun this {pincl_mod; pincl_attributes; pincl_loc} -> + Incl.mk + (this.module_expr this pincl_mod) + ~loc:(this.location this pincl_loc) + ~attrs:(this.attributes this pincl_attributes)); + value_binding = + (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> + Vb.mk (this.pat this pvb_pat) (this.expr this pvb_expr) + ~loc:(this.location this pvb_loc) + ~attrs:(this.attributes this pvb_attributes)); + constructor_declaration = + (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> + Type.constructor (map_loc this pcd_name) + ~args:(T.map_constructor_arguments this pcd_args) + ?res:(map_opt (this.typ this) pcd_res) + ~loc:(this.location this pcd_loc) + ~attrs:(this.attributes this pcd_attributes)); + label_declaration = + (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} -> + Type.field (map_loc this pld_name) (this.typ this pld_type) + ~mut:pld_mutable + ~loc:(this.location this pld_loc) + ~attrs:(this.attributes this pld_attributes)); + cases = (fun this l -> List.map (this.case this) l); + case = + (fun this {pc_lhs; pc_guard; pc_rhs} -> + { + pc_lhs = this.pat this pc_lhs; + pc_guard = map_opt (this.expr this) pc_guard; + pc_rhs = this.expr this pc_rhs; + }); + location = (fun _this l -> l); + extension = (fun this (s, e) -> (map_loc this s, this.payload this e)); + attribute = (fun this (s, e) -> (map_loc this s, this.payload this e)); + attributes = (fun this l -> List.map (this.attribute this) l); + payload = + (fun this -> function + | PStr x -> PStr (this.structure this x) + | PSig x -> PSig (this.signature this x) + | PTyp x -> PTyp (this.typ this x) + | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g)); + } diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml new file mode 100644 index 0000000000..1eedf1c1d7 --- /dev/null +++ b/compiler/ml/ast_mapper_to0.ml @@ -0,0 +1,483 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* A generic Parsetree mapping class *) + +(* +[@@@warning "+9"] + (* Ensure that record patterns don't miss any field. *) +*) + +open Parsetree +open Ast_helper0 +open Location +module Pt = Parsetree0 + +type mapper = { + attribute: mapper -> attribute -> Pt.attribute; + attributes: mapper -> attribute list -> Pt.attribute list; + case: mapper -> case -> Pt.case; + cases: mapper -> case list -> Pt.case list; + constructor_declaration: + mapper -> constructor_declaration -> Pt.constructor_declaration; + expr: mapper -> expression -> Pt.expression; + extension: mapper -> extension -> Pt.extension; + extension_constructor: + mapper -> extension_constructor -> Pt.extension_constructor; + include_declaration: mapper -> include_declaration -> Pt.include_declaration; + include_description: mapper -> include_description -> Pt.include_description; + label_declaration: mapper -> label_declaration -> Pt.label_declaration; + location: mapper -> Location.t -> Location.t; + module_binding: mapper -> module_binding -> Pt.module_binding; + module_declaration: mapper -> module_declaration -> Pt.module_declaration; + module_expr: mapper -> module_expr -> Pt.module_expr; + module_type: mapper -> module_type -> Pt.module_type; + module_type_declaration: + mapper -> module_type_declaration -> Pt.module_type_declaration; + open_description: mapper -> open_description -> Pt.open_description; + pat: mapper -> pattern -> Pt.pattern; + payload: mapper -> payload -> Pt.payload; + signature: mapper -> signature -> Pt.signature; + signature_item: mapper -> signature_item -> Pt.signature_item; + structure: mapper -> structure -> Pt.structure; + structure_item: mapper -> structure_item -> Pt.structure_item; + typ: mapper -> core_type -> Pt.core_type; + type_declaration: mapper -> type_declaration -> Pt.type_declaration; + type_extension: mapper -> type_extension -> Pt.type_extension; + type_kind: mapper -> type_kind -> Pt.type_kind; + value_binding: mapper -> value_binding -> Pt.value_binding; + value_description: mapper -> value_description -> Pt.value_description; + with_constraint: mapper -> with_constraint -> Pt.with_constraint; +} + +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_constant = function + | Pconst_integer (s, suffix) -> Pt.Pconst_integer (s, suffix) + | Pconst_char c -> Pconst_char c + | Pconst_string (s, q) -> Pconst_string (s, q) + | Pconst_float (s, suffix) -> Pconst_float (s, suffix) + +let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} + +module T = struct + (* Type expressions for the core language *) + + let row_field sub = function + | Rtag (l, attrs, b, tl) -> + Pt.Rtag + (map_loc sub l, sub.attributes sub attrs, b, List.map (sub.typ sub) tl) + | Rinherit t -> Rinherit (sub.typ sub t) + + let object_field sub = function + | Otag (l, attrs, t) -> + Pt.Otag (map_loc sub l, sub.attributes sub attrs, sub.typ sub t) + | Oinherit t -> Oinherit (sub.typ sub t) + + let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = + let open Typ in + let loc = sub.location sub loc in + let attrs = sub.attributes sub 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 sub t1) (sub.typ sub t2) + | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) + | Ptyp_constr (lid, tl) -> + constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) + | Ptyp_object (l, o) -> + object_ ~loc ~attrs (List.map (object_field sub) l) o + | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub 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 (List.map (map_loc sub) sl) (sub.typ sub t) + | Ptyp_package (lid, l) -> + package ~loc ~attrs (map_loc sub lid) + (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) + | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub 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 sub)) ptype_params) + ~priv:ptype_private + ~cstrs: + (List.map + (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) + ptype_cstrs) + ~kind:(sub.type_kind sub ptype_kind) + ?manifest:(map_opt (sub.typ sub) ptype_manifest) + ~loc:(sub.location sub ptype_loc) + ~attrs:(sub.attributes sub ptype_attributes) + + let map_type_kind sub = function + | Ptype_abstract -> Pt.Ptype_abstract + | Ptype_variant l -> + Ptype_variant (List.map (sub.constructor_declaration sub) l) + | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) + | Ptype_open -> Ptype_open + + let map_constructor_arguments sub = function + | Pcstr_tuple l -> Pt.Pcstr_tuple (List.map (sub.typ sub) l) + | Pcstr_record l -> Pt.Pcstr_record (List.map (sub.label_declaration sub) l) + + let map_type_extension sub + { + ptyext_path; + ptyext_params; + ptyext_constructors; + ptyext_private; + ptyext_attributes; + } = + Te.mk (map_loc sub ptyext_path) + (List.map (sub.extension_constructor sub) ptyext_constructors) + ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) + ~priv:ptyext_private + ~attrs:(sub.attributes sub ptyext_attributes) + + let map_extension_constructor_kind sub = function + | Pext_decl (ctl, cto) -> + Pt.Pext_decl (map_constructor_arguments sub ctl, map_opt (sub.typ sub) 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 sub pext_loc) + ~attrs:(sub.attributes sub pext_attributes) +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 sub loc in + let attrs = sub.attributes sub 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 sub sg) + | Pmty_functor (s, mt1, mt2) -> + functor_ ~loc ~attrs (map_loc sub s) + (Misc.may_map (sub.module_type sub) mt1) + (sub.module_type sub mt2) + | Pmty_with (mt, l) -> + with_ ~loc ~attrs (sub.module_type sub mt) + (List.map (sub.with_constraint sub) l) + | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me) + | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x) + + let map_with_constraint sub = function + | Pwith_type (lid, d) -> + Pt.Pwith_type (map_loc sub lid, sub.type_declaration sub 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 sub d) + | Pwith_modsubst (s, lid) -> Pwith_modsubst (map_loc sub s, map_loc sub lid) + + let map_signature_item sub {psig_desc = desc; psig_loc = loc} = + let open Sig in + let loc = sub.location sub loc in + match desc with + | Psig_value vd -> value ~loc (sub.value_description sub vd) + | Psig_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) + | Psig_typext te -> type_extension ~loc (sub.type_extension sub te) + | Psig_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) + | Psig_module x -> module_ ~loc (sub.module_declaration sub x) + | Psig_recmodule l -> + rec_module ~loc (List.map (sub.module_declaration sub) l) + | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) + | Psig_open x -> open_ ~loc (sub.open_description sub x) + | Psig_include x -> include_ ~loc (sub.include_description sub x) + | Psig_class _ -> assert false + | Psig_class_type _ -> assert false + | Psig_extension (x, attrs) -> + extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) + | Psig_attribute x -> attribute ~loc (sub.attribute sub 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 sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) + | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) + | Pmod_functor (arg, arg_ty, body) -> + functor_ ~loc ~attrs (map_loc sub arg) + (Misc.may_map (sub.module_type sub) arg_ty) + (sub.module_expr sub body) + | Pmod_apply (m1, m2) -> + apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) + | Pmod_constraint (m, mty) -> + constraint_ ~loc ~attrs (sub.module_expr sub m) (sub.module_type sub mty) + | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) + | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) + + let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = + let open Str in + let loc = sub.location sub loc in + match desc with + | Pstr_eval (x, attrs) -> + eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x) + | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) + | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) + | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) + | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) + | Pstr_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) + | Pstr_module x -> module_ ~loc (sub.module_binding sub x) + | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) + | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) + | Pstr_open x -> open_ ~loc (sub.open_description sub x) + | Pstr_class () -> {pstr_loc = loc; pstr_desc = Pstr_class ()} + | Pstr_class_type () -> {pstr_loc = loc; pstr_desc = Pstr_class_type ()} + | Pstr_include x -> include_ ~loc (sub.include_declaration sub x) + | Pstr_extension (x, attrs) -> + extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) + | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) +end + +module E = struct + (* Value expressions for the core language *) + + let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = + let open Exp in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) + | Pexp_constant x -> constant ~loc ~attrs (map_constant x) + | Pexp_let (r, vbs, e) -> + let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) (sub.expr sub e) + | Pexp_fun (lab, def, p, e) -> + fun_ ~loc ~attrs lab + (map_opt (sub.expr sub) def) + (sub.pat sub p) (sub.expr sub e) + | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel) + | Pexp_apply (e, l) -> + apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) + | Pexp_match (e, pel) -> + match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) + | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) + | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) + | Pexp_construct (lid, arg) -> + construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) + | Pexp_variant (lab, eo) -> + variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) + | Pexp_record (l, eo) -> + record ~loc ~attrs + (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) + (map_opt (sub.expr sub) eo) + | Pexp_field (e, lid) -> + field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) + | Pexp_setfield (e1, lid, e2) -> + setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) (sub.expr sub e2) + | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el) + | Pexp_ifthenelse (e1, e2, e3) -> + ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) + (map_opt (sub.expr sub) e3) + | Pexp_sequence (e1, e2) -> + sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) + | Pexp_while (e1, e2) -> + while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) + | Pexp_for (p, e1, e2, d, e3) -> + for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d + (sub.expr sub e3) + | Pexp_coerce (e, (), t2) -> + coerce ~loc ~attrs (sub.expr sub e) (sub.typ sub t2) + | Pexp_constraint (e, t) -> + constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) + | Pexp_send (e, s) -> send ~loc ~attrs (sub.expr sub e) (map_loc sub s) + | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid) + | Pexp_setinstvar (s, e) -> + setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e) + | Pexp_override sel -> + override ~loc ~attrs + (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel) + | Pexp_letmodule (s, me, e) -> + letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) + (sub.expr sub e) + | Pexp_letexception (cd, e) -> + letexception ~loc ~attrs + (sub.extension_constructor sub cd) + (sub.expr sub e) + | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) + | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e) + | Pexp_poly (e, t) -> + poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t) + | Pexp_object () -> assert false + | Pexp_newtype (s, e) -> + newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) + | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) + | Pexp_open (ovf, lid, e) -> + open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e) + | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) + | Pexp_unreachable -> unreachable ~loc ~attrs () +end + +module P = struct + (* Patterns *) + + let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = + let open Pat in + let loc = sub.location sub loc in + let attrs = sub.attributes sub 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 sub p) (map_loc sub s) + | Ppat_constant c -> constant ~loc ~attrs (map_constant c) + | Ppat_interval (c1, c2) -> + interval ~loc ~attrs (map_constant c1) (map_constant c2) + | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) + | Ppat_construct (l, p) -> + construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p) + | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) + | Ppat_record (lpl, cf) -> + record ~loc ~attrs + (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) + cf + | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) + | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) + | Ppat_constraint (p, t) -> + constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) + | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) + | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p) + | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) + | Ppat_open (lid, p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p) + | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) + | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) +end + +(* Now, a generic AST mapper, to be extended to cover all kinds and + cases of the OCaml grammar. The default behavior of the mapper is + the identity. *) + +let default_mapper = + { + structure = (fun this l -> List.map (this.structure_item this) l); + structure_item = M.map_structure_item; + module_expr = M.map; + signature = (fun this l -> List.map (this.signature_item this) l); + signature_item = MT.map_signature_item; + module_type = MT.map; + with_constraint = MT.map_with_constraint; + type_declaration = T.map_type_declaration; + type_kind = T.map_type_kind; + typ = T.map; + type_extension = T.map_type_extension; + extension_constructor = T.map_extension_constructor; + value_description = + (fun this {pval_name; pval_type; pval_prim; pval_loc; pval_attributes} -> + Val.mk (map_loc this pval_name) (this.typ this pval_type) + ~attrs:(this.attributes this pval_attributes) + ~loc:(this.location this pval_loc) + ~prim:pval_prim); + pat = P.map; + expr = E.map; + module_declaration = + (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> + Md.mk (map_loc this pmd_name) + (this.module_type this pmd_type) + ~attrs:(this.attributes this pmd_attributes) + ~loc:(this.location this pmd_loc)); + module_type_declaration = + (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> + Mtd.mk (map_loc this pmtd_name) + ?typ:(map_opt (this.module_type this) pmtd_type) + ~attrs:(this.attributes this pmtd_attributes) + ~loc:(this.location this pmtd_loc)); + module_binding = + (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> + Mb.mk (map_loc this pmb_name) + (this.module_expr this pmb_expr) + ~attrs:(this.attributes this pmb_attributes) + ~loc:(this.location this pmb_loc)); + open_description = + (fun this {popen_lid; popen_override; popen_attributes; popen_loc} -> + Opn.mk (map_loc this popen_lid) ~override:popen_override + ~loc:(this.location this popen_loc) + ~attrs:(this.attributes this popen_attributes)); + include_description = + (fun this {pincl_mod; pincl_attributes; pincl_loc} -> + Incl.mk + (this.module_type this pincl_mod) + ~loc:(this.location this pincl_loc) + ~attrs:(this.attributes this pincl_attributes)); + include_declaration = + (fun this {pincl_mod; pincl_attributes; pincl_loc} -> + Incl.mk + (this.module_expr this pincl_mod) + ~loc:(this.location this pincl_loc) + ~attrs:(this.attributes this pincl_attributes)); + value_binding = + (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> + Vb.mk (this.pat this pvb_pat) (this.expr this pvb_expr) + ~loc:(this.location this pvb_loc) + ~attrs:(this.attributes this pvb_attributes)); + constructor_declaration = + (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> + Type.constructor (map_loc this pcd_name) + ~args:(T.map_constructor_arguments this pcd_args) + ?res:(map_opt (this.typ this) pcd_res) + ~loc:(this.location this pcd_loc) + ~attrs:(this.attributes this pcd_attributes)); + label_declaration = + (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} -> + Type.field (map_loc this pld_name) (this.typ this pld_type) + ~mut:pld_mutable + ~loc:(this.location this pld_loc) + ~attrs:(this.attributes this pld_attributes)); + cases = (fun this l -> List.map (this.case this) l); + case = + (fun this {pc_lhs; pc_guard; pc_rhs} -> + { + pc_lhs = this.pat this pc_lhs; + pc_guard = map_opt (this.expr this) pc_guard; + pc_rhs = this.expr this pc_rhs; + }); + location = (fun _this l -> l); + extension = (fun this (s, e) -> (map_loc this s, this.payload this e)); + attribute = (fun this (s, e) -> (map_loc this s, this.payload this e)); + attributes = (fun this l -> List.map (this.attribute this) l); + payload = + (fun this -> function + | PStr x -> PStr (this.structure this x) + | PSig x -> PSig (this.signature this x) + | PTyp x -> PTyp (this.typ this x) + | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g)); + } diff --git a/compiler/ml/depend.ml b/compiler/ml/depend.ml index 8d012e9787..8e1c75aa20 100644 --- a/compiler/ml/depend.ml +++ b/compiler/ml/depend.ml @@ -118,7 +118,6 @@ let rec add_type bv ty = | Otag (_, _, t) -> add_type bv t | Oinherit t -> add_type bv t) fl - | Ptyp_class () -> () | Ptyp_alias (t, _) -> add_type bv t | Ptyp_variant (fl, _, _) -> List.iter diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml index 40cc7a1beb..2193de9428 100644 --- a/compiler/ml/parsetree.ml +++ b/compiler/ml/parsetree.ml @@ -95,7 +95,6 @@ and core_type_desc = (* < l1:T1; ...; ln:Tn > (flag = Closed) < l1:T1; ...; ln:Tn; .. > (flag = Open) *) - | Ptyp_class of unit (* dummy AST node *) | Ptyp_alias of core_type * string (* T as 'a *) | Ptyp_variant of row_field list * closed_flag * label list option (* [ `A|`B ] (flag = Closed; labels = None) diff --git a/compiler/ml/parsetree0.ml b/compiler/ml/parsetree0.ml new file mode 100644 index 0000000000..40cc7a1beb --- /dev/null +++ b/compiler/ml/parsetree0.ml @@ -0,0 +1,598 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Abstract syntax tree produced by parsing *) + +open Asttypes + +type constant = + | Pconst_integer of string * char option + (* 3 3l 3L 3n + + Suffixes [g-z][G-Z] are accepted by the parser. + Suffixes except 'l', 'L' are rejected by the typechecker + *) + | Pconst_char of int + (* 'c' *) + | Pconst_string of string * string option + (* "constant" + {delim|other constant|delim} + *) + | Pconst_float of string * char option +(* 3.4 2e5 1.4e-4 + + Suffixes [g-z][G-Z] are accepted by the parser. + Suffixes are rejected by the typechecker. +*) + +(** {1 Extension points} *) + +type attribute = string loc * payload +(* [@id ARG] + [@@id ARG] + + Metadata containers passed around within the AST. + The compiler ignores unknown attributes. +*) + +and extension = string loc * payload +(* [%id ARG] + [%%id ARG] + + Sub-language placeholder -- rejected by the typechecker. +*) + +and attributes = attribute list + +and payload = + | PStr of structure + | PSig of signature (* : SIG *) + | PTyp of core_type (* : T *) + | PPat of pattern * expression option +(* ? P or ? P when E *) + +(* Type expressions *) + +(** {1 Core language} *) + +and core_type = { + ptyp_desc: core_type_desc; + ptyp_loc: Location.t; + ptyp_attributes: attributes; (* ... [@id1] [@id2] *) +} + +and core_type_desc = + | Ptyp_any (* _ *) + | Ptyp_var of string (* 'a *) + | Ptyp_arrow of arg_label * core_type * core_type + (* T1 -> T2 Simple + ~l:T1 -> T2 Labelled + ?l:T1 -> T2 Optional + *) + | Ptyp_tuple of core_type list + (* T1 * ... * Tn + + Invariant: n >= 2 + *) + | Ptyp_constr of Longident.t loc * core_type list + (* tconstr + T tconstr + (T1, ..., Tn) tconstr + *) + | Ptyp_object of object_field list * closed_flag + (* < l1:T1; ...; ln:Tn > (flag = Closed) + < l1:T1; ...; ln:Tn; .. > (flag = Open) + *) + | Ptyp_class of unit (* dummy AST node *) + | Ptyp_alias of core_type * string (* T as 'a *) + | Ptyp_variant of row_field list * closed_flag * label list option + (* [ `A|`B ] (flag = Closed; labels = None) + [> `A|`B ] (flag = Open; labels = None) + [< `A|`B ] (flag = Closed; labels = Some []) + [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) + *) + | Ptyp_poly of string loc list * core_type + (* 'a1 ... 'an. T + + Can only appear in the following context: + + - As the core_type of a Ppat_constraint node corresponding + to a constraint on a let-binding: let x : 'a1 ... 'an. T + = e ... + + - Under Cfk_virtual for methods (not values). + + - As the core_type of a Pctf_method node. + + - As the core_type of a Pexp_poly node. + + - As the pld_type field of a label_declaration. + + - As a core_type of a Ptyp_object node. + *) + | Ptyp_package of package_type (* (module S) *) + | Ptyp_extension of extension +(* [%id] *) + +and package_type = Longident.t loc * (Longident.t loc * core_type) list +(* + (module S) + (module S with type t1 = T1 and ... and tn = Tn) + *) + +and row_field = + | Rtag of label loc * attributes * bool * core_type list + (* [`A] ( true, [] ) + [`A of T] ( false, [T] ) + [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) + [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) + + - The 2nd field is true if the tag contains a + constant (empty) constructor. + - '&' occurs when several types are used for the same constructor + (see 4.2 in the manual) + + - TODO: switch to a record representation, and keep location + *) + | Rinherit of core_type +(* [ T ] *) + +and object_field = + | Otag of label loc * attributes * core_type + | Oinherit of core_type + +(* Patterns *) +and pattern = { + ppat_desc: pattern_desc; + ppat_loc: Location.t; + ppat_attributes: attributes; (* ... [@id1] [@id2] *) +} + +and pattern_desc = + | Ppat_any (* _ *) + | Ppat_var of string loc (* x *) + | Ppat_alias of pattern * string loc (* P as 'a *) + | Ppat_constant of constant (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Ppat_interval of constant * constant + (* 'a'..'z' + + Other forms of interval are recognized by the parser + but rejected by the type-checker. *) + | Ppat_tuple of pattern list + (* (P1, ..., Pn) + + Invariant: n >= 2 + *) + | Ppat_construct of Longident.t loc * pattern option + (* C None + C P Some P + C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) + *) + | Ppat_variant of label * pattern option + (* `A (None) + `A P (Some P) + *) + | Ppat_record of (Longident.t loc * pattern) list * closed_flag + (* { l1=P1; ...; ln=Pn } (flag = Closed) + { l1=P1; ...; ln=Pn; _} (flag = Open) + + Invariant: n > 0 + *) + | Ppat_array of pattern list (* [| P1; ...; Pn |] *) + | Ppat_or of pattern * pattern (* P1 | P2 *) + | Ppat_constraint of pattern * core_type (* (P : T) *) + | Ppat_type of Longident.t loc (* #tconst *) + | Ppat_lazy of pattern (* lazy P *) + | Ppat_unpack of string loc + (* (module P) + Note: (module P : S) is represented as + Ppat_constraint(Ppat_unpack, Ptyp_package) + *) + | Ppat_exception of pattern (* exception P *) + | Ppat_extension of extension (* [%id] *) + | Ppat_open of Longident.t loc * pattern +(* M.(P) *) + +(* Value expressions *) + +and expression = { + pexp_desc: expression_desc; + pexp_loc: Location.t; + (* Hack: made pexp_attributes mutable for use in analysis exe. Please do not use elsewhere! *) + mutable pexp_attributes: attributes; (* ... [@id1] [@id2] *) +} + +and expression_desc = + | Pexp_ident of Longident.t loc + (* x + M.x + *) + | Pexp_constant of constant (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Pexp_let of rec_flag * value_binding list * expression + (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) + *) + | Pexp_function of case list (* function P1 -> E1 | ... | Pn -> En *) + | Pexp_fun of arg_label * expression option * pattern * expression + (* fun P -> E1 (Simple, None) + fun ~l:P -> E1 (Labelled l, None) + fun ?l:P -> E1 (Optional l, None) + fun ?l:(P = E0) -> E1 (Optional l, Some E0) + + Notes: + - If E0 is provided, only Optional is allowed. + - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. + - "let f P = E" is represented using Pexp_fun. + *) + | Pexp_apply of expression * (arg_label * expression) list + (* E0 ~l1:E1 ... ~ln:En + li can be empty (non labeled argument) or start with '?' + (optional argument). + + Invariant: n > 0 + *) + | Pexp_match of expression * case list + (* match E0 with P1 -> E1 | ... | Pn -> En *) + | Pexp_try of expression * case list + (* try E0 with P1 -> E1 | ... | Pn -> En *) + | Pexp_tuple of expression list + (* (E1, ..., En) + + Invariant: n >= 2 + *) + | Pexp_construct of Longident.t loc * expression option + (* C None + C E Some E + C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) + *) + | Pexp_variant of label * expression option + (* `A (None) + `A E (Some E) + *) + | Pexp_record of (Longident.t loc * expression) list * expression option + (* { l1=P1; ...; ln=Pn } (None) + { E0 with l1=P1; ...; ln=Pn } (Some E0) + + Invariant: n > 0 + *) + | Pexp_field of expression * Longident.t loc (* E.l *) + | Pexp_setfield of expression * Longident.t loc * expression (* E1.l <- E2 *) + | Pexp_array of expression list (* [| E1; ...; En |] *) + | Pexp_ifthenelse of expression * expression * expression option + (* if E1 then E2 else E3 *) + | Pexp_sequence of expression * expression (* E1; E2 *) + | Pexp_while of expression * expression (* while E1 do E2 done *) + | Pexp_for of pattern * expression * expression * direction_flag * expression + (* for i = E1 to E2 do E3 done (flag = Upto) + for i = E1 downto E2 do E3 done (flag = Downto) + *) + | Pexp_constraint of expression * core_type (* (E : T) *) + | Pexp_coerce of expression * unit * core_type + (* (E :> T) (None, T) + *) + | Pexp_send of expression * label loc (* E # m *) + | Pexp_new of Longident.t loc (* new M.c *) + | Pexp_setinstvar of label loc * expression (* x <- 2 *) + | Pexp_override of (label loc * expression) list + (* {< x1 = E1; ...; Xn = En >} *) + | Pexp_letmodule of string loc * module_expr * expression + (* let module M = ME in E *) + | Pexp_letexception of extension_constructor * expression + (* let exception C in E *) + | Pexp_assert of expression + (* assert E + Note: "assert false" is treated in a special way by the + type-checker. *) + | Pexp_lazy of expression (* lazy E *) + | Pexp_poly of expression * core_type option + (* Used for method bodies. + + Can only be used as the expression under Cfk_concrete + for methods (not values). *) + | Pexp_object of unit (* dummy AST node *) + | Pexp_newtype of string loc * expression (* fun (type t) -> E *) + | Pexp_pack of module_expr + (* (module ME) + + (module ME : S) is represented as + Pexp_constraint(Pexp_pack, Ptyp_package S) *) + | Pexp_open of override_flag * Longident.t loc * expression + (* M.(E) + let open M in E + let! open M in E *) + | Pexp_extension of extension (* [%id] *) + | Pexp_unreachable +(* . *) + +and case = { + (* (P -> E) or (P when E0 -> E) *) + pc_lhs: pattern; + pc_guard: expression option; + pc_rhs: expression; +} + +(* Value descriptions *) +and value_description = { + pval_name: string loc; + pval_type: core_type; + pval_prim: string list; + pval_attributes: attributes; (* ... [@@id1] [@@id2] *) + pval_loc: Location.t; +} + +(* + val x: T (prim = []) + external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) +*) + +(* Type declarations *) +and type_declaration = { + ptype_name: string loc; + ptype_params: (core_type * variance) list; + (* ('a1,...'an) t; None represents _*) + ptype_cstrs: (core_type * core_type * Location.t) list; + (* ... constraint T1=T1' ... constraint Tn=Tn' *) + ptype_kind: type_kind; + ptype_private: private_flag; (* = private ... *) + ptype_manifest: core_type option; (* = T *) + ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) + ptype_loc: Location.t; +} + +(* + type t (abstract, no manifest) + type t = T0 (abstract, manifest=T0) + type t = C of T | ... (variant, no manifest) + type t = T0 = C of T | ... (variant, manifest=T0) + type t = {l: T; ...} (record, no manifest) + type t = T0 = {l : T; ...} (record, manifest=T0) + type t = .. (open, no manifest) +*) +and type_kind = + | Ptype_abstract + | Ptype_variant of constructor_declaration list + (* Invariant: non-empty list *) + | Ptype_record of label_declaration list (* Invariant: non-empty list *) + | Ptype_open + +and label_declaration = { + pld_name: string loc; + pld_mutable: mutable_flag; + pld_type: core_type; + pld_loc: Location.t; + pld_attributes: attributes; (* l : T [@id1] [@id2] *) +} + +(* { ...; l: T; ... } (mutable=Immutable) + { ...; mutable l: T; ... } (mutable=Mutable) + + Note: T can be a Ptyp_poly. +*) +and constructor_declaration = { + pcd_name: string loc; + pcd_args: constructor_arguments; + pcd_res: core_type option; + pcd_loc: Location.t; + pcd_attributes: attributes; (* C of ... [@id1] [@id2] *) +} + +and constructor_arguments = + | Pcstr_tuple of core_type list + | Pcstr_record of label_declaration list + +(* + | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) + | C: T0 (res = Some T0, args = []) + | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) + | C of {...} (res = None, args = Pcstr_record) + | C: {...} -> T0 (res = Some T0, args = Pcstr_record) + | C of {...} as t (res = None, args = Pcstr_record) +*) +and type_extension = { + ptyext_path: Longident.t loc; + ptyext_params: (core_type * variance) list; + ptyext_constructors: extension_constructor list; + ptyext_private: private_flag; + ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) +} +(* + type t += ... +*) + +and extension_constructor = { + pext_name: string loc; + pext_kind: extension_constructor_kind; + pext_loc: Location.t; + pext_attributes: attributes; (* C of ... [@id1] [@id2] *) +} + +and extension_constructor_kind = + | Pext_decl of constructor_arguments * core_type option + (* + | C of T1 * ... * Tn ([T1; ...; Tn], None) + | C: T0 ([], Some T0) + | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) + *) + | Pext_rebind of Longident.t loc +(* + | C = D + *) + +(* Type expressions for the module language *) + +(** {1 Module language} *) + +and module_type = { + pmty_desc: module_type_desc; + pmty_loc: Location.t; + pmty_attributes: attributes; (* ... [@id1] [@id2] *) +} + +and module_type_desc = + | Pmty_ident of Longident.t loc (* S *) + | Pmty_signature of signature (* sig ... end *) + | Pmty_functor of string loc * module_type option * module_type + (* functor(X : MT1) -> MT2 *) + | Pmty_with of module_type * with_constraint list (* MT with ... *) + | Pmty_typeof of module_expr (* module type of ME *) + | Pmty_extension of extension (* [%id] *) + | Pmty_alias of Longident.t loc +(* (module M) *) + +and signature = signature_item list + +and signature_item = {psig_desc: signature_item_desc; psig_loc: Location.t} + +and signature_item_desc = + | Psig_value of value_description + (* + val x: T + external x: T = "s1" ... "sn" + *) + | Psig_type of rec_flag * type_declaration list + (* type t1 = ... and ... and tn = ... *) + | Psig_typext of type_extension (* type t1 += ... *) + | Psig_exception of extension_constructor (* exception C of T *) + | Psig_module of module_declaration (* module X : MT *) + | Psig_recmodule of module_declaration list + (* module rec X1 : MT1 and ... and Xn : MTn *) + | Psig_modtype of module_type_declaration + (* module type S = MT + module type S *) + | Psig_open of open_description (* open X *) + | Psig_include of include_description (* include MT *) + | Psig_class of unit (* Dummy AST node *) + | Psig_class_type of unit (* Dummy AST node *) + | Psig_attribute of attribute (* [@@@id] *) + | Psig_extension of extension * attributes +(* [%%id] *) + +and module_declaration = { + pmd_name: string loc; + pmd_type: module_type; + pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) + pmd_loc: Location.t; +} +(* S : MT *) + +and module_type_declaration = { + pmtd_name: string loc; + pmtd_type: module_type option; + pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *) + pmtd_loc: Location.t; +} +(* S = MT + S (abstract module type declaration, pmtd_type = None) +*) + +and open_description = { + popen_lid: Longident.t loc; + popen_override: override_flag; + popen_loc: Location.t; + popen_attributes: attributes; +} +(* open! X - popen_override = Override (silences the 'used identifier + shadowing' warning) + open X - popen_override = Fresh +*) + +and 'a include_infos = { + pincl_mod: 'a; + pincl_loc: Location.t; + pincl_attributes: attributes; +} + +and include_description = module_type include_infos +(* include MT *) + +and include_declaration = module_expr include_infos +(* include ME *) + +and with_constraint = + | Pwith_type of Longident.t loc * type_declaration + (* with type X.t = ... + + Note: the last component of the longident must match + the name of the type_declaration. *) + | Pwith_module of Longident.t loc * Longident.t loc (* with module X.Y = Z *) + | Pwith_typesubst of Longident.t loc * type_declaration + (* with type X.t := ..., same format as [Pwith_type] *) + | Pwith_modsubst of Longident.t loc * Longident.t loc +(* with module X.Y := Z *) + +(* Value expressions for the module language *) + +and module_expr = { + pmod_desc: module_expr_desc; + pmod_loc: Location.t; + pmod_attributes: attributes; (* ... [@id1] [@id2] *) +} + +and module_expr_desc = + | Pmod_ident of Longident.t loc (* X *) + | Pmod_structure of structure (* struct ... end *) + | Pmod_functor of string loc * module_type option * module_expr + (* functor(X : MT1) -> ME *) + | Pmod_apply of module_expr * module_expr (* ME1(ME2) *) + | Pmod_constraint of module_expr * module_type (* (ME : MT) *) + | Pmod_unpack of expression (* (val E) *) + | Pmod_extension of extension +(* [%id] *) + +and structure = structure_item list + +and structure_item = {pstr_desc: structure_item_desc; pstr_loc: Location.t} + +and structure_item_desc = + | Pstr_eval of expression * attributes (* E *) + | Pstr_value of rec_flag * value_binding list + (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN (flag = Recursive) + *) + | Pstr_primitive of value_description + (* val x: T + external x: T = "s1" ... "sn" *) + | Pstr_type of rec_flag * type_declaration list + (* type t1 = ... and ... and tn = ... *) + | Pstr_typext of type_extension (* type t1 += ... *) + | Pstr_exception of extension_constructor + (* exception C of T + exception C = M.X *) + | Pstr_module of module_binding (* module X = ME *) + | Pstr_recmodule of module_binding list + (* module rec X1 = ME1 and ... and Xn = MEn *) + | Pstr_modtype of module_type_declaration (* module type S = MT *) + | Pstr_open of open_description (* open X *) + | Pstr_class of unit (* Dummy AST node *) + | Pstr_class_type of unit (* Dummy AST node *) + | Pstr_include of include_declaration (* include ME *) + | Pstr_attribute of attribute (* [@@@id] *) + | Pstr_extension of extension * attributes +(* [%%id] *) + +and value_binding = { + pvb_pat: pattern; + pvb_expr: expression; + pvb_attributes: attributes; + pvb_loc: Location.t; +} + +and module_binding = { + pmb_name: string loc; + pmb_expr: module_expr; + pmb_attributes: attributes; + pmb_loc: Location.t; +} +(* X = ME *) diff --git a/compiler/ml/pprintast.ml b/compiler/ml/pprintast.ml index cfc113cb27..9aca49766f 100644 --- a/compiler/ml/pprintast.ml +++ b/compiler/ml/pprintast.ml @@ -321,7 +321,6 @@ and core_type1 ctxt f x = in pp f "@[<@ %a%a@ > @]" (list core_field_type ~sep:";") l field_var o (* Cf #7200 *) - | Ptyp_class () -> () | Ptyp_package (lid, cstrs) -> let aux f (s, ct) = pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct in diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml index 5984b35c6a..21e87aae9f 100644 --- a/compiler/ml/printast.ml +++ b/compiler/ml/printast.ml @@ -150,7 +150,6 @@ let rec core_type i ppf x = line i ppf "Oinherit\n"; core_type (i + 1) ppf ct) l - | Ptyp_class () -> () | Ptyp_alias (ct, s) -> line i ppf "Ptyp_alias \"%s\"\n" s; core_type i ppf ct diff --git a/compiler/ml/printtyped.ml b/compiler/ml/printtyped.ml index 63b673f3f1..b34db23013 100644 --- a/compiler/ml/printtyped.ml +++ b/compiler/ml/printtyped.ml @@ -179,7 +179,6 @@ let rec core_type i ppf x = line i ppf "OTinherit\n"; core_type (i + 1) ppf ct) l - | Ttyp_class () -> () | Ttyp_alias (ct, s) -> line i ppf "Ttyp_alias \"%s\"\n" s; core_type i ppf ct diff --git a/compiler/ml/tast_iterator.ml b/compiler/ml/tast_iterator.ml index 8b713895b1..97a2d31821 100644 --- a/compiler/ml/tast_iterator.ml +++ b/compiler/ml/tast_iterator.ml @@ -303,7 +303,6 @@ let typ sub {ctyp_desc; ctyp_env; _} = | Ttyp_tuple list -> List.iter (sub.typ sub) list | Ttyp_constr (_, _, list) -> List.iter (sub.typ sub) list | Ttyp_object (list, _) -> List.iter (sub.object_field sub) list - | Ttyp_class () -> () | Ttyp_alias (ct, _) -> sub.typ sub ct | Ttyp_variant (list, _, _) -> List.iter (sub.row_field sub) list | Ttyp_poly (_, ct) -> sub.typ sub ct diff --git a/compiler/ml/tast_mapper.ml b/compiler/ml/tast_mapper.ml index cf01423a9c..7f5f55a016 100644 --- a/compiler/ml/tast_mapper.ml +++ b/compiler/ml/tast_mapper.ml @@ -370,7 +370,6 @@ let typ sub x = Ttyp_constr (path, lid, List.map (sub.typ sub) list) | Ttyp_object (list, closed) -> Ttyp_object (List.map (sub.object_field sub) list, closed) - | Ttyp_class () -> Ttyp_class () | Ttyp_alias (ct, s) -> Ttyp_alias (sub.typ sub ct, s) | Ttyp_variant (list, closed, labels) -> Ttyp_variant (List.map (sub.row_field sub) list, closed, labels) diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index 95ff18b3a4..d72cf01b30 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -158,7 +158,6 @@ let is_fixed_type sd = let rec has_row_var sty = match sty.ptyp_desc with | Ptyp_alias (sty, _) -> has_row_var sty - | Ptyp_class _ | Ptyp_object (_, Open) | Ptyp_variant (_, Open, _) | Ptyp_variant (_, Closed, Some _) -> diff --git a/compiler/ml/typedtree.ml b/compiler/ml/typedtree.ml index 82b447d63e..75a8f4d328 100644 --- a/compiler/ml/typedtree.ml +++ b/compiler/ml/typedtree.ml @@ -314,7 +314,6 @@ and core_type_desc = | Ttyp_tuple of core_type list | Ttyp_constr of Path.t * Longident.t loc * core_type list | Ttyp_object of object_field list * closed_flag - | Ttyp_class of unit (* dummy AST node *) | Ttyp_alias of core_type * string | Ttyp_variant of row_field list * closed_flag * label list option | Ttyp_poly of string list * core_type diff --git a/compiler/ml/typedtree.mli b/compiler/ml/typedtree.mli index 97d546dccf..0d86e70105 100644 --- a/compiler/ml/typedtree.mli +++ b/compiler/ml/typedtree.mli @@ -420,7 +420,6 @@ and core_type_desc = | Ttyp_tuple of core_type list | Ttyp_constr of Path.t * Longident.t loc * core_type list | Ttyp_object of object_field list * closed_flag - | Ttyp_class of unit (* dummy AST node *) | Ttyp_alias of core_type * string | Ttyp_variant of row_field list * closed_flag * label list option | Ttyp_poly of string list * core_type diff --git a/compiler/ml/typedtreeIter.ml b/compiler/ml/typedtreeIter.ml index 52e5fcca22..45d0506347 100644 --- a/compiler/ml/typedtreeIter.ml +++ b/compiler/ml/typedtreeIter.ml @@ -391,7 +391,6 @@ end = struct | Ttyp_tuple list -> List.iter iter_core_type list | Ttyp_constr (_path, _, list) -> List.iter iter_core_type list | Ttyp_object (list, _o) -> List.iter iter_object_field list - | Ttyp_class () -> () | Ttyp_alias (ct, _s) -> iter_core_type ct | Ttyp_variant (list, _bool, _labels) -> List.iter iter_row_field list | Ttyp_poly (_list, ct) -> iter_core_type ct diff --git a/compiler/ml/typetexp.ml b/compiler/ml/typetexp.ml index 0dda845547..cdd561ea6b 100644 --- a/compiler/ml/typetexp.ml +++ b/compiler/ml/typetexp.ml @@ -379,7 +379,6 @@ and transl_type_aux env policy styp = | Ptyp_object (fields, o) -> let ty, fields = transl_fields env policy o fields in ctyp (Ttyp_object (fields, o)) (newobj ty) - | Ptyp_class () -> assert false | Ptyp_alias (st, alias) -> let cty = try diff --git a/compiler/ml/untypeast.ml b/compiler/ml/untypeast.ml index 8684240afb..92d174c844 100644 --- a/compiler/ml/untypeast.ml +++ b/compiler/ml/untypeast.ml @@ -519,7 +519,6 @@ let core_type sub ct = Ptyp_constr (map_loc sub lid, List.map (sub.typ sub) list) | Ttyp_object (list, o) -> Ptyp_object (List.map (sub.object_field sub) list, o) - | Ttyp_class () -> Ptyp_class () | Ttyp_alias (ct, s) -> Ptyp_alias (sub.typ sub ct, s) | Ttyp_variant (list, bool, labels) -> Ptyp_variant (List.map (sub.row_field sub) list, bool, labels) diff --git a/compiler/syntax/src/res_ast_debugger.ml b/compiler/syntax/src/res_ast_debugger.ml index 4bb3d5a965..aa944c3459 100644 --- a/compiler/syntax/src/res_ast_debugger.ml +++ b/compiler/syntax/src/res_ast_debugger.ml @@ -875,7 +875,6 @@ module SexpAst = struct closed_flag flag; Sexp.list (map_empty ~f:object_field fields); ] - | Ptyp_class () -> assert false | Ptyp_variant (fields, flag, opt_labels) -> Sexp.list [ diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml index da02a6c907..46ca96475f 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -1766,7 +1766,6 @@ and print_typ_expr ~(state : State.t) (typ_expr : Parsetree.core_type) cmt_tbl = | Ptyp_package package_type -> print_package_type ~state ~print_module_keyword_and_parens:true package_type cmt_tbl - | Ptyp_class _ -> Doc.text "classes are not supported in types" | Ptyp_variant (row_fields, closed_flag, labels_opt) -> let force_break = typ_expr.ptyp_loc.Location.loc_start.pos_lnum diff --git a/tests/analysis_tests/tests-generic-jsx-transform/package-lock.json b/tests/analysis_tests/tests-generic-jsx-transform/package-lock.json index 9d41adabff..a32973e70e 100644 --- a/tests/analysis_tests/tests-generic-jsx-transform/package-lock.json +++ b/tests/analysis_tests/tests-generic-jsx-transform/package-lock.json @@ -9,6 +9,7 @@ } }, "../../..": { + "name": "rescript", "version": "12.0.0-alpha.6", "hasInstallScript": true, "license": "SEE LICENSE IN LICENSE", diff --git a/tests/analysis_tests/tests-incremental-typechecking/package-lock.json b/tests/analysis_tests/tests-incremental-typechecking/package-lock.json index 7ac4926c77..38b2e7ef61 100644 --- a/tests/analysis_tests/tests-incremental-typechecking/package-lock.json +++ b/tests/analysis_tests/tests-incremental-typechecking/package-lock.json @@ -9,6 +9,7 @@ } }, "../../..": { + "name": "rescript", "version": "12.0.0-alpha.6", "hasInstallScript": true, "license": "SEE LICENSE IN LICENSE", diff --git a/tests/analysis_tests/tests-reanalyze/termination/package-lock.json b/tests/analysis_tests/tests-reanalyze/termination/package-lock.json index 99d878c69c..6b8ba086d1 100644 --- a/tests/analysis_tests/tests-reanalyze/termination/package-lock.json +++ b/tests/analysis_tests/tests-reanalyze/termination/package-lock.json @@ -12,6 +12,7 @@ } }, "../../../..": { + "name": "rescript", "version": "12.0.0-alpha.6", "dev": true, "hasInstallScript": true, diff --git a/tests/tools_tests/ppx/TestPpx.res b/tests/tools_tests/ppx/TestPpx.res new file mode 100644 index 0000000000..7e7f4369c7 --- /dev/null +++ b/tests/tools_tests/ppx/TestPpx.res @@ -0,0 +1,6 @@ +Console.log("ppx test") + +type t = [#A | #B] + +let a: t = #A +let b: t = #B diff --git a/tests/tools_tests/src/expected/TestPpx.res.jsout b/tests/tools_tests/src/expected/TestPpx.res.jsout new file mode 100644 index 0000000000..54845d6992 --- /dev/null +++ b/tests/tools_tests/src/expected/TestPpx.res.jsout @@ -0,0 +1,15 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE +'use strict'; + + +console.log("ppx test"); + +console.log("ppx test"); + +let a = "A"; + +let b = "B"; + +exports.a = a; +exports.b = b; +/* Not a pure module */ diff --git a/tests/tools_tests/test.sh b/tests/tools_tests/test.sh index 0534552c15..41f06fa961 100755 --- a/tests/tools_tests/test.sh +++ b/tests/tools_tests/test.sh @@ -7,6 +7,15 @@ for file in src/*.{res,resi}; do fi done +for file in ppx/*.res; do + output="src/expected/$(basename $file).jsout" + ../../cli/bsc -ppx "../../_build/install/default/bin/rescript-tools ppx" $file > $output + # # CI. We use LF, and the CI OCaml fork prints CRLF. Convert. + if [ "$RUNNER_OS" == "Windows" ]; then + perl -pi -e 's/\r\n/\n/g' -- $output + fi +done + warningYellow='\033[0;33m' successGreen='\033[0;32m' reset='\033[0m' diff --git a/tools/bin/main.ml b/tools/bin/main.ml index bde33dc0f2..2d97dea930 100644 --- a/tools/bin/main.ml +++ b/tools/bin/main.ml @@ -56,6 +56,26 @@ let main () = (Tools.extractEmbedded ~extensionPoints:(extPointNames |> String.split_on_char ',') ~filename)) + | ["ppx"; file_in; file_out] -> + let ic = open_in_bin file_in in + let magic = + really_input_string ic (String.length Config.ast_impl_magic_number) + in + let loc = input_value ic in + let ast0 : Parsetree0.structure = input_value ic in + let prefix = + match ast0 with + | c1 :: c2 :: _ -> [c1; c2] + | _ -> [] + in + let ast = prefix @ ast0 in + close_in ic; + let oc = open_out_bin file_out in + output_string oc magic; + output_value oc loc; + output_value oc ast; + close_out oc; + exit 0 | ["-h"] | ["--help"] -> logAndExit (Ok help) | ["-v"] | ["--version"] -> logAndExit (Ok version) | _ -> logAndExit (Error help)