Merge pull request #3749 from BuckleScript/minimal_bsb_helper

minimize the size of bsb_helper

Author: bobzhang

jscomp/bsb/bsb_ninja_file_groups.ml

@@ -37,7 +37,7 @@ let handle_generators oc
   Ext_list.iter group.generators (fun {output; input; command} -> 
       (*TODO: add a loc for better error message *)
       match String_map.find_opt custom_rules command with 
-      | None -> Ext_pervasives.failwithf ~loc:__LOC__ "custom rule %s used but  not defined" command
+      | None -> Ext_fmt.failwithf ~loc:__LOC__ "custom rule %s used but  not defined" command
       | Some rule -> 
         Bsb_ninja_targets.output_build oc 
           ~outputs:(Ext_list.map  output  map_to_source_dir)

jscomp/bsb_helper/bsb_arg.ml

@@ -0,0 +1,151 @@
+
+type key = string
+type doc = string
+type usage_msg = string
+type anon_fun = (string -> unit)
+
+type spec =
+  | Unit of (unit -> unit)     
+  | Set of bool ref            
+  | String of (string -> unit) 
+  | Set_string of string ref   
+  | Int of (int -> unit)       
+  | Set_int of int ref         
+
+exception Bad of string
+exception Help of string
+
+type error =
+  | Unknown of string
+  | Wrong of string * string * string  (* option, actual, expected *)
+  | Missing of string
+  | Message of string
+
+exception Stop of error
+
+
+type t = (string * spec * string) list 
+
+let rec assoc3 (x : string) (l : t) =
+  match l with
+  | [] -> None
+  | (y1, y2, y3) :: t when y1 = x -> Some y2
+  | _ :: t -> assoc3 x t
+;;
+
+
+
+let usage_b (buf : Ext_buffer.t) speclist errmsg =
+  let print_spec buf (key, spec, doc) =
+    if  doc <> "" then begin 
+      Ext_buffer.add_string buf "  ";
+      Ext_buffer.add_string_char buf key ' ';  
+      Ext_buffer.add_string_char buf doc '\n'  
+    end 
+  in 
+
+  Ext_buffer.add_string_char buf errmsg '\n';
+  Ext_list.iter speclist (print_spec buf) 
+;;
+
+
+  
+let stop_raise progname (error : error) speclist errmsg  =
+  let b = Ext_buffer.create 200 in  
+  begin match error with
+    | Unknown ("-help" | "--help" | "-h") -> 
+      usage_b b speclist errmsg;
+      output_string stdout (Ext_buffer.contents b);
+      exit 0
+      
+    | Unknown s ->
+      Ext_buffer.add_string_char b progname ':';
+      Ext_buffer.add_string b  " unknown option '";
+      Ext_buffer.add_string b s ;
+      Ext_buffer.add_string b "'.\n"
+    | Missing s ->
+      Ext_buffer.add_string_char b progname ':';
+      Ext_buffer.add_string b " option '";
+      Ext_buffer.add_string b s;
+      Ext_buffer.add_string b "' needs an argument.\n"      
+    | Wrong (opt, arg, expected) ->
+      Ext_buffer.add_string_char b progname ':';
+      Ext_buffer.add_string b " wrong argument '";
+      Ext_buffer.add_string b arg; 
+      Ext_buffer.add_string b "'; option '";
+      Ext_buffer.add_string b opt;
+      Ext_buffer.add_string b "' expects ";
+      Ext_buffer.add_string b expected;
+      Ext_buffer.add_string b ".\n"      
+    | Message s ->
+      Ext_buffer.add_string_char b progname ':';
+      Ext_buffer.add_char_string b ' ' s;
+      Ext_buffer.add_string b ".\n"
+  end;
+  usage_b b speclist errmsg;
+  raise (Bad (Ext_buffer.contents b))
+
+
+let parse_exn  (speclist : t) anonfun errmsg =    
+  let argv = Sys.argv in 
+  let stop_raise error = stop_raise argv.(0) error speclist errmsg in 
+  let l = Array.length argv in
+  let current = ref 1 in (* 0 is progname*)
+  while !current < l do
+    let s = argv.(!current) in
+    if s <> "" && s.[0] = '-' then begin
+      let action =
+        match assoc3 s speclist with 
+        | Some action -> action 
+        | None -> stop_raise (Unknown s)
+      in
+      begin try
+        let rec treat_action = function
+        | Unit f -> f ();
+        | Set r -> r := true;
+        | String f when !current + 1 < l ->
+            f argv.(!current + 1);
+            incr current;
+        | Set_string r when !current + 1 < l ->
+            r := argv.(!current + 1);
+            incr current;
+        | Int f when !current + 1 < l ->
+            let arg = argv.(!current + 1) in
+            begin try f (int_of_string arg)
+            with Failure "int_of_string" ->
+                   raise (Stop (Wrong (s, arg, "an integer")))
+            end;
+            incr current;
+        | Set_int r when !current + 1 < l ->
+            let arg = argv.(!current + 1) in
+            begin try r := (int_of_string arg)
+            with Failure "int_of_string" ->
+                   raise (Stop (Wrong (s, arg, "an integer")))
+            end;
+            incr current;
+        | _ -> raise (Stop (Missing s))
+        in
+        treat_action action
+      with Bad m -> stop_raise (Message m);
+         | Stop e -> stop_raise e;
+      end;
+      incr current;
+    end else begin
+      (try anonfun s with Bad m -> stop_raise (Message m));
+      incr current;
+    end;
+  done;
+;;
+
+
+
+(* let parse l f msg =
+  try
+    parse_exn l f msg;
+  with
+  | Bad msg -> 
+    output_string stderr msg ; exit 2;
+  | Help msg -> 
+    output_string stdout  msg; exit 0;
+;;
+ *)

jscomp/bsb_helper/bsb_arg.mli

@@ -0,0 +1,21 @@
+
+
+
+type spec =
+  | Unit of (unit -> unit)       
+  | Set of bool ref            
+  | String of (string -> unit) 
+  | Set_string of string ref   
+  | Int of (int -> unit)       
+  | Set_int of int ref         
+
+type key = string
+type doc = string
+type usage_msg = string
+type anon_fun = (string -> unit)
+
+val parse_exn :
+  (key * spec * doc) list -> anon_fun -> usage_msg -> unit
+
+
+

jscomp/bsb_helper/bsb_db_decode.ml

@@ -93,7 +93,9 @@ let read_build_cache ~dir  : t =
     Ext_io.load_file (Filename.concat dir bsbuild_cache) in   
   decode_internal all_content (ref (Ext_digest.length + 1)), all_content
 
-let cmp (a : string) b = String_map.compare_key a b   
+(* Invariant: the same as encoding String_map.compare_key  *)  
+let cmp  =  Ext_string.compare
+    
 
 let rec binarySearchAux (arr : string array) (lo : int) (hi : int) (key : string)  : _ option = 
   let mid = (lo + hi)/2 in 
@@ -129,7 +131,7 @@ let find_opt_aux sorted key  : _ option =
 
 
 type module_info =  {
-  case : Bsb_db.case; 
+  case : bool ; (* which is Bsb_db.case*)
   dir_name : string
 } 
 

jscomp/bsb_helper/bsb_db_decode.mli

@@ -48,7 +48,7 @@ val read_build_cache :
 
 
 type module_info = {
-  case : Bsb_db.case;
+  case : bool (* Bsb_db.case*);
   dir_name : string
 } 
 

jscomp/common/js_config.ml

@@ -30,19 +30,19 @@
 (* let add_npm_package_path s =
   match !packages_info  with
   | Empty ->
-    Ext_pervasives.bad_argf "please set package name first using -bs-package-name ";
+    Ext_arg.bad_argf "please set package name first using -bs-package-name ";
   | NonBrowser(name,  envs) ->
     let env, path =
       match Ext_string.split ~keep_empty:false s ':' with
       | [ package_name; path]  ->
         (match Js_packages_info.module_system_of_string package_name with
          | Some x -> x
          | None ->
-           Ext_pervasives.bad_argf "invalid module system %s" package_name), path
+           Ext_arg.bad_argf "invalid module system %s" package_name), path
       | [path] ->
         NodeJS, path
       | _ ->
-        Ext_pervasives.bad_argf "invalid npm package path: %s" s
+        Ext_arg.bad_argf "invalid npm package path: %s" s
     in
     packages_info := NonBrowser (name,  ((env,path) :: envs)) *)
 (** Browser is not set via command line only for internal use *)

jscomp/core/js_cmj_format.ml

@@ -88,7 +88,7 @@ let digest_length = 16 (*16 chars *)
 let verify_magic_in_beg ic =
   let buffer = really_input_string ic cmj_magic_number_length in 
   if buffer <> cmj_magic_number then
-    Ext_pervasives.failwithf ~loc:__LOC__ 
+    Ext_fmt.failwithf ~loc:__LOC__ 
       "cmj files have incompatible versions, please rebuilt using the new compiler : %s" 
         __LOC__
 
@@ -116,7 +116,7 @@ let from_string s : t =
   if magic_number = cmj_magic_number then 
     Marshal.from_string s  (digest_length + cmj_magic_number_length)
   else 
-    Ext_pervasives.failwithf ~loc:__LOC__ 
+    Ext_fmt.failwithf ~loc:__LOC__ 
       "cmj files have incompatible versions, please rebuilt using the new compiler : %s"
         __LOC__
 

jscomp/core/js_exp_make.ml

@@ -1128,6 +1128,15 @@ let int32_lsl ?comment (e1 : J.expression) (e2 : J.expression) : J.expression =
       expression_desc = Bin (Lsl, e1,e2)
     }
 
+let  is_pos_pow n = 
+  let module M = struct exception E end in 
+  let rec aux c (n : Int32.t) = 
+    if n <= 0l then -2 
+    else if n = 1l then c 
+    else if Int32.logand n 1l =  0l then   
+      aux (c + 1) (Int32.shift_right n 1 )
+    else raise_notrace M.E in 
+  try aux 0 n  with M.E -> -1
 
 let int32_mul ?comment 
     (e1 : J.expression) 
@@ -1144,7 +1153,7 @@ let int32_mul ?comment
   | e , {expression_desc = Number (Int {i = i0} | Uint i0 ); _}
   | {expression_desc = Number (Int {i = i0} | Uint i0 ); _}, e 
     -> 
-    let i =  Ext_pervasives.is_pos_pow i0  in 
+    let i =  is_pos_pow i0  in 
     if i >= 0 then 
       int32_lsl e (small_int i)
     else 

jscomp/core/js_implementation.ml

@@ -78,9 +78,13 @@ let after_parsing_sig ppf  outputprefix ast  =
           initial_env sg ;
       end
     end
-let interface ppf sourcefile outputprefix =
+
+
+
+let interface ppf fname outputprefix =
   Compmisc.init_path false;
-  Ocaml_parse.parse_interface ppf sourcefile
+  Pparse.parse_interface ~tool_name:Js_config.tool_name ppf fname
+  |> Ppx_entry.rewrite_signature
   |> print_if ppf Clflags.dump_parsetree Printast.interface
   |> print_if ppf Clflags.dump_source Pprintast.signature 
   |> after_parsing_sig ppf  outputprefix 
@@ -142,7 +146,8 @@ let after_parsing_impl ppf  outputprefix ast =
     end
 let implementation ppf fname outputprefix =
   Compmisc.init_path false;
-  Ocaml_parse.parse_implementation ppf fname
+  Pparse.parse_implementation ~tool_name:Js_config.tool_name ppf fname
+  |> Ppx_entry.rewrite_implementation
   |> print_if ppf Clflags.dump_parsetree Printast.implementation
   |> print_if ppf Clflags.dump_source Pprintast.structure
   |> after_parsing_impl ppf outputprefix 

jscomp/core/js_packages_info.ml

@@ -228,23 +228,23 @@ let get_output_dir
 
 let add_npm_package_path (packages_info : t) (s : string)  : t =
   if is_empty packages_info then 
-    Ext_pervasives.bad_argf "please set package name first using -bs-package-name "
+    Ext_arg.bad_argf "please set package name first using -bs-package-name "
   else   
     let module_system, path =
       match Ext_string.split ~keep_empty:false s ':' with
       | [ module_system; path]  ->
         (match module_system_of_string module_system with
          | Some x -> x
          | None ->
-           Ext_pervasives.bad_argf "invalid module system %s" module_system), path
+           Ext_arg.bad_argf "invalid module system %s" module_system), path
       | [path] ->
         NodeJS, path
       | module_system :: path -> 
         (match module_system_of_string module_system with 
         | Some x -> x
-        | None -> Ext_pervasives.bad_argf "invalid module system %s" module_system), (String.concat ":" path)
+        | None -> Ext_arg.bad_argf "invalid module system %s" module_system), (String.concat ":" path)
       | _ ->
-        Ext_pervasives.bad_argf "invalid npm package path: %s" s
+        Ext_arg.bad_argf "invalid npm package path: %s" s
     in
     { packages_info with module_systems = {module_system; path}::packages_info.module_systems}