using our own command line parsing for tweaks later

bobzhang · bobzhang · commit f53776576223 · 2020-06-12T17:21:19.000+08:00
diff --git a/jscomp/bsb/bsb_arg.ml b/jscomp/bsb/bsb_arg.ml
@@ -0,0 +1,140 @@
+(* Copyright (C) 2020- Authors of BuckleScript
+ *
+ * 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. *)
+
+
+
+
+ type key = string
+ type doc = string
+ type anon_fun = rev_args:string list -> unit
+ 
+ type string_action = 
+   | String_call of (string -> unit)  
+   | String_set of string ref
+
+ type unit_action = 
+    | Unit_call of (unit -> unit) 
+    | Unit_set of bool ref
+
+ type spec =
+   | Unit of unit_action
+   | String of string_action 
+ 
+ 
+ exception Bad of string
+ 
+ 
+ type error =
+   | Unknown of string
+   | Missing of string
+ 
+ type t = (string * spec * string) list 
+ 
+ let rec assoc3 (x : string) (l : t) =
+   match l with
+   | [] -> None
+   | (y1, y2, _) :: _ when y1 = x -> Some y2
+   | _ :: t -> assoc3 x t
+ ;;
+ 
+ 
+ let (+>) = Ext_buffer.add_string
+ 
+ let usage_b (buf : Ext_buffer.t) ~usage speclist  =
+   buf +> usage;
+   buf +> "\nOptions:\n";
+   let max_col = ref 0 in 
+   Ext_list.iter speclist (fun (key,_,_) -> 
+       if String.length key > !max_col then 
+         max_col := String.length key
+     );
+   Ext_list.iter speclist (fun (key,_,doc) -> 
+       buf +> "  ";
+       buf +> key ; 
+       buf +> (String.make (!max_col - String.length key + 2 ) ' ');
+       buf +> doc;
+       buf +> "\n"
+     )
+ ;;
+ 
+ 
+   
+ let stop_raise ~usage ~(error : error) speclist   =
+   let b = Ext_buffer.create 200 in  
+   begin match error with
+     | Unknown ("-help" | "--help" | "-h") -> 
+       usage_b b ~usage speclist ;
+       Ext_buffer.output_buffer stdout b;
+       exit 0      
+     | Unknown s ->
+       b +> "unknown option: '";
+       b +> s ;
+       b +> "'.\n"
+     | Missing s ->
+       b +> "option '";
+       b +> s;
+       b +> "' needs an argument.\n"      
+   end;
+   usage_b b ~usage speclist ;
+   raise (Bad (Ext_buffer.contents b))
+ 
+ 
+ let parse_exn  ~usage ~argv ~start (speclist : t) anonfun  =    
+   let l = Array.length argv in
+   let current = ref start in 
+   let rev_list = ref [] in 
+   while !current < l do
+     let s = argv.(!current) in
+     incr current;  
+     if s <> "" && s.[0] = '-' then begin
+       match assoc3 s speclist with 
+       | Some action -> begin       
+           begin match action with 
+             | Unit r -> 
+               begin match r with 
+                 | Unit_set r -> r.contents <- true
+                 | Unit_call f -> f ()
+               end
+             | String f  ->
+               if !current >= l then stop_raise ~usage ~error:(Missing s) speclist 
+               else begin                 
+                 let arg = argv.(!current) in 
+                 incr current;  
+                 match f with 
+                 | String_call f ->   
+                   f arg
+                 | String_set u -> u.contents <- arg
+               end             
+           end;      
+         end;      
+       | None -> stop_raise ~usage ~error:(Unknown s) speclist 
+     end else begin
+       rev_list := s :: !rev_list;      
+     end;
+   done;
+   anonfun ~rev_args:!rev_list
+ ;;
+ 
+ 
+ 
diff --git a/jscomp/bsb/bsb_arg.mli b/jscomp/bsb/bsb_arg.mli
@@ -0,0 +1,49 @@
+(* Copyright (C) 2020- Authors of BuckleScript
+ *
+ * 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. *)
+
+type string_action = 
+  | String_call of (string -> unit)  
+  | String_set of string ref 
+
+type unit_action = 
+  | Unit_call of (unit -> unit) 
+  | Unit_set of bool ref 
+
+exception Bad of string
+
+type spec =
+  | Unit of unit_action
+  | String of string_action 
+
+type key = string
+type doc = string
+
+type anon_fun = rev_args:string list -> unit
+
+val parse_exn :
+  usage:string -> 
+  argv:string array -> 
+  start:int ->
+  (key * spec * doc) list -> 
+  anon_fun  -> unit
diff --git a/jscomp/main/bsb_main.ml b/jscomp/main/bsb_main.ml
@@ -23,72 +23,72 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
 let () =  Bsb_log.setup () 
-
-let force_regenerate = ref false
-
 let current_theme = ref "basic"
-let set_theme s = current_theme := s 
 let generate_theme_with_path = ref None
 let regen = "-regen"
 let separator = "--"
 let watch_mode = ref false
 let make_world = ref false 
 let do_install = ref false
-let set_make_world () = make_world := true
 let bs_version_string = Bs_version.version
-
 let print_version_string () = 
   print_string bs_version_string;
   print_newline (); 
   exit 0 
+type spec = Bsb_arg.spec
 
-let bsb_main_flags : (string * Arg.spec * string) list=
+let call_spec f : spec = Unit (Unit_call f )
+let  unit_set_spec b : spec = Unit (Unit_set b)
+
+
+let force_regenerate = ref false
+let bsb_main_flags : (string * spec * string) list=
   [
-    "-v", Unit print_version_string, 
-    " Print version and exit";
-    "-version", Unit print_version_string, 
-    " Print version and exit";
-    "-verbose", Unit Bsb_log.verbose,
-    " Set the output(from bsb) to be verbose";
-    "-w", Set watch_mode,
-    " Watch mode" ;     
-    "-clean-world", Unit (fun _ -> 
+    "-v", call_spec print_version_string, 
+    "Print version and exit";
+    "-version", call_spec print_version_string, 
+    "Print version and exit";
+    "-verbose", call_spec Bsb_log.verbose,
+    "Set the output(from bsb) to be verbose";
+    "-w", unit_set_spec watch_mode,
+    "Watch mode" ;     
+    "-clean-world",call_spec (fun _ -> 
         Bsb_clean.clean_bs_deps  Bsb_global_paths.cwd),
-    " Clean all bs dependencies";
-    "-clean", Unit (fun _ -> 
+    "Clean all bs dependencies";
+    "-clean", call_spec (fun _ -> 
         Bsb_clean.clean_self  Bsb_global_paths.cwd),
-    " Clean only current project";
-    "-make-world", Unit set_make_world,
-    " Build all dependencies and itself ";
-    "-install", Set do_install,
-    " Install public interface files into lib/ocaml";
-    "-init", String (fun path -> generate_theme_with_path := Some path),
-    " Init sample project to get started. Note (`bsb -init sample` will create a sample project while `bsb -init .` will reuse current directory)";
-    "-theme", String set_theme,
-    " The theme for project initialization, default is basic(https://github.com/bucklescript/bucklescript/tree/master/jscomp/bsb/templates)";
+    "Clean only current project";
+    "-make-world", unit_set_spec make_world,
+    "Build all dependencies and itself ";
+    "-install", unit_set_spec do_install,
+    "Install public interface files into lib/ocaml";
+    "-init", String (String_call (fun path -> generate_theme_with_path := Some path)),
+    "Init sample project to get started. Note (`bsb -init sample` will create a sample project while `bsb -init .` will reuse current directory)";
+    "-theme", String (String_set current_theme),
+    "The theme for project initialization, default is basic(https://github.com/bucklescript/bucklescript/tree/master/jscomp/bsb/templates)";
     
-    regen, Set force_regenerate,
-    " (internal) Always regenerate build.ninja no matter bsconfig.json is changed or not (for debugging purpose)";
-    "-themes", Unit Bsb_theme_init.list_themes,
-    " List all available themes";
+    regen, unit_set_spec force_regenerate,
+    "(internal) Always regenerate build.ninja no matter bsconfig.json is changed or not (for debugging purpose)";
+    "-themes", call_spec Bsb_theme_init.list_themes,
+    "List all available themes";
     "-where",
-    Unit (fun _ -> 
+    call_spec (fun _ -> 
         print_endline (Filename.dirname Sys.executable_name)),
-    " Show where bsb.exe is located";
+    "Show where bsb.exe is located";
 (** Below flags are only for bsb script, it is not available for bsb.exe 
   we make it at this time to make `bsb -help` easier
 *)
-    "-ws", Bool ignore, 
-    " [host:]port specify a websocket number (and optionally, a host). When a build finishes, we send a message to that port. For tools that listen on build completion." ;
+    "-ws", call_spec ignore, 
+    "[host:]port specify a websocket number (and optionally, a host). When a build finishes, we send a message to that port. For tools that listen on build completion." ;
 #if BS_NATIVE then
-    "-backend", String (fun s -> 
+    "-backend", String (String_call (fun s -> 
         match s with
         | "js"       -> Bsb_global_backend.set_backend Bsb_config_types.Js
         | "native"   -> Bsb_global_backend.set_backend Bsb_config_types.Native
         | "bytecode" -> Bsb_global_backend.set_backend Bsb_config_types.Bytecode
         | _ -> failwith "-backend should be one of: 'js', 'bytecode' or 'native'."
-      ),
-    " Builds the entries specified in the bsconfig that match the given backend. Can be either 'js', 'bytecode' or 'native'.";
+      )),
+    "Builds the entries specified in the bsconfig that match the given backend. Can be either 'js', 'bytecode' or 'native'.";
 #end
   ]
 
@@ -135,13 +135,16 @@ let ninja_command_exit   ninja_args  =
    ninja -C _build
 *)
 let usage = "Usage : bsb.exe <bsb-options> -- <ninja_options>\n\
-             For ninja options, try ninja -h \n\
+             For ninja options, try bsb.exe --  -h.  \n\
+             Note they are supposed to be internals and not reliable.\n\
              ninja will be loaded either by just running `bsb.exe' or `bsb.exe .. -- ..`\n\
-             It is always recommended to run ninja via bsb.exe \n\
-             Bsb options are:"
+             It is always recommended to run ninja via bsb.exe"
 
-let handle_anonymous_arg arg =
-  raise (Arg.Bad ("Unknown arg \"" ^ arg ^ "\""))
+let handle_anonymous_arg ~rev_args =
+  match rev_args with 
+  | [] -> ()  
+  | arg:: _ ->
+    raise (Bsb_arg.Bad ("Unknown arg \"" ^ arg ^ "\""))
 
 
 let program_exit () =
@@ -199,10 +202,16 @@ let () =
         | `No_split
           ->
           begin
-            Arg.parse bsb_main_flags handle_anonymous_arg usage;
+            Bsb_arg.parse_exn 
+            ~usage
+            ~argv 
+            ~start:1
+            bsb_main_flags 
+            handle_anonymous_arg            
+            ;
             (* first, check whether we're in boilerplate generation mode, aka -init foo -theme bar *)
             match !generate_theme_with_path with
-            | Some path -> Bsb_theme_init.init_sample_project ~cwd:Bsb_global_paths.cwd ~theme:!current_theme path
+            | Some path -> Bsb_theme_init.init_sample_project ~cwd:Bsb_global_paths.cwd ~theme:!current_theme  path
             | None -> 
               (* [-make-world] should never be combined with [-package-specs] *)
               let make_world = !make_world in 
@@ -240,17 +249,21 @@ let () =
         | `Split (bsb_args,ninja_args)
           -> (* -make-world all dependencies fall into this category *)
           begin
-            Arg.parse_argv bsb_args bsb_main_flags handle_anonymous_arg usage ;
-            let config_opt = 
-              Bsb_ninja_regen.regenerate_ninja 
+            Bsb_arg.parse_exn 
+            ~usage
+            ~argv:bsb_args 
+            ~start:1
+            bsb_main_flags handle_anonymous_arg  ;
+            let config_opt = lazy
+              (Bsb_ninja_regen.regenerate_ninja 
                 ~toplevel_package_specs:None 
                 ~per_proj_dir:Bsb_global_paths.cwd 
-                ~forced:!force_regenerate in
+                ~forced:!force_regenerate) in
             (* [-make-world] should never be combined with [-package-specs] *)
             if !make_world then
-              Bsb_world.make_world_deps Bsb_global_paths.cwd config_opt ninja_args;
+              Bsb_world.make_world_deps Bsb_global_paths.cwd (Lazy.force config_opt) ninja_args;
             if !do_install then
-              install_target config_opt;
+              install_target (Lazy.force config_opt);
             if !watch_mode then program_exit ()
             else ninja_command_exit  ninja_args 
           end
