support .iast/.ast

Author: bobzhang

jscomp/common/ml_binary.ml

@@ -55,13 +55,3 @@ let magic_of_kind : type a . a kind -> string = function
   | Mli -> Config.ast_intf_magic_number
 
 
-let read_my_ast (type t ) (_ : t  kind) ic : t  =
-  Location.set_input_name (input_line ic);
-  input_value ic 
-
-let write_my_ast (type t) ( _ : t kind)
-    (fname : string)
-    (pt : t) oc = 
-  output_string oc fname;
-  output_char oc '\n';
-  output_value oc pt

jscomp/common/ml_binary.mli

@@ -39,14 +39,3 @@ val write_ast :
 
 val magic_of_kind : 'a kind -> string   
 
-val read_my_ast : 
-  'a kind ->
-  in_channel ->
-   'a
-
-val write_my_ast : 
-  'a kind -> 
-   string -> 
-   'a -> 
-   out_channel -> 
-   unit

jscomp/core/js_implementation.ml

@@ -111,9 +111,9 @@ let interface ~parser ppf fname outputprefix =
   |> print_if_pipe ppf Clflags.dump_source Pprintast.signature 
   |> after_parsing_sig ppf  outputprefix 
 
-let interface_mliast ppf fname outputprefix  = 
+let interface_mliast ppf fname outputprefix  setup = 
   Res_compmisc.init_path ();
-  Binary_ast.read_ast_exn Mli ~fname 
+  Binary_ast.read_ast_exn ~fname Mli  setup
   |> print_if_pipe ppf Clflags.dump_parsetree Printast.interface
   |> print_if_pipe ppf Clflags.dump_source Pprintast.signature 
   |> after_parsing_sig ppf  outputprefix 
@@ -205,9 +205,9 @@ let implementation ~parser ppf fname outputprefix  =
   |> print_if_pipe ppf Clflags.dump_source Pprintast.structure
   |> after_parsing_impl ppf outputprefix 
 
-let implementation_mlast ppf fname outputprefix = 
+let implementation_mlast ppf fname outputprefix setup = 
   Res_compmisc.init_path ();
-  Binary_ast.read_ast_exn Ml ~fname
+  Binary_ast.read_ast_exn ~fname Ml  setup
   |> print_if_pipe ppf Clflags.dump_parsetree Printast.implementation
   |> print_if_pipe ppf Clflags.dump_source Pprintast.structure
   |> after_parsing_impl ppf  outputprefix 

jscomp/core/js_implementation.mli

@@ -42,7 +42,12 @@ val interface :
   string -> 
   unit
 
-val interface_mliast : Format.formatter -> string -> string  -> unit
+val interface_mliast : 
+  Format.formatter -> 
+  string -> 
+  string  -> 
+  ([`ml | `rescript | `reason ] -> unit) ->
+  unit
 
 
 
@@ -64,6 +69,11 @@ val implementation :
   unit
 (** [implementation ppf sourcefile outprefix] compiles to JS directly *) 
 
-val implementation_mlast : Format.formatter -> string -> string -> unit
+val implementation_mlast : 
+  Format.formatter ->
+  string -> 
+  string -> 
+  ([`ml | `rescript | `reason ]  -> unit) ->
+  unit
 
 val implementation_map : Format.formatter -> string -> string -> unit

jscomp/depends/binary_ast.ml

@@ -26,14 +26,25 @@
  (** Synced up with module {!Bsb_helper_depfile_gen} *)
 module Set_string = Ast_extract.Set_string
 
+type 'a kind = 'a Ml_binary.kind =
+  | Ml : Parsetree.structure kind 
+  | Mli : Parsetree.signature kind
 
 
-let read_ast_exn (type t ) ~fname (kind : t  Ml_binary.kind)  : t  =
+let read_ast_exn (type t ) ~fname (_ : t  kind) setup : t  =
   let ic = open_in_bin fname in
   let dep_size = input_binary_int ic in 
   seek_in  ic (pos_in ic + dep_size) ; 
-  let ast = Ml_binary.read_my_ast kind ic in 
+  let sourcefile = (input_line ic) in
+  Location.set_input_name sourcefile;
+  let ast = input_value ic in
   close_in ic;
+  begin match Ext_file_extensions.classify_input 
+                (Ext_filename.get_extension_maybe sourcefile) with 
+  | Re | Rei -> setup `reason   
+  | Res | Resi -> setup `rescript 
+  | _ -> ()
+  end;
   ast
 
 let magic_sep_char = '\n'
@@ -42,7 +53,7 @@ let magic_sep_char = '\n'
    1. for performance , easy skipping and calcuate the length 
    2. cut dependency, otherwise its type is {!Ast_extract.Set_string.t}
 *)      
-let write_ast (type t) ~(sourcefile : string) ~output (kind : t Ml_binary.kind) ( pt : t) : unit =
+let write_ast (type t) ~(sourcefile : string) ~output (kind : t kind) ( pt : t) : unit =
   let oc = open_out_bin output in 
   let output_set = Ast_extract.read_parse_and_extract kind pt in
   let buf = Ext_buffer.create 1000 in
@@ -55,6 +66,8 @@ let write_ast (type t) ~(sourcefile : string) ~output (kind : t Ml_binary.kind)
     ) output_set ;  
   output_binary_int oc (Ext_buffer.length buf);  
   Ext_buffer.output_buffer oc buf;
-  Ml_binary.write_my_ast kind sourcefile pt oc;
+  output_string oc sourcefile;
+  output_char oc '\n';
+  output_value oc pt;
   close_out oc 
 

jscomp/depends/binary_ast.mli

@@ -23,9 +23,14 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
 
+type _ kind = 
+  | Ml : Parsetree.structure kind 
+  | Mli : Parsetree.signature kind
+
 val read_ast_exn : 
   fname:string -> 
-  'a Ml_binary.kind ->  
+  'a kind ->  
+  ([`ml | `rescript | `reason ] -> unit) ->
   'a 
 
 
@@ -46,5 +51,10 @@ val magic_sep_char : char
    Use case cat - | fan -printer -impl -
    redirect the standard input to fan
  *)
-val write_ast : sourcefile:string -> output:string -> 'a Ml_binary.kind -> 'a -> unit
+val write_ast : 
+  sourcefile:string -> 
+  output:string -> 
+  'a kind -> 
+  'a -> 
+  unit
 

jscomp/ext/ext_file_extensions.ml

@@ -0,0 +1,43 @@
+type valid_input = 
+  | Ml 
+  | Mli
+  | Re
+  | Rei
+  | Res
+  | Resi
+  | Intf_ast
+  | Impl_ast
+  | Mlmap
+  | Cmi
+  | Unknown
+
+
+(** This is per-file based, 
+    when [ocamlc] [-c -o another_dir/xx.cmi] 
+    it will return (another_dir/xx)
+*)    
+
+let classify_input ext = 
+
+  match () with 
+  | _ when ext = Literals.suffix_ml ->   
+    Ml
+  | _ when ext = Literals.suffix_re ->
+    Re
+  | _ when ext = !Config.interface_suffix ->
+    Mli  
+  | _ when ext = Literals.suffix_rei ->
+    Rei
+  | _ when ext =  Literals.suffix_ast ->
+    Impl_ast 
+  | _ when ext = Literals.suffix_iast ->
+    Intf_ast
+  | _ when ext =  Literals.suffix_mlmap ->
+    Mlmap 
+  | _ when ext =  Literals.suffix_cmi ->
+    Cmi
+  | _ when ext = Literals.suffix_res -> 
+    Res
+  | _ when ext = Literals.suffix_resi -> 
+    Resi    
+  | _ -> Unknown  

jscomp/ext/literals.ml

@@ -95,6 +95,8 @@ let suffix_mlmap = ".mlmap"
 
 let suffix_cmt = ".cmt"
 let suffix_cmti = ".cmti"
+let suffix_ast = ".ast"
+let suffix_iast = ".iast"
 let suffix_mlast = ".mlast"
 let suffix_mlast_simple = ".mlast_simple"
 let suffix_mliast = ".mliast"

jscomp/main/js_main.ml

@@ -28,18 +28,22 @@ let process_implementation_file ppf name =
   (output_prefix name)
 
 
-let setup_reason_error_printer () = 
-  Config.syntax_kind := `reason ;  
-  Lazy.force Super_main.setup;  
-  Lazy.force Reason_outcome_printer_main.setup
+let setup_error_printer (syntax_kind : [ `ml | `reason | `rescript ])= 
+  Config.syntax_kind := syntax_kind ;   
+  if syntax_kind = `reason then begin 
+    Lazy.force Super_main.setup;  
+    Lazy.force Reason_outcome_printer_main.setup
+  end else if !Config.syntax_kind = `rescript then begin 
+    Lazy.force Super_main.setup;  
+    Lazy.force Res_outcome_printer.setup  
+  end  
 
-let setup_napkin_error_printer () =  
-  Config.syntax_kind := `rescript ;
-  Lazy.force Super_main.setup;  
-  Lazy.force Res_outcome_printer.setup
+
+  
+  
 
 let handle_reason (type a) (kind : a Ml_binary.kind) sourcefile ppf opref = 
-  setup_reason_error_printer ();
+  setup_error_printer `reason;
   let tmpfile =  Ast_reason_pp.pp sourcefile in   
   (match kind with 
    | Ml_binary.Ml -> 
@@ -62,60 +66,10 @@ let handle_reason (type a) (kind : a Ml_binary.kind) sourcefile ppf opref =
   Ast_reason_pp.clean tmpfile 
 
 
-type valid_input = 
-  | Ml 
-  | Mli
-  | Re
-  | Rei
-  | Res
-  | Resi
-  | Resast
-  | Resiast
-  | Mlast    
-  | Mliast 
-  | Reast
-  | Reiast
-  | Mlmap
-  | Cmi
-  | Unknown
-
-
-
-(** This is per-file based, 
-    when [ocamlc] [-c -o another_dir/xx.cmi] 
-    it will return (another_dir/xx)
-*)    
-
-let classify_input ext = 
-
-  match () with 
-  | _ when ext = Literals.suffix_ml ->   
-    Ml
-  | _ when ext = Literals.suffix_re ->
-    Re
-  | _ when ext = !Config.interface_suffix ->
-    Mli  
-  | _ when ext = Literals.suffix_rei ->
-    Rei
-  | _ when ext =  Literals.suffix_mlast ->
-    Mlast 
-  | _ when ext = Literals.suffix_mliast ->
-    Mliast
-  | _ when ext = Literals.suffix_reast ->
-    Reast 
-  | _ when ext = Literals.suffix_reiast ->
-    Reiast
-  | _ when ext =  Literals.suffix_mlmap ->
-    Mlmap 
-  | _ when ext =  Literals.suffix_cmi ->
-    Cmi
-  | _ when ext = Literals.suffix_res -> 
-    Res
-  | _ when ext = Literals.suffix_resi -> 
-    Resi    
-  | _ when ext = Literals.suffix_resast -> Resast   
-  | _ when ext = Literals.suffix_resiast -> Resiast
-  | _ -> Unknown
+
+
+
+
 
 let process_file ppf sourcefile = 
   (* This is a better default then "", it will be changed later 
@@ -124,50 +78,38 @@ let process_file ppf sourcefile =
   *)
   Location.set_input_name  sourcefile;  
   let ext = Ext_filename.get_extension_maybe sourcefile in 
-  let input = classify_input ext in 
+  let input = Ext_file_extensions.classify_input ext in 
   let opref = output_prefix sourcefile in 
   match input with 
   | Re -> handle_reason Ml sourcefile ppf opref     
   | Rei ->
     handle_reason Mli sourcefile ppf opref 
-  | Reiast 
-    -> 
-    setup_reason_error_printer ();
-    Js_implementation.interface_mliast ppf sourcefile opref   
-  | Reast 
-    -> 
-    setup_reason_error_printer ();
-    Js_implementation.implementation_mlast ppf sourcefile opref
+  | Ml ->
+    Js_implementation.implementation 
+      ~parser:Pparse_driver.parse_implementation
+      ppf sourcefile opref 
+  | Mli  ->   
+    Js_implementation.interface 
+      ~parser:Pparse_driver.parse_interface
+      ppf sourcefile opref   
   | Res -> 
-    setup_napkin_error_printer ();
+    setup_error_printer `rescript;
     Js_implementation.implementation 
       ~parser:Res_driver.parse_implementation
       ppf sourcefile opref 
   | Resi ->   
-    setup_napkin_error_printer ();
+    setup_error_printer `rescript;
     Js_implementation.interface 
       ~parser:Res_driver.parse_interface
-      ppf sourcefile opref       
-  | Ml ->
-    Js_implementation.implementation 
-    ~parser:Pparse_driver.parse_implementation
-    ppf sourcefile opref 
-  | Mli  ->   
-    Js_implementation.interface 
-    ~parser:Pparse_driver.parse_interface
-    ppf sourcefile opref   
-  | Resiast
-    ->   
-    setup_napkin_error_printer ();
-    Js_implementation.interface_mliast ppf sourcefile opref 
-  | Mliast 
-    -> Js_implementation.interface_mliast ppf sourcefile opref 
-  | Resast  
-    ->
-    setup_napkin_error_printer ();
+      ppf sourcefile opref     
+  | Intf_ast 
+    ->     
+    Js_implementation.interface_mliast ppf sourcefile opref   
+    setup_error_printer ;
+  | Impl_ast 
+    -> 
     Js_implementation.implementation_mlast ppf sourcefile opref
-  | Mlast 
-    -> Js_implementation.implementation_mlast ppf sourcefile opref
+    setup_error_printer;  
   | Mlmap 
     -> Js_implementation.implementation_map ppf sourcefile opref
   | Cmi
@@ -213,7 +155,7 @@ let intf filename =
 
 
 let format_file input =  
-  let ext = classify_input (Ext_filename.get_extension_maybe input) in 
+  let ext = Ext_file_extensions.classify_input (Ext_filename.get_extension_maybe input) in 
   let syntax = 
     match ext with 
     | Ml | Mli -> `ml