@tellahq/rescript 10.1.0-alpha.1

package/lib/ocaml/arg.ml

@@ -0,0 +1,359 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*              Damien Doligez, projet Para, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type key = string
+type doc = string
+type usage_msg = string
+type anon_fun = (string -> unit)
+
+type spec =
+  | Unit of (unit -> unit)     (* Call the function with unit argument *)
+  | Bool of (bool -> unit)     (* Call the function with a bool argument *)
+  | Set of bool ref            (* Set the reference to true *)
+  | Clear of bool ref          (* Set the reference to false *)
+  | String of (string -> unit) (* Call the function with a string argument *)
+  | Set_string of string ref   (* Set the reference to the string argument *)
+  | Int of (int -> unit)       (* Call the function with an int argument *)
+  | Set_int of int ref         (* Set the reference to the int argument *)
+  | Float of (float -> unit)   (* Call the function with a float argument *)
+  | Set_float of float ref     (* Set the reference to the float argument *)
+  | Tuple of spec list         (* Take several arguments according to the
+                                  spec list *)
+  | Symbol of string list * (string -> unit)
+                               (* Take one of the symbols as argument and
+                                  call the function with the symbol. *)
+  | Rest of (string -> unit)   (* Stop interpreting keywords and call the
+                                  function with each remaining argument *)
+  | Expand of (string -> string array) (* If the remaining arguments to process
+                                          are of the form
+                                          [["-foo"; "arg"] @ rest] where "foo" is
+                                          registered as [Expand f], then the
+                                          arguments [f "arg" @ rest] are
+                                          processed. Only allowed in
+                                          [parse_and_expand_argv_dynamic]. *)
+
+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 (* used internally *)
+
+
+
+let rec assoc3 x l =
+  match l with
+  | [] -> raise Not_found
+  | (y1, y2, _) :: _ when y1 = x -> y2
+  | _ :: t -> assoc3 x t
+
+
+let split s =
+  let i = String.index s '=' in
+  let len = String.length s in
+  String.sub s 0 i, String.sub s (i+1) (len-(i+1))
+
+
+let make_symlist prefix sep suffix l =
+  match l with
+  | [] -> "<none>"
+  | h::t -> (List.fold_left (fun x y -> x ^ sep ^ y) (prefix ^ h) t) ^ suffix
+
+
+let print_spec buf (key, spec, doc) =
+  if String.length doc > 0 then
+    match spec with
+    | Symbol (l, _) ->
+        let sym = make_symlist "{" "|" "}" l in 
+        Buffer.add_string buf {j|  $(key) $(sym)$(doc)\n|j}
+    | _ ->
+        Buffer.add_string buf {j|  $(key) $(doc)\n|j}
+
+
+
+let help_action () = raise (Stop (Unknown "-help"))
+
+let add_help speclist =
+  let add1 =
+    try ignore (assoc3 "-help" speclist); []
+    with Not_found ->
+            ["-help", Unit help_action, " Display this list of options"]
+  and add2 =
+    try ignore (assoc3 "--help" speclist); []
+    with Not_found ->
+            ["--help", Unit help_action, " Display this list of options"]
+  in
+  speclist @ (add1 @ add2)
+
+
+let usage_b buf speclist errmsg =
+  Buffer.add_string buf {j|$(errmsg)\n|j};
+  List.iter (print_spec buf) (add_help speclist)
+
+
+let usage_string speclist errmsg =
+  let b = Buffer.create 200 in
+  usage_b b speclist errmsg;
+  Buffer.contents b
+
+
+let usage speclist errmsg =
+  Js.log (usage_string speclist errmsg)
+
+
+let current = ref 0
+
+let bool_of_string_opt x =
+  try Some (bool_of_string x)
+  with Invalid_argument _ -> None
+
+let int_of_string_opt x =
+  try Some (int_of_string x)
+  with Failure _ -> None
+
+let float_of_string_opt x =
+  try Some (float_of_string x)
+  with Failure _ -> None
+
+let parse_and_expand_argv_dynamic_aux allow_expand current argv speclist anonfun errmsg =
+  let initpos = !current in
+  let convert_error error =
+    (* convert an internal error to a Bad/Help exception
+       *or* add the program name as a prefix and the usage message as a suffix
+       to an user-raised Bad exception.
+    *)
+    let b = Buffer.create 200 in
+    let progname = if initpos < (Array.length !argv) then !argv.(initpos) else "(?)" in
+    begin match error with
+      | Unknown "-help" -> ()
+      | Unknown "--help" -> ()
+      | Unknown s ->
+          Buffer.add_string b {j|$(progname): unknown option '$(s)'.\n|j} 
+      | Missing s ->
+          Buffer.add_string b {j|$(progname): option '$(s)' needs an argument.\n|j}
+      | Wrong (opt, arg, expected) ->
+          Buffer.add_string b {j|$(progname): wrong argument '$(arg)'; option '$(opt)' expects $(expected).\n|j}
+      | Message s -> (* user error message *)
+          Buffer.add_string b {j|$(progname): $(s).\n|j}
+    end;
+    usage_b b !speclist errmsg;
+    if error = Unknown "-help" || error = Unknown "--help"
+    then Help (Buffer.contents b)
+    else Bad (Buffer.contents b)
+  in
+  incr current;
+  while !current < (Array.length !argv) do
+    begin try
+      let s = !argv.(!current) in
+      if String.length s >= 1 && s.[0] = '-' then begin
+        let action, follow =
+          try assoc3 s !speclist, None
+          with Not_found ->
+          try
+            let keyword, arg = split s in
+            assoc3 keyword !speclist, Some arg
+          with Not_found -> raise (Stop (Unknown s))
+        in
+        let no_arg () =
+          match follow with
+          | None -> ()
+          | Some arg -> raise (Stop (Wrong (s, arg, "no argument"))) in
+        let get_arg () =
+          match follow with
+          | None ->
+              if !current + 1 < (Array.length !argv) then !argv.(!current + 1)
+              else raise (Stop (Missing s))
+          | Some arg -> arg
+        in
+        let consume_arg () =
+          match follow with
+          | None -> incr current
+          | Some _ -> ()
+        in
+        let rec treat_action = function
+        | Unit f -> f ();
+        | Bool f ->
+            let arg = get_arg () in
+            begin match bool_of_string_opt arg with
+            | None -> raise (Stop (Wrong (s, arg, "a boolean")))
+            | Some s -> f s
+            end;
+            consume_arg ();
+        | Set r -> no_arg (); r := true;
+        | Clear r -> no_arg (); r := false;
+        | String f ->
+            let arg = get_arg () in
+            f arg;
+            consume_arg ();
+        | Symbol (symb, f) ->
+            let arg = get_arg () in
+            if List.mem arg symb then begin
+              f arg;
+              consume_arg ();
+            end else begin
+              raise (Stop (Wrong (s, arg, "one of: "
+                                          ^ (make_symlist "" " " "" symb))))
+            end
+        | Set_string r ->
+            r := get_arg ();
+            consume_arg ();
+        | Int f ->
+            let arg = get_arg () in
+            begin match int_of_string_opt arg with
+            | None -> raise (Stop (Wrong (s, arg, "an integer")))
+            | Some x -> f x
+            end;
+            consume_arg ();
+        | Set_int r ->
+            let arg = get_arg () in
+            begin match int_of_string_opt arg with
+            | None -> raise (Stop (Wrong (s, arg, "an integer")))
+            | Some x -> r := x
+            end;
+            consume_arg ();
+        | Float f ->
+            let arg = get_arg () in
+            begin match float_of_string_opt arg with
+            | None -> raise (Stop (Wrong (s, arg, "a float")))
+            | Some x -> f x
+            end;
+            consume_arg ();
+        | Set_float r ->
+            let arg = get_arg () in
+            begin match float_of_string_opt arg with
+            | None -> raise (Stop (Wrong (s, arg, "a float")))
+            | Some x -> r := x
+            end;
+            consume_arg ();
+        | Tuple specs ->
+            List.iter treat_action specs;
+        | Rest f ->
+            while !current < (Array.length !argv) - 1 do
+              f !argv.(!current + 1);
+              consume_arg ();
+            done;
+        | Expand f ->
+            if not allow_expand then
+              raise (Invalid_argument "Arg.Expand is is only allowed with Arg.parse_and_expand_argv_dynamic");
+            let arg = get_arg () in
+            let newarg = f arg in
+            consume_arg ();
+            let before = Array.sub !argv 0 (!current + 1)
+            and after = Array.sub !argv (!current + 1) ((Array.length !argv) - !current - 1) in
+            argv:= Array.concat [before;newarg;after];
+        in
+        treat_action action end
+      else anonfun s
+    with | Bad m -> raise (convert_error (Message m));
+         | Stop e -> raise (convert_error e);
+    end;
+    incr current
+  done
+
+let parse_and_expand_argv_dynamic current argv speclist anonfun errmsg =
+  parse_and_expand_argv_dynamic_aux true current argv speclist anonfun errmsg
+
+let parse_argv_dynamic ?(current=current) argv speclist anonfun errmsg =
+  parse_and_expand_argv_dynamic_aux false current (ref argv) speclist anonfun errmsg
+
+
+let parse_argv ?(current=current) argv speclist anonfun errmsg =
+  parse_argv_dynamic ~current:current argv (ref speclist) anonfun errmsg
+
+
+let parse l f msg =
+  try
+    parse_argv Sys.argv l f msg
+  with
+  | Bad msg -> Js.log msg; exit 2
+  | Help msg -> Js.log msg; exit 0
+
+
+let parse_dynamic l f msg =
+  try
+    parse_argv_dynamic Sys.argv l f msg
+  with
+  | Bad msg -> Js.log msg; exit 2
+  | Help msg -> Js.log msg; exit 0
+
+let parse_expand l f msg =
+  try
+    let argv = ref Sys.argv in
+    let spec = ref l in
+    let current = ref (!current) in
+    parse_and_expand_argv_dynamic current argv spec f msg
+  with
+  | Bad msg -> Js.log msg; exit 2
+  | Help msg -> Js.log msg; exit 0
+
+
+let second_word s =
+  let len = String.length s in
+  let rec loop n =
+    if n >= len then len
+    else if s.[n] = ' ' then loop (n+1)
+    else n
+  in
+  match String.index s '\t' with
+  | n -> loop (n+1)
+  | exception Not_found ->
+      begin match String.index s ' ' with
+      | n -> loop (n+1)
+      | exception Not_found -> len
+      end
+
+
+let max_arg_len cur (kwd, spec, doc) =
+  match spec with
+  | Symbol _ -> max cur (String.length kwd)
+  | _ -> max cur (String.length kwd + second_word doc)
+
+
+let replace_leading_tab s =
+  let seen = ref false in
+  String.map (function '\t' when not !seen -> seen := true; ' ' | c -> c) s
+
+let add_padding len ksd =
+  match ksd with
+  | (_, _, "") ->
+      (* Do not pad undocumented options, so that they still don't show up when
+       * run through [usage] or [parse]. *)
+      ksd
+  | (kwd, (Symbol _ as spec), msg) ->
+      let cutcol = second_word msg in
+      let spaces = String.make ((max 0 (len - cutcol)) + 3) ' ' in
+      (kwd, spec, "\n" ^ spaces ^ replace_leading_tab msg)
+  | (kwd, spec, msg) ->
+      let cutcol = second_word msg in
+      let kwd_len = String.length kwd in
+      let diff = len - kwd_len - cutcol in
+      if diff <= 0 then
+        (kwd, spec, replace_leading_tab msg)
+      else
+        let spaces = String.make diff ' ' in
+        let prefix = String.sub (replace_leading_tab msg) 0 cutcol in
+        let suffix = String.sub msg cutcol (String.length msg - cutcol) in
+        (kwd, spec, prefix ^ spaces ^ suffix)
+
+
+let align ?(limit=max_int) speclist =
+  let completed = add_help speclist in
+  let len = List.fold_left max_arg_len 0 completed in
+  let len = min len limit in
+  List.map (add_padding len) completed

package/lib/ocaml/arg.mli

@@ -0,0 +1,185 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*              Damien Doligez, projet Para, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Parsing of command line arguments.
+
+   This module provides a general mechanism for extracting options and
+   arguments from the command line to the program.
+
+   Syntax of command lines:
+    A keyword is a character string starting with a [-].
+    An option is a keyword alone or followed by an argument.
+    The types of keywords are: [Unit], [Bool], [Set], [Clear],
+    [String], [Set_string], [Int], [Set_int], [Float], [Set_float],
+    [Tuple], [Symbol], and [Rest].
+    [Unit], [Set] and [Clear] keywords take no argument. A [Rest]
+    keyword takes the remaining of the command line as arguments.
+    Every other keyword takes the following word on the command line
+    as argument.  For compatibility with GNU getopt_long, [keyword=arg]
+    is also allowed.
+    Arguments not preceded by a keyword are called anonymous arguments.
+
+   Examples ([cmd] is assumed to be the command name):
+-   [cmd -flag           ](a unit option)
+-   [cmd -int 1          ](an int option with argument [1])
+-   [cmd -string foobar  ](a string option with argument ["foobar"])
+-   [cmd -float 12.34    ](a float option with argument [12.34])
+-   [cmd a b c           ](three anonymous arguments: ["a"], ["b"], and ["c"])
+-   [cmd a b -- c d      ](two anonymous arguments and a rest option with
+                           two arguments)
+*)
+
+type spec =
+  | Unit of (unit -> unit)     (** Call the function with unit argument *)
+  | Bool of (bool -> unit)     (** Call the function with a bool argument *)
+  | Set of bool ref            (** Set the reference to true *)
+  | Clear of bool ref          (** Set the reference to false *)
+  | String of (string -> unit) (** Call the function with a string argument *)
+  | Set_string of string ref   (** Set the reference to the string argument *)
+  | Int of (int -> unit)       (** Call the function with an int argument *)
+  | Set_int of int ref         (** Set the reference to the int argument *)
+  | Float of (float -> unit)   (** Call the function with a float argument *)
+  | Set_float of float ref     (** Set the reference to the float argument *)
+  | Tuple of spec list         (** Take several arguments according to the
+                                   spec list *)
+  | Symbol of string list * (string -> unit)
+                               (** Take one of the symbols as argument and
+                                   call the function with the symbol *)
+  | Rest of (string -> unit)   (** Stop interpreting keywords and call the
+                                   function with each remaining argument *)
+  | Expand of (string -> string array) (** If the remaining arguments to process
+                                           are of the form
+                                           [["-foo"; "arg"] @ rest] where "foo" is
+                                           registered as [Expand f], then the
+                                           arguments [f "arg" @ rest] are
+                                           processed. Only allowed in
+                                           [parse_and_expand_argv_dynamic]. *)
+(** The concrete type describing the behavior associated
+   with a keyword. *)
+
+type key = string
+type doc = string
+type usage_msg = string
+type anon_fun = (string -> unit)
+
+val parse :
+  (key * spec * doc) list -> anon_fun -> usage_msg -> unit
+(** [Arg.parse speclist anon_fun usage_msg] parses the command line.
+    [speclist] is a list of triples [(key, spec, doc)].
+    [key] is the option keyword, it must start with a ['-'] character.
+    [spec] gives the option type and the function to call when this option
+    is found on the command line.
+    [doc] is a one-line description of this option.
+    [anon_fun] is called on anonymous arguments.
+    The functions in [spec] and [anon_fun] are called in the same order
+    as their arguments appear on the command line.
+
+    If an error occurs, [Arg.parse] exits the program, after printing
+    to standard error an error message as follows:
+-   The reason for the error: unknown option, invalid or missing argument, etc.
+-   [usage_msg]
+-   The list of options, each followed by the corresponding [doc] string.
+    Beware: options that have an empty [doc] string will not be included in the
+    list.
+
+    For the user to be able to specify anonymous arguments starting with a
+    [-], include for example [("-", String anon_fun, doc)] in [speclist].
+
+    By default, [parse] recognizes two unit options, [-help] and [--help],
+    which will print to standard output [usage_msg] and the list of
+    options, and exit the program.  You can override this behaviour
+    by specifying your own [-help] and [--help] options in [speclist].
+*)
+
+val parse_dynamic :
+  (key * spec * doc) list ref -> anon_fun -> usage_msg -> unit
+(** Same as {!Arg.parse}, except that the [speclist] argument is a reference
+    and may be updated during the parsing. A typical use for this feature
+    is to parse command lines of the form:
+-     command subcommand [options]
+    where the list of options depends on the value of the subcommand argument.
+    @since 4.01.0
+*)
+
+val parse_argv : ?current: int ref -> string array ->
+  (key * spec * doc) list -> anon_fun -> usage_msg -> unit
+(** [Arg.parse_argv ~current args speclist anon_fun usage_msg] parses
+  the array [args] as if it were the command line.  It uses and updates
+  the value of [~current] (if given), or {!Arg.current}.  You must set
+  it before calling [parse_argv].  The initial value of [current]
+  is the index of the program name (argument 0) in the array.
+  If an error occurs, [Arg.parse_argv] raises {!Arg.Bad} with
+  the error message as argument.  If option [-help] or [--help] is
+  given, [Arg.parse_argv] raises {!Arg.Help} with the help message
+  as argument.
+*)
+
+val parse_argv_dynamic : ?current:int ref -> string array ->
+  (key * spec * doc) list ref -> anon_fun -> string -> unit
+(** Same as {!Arg.parse_argv}, except that the [speclist] argument is a
+    reference and may be updated during the parsing.
+    See {!Arg.parse_dynamic}.
+    @since 4.01.0
+*)
+
+val parse_and_expand_argv_dynamic : int ref -> string array ref ->
+  (key * spec * doc) list ref -> anon_fun -> string -> unit
+(** Same as {!Arg.parse_argv_dynamic}, except that the [argv] argument is a
+    reference and may be updated during the parsing of [Expand] arguments.
+    See {!Arg.parse_argv_dynamic}.
+    @since 4.05.0
+*)
+
+val parse_expand:
+  (key * spec * doc) list -> anon_fun -> usage_msg -> unit
+(** Same as {!Arg.parse}, except that the [Expand] arguments are allowed and
+    the {!current} reference is not updated.
+    @since 4.05.0
+*)
+
+exception Help of string
+(** Raised by [Arg.parse_argv] when the user asks for help. *)
+
+exception Bad of string
+(** Functions in [spec] or [anon_fun] can raise [Arg.Bad] with an error
+    message to reject invalid arguments.
+    [Arg.Bad] is also raised by {!Arg.parse_argv} in case of an error. *)
+
+val usage : (key * spec * doc) list -> usage_msg -> unit
+(** [Arg.usage speclist usage_msg] prints to standard error
+    an error message that includes the list of valid options.  This is
+    the same message that {!Arg.parse} prints in case of error.
+    [speclist] and [usage_msg] are the same as for {!Arg.parse}. *)
+
+val usage_string : (key * spec * doc) list -> usage_msg -> string
+(** Returns the message that would have been printed by {!Arg.usage},
+    if provided with the same parameters. *)
+
+val align: ?limit: int -> (key * spec * doc) list -> (key * spec * doc) list
+(** Align the documentation strings by inserting spaces at the first alignment
+    separator (tab or, if tab is not found, space), according to the length of
+    the keyword.  Use a alignment separator as the first character in a doc
+    string if you want to align the whole string.  The doc strings corresponding
+    to [Symbol] arguments are aligned on the next line.
+    @param limit options with keyword and message longer than [limit] will not
+    be used to compute the alignment. *)
+
+val current : int ref
+(** Position (in {!Sys.argv}) of the argument being processed.  You can
+    change this value, e.g. to force {!Arg.parse} to skip some arguments.
+    {!Arg.parse} uses the initial value of {!Arg.current} as the index of
+    argument 0 (the program name) and starts parsing arguments
+    at the next element. *)
+