specialized argument parsing for the main compiler

Author: bobzhang

jscomp/core/bsc_args.ml

@@ -0,0 +1,172 @@
+(* 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
+   | String_optional_set of string option ref 
+   | String_list_add of string list ref 
+
+ type unit_action = 
+    | Unit_call of (unit -> unit) 
+    | Unit_lazy of unit lazy_t
+    | Unit_set of bool ref
+    | Unit_clear of bool ref 
+
+ type spec =
+   | Unit of unit_action
+   | String of string_action 
+ 
+ 
+ exception Bsc_bad_arg of string
+ 
+ 
+ type error =
+   | Unknown of string
+   | Missing of string
+ 
+type t = (string * spec * string) array
+
+let rec unsafe_loop i (l : t) n x = 
+  if i = n then None
+  else 
+    let (y1,y2,_) =  Array.unsafe_get l i in
+    if y1 = x then  Some y2
+    else unsafe_loop (i + 1) l n x 
+
+ let assoc3 (x : string) (l : t) =
+   let n = Array.length l in 
+   unsafe_loop 0 l n x 
+ ;;
+ 
+ 
+ let (+>) = Ext_buffer.add_string
+ 
+ let usage_b (buf : Ext_buffer.t) ~usage (speclist : t) =
+   buf +> usage;
+   buf +> "\nOptions:\n";
+   let max_col = ref 0 in 
+   Ext_array.iter speclist (fun (key,_,_) -> 
+       if String.length key > !max_col then 
+         max_col := String.length key
+     );
+   Ext_array.iter speclist (fun (key,_,doc) -> 
+       if not (Ext_string.starts_with doc "*internal*") then begin 
+         buf +> "  ";
+         buf +> key ; 
+         buf +> (String.make (!max_col - String.length key + 2 ) ' ');
+         let cur = ref 0 in 
+         let doc_length = String.length doc in 
+         while !cur < doc_length do 
+           match String.index_from_opt doc !cur '\n' with 
+           | None -> 
+             if !cur <> 0 then begin 
+               buf +>  "\n";
+               buf +> String.make (!max_col + 4) ' ' ;
+             end;
+             buf +> String.sub doc !cur (String.length doc - !cur );
+             cur := doc_length
+           | Some new_line_pos -> 
+             if !cur <> 0 then begin 
+               buf +>  "\n";
+               buf +> String.make (!max_col + 4) ' ' ;
+             end;
+             buf +> String.sub doc !cur (new_line_pos - !cur );
+             cur := new_line_pos + 1
+         done ;
+         buf +> "\n"
+       end
+     )
+ ;;
+ 
+ 
+   
+ let stop_raise ~usage ~(error : error) (speclist : t )  =
+   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 (Bsc_bad_arg (Ext_buffer.contents b))
+ 
+ 
+let parse_exn  ~usage ~argv ?(start=1) ?(finish=Array.length argv) (speclist : t) 
+    (anonfun : rev_args:string list -> unit) =
+  let current = ref start in 
+  let rev_list = ref [] in 
+  while !current < finish 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 := true
+                | Unit_clear r -> r := false
+                | Unit_call f -> f ()
+                | Unit_lazy f -> Lazy.force f
+              end
+            | String f  ->
+              if !current >= finish 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 := arg
+                | String_optional_set s -> s := Some arg
+                | String_list_add s -> s := arg :: !s
+              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
+;;
+
+