bsb_arg.ml

(* Copyright (C) 2020- Hongbo Zhang, Authors of ReScript
 *
 * 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 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

type error = Unknown of string | Missing of string

type t = spec Ext_spec.t

exception Bad of string

let bad_arg s = raise_notrace (Bad s)

let ( +> ) = Ext_buffer.add_string

let usage_b (buf : Ext_buffer.t) ~usage (speclist : t) =
  buf +> usage;
  if Ext_array.is_empty speclist then ()
  else (
    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 (
          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
            if !cur <> 0 then (
              buf +> "\n";
              buf +> String.make (!max_col + 4) ' ');
            match String.index_from_opt doc !cur '\n' with
            | None ->
                buf +> String.sub doc !cur (String.length doc - !cur);
                cur := doc_length
            | Some new_line_pos ->
                buf +> String.sub doc !cur (new_line_pos - !cur);
                cur := new_line_pos + 1
          done;
          buf +> "\n")))

let stop_raise ~usage ~(error : error) (speclist : t) =
  let b = Ext_buffer.create 200 in
  (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");
  usage_b b ~usage speclist;
  bad_arg (Ext_buffer.contents b)

let parse_exn ~usage ~argv ?(start = 1) ?(finish = Array.length argv)
    (speclist : t) anonfun =
  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
      match Ext_spec.assoc3 speclist s with
      | Some action -> (
          match action with
          | Unit r -> (
              match r with
              | Unit_set r -> r.contents <- true
              | Unit_call f -> f ())
          | String f -> (
              if !current >= finish then
                stop_raise ~usage ~error:(Missing s) speclist
              else
                let arg = argv.(!current) in
                incr current;
                match f with
                | String_call f -> f arg
                | String_set u -> u.contents <- arg))
      | None -> stop_raise ~usage ~error:(Unknown s) speclist
    else rev_list := s :: !rev_list
  done;
  anonfun ~rev_args:!rev_list