Merge pull request #4471 from BuckleScript/remove_pparse

use our own front-end driver instead of pparse

Author: bobzhang

jscomp/common/ml_binary.ml

@@ -48,4 +48,10 @@ let write_ast (type t) (kind : t kind)
     | Mli -> Config.ast_intf_magic_number in
   output_string oc magic ;
   output_value oc fname;
-  output_value oc pt
+  output_value oc pt
+
+let magic_of_kind : type a . a kind -> string = function
+  | Ml -> Config.ast_impl_magic_number
+  | Mli -> Config.ast_intf_magic_number
+
+  

jscomp/common/ml_binary.mli

@@ -32,4 +32,6 @@ type _ kind =
 val read_ast : 'a kind -> in_channel -> 'a 
 
 val write_ast :
-   'a kind -> string -> 'a -> out_channel -> unit
+   'a kind -> string -> 'a -> out_channel -> unit
+
+val magic_of_kind : 'a kind -> string   

jscomp/core/cmd_ast_exception.ml

@@ -0,0 +1,27 @@
+type error =
+  | CannotRun of string
+  | WrongMagic of string
+
+exception Error of error
+
+
+let report_error ppf = function
+  | CannotRun cmd ->
+      Format.fprintf ppf "Error while running external preprocessor@.\
+                   Command line: %s@." cmd
+  | WrongMagic cmd ->
+      Format.fprintf ppf "External preprocessor does not produce a valid file@.\
+                   Command line: %s@." cmd
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )
+
+let cannot_run comm = 
+  raise (Error (CannotRun comm))    
+
+let wrong_magic magic = 
+    raise (Error (WrongMagic magic))  

jscomp/core/cmd_ppx_apply.ml

@@ -0,0 +1,83 @@
+
+
+(* 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 oc = open_out_bin fn in
+  output_string oc (Ml_binary.magic_of_kind kind);
+  output_value oc (!Location.input_name : string);
+  output_value oc (ast : a);
+  close_out oc
+
+let apply_rewriter kind fn_in ppx =
+  let magic = Ml_binary.magic_of_kind kind in
+  let fn_out = Filename.temp_file "camlppx" "" in
+  let comm =
+    Printf.sprintf "%s %s %s" ppx (Filename.quote fn_in) (Filename.quote fn_out)
+  in
+  let ok = Ccomp.command comm = 0 in
+  Misc.remove_file fn_in;
+  if not ok then begin
+    Misc.remove_file fn_out;
+    Cmd_ast_exception.cannot_run comm
+  end;
+  if not (Sys.file_exists fn_out) then
+    Cmd_ast_exception.cannot_run comm;
+  (* check magic before passing to the next ppx *)
+  let ic = open_in_bin fn_out in
+  let buffer =
+    try really_input_string ic (String.length magic) with End_of_file -> "" in
+  close_in ic;
+  if buffer <> magic then begin
+    Misc.remove_file fn_out;
+    Cmd_ast_exception.wrong_magic buffer;
+  end;
+  fn_out
+
+let read_ast (type a) (kind : a Ml_binary.kind) fn : a =
+  let ic = open_in_bin fn in
+  try
+    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
+    close_in ic;
+    Misc.remove_file fn;
+    ast
+  with exn ->
+    close_in ic;
+    Misc.remove_file fn;
+    raise exn
+let rewrite kind ppxs ast =
+  let fn = Filename.temp_file "camlppx" "" in
+  write_ast kind fn ast;
+  let fn = List.fold_left (apply_rewriter kind) fn (List.rev ppxs) in
+  read_ast kind fn
+
+let apply_rewriters_str ?(restore = true) ~tool_name ast =
+  match !Clflags.all_ppx with
+  | [] -> ast
+  | ppxs ->
+    ast
+    |> Ast_mapper.add_ppx_context_str ~tool_name
+    |> rewrite Ml ppxs
+    |> Ast_mapper.drop_ppx_context_str ~restore
+
+let apply_rewriters_sig ?(restore = true) ~tool_name ast =
+  match !Clflags.all_ppx with
+  | [] -> ast
+  | ppxs ->
+    ast
+    |> Ast_mapper.add_ppx_context_sig ~tool_name
+    |> rewrite Mli ppxs
+    |> Ast_mapper.drop_ppx_context_sig ~restore
+
+let apply_rewriters ?restore ~tool_name
+    (type a) (kind : a Ml_binary.kind) (ast : a) : a =
+  match kind with
+  | Ml_binary.Ml ->
+    apply_rewriters_str ?restore ~tool_name ast
+  | Ml_binary.Mli ->
+    apply_rewriters_sig ?restore ~tool_name ast

jscomp/core/js_implementation.ml

@@ -103,7 +103,8 @@ let after_parsing_sig ppf  outputprefix ast  =
 
 let interface ppf fname outputprefix =
   Compmisc.init_path false;
-  Pparse.parse_interface ~tool_name:Js_config.tool_name ppf fname
+  Pparse_driver.parse_interface  ppf fname
+  |> Cmd_ppx_apply.apply_rewriters ~restore:false ~tool_name:Js_config.tool_name Mli 
   |> Ppx_entry.rewrite_signature
   |> print_if_pipe ppf Clflags.dump_parsetree Printast.interface
   |> print_if_pipe ppf Clflags.dump_source Pprintast.signature 
@@ -200,8 +201,9 @@ let after_parsing_impl ppf  outputprefix (ast : Parsetree.structure) =
       process_with_gentype (outputprefix ^ ".cmt")        
     end
 let implementation ppf fname outputprefix =
-  Compmisc.init_path false;
-  Pparse.parse_implementation ~tool_name:Js_config.tool_name ppf fname
+  Compmisc.init_path false;  
+  Pparse_driver.parse_implementation  ppf fname
+  |> Cmd_ppx_apply.apply_rewriters ~restore:false ~tool_name:Js_config.tool_name Ml  
   |> Ppx_entry.rewrite_implementation
   |> print_if_pipe ppf Clflags.dump_parsetree Printast.implementation
   |> print_if_pipe ppf Clflags.dump_source Pprintast.structure

jscomp/core/pparse_driver.ml

@@ -0,0 +1,96 @@
+
+
+
+(* Optionally preprocess a source file *)
+
+let call_external_preprocessor sourcefile pp =
+      let tmpfile = Filename.temp_file "ocamlpp" "" in
+      let comm = Printf.sprintf "%s %s > %s"
+                                pp (Filename.quote sourcefile) tmpfile
+      in
+      if Ccomp.command comm <> 0 then begin
+        Misc.remove_file tmpfile;
+        Cmd_ast_exception.cannot_run comm
+      end;
+      tmpfile
+
+let preprocess sourcefile =
+  match !Clflags.preprocessor with
+    None -> sourcefile
+  | Some pp ->
+    call_external_preprocessor sourcefile pp
+
+
+let remove_preprocessed inputfile =
+  match !Clflags.preprocessor with
+    None -> ()
+  | Some _ -> Misc.remove_file inputfile
+
+
+
+
+
+
+(* Parse a file or get a dumped syntax tree from it *)
+
+let parse (type a) (kind : a Ml_binary.kind) lexbuf : a =
+  match kind with
+  | Ml_binary.Ml -> Parse.implementation lexbuf
+  | Ml_binary.Mli -> Parse.interface lexbuf
+
+let file_aux ppf  inputfile (type a) (parse_fun  : _ -> a)
+             (kind : a Ml_binary.kind) : a  =
+  let ast_magic = Ml_binary.magic_of_kind kind in
+  let ic = open_in_bin inputfile in
+  let is_ast_file =
+    match really_input_string ic (String.length ast_magic) with 
+    | exception _ -> false 
+    |  buffer ->
+      if buffer = ast_magic then true
+      else if Ext_string.starts_with buffer "Caml1999" then
+        Cmd_ast_exception.wrong_magic buffer
+      else false in 
+  let ast =
+    try
+      if is_ast_file then begin
+        if !Clflags.fast then
+          (* FIXME make this a proper warning *)
+          Format.fprintf ppf "@[Warning: %s@]@."
+            "option -unsafe used with a preprocessor returning a syntax tree";
+        Location.set_input_name (input_value ic : string);
+        (input_value ic : a)
+      end else begin
+        seek_in ic 0;
+        let lexbuf = Lexing.from_channel ic in
+        Location.init lexbuf inputfile;
+        parse_fun lexbuf
+      end
+    with x -> close_in ic; raise x
+  in
+  close_in ic; ast   
+  
+  
+
+
+
+let parse_file (type a) (kind  : a Ml_binary.kind) (ppf : Format.formatter) (sourcefile : string) : a =
+  Location.set_input_name  sourcefile;
+  let inputfile = preprocess sourcefile in
+  let ast =
+    try 
+      (file_aux ppf  inputfile (parse kind)  kind)
+    with exn ->
+      remove_preprocessed inputfile;
+      raise exn
+  in
+  remove_preprocessed inputfile;
+  ast
+
+
+
+let parse_implementation ppf  sourcefile =  
+  (parse_file 
+       Ml ppf sourcefile)
+
+let parse_interface ppf  sourcefile =
+  parse_file Mli ppf sourcefile

jscomp/core/pparse_driver.mli

@@ -0,0 +1,11 @@
+
+
+val parse_implementation:
+  Format.formatter ->
+  string -> Parsetree.structure
+
+
+val parse_interface:   
+  Format.formatter ->
+
+  string -> Parsetree.signature