Modernise ast

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
 

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" );

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

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

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

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

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,25 +55,29 @@ 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]
     are stored as [-ppx3; -ppx2; -ppx1]
     [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)

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

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

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 =

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)