From bf5a7b4094bad44970bee3b9faff158183af41f1 Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Sat, 20 Jul 2024 17:57:11 -0700 Subject: [PATCH 1/7] update vendored cmdliner --- .../vendor/cmdliner/cmdliner_arg.ml | 361 ++++ .../vendor/cmdliner/cmdliner_arg.mli | 98 + .../vendor/cmdliner/cmdliner_base.ml | 341 ++++ .../vendor/cmdliner/cmdliner_base.mli | 60 + .../vendor/cmdliner/cmdliner_cline.ml | 203 ++ .../vendor/cmdliner/cmdliner_cline.mli | 20 + .../vendor/cmdliner/cmdliner_cmd.ml | 30 + .../vendor/cmdliner/cmdliner_cmd.mli | 24 + .../vendor/cmdliner/cmdliner_docgen.ml | 395 ++++ .../vendor/cmdliner/cmdliner_docgen.mli | 11 + .../vendor/cmdliner/cmdliner_eval.ml | 282 +++ .../vendor/cmdliner/cmdliner_eval.mli | 50 + .../vendor/cmdliner/cmdliner_exit.ml | 4 + .../vendor/cmdliner/cmdliner_exit.mli | 4 + .../vendor/cmdliner/cmdliner_info.ml | 225 +++ .../vendor/cmdliner/cmdliner_info.mli | 139 ++ .../vendor/cmdliner/cmdliner_manpage.ml | 527 +++++ .../vendor/cmdliner/cmdliner_manpage.mli | 84 + .../vendor/cmdliner/cmdliner_msg.ml | 106 + .../vendor/cmdliner/cmdliner_msg.mli | 40 + .../vendor/cmdliner/cmdliner_term.ml | 90 + .../vendor/cmdliner/cmdliner_term.mli | 43 + .../cmdliner/cmdliner_term_deprecated.ml | 77 + .../vendor/cmdliner/cmdliner_trie.ml | 80 + .../vendor/cmdliner/cmdliner_trie.mli | 18 + src/reason-parser/vendor/cmdliner/dune | 5 +- .../vendor/cmdliner/vendored_cmdliner.ml | 1458 +------------- .../vendor/cmdliner/vendored_cmdliner.mli | 1710 ++++++++--------- src/refmt/refmt.ml | 10 +- src/refmt/refmt_args.ml | 6 +- 30 files changed, 4162 insertions(+), 2339 deletions(-) create mode 100644 src/reason-parser/vendor/cmdliner/cmdliner_arg.ml create mode 100644 src/reason-parser/vendor/cmdliner/cmdliner_arg.mli create mode 100644 src/reason-parser/vendor/cmdliner/cmdliner_base.ml create mode 100644 src/reason-parser/vendor/cmdliner/cmdliner_base.mli create mode 100644 src/reason-parser/vendor/cmdliner/cmdliner_cline.ml create mode 100644 src/reason-parser/vendor/cmdliner/cmdliner_cline.mli create mode 100644 src/reason-parser/vendor/cmdliner/cmdliner_cmd.ml create mode 100644 src/reason-parser/vendor/cmdliner/cmdliner_cmd.mli create mode 100644 src/reason-parser/vendor/cmdliner/cmdliner_docgen.ml create mode 100644 src/reason-parser/vendor/cmdliner/cmdliner_docgen.mli create mode 100644 src/reason-parser/vendor/cmdliner/cmdliner_eval.ml create mode 100644 src/reason-parser/vendor/cmdliner/cmdliner_eval.mli create mode 100644 src/reason-parser/vendor/cmdliner/cmdliner_exit.ml create mode 100644 src/reason-parser/vendor/cmdliner/cmdliner_exit.mli create mode 100644 src/reason-parser/vendor/cmdliner/cmdliner_info.ml create mode 100644 src/reason-parser/vendor/cmdliner/cmdliner_info.mli create mode 100644 src/reason-parser/vendor/cmdliner/cmdliner_manpage.ml create mode 100644 src/reason-parser/vendor/cmdliner/cmdliner_manpage.mli create mode 100644 src/reason-parser/vendor/cmdliner/cmdliner_msg.ml create mode 100644 src/reason-parser/vendor/cmdliner/cmdliner_msg.mli create mode 100644 src/reason-parser/vendor/cmdliner/cmdliner_term.ml create mode 100644 src/reason-parser/vendor/cmdliner/cmdliner_term.mli create mode 100644 src/reason-parser/vendor/cmdliner/cmdliner_term_deprecated.ml create mode 100644 src/reason-parser/vendor/cmdliner/cmdliner_trie.ml create mode 100644 src/reason-parser/vendor/cmdliner/cmdliner_trie.mli diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_arg.ml b/src/reason-parser/vendor/cmdliner/cmdliner_arg.ml new file mode 100644 index 000000000..c6ae9e996 --- /dev/null +++ b/src/reason-parser/vendor/cmdliner/cmdliner_arg.ml @@ -0,0 +1,361 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +let rev_compare n0 n1 = compare n1 n0 + +(* Invalid_argument strings **) + +let err_not_opt = "Option argument without name" +let err_not_pos = "Positional argument with a name" + +(* Documentation formatting helpers *) + +let strf = Printf.sprintf +let doc_quote = Cmdliner_base.quote +let doc_alts = Cmdliner_base.alts_str +let doc_alts_enum ?quoted enum = doc_alts ?quoted (List.map fst enum) + +let str_of_pp pp v = pp Format.str_formatter v; Format.flush_str_formatter () + +(* Argument converters *) + +type 'a parser = string -> [ `Ok of 'a | `Error of string ] +type 'a printer = Format.formatter -> 'a -> unit + +type 'a conv = 'a parser * 'a printer +type 'a converter = 'a conv + +let default_docv = "VALUE" +let conv ?docv (parse, print) = + let parse s = match parse s with Ok v -> `Ok v | Error (`Msg e) -> `Error e in + parse, print + +let conv' ?docv (parse, print) = + let parse s = match parse s with Ok v -> `Ok v | Error e -> `Error e in + parse, print + +let pconv ?docv conv = conv + +let conv_parser (parse, _) = + fun s -> match parse s with `Ok v -> Ok v | `Error e -> Error (`Msg e) + +let conv_printer (_, print) = print +let conv_docv _ = default_docv + +let err_invalid s kind = `Msg (strf "invalid value '%s', expected %s" s kind) +let parser_of_kind_of_string ~kind k_of_string = + fun s -> match k_of_string s with + | None -> Error (err_invalid s kind) + | Some v -> Ok v + +let some = Cmdliner_base.some +let some' = Cmdliner_base.some' + +(* Argument information *) + +type env = Cmdliner_info.Env.info +let env_var = Cmdliner_info.Env.info + +type 'a t = 'a Cmdliner_term.t +type info = Cmdliner_info.Arg.t +let info = Cmdliner_info.Arg.v + +(* Arguments *) + +let ( & ) f x = f x + +let err e = Error (`Parse e) + +let parse_to_list parser s = match parser s with +| `Ok v -> `Ok [v] +| `Error _ as e -> e + +let report_deprecated_env ei e = match Cmdliner_info.Env.info_deprecated e with +| None -> () +| Some msg -> + let var = Cmdliner_info.Env.info_var e in + let msg = String.concat "" ["environment variable "; var; ": "; msg ] in + let err_fmt = Cmdliner_info.Eval.err_ppf ei in + Cmdliner_msg.pp_err err_fmt ei ~err:msg + +let try_env ei a parse ~absent = match Cmdliner_info.Arg.env a with +| None -> Ok absent +| Some env -> + let var = Cmdliner_info.Env.info_var env in + match Cmdliner_info.Eval.env_var ei var with + | None -> Ok absent + | Some v -> + match parse v with + | `Error e -> err (Cmdliner_msg.err_env_parse env ~err:e) + | `Ok v -> report_deprecated_env ei env; Ok v + +let arg_to_args = Cmdliner_info.Arg.Set.singleton +let list_to_args f l = + let add acc v = Cmdliner_info.Arg.Set.add (f v) acc in + List.fold_left add Cmdliner_info.Arg.Set.empty l + +let flag a = + if Cmdliner_info.Arg.is_pos a then invalid_arg err_not_opt else + let convert ei cl = match Cmdliner_cline.opt_arg cl a with + | [] -> try_env ei a Cmdliner_base.env_bool_parse ~absent:false + | [_, _, None] -> Ok true + | [_, f, Some v] -> err (Cmdliner_msg.err_flag_value f v) + | (_, f, _) :: (_ ,g, _) :: _ -> err (Cmdliner_msg.err_opt_repeated f g) + in + arg_to_args a, convert + +let flag_all a = + if Cmdliner_info.Arg.is_pos a then invalid_arg err_not_opt else + let a = Cmdliner_info.Arg.make_all_opts a in + let convert ei cl = match Cmdliner_cline.opt_arg cl a with + | [] -> + try_env ei a (parse_to_list Cmdliner_base.env_bool_parse) ~absent:[] + | l -> + try + let truth (_, f, v) = match v with + | None -> true + | Some v -> failwith (Cmdliner_msg.err_flag_value f v) + in + Ok (List.rev_map truth l) + with Failure e -> err e + in + arg_to_args a, convert + +let vflag v l = + let convert _ cl = + let rec aux fv = function + | (v, a) :: rest -> + begin match Cmdliner_cline.opt_arg cl a with + | [] -> aux fv rest + | [_, f, None] -> + begin match fv with + | None -> aux (Some (f, v)) rest + | Some (g, _) -> failwith (Cmdliner_msg.err_opt_repeated g f) + end + | [_, f, Some v] -> failwith (Cmdliner_msg.err_flag_value f v) + | (_, f, _) :: (_, g, _) :: _ -> + failwith (Cmdliner_msg.err_opt_repeated g f) + end + | [] -> match fv with None -> v | Some (_, v) -> v + in + try Ok (aux None l) with Failure e -> err e + in + let flag (_, a) = + if Cmdliner_info.Arg.is_pos a then invalid_arg err_not_opt else a + in + list_to_args flag l, convert + +let vflag_all v l = + let convert _ cl = + let rec aux acc = function + | (fv, a) :: rest -> + begin match Cmdliner_cline.opt_arg cl a with + | [] -> aux acc rest + | l -> + let fval (k, f, v) = match v with + | None -> (k, fv) + | Some v -> failwith (Cmdliner_msg.err_flag_value f v) + in + aux (List.rev_append (List.rev_map fval l) acc) rest + end + | [] -> + if acc = [] then v else List.rev_map snd (List.sort rev_compare acc) + in + try Ok (aux [] l) with Failure e -> err e + in + let flag (_, a) = + if Cmdliner_info.Arg.is_pos a then invalid_arg err_not_opt else + Cmdliner_info.Arg.make_all_opts a + in + list_to_args flag l, convert + +let parse_opt_value parse f v = match parse v with +| `Ok v -> v +| `Error err -> failwith (Cmdliner_msg.err_opt_parse f ~err) + +let opt ?vopt (parse, print) v a = + if Cmdliner_info.Arg.is_pos a then invalid_arg err_not_opt else + let absent = match Cmdliner_info.Arg.absent a with + | Cmdliner_info.Arg.Doc d as a when d <> "" -> a + | _ -> Cmdliner_info.Arg.Val (lazy (str_of_pp print v)) + in + let kind = match vopt with + | None -> Cmdliner_info.Arg.Opt + | Some dv -> Cmdliner_info.Arg.Opt_vopt (str_of_pp print dv) + in + let a = Cmdliner_info.Arg.make_opt ~absent ~kind a in + let convert ei cl = match Cmdliner_cline.opt_arg cl a with + | [] -> try_env ei a parse ~absent:v + | [_, f, Some v] -> + (try Ok (parse_opt_value parse f v) with Failure e -> err e) + | [_, f, None] -> + begin match vopt with + | None -> err (Cmdliner_msg.err_opt_value_missing f) + | Some optv -> Ok optv + end + | (_, f, _) :: (_, g, _) :: _ -> err (Cmdliner_msg.err_opt_repeated g f) + in + arg_to_args a, convert + +let opt_all ?vopt (parse, print) v a = + if Cmdliner_info.Arg.is_pos a then invalid_arg err_not_opt else + let absent = match Cmdliner_info.Arg.absent a with + | Cmdliner_info.Arg.Doc d as a when d <> "" -> a + | _ -> Cmdliner_info.Arg.Val (lazy "") + in + let kind = match vopt with + | None -> Cmdliner_info.Arg.Opt + | Some dv -> Cmdliner_info.Arg.Opt_vopt (str_of_pp print dv) + in + let a = Cmdliner_info.Arg.make_opt_all ~absent ~kind a in + let convert ei cl = match Cmdliner_cline.opt_arg cl a with + | [] -> try_env ei a (parse_to_list parse) ~absent:v + | l -> + let parse (k, f, v) = match v with + | Some v -> (k, parse_opt_value parse f v) + | None -> match vopt with + | None -> failwith (Cmdliner_msg.err_opt_value_missing f) + | Some dv -> (k, dv) + in + try Ok (List.rev_map snd + (List.sort rev_compare (List.rev_map parse l))) with + | Failure e -> err e + in + arg_to_args a, convert + +(* Positional arguments *) + +let parse_pos_value parse a v = match parse v with +| `Ok v -> v +| `Error err -> failwith (Cmdliner_msg.err_pos_parse a ~err) + +let pos ?(rev = false) k (parse, print) v a = + if Cmdliner_info.Arg.is_opt a then invalid_arg err_not_pos else + let absent = match Cmdliner_info.Arg.absent a with + | Cmdliner_info.Arg.Doc d as a when d <> "" -> a + | _ -> Cmdliner_info.Arg.Val (lazy (str_of_pp print v)) + in + let pos = Cmdliner_info.Arg.pos ~rev ~start:k ~len:(Some 1) in + let a = Cmdliner_info.Arg.make_pos_abs ~absent ~pos a in + let convert ei cl = match Cmdliner_cline.pos_arg cl a with + | [] -> try_env ei a parse ~absent:v + | [v] -> + (try Ok (parse_pos_value parse a v) with Failure e -> err e) + | _ -> assert false + in + arg_to_args a, convert + +let pos_list pos (parse, _) v a = + if Cmdliner_info.Arg.is_opt a then invalid_arg err_not_pos else + let a = Cmdliner_info.Arg.make_pos ~pos a in + let convert ei cl = match Cmdliner_cline.pos_arg cl a with + | [] -> try_env ei a (parse_to_list parse) ~absent:v + | l -> + try Ok (List.rev (List.rev_map (parse_pos_value parse a) l)) with + | Failure e -> err e + in + arg_to_args a, convert + +let all = Cmdliner_info.Arg.pos ~rev:false ~start:0 ~len:None +let pos_all c v a = pos_list all c v a + +let pos_left ?(rev = false) k = + let start = if rev then k + 1 else 0 in + let len = if rev then None else Some k in + pos_list (Cmdliner_info.Arg.pos ~rev ~start ~len) + +let pos_right ?(rev = false) k = + let start = if rev then 0 else k + 1 in + let len = if rev then Some k else None in + pos_list (Cmdliner_info.Arg.pos ~rev ~start ~len) + +(* Arguments as terms *) + +let absent_error args = + let make_req a acc = + let req_a = Cmdliner_info.Arg.make_req a in + Cmdliner_info.Arg.Set.add req_a acc + in + Cmdliner_info.Arg.Set.fold make_req args Cmdliner_info.Arg.Set.empty + +let value a = a + +let err_arg_missing args = + err @@ Cmdliner_msg.err_arg_missing (Cmdliner_info.Arg.Set.choose args) + +let required (args, convert) = + let args = absent_error args in + let convert ei cl = match convert ei cl with + | Ok (Some v) -> Ok v + | Ok None -> err_arg_missing args + | Error _ as e -> e + in + args, convert + +let non_empty (al, convert) = + let args = absent_error al in + let convert ei cl = match convert ei cl with + | Ok [] -> err_arg_missing args + | Ok l -> Ok l + | Error _ as e -> e + in + args, convert + +let last (args, convert) = + let convert ei cl = match convert ei cl with + | Ok [] -> err_arg_missing args + | Ok l -> Ok (List.hd (List.rev l)) + | Error _ as e -> e + in + args, convert + +(* Predefined arguments *) + +let man_fmts = + ["auto", `Auto; "pager", `Pager; "groff", `Groff; "plain", `Plain] + +let man_fmt_docv = "FMT" +let man_fmts_enum = Cmdliner_base.enum man_fmts +let man_fmts_alts = doc_alts_enum man_fmts +let man_fmts_doc kind = + strf "Show %s in format $(docv). The value $(docv) must be %s. \ + With $(b,auto), the format is $(b,pager) or $(b,plain) whenever \ + the $(b,TERM) env var is $(b,dumb) or undefined." + kind man_fmts_alts + +let man_format = + let doc = man_fmts_doc "output" in + let docv = man_fmt_docv in + value & opt man_fmts_enum `Pager & info ["man-format"] ~docv ~doc + +let stdopt_version ~docs = + value & flag & info ["version"] ~docs ~doc:"Show version information." + +let stdopt_help ~docs = + let doc = man_fmts_doc "this help" in + let docv = man_fmt_docv in + value & opt ~vopt:(Some `Auto) (some man_fmts_enum) None & + info ["help"] ~docv ~docs ~doc + +(* Predefined converters. *) + +let bool = Cmdliner_base.bool +let char = Cmdliner_base.char +let int = Cmdliner_base.int +let nativeint = Cmdliner_base.nativeint +let int32 = Cmdliner_base.int32 +let int64 = Cmdliner_base.int64 +let float = Cmdliner_base.float +let string = Cmdliner_base.string +let enum = Cmdliner_base.enum +let file = Cmdliner_base.file +let dir = Cmdliner_base.dir +let non_dir_file = Cmdliner_base.non_dir_file +let list = Cmdliner_base.list +let array = Cmdliner_base.array +let pair = Cmdliner_base.pair +let t2 = Cmdliner_base.t2 +let t3 = Cmdliner_base.t3 +let t4 = Cmdliner_base.t4 diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_arg.mli b/src/reason-parser/vendor/cmdliner/cmdliner_arg.mli new file mode 100644 index 000000000..1166b13b4 --- /dev/null +++ b/src/reason-parser/vendor/cmdliner/cmdliner_arg.mli @@ -0,0 +1,98 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +(** Command line arguments as terms. *) + +type 'a parser = string -> [ `Ok of 'a | `Error of string ] +type 'a printer = Format.formatter -> 'a -> unit +type 'a conv = 'a parser * 'a printer +type 'a converter = 'a conv + +val conv : + ?docv:string -> (string -> ('a, [`Msg of string]) result) * 'a printer -> + 'a conv + +val conv' : + ?docv:string -> (string -> ('a, string) result) * 'a printer -> 'a conv + +val pconv : ?docv:string -> 'a parser * 'a printer -> 'a conv +val conv_parser : 'a conv -> (string -> ('a, [`Msg of string]) result) +val conv_printer : 'a conv -> 'a printer +val conv_docv : 'a conv -> string + +val parser_of_kind_of_string : + kind:string -> (string -> 'a option) -> + (string -> ('a, [`Msg of string]) result) + +val some : ?none:string -> 'a converter -> 'a option converter +val some' : ?none:'a -> 'a converter -> 'a option converter + +type env = Cmdliner_info.Env.info +val env_var : ?deprecated:string -> ?docs:string -> ?doc:string -> string -> env + +type 'a t = 'a Cmdliner_term.t + +type info +val info : + ?deprecated:string -> ?absent:string -> ?docs:string -> ?docv:string -> + ?doc:string -> ?env:env -> string list -> info + +val ( & ) : ('a -> 'b) -> 'a -> 'b + +val flag : info -> bool t +val flag_all : info -> bool list t +val vflag : 'a -> ('a * info) list -> 'a t +val vflag_all : 'a list -> ('a * info) list -> 'a list t +val opt : ?vopt:'a -> 'a converter -> 'a -> info -> 'a t +val opt_all : ?vopt:'a -> 'a converter -> 'a list -> info -> 'a list t + +val pos : ?rev:bool -> int -> 'a converter -> 'a -> info -> 'a t +val pos_all : 'a converter -> 'a list -> info -> 'a list t +val pos_left : ?rev:bool -> int -> 'a converter -> 'a list -> info -> 'a list t +val pos_right : ?rev:bool -> int -> 'a converter -> 'a list -> info -> 'a list t + +(** {1 As terms} *) + +val value : 'a t -> 'a Cmdliner_term.t +val required : 'a option t -> 'a Cmdliner_term.t +val non_empty : 'a list t -> 'a list Cmdliner_term.t +val last : 'a list t -> 'a Cmdliner_term.t + +(** {1 Predefined arguments} *) + +val man_format : Cmdliner_manpage.format Cmdliner_term.t +val stdopt_version : docs:string -> bool Cmdliner_term.t +val stdopt_help : docs:string -> Cmdliner_manpage.format option Cmdliner_term.t + +(** {1 Converters} *) + +val bool : bool converter +val char : char converter +val int : int converter +val nativeint : nativeint converter +val int32 : int32 converter +val int64 : int64 converter +val float : float converter +val string : string converter +val enum : (string * 'a) list -> 'a converter +val file : string converter +val dir : string converter +val non_dir_file : string converter +val list : ?sep:char -> 'a converter -> 'a list converter +val array : ?sep:char -> 'a converter -> 'a array converter +val pair : ?sep:char -> 'a converter -> 'b converter -> ('a * 'b) converter +val t2 : ?sep:char -> 'a converter -> 'b converter -> ('a * 'b) converter + +val t3 : + ?sep:char -> 'a converter ->'b converter -> 'c converter -> + ('a * 'b * 'c) converter + +val t4 : + ?sep:char -> 'a converter ->'b converter -> 'c converter -> 'd converter -> + ('a * 'b * 'c * 'd) converter + +val doc_quote : string -> string +val doc_alts : ?quoted:bool -> string list -> string +val doc_alts_enum : ?quoted:bool -> (string * 'a) list -> string diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_base.ml b/src/reason-parser/vendor/cmdliner/cmdliner_base.ml new file mode 100644 index 000000000..f1c659ca8 --- /dev/null +++ b/src/reason-parser/vendor/cmdliner/cmdliner_base.ml @@ -0,0 +1,341 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +let strf = Printf.sprintf + +(* Unique ids *) + +let uid = + (* Thread-safe UIDs, Oo.id (object end) was used before. + Note this won't be thread-safe in multicore, we should use + Atomic but this is >= 4.12 and we have 4.08 for now. *) + let c = ref 0 in + fun () -> + let id = !c in + incr c; if id > !c then assert false (* too many ids *) else id + +(* Edit distance *) + +let edit_distance s0 s1 = + let minimum (a : int) (b : int) (c : int) : int = min a (min b c) in + let s0,s1 = if String.length s0 <= String.length s1 then s0,s1 else s1,s0 in + let m = String.length s0 and n = String.length s1 in + let rec rows row0 row i = match i > n with + | true -> row0.(m) + | false -> + row.(0) <- i; + for j = 1 to m do + if s0.[j - 1] = s1.[i - 1] then row.(j) <- row0.(j - 1) else + row.(j) <- minimum (row0.(j - 1) + 1) (row0.(j) + 1) (row.(j - 1) + 1) + done; + rows row row0 (i + 1) + in + rows (Array.init (m + 1) (fun x -> x)) (Array.make (m + 1) 0) 1 + +let suggest s candidates = + let add (min, acc) name = + let d = edit_distance s name in + if d = min then min, (name :: acc) else + if d < min then d, [name] else + min, acc + in + let dist, suggs = List.fold_left add (max_int, []) candidates in + if dist < 3 (* suggest only if not too far *) then suggs else [] + +(* Invalid argument strings *) + +let err_empty_list = "empty list" +let err_incomplete_enum ss = + strf "Arg.enum: missing printable string for a value, other strings are: %s" + (String.concat ", " ss) + +(* Formatting tools *) + +let pp = Format.fprintf +let pp_sp = Format.pp_print_space +let pp_str = Format.pp_print_string +let pp_char = Format.pp_print_char +let pp_text = Format.pp_print_text +let pp_lines ppf s = + let rec stop_at sat ~start ~max s = + if start > max then start else + if sat s.[start] then start else + stop_at sat ~start:(start + 1) ~max s + in + let sub s start stop ~max = + if start = stop then "" else + if start = 0 && stop > max then s else + String.sub s start (stop - start) + in + let is_nl c = c = '\n' in + let max = String.length s - 1 in + let rec loop start s = match stop_at is_nl ~start ~max s with + | stop when stop > max -> Format.pp_print_string ppf (sub s start stop ~max) + | stop -> + Format.pp_print_string ppf (sub s start stop ~max); + Format.pp_force_newline ppf (); + loop (stop + 1) s + in + loop 0 s + +let pp_tokens ~spaces ppf s = (* collapse white and hint spaces (maybe) *) + let is_space = function ' ' | '\n' | '\r' | '\t' -> true | _ -> false in + let i_max = String.length s - 1 in + let flush start stop = pp_str ppf (String.sub s start (stop - start + 1)) in + let rec skip_white i = + if i > i_max then i else + if is_space s.[i] then skip_white (i + 1) else i + in + let rec loop start i = + if i > i_max then flush start i_max else + if not (is_space s.[i]) then loop start (i + 1) else + let next_start = skip_white i in + (flush start (i - 1); if spaces then pp_sp ppf () else pp_char ppf ' '; + if next_start > i_max then () else loop next_start next_start) + in + loop 0 0 + +(* Converter (end-user) error messages *) + +let quote s = strf "'%s'" s +let alts_str ?quoted alts = + let quote = match quoted with + | None -> strf "$(b,%s)" + | Some quoted -> if quoted then quote else (fun s -> s) + in + match alts with + | [] -> invalid_arg err_empty_list + | [a] -> (quote a) + | [a; b] -> strf "either %s or %s" (quote a) (quote b) + | alts -> + let rev_alts = List.rev alts in + strf "one of %s or %s" + (String.concat ", " (List.rev_map quote (List.tl rev_alts))) + (quote (List.hd rev_alts)) + +let err_multi_def ~kind name doc v v' = + strf "%s %s defined twice (doc strings are '%s' and '%s')" + kind name (doc v) (doc v') + +let err_ambiguous ~kind s ~ambs = + strf "%s %s ambiguous and could be %s" kind (quote s) + (alts_str ~quoted:true ambs) + +let err_unknown ?(dom = []) ?(hints = []) ~kind v = + let hints = match hints, dom with + | [], [] -> "." + | [], dom -> strf ", must be %s." (alts_str ~quoted:true dom) + | hints, _ -> strf ", did you mean %s?" (alts_str ~quoted:true hints) + in + strf "unknown %s %s%s" kind (quote v) hints + +let err_no kind s = strf "no %s %s" (quote s) kind +let err_not_dir s = strf "%s is not a directory" (quote s) +let err_is_dir s = strf "%s is a directory" (quote s) +let err_element kind s exp = + strf "invalid element in %s ('%s'): %s" kind s exp + +let err_invalid kind s exp = strf "invalid %s %s, %s" kind (quote s) exp +let err_invalid_val = err_invalid "value" +let err_sep_miss sep s = + err_invalid_val s (strf "missing a '%c' separator" sep) + +(* Converters *) + +type 'a parser = string -> [ `Ok of 'a | `Error of string ] +type 'a printer = Format.formatter -> 'a -> unit +type 'a conv = 'a parser * 'a printer + +let some ?(none = "") (parse, print) = + let parse s = match parse s with `Ok v -> `Ok (Some v) | `Error _ as e -> e in + let print ppf v = match v with + | None -> Format.pp_print_string ppf none + | Some v -> print ppf v + in + parse, print + +let some' ?none (parse, print) = + let parse s = match parse s with `Ok v -> `Ok (Some v) | `Error _ as e -> e in + let print ppf = function + | None -> (match none with None -> () | Some v -> print ppf v) + | Some v -> print ppf v + in + parse, print + +let bool = + let parse s = try `Ok (bool_of_string s) with + | Invalid_argument _ -> + `Error (err_invalid_val s (alts_str ~quoted:true ["true"; "false"])) + in + parse, Format.pp_print_bool + +let char = + let parse s = match String.length s = 1 with + | true -> `Ok s.[0] + | false -> `Error (err_invalid_val s "expected a character") + in + parse, pp_char + +let parse_with t_of_str exp s = + try `Ok (t_of_str s) with Failure _ -> `Error (err_invalid_val s exp) + +let int = + parse_with int_of_string "expected an integer", Format.pp_print_int + +let int32 = + parse_with Int32.of_string "expected a 32-bit integer", + (fun ppf -> pp ppf "%ld") + +let int64 = + parse_with Int64.of_string "expected a 64-bit integer", + (fun ppf -> pp ppf "%Ld") + +let nativeint = + parse_with Nativeint.of_string "expected a processor-native integer", + (fun ppf -> pp ppf "%nd") + +let float = + parse_with float_of_string "expected a floating point number", + Format.pp_print_float + +let string = (fun s -> `Ok s), pp_str +let enum sl = + if sl = [] then invalid_arg err_empty_list else + let t = Cmdliner_trie.of_list sl in + let parse s = match Cmdliner_trie.find t s with + | `Ok _ as r -> r + | `Ambiguous -> + let ambs = List.sort compare (Cmdliner_trie.ambiguities t s) in + `Error (err_ambiguous ~kind:"enum value" s ~ambs) + | `Not_found -> + let alts = List.rev (List.rev_map (fun (s, _) -> s) sl) in + `Error (err_invalid_val s ("expected " ^ (alts_str ~quoted:true alts))) + in + let print ppf v = + let sl_inv = List.rev_map (fun (s,v) -> (v,s)) sl in + try pp_str ppf (List.assoc v sl_inv) + with Not_found -> invalid_arg (err_incomplete_enum (List.map fst sl)) + in + parse, print + +let file = + let parse s = match Sys.file_exists s with + | true -> `Ok s + | false -> `Error (err_no "file or directory" s) + in + parse, pp_str + +let dir = + let parse s = match Sys.file_exists s with + | true -> if Sys.is_directory s then `Ok s else `Error (err_not_dir s) + | false -> `Error (err_no "directory" s) + in + parse, pp_str + +let non_dir_file = + let parse s = match Sys.file_exists s with + | true -> if not (Sys.is_directory s) then `Ok s else `Error (err_is_dir s) + | false -> `Error (err_no "file" s) + in + parse, pp_str + +let split_and_parse sep parse s = (* raises [Failure] *) + let parse sub = match parse sub with + | `Error e -> failwith e | `Ok v -> v + in + let rec split accum j = + let i = try String.rindex_from s j sep with Not_found -> -1 in + if (i = -1) then + let p = String.sub s 0 (j + 1) in + if p <> "" then parse p :: accum else accum + else + let p = String.sub s (i + 1) (j - i) in + let accum' = if p <> "" then parse p :: accum else accum in + split accum' (i - 1) + in + split [] (String.length s - 1) + +let list ?(sep = ',') (parse, pp_e) = + let parse s = try `Ok (split_and_parse sep parse s) with + | Failure e -> `Error (err_element "list" s e) + in + let rec print ppf = function + | v :: l -> pp_e ppf v; if (l <> []) then (pp_char ppf sep; print ppf l) + | [] -> () + in + parse, print + +let array ?(sep = ',') (parse, pp_e) = + let parse s = try `Ok (Array.of_list (split_and_parse sep parse s)) with + | Failure e -> `Error (err_element "array" s e) + in + let print ppf v = + let max = Array.length v - 1 in + for i = 0 to max do pp_e ppf v.(i); if i <> max then pp_char ppf sep done + in + parse, print + +let split_left sep s = + try + let i = String.index s sep in + let len = String.length s in + Some ((String.sub s 0 i), (String.sub s (i + 1) (len - i - 1))) + with Not_found -> None + +let pair ?(sep = ',') (pa0, pr0) (pa1, pr1) = + let parser s = match split_left sep s with + | None -> `Error (err_sep_miss sep s) + | Some (v0, v1) -> + match pa0 v0, pa1 v1 with + | `Ok v0, `Ok v1 -> `Ok (v0, v1) + | `Error e, _ | _, `Error e -> `Error (err_element "pair" s e) + in + let printer ppf (v0, v1) = pp ppf "%a%c%a" pr0 v0 sep pr1 v1 in + parser, printer + +let t2 = pair +let t3 ?(sep = ',') (pa0, pr0) (pa1, pr1) (pa2, pr2) = + let parse s = match split_left sep s with + | None -> `Error (err_sep_miss sep s) + | Some (v0, s) -> + match split_left sep s with + | None -> `Error (err_sep_miss sep s) + | Some (v1, v2) -> + match pa0 v0, pa1 v1, pa2 v2 with + | `Ok v0, `Ok v1, `Ok v2 -> `Ok (v0, v1, v2) + | `Error e, _, _ | _, `Error e, _ | _, _, `Error e -> + `Error (err_element "triple" s e) + in + let print ppf (v0, v1, v2) = + pp ppf "%a%c%a%c%a" pr0 v0 sep pr1 v1 sep pr2 v2 + in + parse, print + +let t4 ?(sep = ',') (pa0, pr0) (pa1, pr1) (pa2, pr2) (pa3, pr3) = + let parse s = match split_left sep s with + | None -> `Error (err_sep_miss sep s) + | Some(v0, s) -> + match split_left sep s with + | None -> `Error (err_sep_miss sep s) + | Some (v1, s) -> + match split_left sep s with + | None -> `Error (err_sep_miss sep s) + | Some (v2, v3) -> + match pa0 v0, pa1 v1, pa2 v2, pa3 v3 with + | `Ok v1, `Ok v2, `Ok v3, `Ok v4 -> `Ok (v1, v2, v3, v4) + | `Error e, _, _, _ | _, `Error e, _, _ | _, _, `Error e, _ + | _, _, _, `Error e -> `Error (err_element "quadruple" s e) + in + let print ppf (v0, v1, v2, v3) = + pp ppf "%a%c%a%c%a%c%a" pr0 v0 sep pr1 v1 sep pr2 v2 sep pr3 v3 + in + parse, print + +let env_bool_parse s = match String.lowercase_ascii s with +| "" | "false" | "no" | "n" | "0" -> `Ok false +| "true" | "yes" | "y" | "1" -> `Ok true +| s -> + let alts = alts_str ~quoted:true ["true"; "yes"; "false"; "no" ] in + `Error (err_invalid_val s alts) diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_base.mli b/src/reason-parser/vendor/cmdliner/cmdliner_base.mli new file mode 100644 index 000000000..3b12e7351 --- /dev/null +++ b/src/reason-parser/vendor/cmdliner/cmdliner_base.mli @@ -0,0 +1,60 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +(** A few helpful base definitions. *) + +val uid : unit -> int +(** [uid ()] is new unique for the program run. *) + +val suggest : string -> string list -> string list +(** [suggest near candidates] suggest values from [candidates] + not too far from [near]. *) + +(** {1:fmt Formatting helpers} *) + +val pp_text : Format.formatter -> string -> unit +val pp_lines : Format.formatter -> string -> unit +val pp_tokens : spaces:bool -> Format.formatter -> string -> unit + +(** {1:err Error message helpers} *) + +val quote : string -> string +val alts_str : ?quoted:bool -> string list -> string +val err_ambiguous : kind:string -> string -> ambs:string list -> string +val err_unknown : + ?dom:string list -> ?hints:string list -> kind:string -> string -> string +val err_multi_def : + kind:string -> string -> ('b -> string) -> 'b -> 'b -> string + +(** {1:conv Textual OCaml value converters} *) + +type 'a parser = string -> [ `Ok of 'a | `Error of string ] +type 'a printer = Format.formatter -> 'a -> unit +type 'a conv = 'a parser * 'a printer + +val some : ?none:string -> 'a conv -> 'a option conv +val some' : ?none:'a -> 'a conv -> 'a option conv +val bool : bool conv +val char : char conv +val int : int conv +val nativeint : nativeint conv +val int32 : int32 conv +val int64 : int64 conv +val float : float conv +val string : string conv +val enum : (string * 'a) list -> 'a conv +val file : string conv +val dir : string conv +val non_dir_file : string conv +val list : ?sep:char -> 'a conv -> 'a list conv +val array : ?sep:char -> 'a conv -> 'a array conv +val pair : ?sep:char -> 'a conv -> 'b conv -> ('a * 'b) conv +val t2 : ?sep:char -> 'a conv -> 'b conv -> ('a * 'b) conv +val t3 : ?sep:char -> 'a conv ->'b conv -> 'c conv -> ('a * 'b * 'c) conv +val t4 : + ?sep:char -> 'a conv -> 'b conv -> 'c conv -> 'd conv -> + ('a * 'b * 'c * 'd) conv + +val env_bool_parse : bool parser diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_cline.ml b/src/reason-parser/vendor/cmdliner/cmdliner_cline.ml new file mode 100644 index 000000000..cc817024a --- /dev/null +++ b/src/reason-parser/vendor/cmdliner/cmdliner_cline.ml @@ -0,0 +1,203 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +(* A command line stores pre-parsed information about the command + line's arguments in a more structured way. Given the + Cmdliner_info.arg values mentioned in a term and Sys.argv + (without exec name) we parse the command line into a map of + Cmdliner_info.arg values to [arg] values (see below). This map is used by + the term's closures to retrieve and convert command line arguments + (see the Cmdliner_arg module). *) + +let err_multi_opt_name_def name a a' = + Cmdliner_base.err_multi_def + ~kind:"option name" name Cmdliner_info.Arg.doc a a' + +module Amap = Map.Make (Cmdliner_info.Arg) + +type arg = (* unconverted argument data as found on the command line. *) +| O of (int * string * (string option)) list (* (pos, name, value) of opt. *) +| P of string list + +type t = arg Amap.t (* command line, maps arg_infos to arg value. *) + +let get_arg cl a = try Amap.find a cl with Not_found -> assert false +let opt_arg cl a = match get_arg cl a with O l -> l | _ -> assert false +let pos_arg cl a = match get_arg cl a with P l -> l | _ -> assert false +let actual_args cl a = match get_arg cl a with +| P args -> args +| O l -> + let extract_args (_pos, name, value) = + name :: (match value with None -> [] | Some v -> [v]) + in + List.concat (List.map extract_args l) + +let arg_info_indexes args = + (* from [args] returns a trie mapping the names of optional arguments to + their arg_info, a list with all arg_info for positional arguments and + a cmdline mapping each arg_info to an empty [arg]. *) + let rec loop optidx posidx cl = function + | [] -> optidx, posidx, cl + | a :: l -> + match Cmdliner_info.Arg.is_pos a with + | true -> loop optidx (a :: posidx) (Amap.add a (P []) cl) l + | false -> + let add t name = match Cmdliner_trie.add t name a with + | `New t -> t + | `Replaced (a', _) -> invalid_arg (err_multi_opt_name_def name a a') + in + let names = Cmdliner_info.Arg.opt_names a in + let optidx = List.fold_left add optidx names in + loop optidx posidx (Amap.add a (O []) cl) l + in + loop Cmdliner_trie.empty [] Amap.empty (Cmdliner_info.Arg.Set.elements args) + +(* Optional argument parsing *) + +let is_opt s = String.length s > 1 && s.[0] = '-' +let is_short_opt s = String.length s = 2 && s.[0] = '-' + +let parse_opt_arg s = (* (name, value) of opt arg, assert len > 1. *) + let l = String.length s in + if s.[1] <> '-' then (* short opt *) + if l = 2 then s, None else + String.sub s 0 2, Some (String.sub s 2 (l - 2)) (* with glued opt arg *) + else try (* long opt *) + let i = String.index s '=' in + String.sub s 0 i, Some (String.sub s (i + 1) (l - i - 1)) + with Not_found -> s, None + +let hint_matching_opt optidx s = + (* hint options that could match [s] in [optidx]. FIXME explain this is + a bit obscure. *) + if String.length s <= 2 then [] else + let short_opt, long_opt = + if s.[1] <> '-' + then s, Printf.sprintf "-%s" s + else String.sub s 1 (String.length s - 1), s + in + let short_opt, _ = parse_opt_arg short_opt in + let long_opt, _ = parse_opt_arg long_opt in + let all = Cmdliner_trie.ambiguities optidx "-" in + match List.mem short_opt all, Cmdliner_base.suggest long_opt all with + | false, [] -> [] + | false, l -> l + | true, [] -> [short_opt] + | true, l -> if List.mem short_opt l then l else short_opt :: l + +let parse_opt_args ~peek_opts optidx cl args = + (* returns an updated [cl] cmdline according to the options found in [args] + with the trie index [optidx]. Positional arguments are returned in order + in a list. *) + let rec loop errs k cl pargs = function + | [] -> List.rev errs, cl, List.rev pargs + | "--" :: args -> List.rev errs, cl, (List.rev_append pargs args) + | s :: args -> + if not (is_opt s) then loop errs (k + 1) cl (s :: pargs) args else + let name, value = parse_opt_arg s in + match Cmdliner_trie.find optidx name with + | `Ok a -> + let value, args = match value, Cmdliner_info.Arg.opt_kind a with + | Some v, Cmdliner_info.Arg.Flag when is_short_opt name -> + None, ("-" ^ v) :: args + | Some _, _ -> value, args + | None, Cmdliner_info.Arg.Flag -> value, args + | None, _ -> + match args with + | [] -> None, args + | v :: rest -> if is_opt v then None, args else Some v, rest + in + let arg = O ((k, name, value) :: opt_arg cl a) in + loop errs (k + 1) (Amap.add a arg cl) pargs args + | `Not_found when peek_opts -> loop errs (k + 1) cl pargs args + | `Not_found -> + let hints = hint_matching_opt optidx s in + let err = Cmdliner_base.err_unknown ~kind:"option" ~hints name in + loop (err :: errs) (k + 1) cl pargs args + | `Ambiguous -> + let ambs = Cmdliner_trie.ambiguities optidx name in + let ambs = List.sort compare ambs in + let err = Cmdliner_base.err_ambiguous ~kind:"option" name ~ambs in + loop (err :: errs) (k + 1) cl pargs args + in + let errs, cl, pargs = loop [] 0 cl [] args in + if errs = [] then Ok (cl, pargs) else + let err = String.concat "\n" errs in + Error (err, cl, pargs) + +let take_range start stop l = + let rec loop i acc = function + | [] -> List.rev acc + | v :: vs -> + if i < start then loop (i + 1) acc vs else + if i <= stop then loop (i + 1) (v :: acc) vs else + List.rev acc + in + loop 0 [] l + +let process_pos_args posidx cl pargs = + (* returns an updated [cl] cmdline in which each positional arg mentioned + in the list index posidx, is given a value according the list + of positional arguments values [pargs]. *) + if pargs = [] then + let misses = List.filter Cmdliner_info.Arg.is_req posidx in + if misses = [] then Ok cl else + Error (Cmdliner_msg.err_pos_misses misses, cl) + else + let last = List.length pargs - 1 in + let pos rev k = if rev then last - k else k in + let rec loop misses cl max_spec = function + | [] -> misses, cl, max_spec + | a :: al -> + let apos = Cmdliner_info.Arg.pos_kind a in + let rev = Cmdliner_info.Arg.pos_rev apos in + let start = pos rev (Cmdliner_info.Arg.pos_start apos) in + let stop = match Cmdliner_info.Arg.pos_len apos with + | None -> pos rev last + | Some n -> pos rev (Cmdliner_info.Arg.pos_start apos + n - 1) + in + let start, stop = if rev then stop, start else start, stop in + let args = take_range start stop pargs in + let max_spec = max stop max_spec in + let cl = Amap.add a (P args) cl in + let misses = match Cmdliner_info.Arg.is_req a && args = [] with + | true -> a :: misses + | false -> misses + in + loop misses cl max_spec al + in + let misses, cl, max_spec = loop [] cl (-1) posidx in + if misses <> [] then Error (Cmdliner_msg.err_pos_misses misses, cl) else + if last <= max_spec then Ok cl else + let excess = take_range (max_spec + 1) last pargs in + Error (Cmdliner_msg.err_pos_excess excess, cl) + +let create ?(peek_opts = false) al args = + let optidx, posidx, cl = arg_info_indexes al in + match parse_opt_args ~peek_opts optidx cl args with + | Ok (cl, _) when peek_opts -> Ok cl + | Ok (cl, pargs) -> process_pos_args posidx cl pargs + | Error (errs, cl, _) -> Error (errs, cl) + +let deprecated_msgs cl = + let add i arg acc = match Cmdliner_info.Arg.deprecated i with + | None -> acc + | Some msg -> + let plural l = if List.length l > 1 then "s " else " " in + match arg with + | O [] | P [] -> acc (* Should not happen *) + | O os -> + let plural = plural os in + let names = List.map (fun (_, n, _) -> n) os in + let names = String.concat " " (List.map Cmdliner_base.quote names) in + let msg = "option" :: plural :: names :: ": " :: msg :: [] in + String.concat "" msg :: acc + | P args -> + let plural = plural args in + let args = String.concat " " (List.map Cmdliner_base.quote args) in + let msg = "argument" :: plural :: args :: ": " :: msg :: [] in + String.concat "" msg :: acc + in + Amap.fold add cl [] diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_cline.mli b/src/reason-parser/vendor/cmdliner/cmdliner_cline.mli new file mode 100644 index 000000000..f9075b01d --- /dev/null +++ b/src/reason-parser/vendor/cmdliner/cmdliner_cline.mli @@ -0,0 +1,20 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +(** Command lines. *) + +type t + +val create : + ?peek_opts:bool -> Cmdliner_info.Arg.Set.t -> string list -> + (t, string * t) result + +val opt_arg : t -> Cmdliner_info.Arg.t -> (int * string * (string option)) list +val pos_arg : t -> Cmdliner_info.Arg.t -> string list +val actual_args : t -> Cmdliner_info.Arg.t -> string list +(** Actual command line arguments from the command line *) + +val is_opt : string -> bool +val deprecated_msgs : t -> string list diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_cmd.ml b/src/reason-parser/vendor/cmdliner/cmdliner_cmd.ml new file mode 100644 index 000000000..0cff096bc --- /dev/null +++ b/src/reason-parser/vendor/cmdliner/cmdliner_cmd.ml @@ -0,0 +1,30 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2022 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +(* Commands *) + +(* Command info *) + +type info = Cmdliner_info.Cmd.t +let info = Cmdliner_info.Cmd.v + +type 'a t = +| Cmd of info * 'a Cmdliner_term.parser +| Group of info * ('a Cmdliner_term.parser option * 'a t list) + +let get_info = function Cmd (i, _) | Group (i, _) -> i +let children_infos = function +| Cmd _ -> [] | Group (_, (_, cs)) -> List.map get_info cs + +let v i (args, p) = Cmd (Cmdliner_info.Cmd.add_args i args, p) +let group ?default i cmds = + let args, parser = match default with + | None -> None, None | Some (args, p) -> Some args, Some p + in + let children = List.map get_info cmds in + let i = Cmdliner_info.Cmd.with_children i ~args ~children in + Group (i, (parser, cmds)) + +let name c = Cmdliner_info.Cmd.name (get_info c) diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_cmd.mli b/src/reason-parser/vendor/cmdliner/cmdliner_cmd.mli new file mode 100644 index 000000000..f2e3062ca --- /dev/null +++ b/src/reason-parser/vendor/cmdliner/cmdliner_cmd.mli @@ -0,0 +1,24 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2022 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +(** Commands and their information. *) + +type info = Cmdliner_info.Cmd.t + +val info : + ?deprecated:string -> + ?man_xrefs:Cmdliner_manpage.xref list -> ?man:Cmdliner_manpage.block list -> + ?envs:Cmdliner_info.Env.info list -> ?exits:Cmdliner_info.Exit.info list -> + ?sdocs:string -> ?docs:string -> ?doc:string -> ?version:string -> + string -> info + +type 'a t = +| Cmd of info * 'a Cmdliner_term.parser +| Group of info * ('a Cmdliner_term.parser option * 'a t list) + +val v : info -> 'a Cmdliner_term.t -> 'a t +val group : ?default:'a Cmdliner_term.t -> info -> 'a t list -> 'a t +val name : 'a t -> string +val get_info : 'a t -> info diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_docgen.ml b/src/reason-parser/vendor/cmdliner/cmdliner_docgen.ml new file mode 100644 index 000000000..3a36df5c4 --- /dev/null +++ b/src/reason-parser/vendor/cmdliner/cmdliner_docgen.ml @@ -0,0 +1,395 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +let rev_compare n0 n1 = compare n1 n0 +let strf = Printf.sprintf + +let order_args a0 a1 = + match Cmdliner_info.Arg.is_opt a0, Cmdliner_info.Arg.is_opt a1 with + | true, true -> (* optional by name *) + let key names = + let k = List.hd (List.sort rev_compare names) in + let k = String.lowercase_ascii k in + if k.[1] = '-' then String.sub k 1 (String.length k - 1) else k + in + compare + (key @@ Cmdliner_info.Arg.opt_names a0) + (key @@ Cmdliner_info.Arg.opt_names a1) + | false, false -> (* positional by variable *) + compare + (String.lowercase_ascii @@ Cmdliner_info.Arg.docv a0) + (String.lowercase_ascii @@ Cmdliner_info.Arg.docv a1) + | true, false -> -1 (* positional first *) + | false, true -> 1 (* optional after *) + +let esc = Cmdliner_manpage.escape +let cmd_name t = esc @@ Cmdliner_info.Cmd.name t + +let sorted_items_to_blocks ~boilerplate:b items = + (* Items are sorted by section and then rev. sorted by appearance. + We gather them by section in correct order in a `Block and prefix + them with optional boilerplate *) + let boilerplate = match b with None -> (fun _ -> None) | Some b -> b in + let mk_block sec acc = match boilerplate sec with + | None -> (sec, `Blocks acc) + | Some b -> (sec, `Blocks (b :: acc)) + in + let rec loop secs sec acc = function + | (sec', it) :: its when sec' = sec -> loop secs sec (it :: acc) its + | (sec', it) :: its -> loop (mk_block sec acc :: secs) sec' [it] its + | [] -> (mk_block sec acc) :: secs + in + match items with + | [] -> [] + | (sec, it) :: its -> loop [] sec [it] its + +(* Doc string variables substitutions. *) + +let env_info_subst ~subst e = function +| "env" -> Some (strf "$(b,%s)" @@ esc (Cmdliner_info.Env.info_var e)) +| id -> subst id + +let exit_info_subst ~subst e = function +| "status" -> Some (strf "%d" (fst @@ Cmdliner_info.Exit.info_codes e)) +| "status_max" -> Some (strf "%d" (snd @@ Cmdliner_info.Exit.info_codes e)) +| id -> subst id + +let arg_info_subst ~subst a = function +| "docv" -> + Some (strf "$(i,%s)" @@ esc (Cmdliner_info.Arg.docv a)) +| "opt" when Cmdliner_info.Arg.is_opt a -> + Some (strf "$(b,%s)" @@ esc (Cmdliner_info.Arg.opt_name_sample a)) +| "env" as id -> + begin match Cmdliner_info.Arg.env a with + | Some e -> env_info_subst ~subst e id + | None -> subst id + end +| id -> subst id + +let cmd_info_subst ei = function +| "tname" -> Some (strf "$(b,%s)" @@ cmd_name (Cmdliner_info.Eval.cmd ei)) +| "mname" -> Some (strf "$(b,%s)" @@ cmd_name (Cmdliner_info.Eval.main ei)) +| "iname" -> + let cmd = Cmdliner_info.Eval.cmd ei :: Cmdliner_info.Eval.parents ei in + let cmd = String.concat " " (List.rev_map Cmdliner_info.Cmd.name cmd) in + Some (strf "$(b,%s)" cmd) +| _ -> None + +(* Command docs *) + +let invocation ?(sep = " ") ?(parents = []) cmd = + let names = List.rev_map Cmdliner_info.Cmd.name (cmd :: parents) in + esc @@ String.concat sep names + +let synopsis_pos_arg a = + let v = match Cmdliner_info.Arg.docv a with "" -> "ARG" | v -> v in + let v = strf "$(i,%s)" (esc v) in + let v = (if Cmdliner_info.Arg.is_req a then strf "%s" else strf "[%s]") v in + match Cmdliner_info.Arg.(pos_len @@ pos_kind a) with + | None -> v ^ "…" + | Some 1 -> v + | Some n -> + let rec loop n acc = if n <= 0 then acc else loop (n - 1) (v :: acc) in + String.concat " " (loop n []) + +let synopsis_opt_arg a n = + let var = match Cmdliner_info.Arg.docv a with "" -> "VAL" | v -> v in + match Cmdliner_info.Arg.opt_kind a with + | Cmdliner_info.Arg.Flag -> strf "$(b,%s)" (esc n) + | Cmdliner_info.Arg.Opt -> + if String.length n > 2 + then strf "$(b,%s)=$(i,%s)" (esc n) (esc var) + else strf "$(b,%s) $(i,%s)" (esc n) (esc var) + | Cmdliner_info.Arg.Opt_vopt _ -> + if String.length n > 2 + then strf "$(b,%s)[=$(i,%s)]" (esc n) (esc var) + else strf "$(b,%s) [$(i,%s)]" (esc n) (esc var) + +let deprecated cmd = match Cmdliner_info.Cmd.deprecated cmd with +| None -> "" | Some _ -> "(Deprecated) " + +let synopsis ?parents cmd = match Cmdliner_info.Cmd.children cmd with +| [] -> + let rev_cli_order (a0, _) (a1, _) = + Cmdliner_info.Arg.rev_pos_cli_order a0 a1 + in + let args = Cmdliner_info.Cmd.args cmd in + let oargs, pargs = Cmdliner_info.Arg.(Set.partition is_opt args) in + let oargs = + (* Keep only those that are listed in the s_options section and + that are not [--version] or [--help]. * *) + let keep a = + let drop_names n = n = "--help" || n = "--version" in + Cmdliner_info.Arg.docs a = Cmdliner_manpage.s_options && + not (List.exists drop_names (Cmdliner_info.Arg.opt_names a)) + in + let oargs = Cmdliner_info.Arg.Set.(elements (filter keep oargs)) in + let count = List.length oargs in + let any_option = "[$(i,OPTION)]…" in + if count = 0 || count > 3 then any_option else + let syn a = + strf "[%s]" (synopsis_opt_arg a (Cmdliner_info.Arg.opt_name_sample a)) + in + let oargs = List.sort order_args oargs in + let oargs = String.concat " " (List.map syn oargs) in + String.concat " " [oargs; any_option] + in + let pargs = + let pargs = Cmdliner_info.Arg.Set.elements pargs in + if pargs = [] then "" else + let pargs = List.map (fun a -> a, synopsis_pos_arg a) pargs in + let pargs = List.sort rev_cli_order pargs in + String.concat " " ("" (* add a space *) :: List.rev_map snd pargs) + in + strf "%s$(b,%s) %s%s" + (deprecated cmd) (invocation ?parents cmd) oargs pargs +| _cmds -> + let subcmd = match Cmdliner_info.Cmd.has_args cmd with + | false -> "$(i,COMMAND)" | true -> "[$(i,COMMAND)]" + in + strf "%s$(b,%s) %s …" (deprecated cmd) (invocation ?parents cmd) subcmd + +let cmd_docs ei = match Cmdliner_info.(Cmd.children (Eval.cmd ei)) with +| [] -> [] +| cmds -> + let add_cmd acc cmd = + let syn = synopsis cmd in + (Cmdliner_info.Cmd.docs cmd, `I (syn, Cmdliner_info.Cmd.doc cmd)) :: acc + in + let by_sec_by_rev_name (s0, `I (c0, _)) (s1, `I (c1, _)) = + let c = compare s0 s1 in + if c <> 0 then c else compare c1 c0 (* N.B. reverse *) + in + let cmds = List.fold_left add_cmd [] cmds in + let cmds = List.sort by_sec_by_rev_name cmds in + let cmds = (cmds :> (string * Cmdliner_manpage.block) list) in + sorted_items_to_blocks ~boilerplate:None cmds + +(* Argument docs *) + +let arg_man_item_label a = + let s = match Cmdliner_info.Arg.is_pos a with + | true -> strf "$(i,%s)" (esc @@ Cmdliner_info.Arg.docv a) + | false -> + let names = List.sort compare (Cmdliner_info.Arg.opt_names a) in + String.concat ", " (List.rev_map (synopsis_opt_arg a) names) + in + match Cmdliner_info.Arg.deprecated a with + | None -> s | Some _ -> "(Deprecated) " ^ s + +let arg_to_man_item ~errs ~subst ~buf a = + let subst = arg_info_subst ~subst a in + let or_env ~value a = match Cmdliner_info.Arg.env a with + | None -> "" + | Some e -> + let value = if value then " or" else "absent " in + strf "%s $(b,%s) env" value (esc @@ Cmdliner_info.Env.info_var e) + in + let absent = match Cmdliner_info.Arg.absent a with + | Cmdliner_info.Arg.Err -> "required" + | Cmdliner_info.Arg.Doc "" -> strf "%s" (or_env ~value:false a) + | Cmdliner_info.Arg.Doc s -> + let s = Cmdliner_manpage.subst_vars ~errs ~subst buf s in + strf "absent=%s%s" s (or_env ~value:true a) + | Cmdliner_info.Arg.Val v -> + match Lazy.force v with + | "" -> strf "%s" (or_env ~value:false a) + | v -> strf "absent=$(b,%s)%s" (esc v) (or_env ~value:true a) + in + let optvopt = match Cmdliner_info.Arg.opt_kind a with + | Cmdliner_info.Arg.Opt_vopt v -> strf "default=$(b,%s)" (esc v) + | _ -> "" + in + let argvdoc = match optvopt, absent with + | "", "" -> "" + | s, "" | "", s -> strf " (%s)" s + | s, s' -> strf " (%s) (%s)" s s' + in + let doc = Cmdliner_info.Arg.doc a in + let doc = Cmdliner_manpage.subst_vars ~errs ~subst buf doc in + (Cmdliner_info.Arg.docs a, `I (arg_man_item_label a ^ argvdoc, doc)) + +let arg_docs ~errs ~subst ~buf ei = + let by_sec_by_arg a0 a1 = + let c = compare (Cmdliner_info.Arg.docs a0) (Cmdliner_info.Arg.docs a1) in + if c <> 0 then c else + let c = + match Cmdliner_info.Arg.deprecated a0, Cmdliner_info.Arg.deprecated a1 + with + | None, None | Some _, Some _ -> 0 + | None, Some _ -> -1 | Some _, None -> 1 + in + if c <> 0 then c else order_args a0 a1 + in + let keep_arg a acc = + if not Cmdliner_info.Arg.(is_pos a && (docv a = "" || doc a = "")) + then (a :: acc) else acc + in + let args = Cmdliner_info.Cmd.args @@ Cmdliner_info.Eval.cmd ei in + let args = Cmdliner_info.Arg.Set.fold keep_arg args [] in + let args = List.sort by_sec_by_arg args in + let args = List.rev_map (arg_to_man_item ~errs ~subst ~buf) args in + sorted_items_to_blocks ~boilerplate:None args + +(* Exit statuses doc *) + +let exit_boilerplate sec = match sec = Cmdliner_manpage.s_exit_status with +| false -> None +| true -> Some (Cmdliner_manpage.s_exit_status_intro) + +let exit_docs ~errs ~subst ~buf ~has_sexit ei = + let by_sec (s0, _) (s1, _) = compare s0 s1 in + let add_exit_item acc e = + let subst = exit_info_subst ~subst e in + let min, max = Cmdliner_info.Exit.info_codes e in + let doc = Cmdliner_info.Exit.info_doc e in + let label = if min = max then strf "%d" min else strf "%d-%d" min max in + let item = `I (label, Cmdliner_manpage.subst_vars ~errs ~subst buf doc) in + (Cmdliner_info.Exit.info_docs e, item) :: acc + in + let exits = Cmdliner_info.Cmd.exits @@ Cmdliner_info.Eval.cmd ei in + let exits = List.sort Cmdliner_info.Exit.info_order exits in + let exits = List.fold_left add_exit_item [] exits in + let exits = List.stable_sort by_sec (* sort by section *) exits in + let boilerplate = if has_sexit then None else Some exit_boilerplate in + sorted_items_to_blocks ~boilerplate exits + +(* Environment doc *) + +let env_boilerplate sec = match sec = Cmdliner_manpage.s_environment with +| false -> None +| true -> Some (Cmdliner_manpage.s_environment_intro) + +let env_docs ~errs ~subst ~buf ~has_senv ei = + let add_env_item ~subst (seen, envs as acc) e = + if Cmdliner_info.Env.Set.mem e seen then acc else + let seen = Cmdliner_info.Env.Set.add e seen in + let var = strf "$(b,%s)" @@ esc (Cmdliner_info.Env.info_var e) in + let var = match Cmdliner_info.Env.info_deprecated e with + | None -> var | Some _ -> "(Deprecated) " ^ var in + let doc = Cmdliner_info.Env.info_doc e in + let doc = Cmdliner_manpage.subst_vars ~errs ~subst buf doc in + let envs = (Cmdliner_info.Env.info_docs e, `I (var, doc)) :: envs in + seen, envs + in + let add_arg_env a acc = match Cmdliner_info.Arg.env a with + | None -> acc + | Some e -> add_env_item ~subst:(arg_info_subst ~subst a) acc e + in + let add_env acc e = add_env_item ~subst:(env_info_subst ~subst e) acc e in + let by_sec_by_rev_name (s0, `I (v0, _)) (s1, `I (v1, _)) = + let c = compare s0 s1 in + if c <> 0 then c else compare v1 v0 (* N.B. reverse *) + in + (* Arg envs before term envs is important here: if the same is mentioned + both in an arg and in a term the substs of the arg are allowed. *) + let args = Cmdliner_info.Cmd.args @@ Cmdliner_info.Eval.cmd ei in + let tenvs = Cmdliner_info.Cmd.envs @@ Cmdliner_info.Eval.cmd ei in + let init = Cmdliner_info.Env.Set.empty, [] in + let acc = Cmdliner_info.Arg.Set.fold add_arg_env args init in + let _, envs = List.fold_left add_env acc tenvs in + let envs = List.sort by_sec_by_rev_name envs in + let envs = (envs :> (string * Cmdliner_manpage.block) list) in + let boilerplate = if has_senv then None else Some env_boilerplate in + sorted_items_to_blocks ~boilerplate envs + +(* xref doc *) + +let xref_docs ~errs ei = + let main = Cmdliner_info.Eval.main ei in + let to_xref = function + | `Main -> Cmdliner_info.Cmd.name main, 1 + | `Tool tool -> tool, 1 + | `Page (name, sec) -> name, sec + | `Cmd c -> + (* N.B. we are handling only the first subcommand level here *) + let cmds = Cmdliner_info.Cmd.children main in + let mname = Cmdliner_info.Cmd.name main in + let is_cmd cmd = Cmdliner_info.Cmd.name cmd = c in + if List.exists is_cmd cmds then strf "%s-%s" mname c, 1 else + (Format.fprintf errs "xref %s: no such command name@." c; "doc-err", 0) + in + let xref_str (name, sec) = strf "%s(%d)" (esc name) sec in + let xrefs = Cmdliner_info.Cmd.man_xrefs @@ Cmdliner_info.Eval.cmd ei in + let xrefs = match main == Cmdliner_info.Eval.cmd ei with + | true -> List.filter (fun x -> x <> `Main) xrefs (* filter out default *) + | false -> xrefs + in + let xrefs = List.fold_left (fun acc x -> to_xref x :: acc) [] xrefs in + let xrefs = List.(rev_map xref_str (sort rev_compare xrefs)) in + if xrefs = [] then [] else + [Cmdliner_manpage.s_see_also, `P (String.concat ", " xrefs)] + +(* Man page construction *) + +let ensure_s_name ei sm = + if Cmdliner_manpage.(smap_has_section sm ~sec:s_name) then sm else + let cmd = Cmdliner_info.Eval.cmd ei in + let parents = Cmdliner_info.Eval.parents ei in + let tname = (deprecated cmd) ^ invocation ~sep:"-" ~parents cmd in + let tdoc = Cmdliner_info.Cmd.doc cmd in + let tagline = if tdoc = "" then "" else strf " - %s" tdoc in + let tagline = `P (strf "%s%s" tname tagline) in + Cmdliner_manpage.(smap_append_block sm ~sec:s_name tagline) + +let ensure_s_synopsis ei sm = + if Cmdliner_manpage.(smap_has_section sm ~sec:s_synopsis) then sm else + let cmd = Cmdliner_info.Eval.cmd ei in + let parents = Cmdliner_info.Eval.parents ei in + let synopsis = `P (synopsis ~parents cmd) in + Cmdliner_manpage.(smap_append_block sm ~sec:s_synopsis synopsis) + +let insert_cmd_man_docs ~errs ei sm = + let buf = Buffer.create 200 in + let subst = cmd_info_subst ei in + let ins sm (sec, b) = Cmdliner_manpage.smap_append_block sm ~sec b in + let has_senv = Cmdliner_manpage.(smap_has_section sm ~sec:s_environment) in + let has_sexit = Cmdliner_manpage.(smap_has_section sm ~sec:s_exit_status) in + let sm = List.fold_left ins sm (cmd_docs ei) in + let sm = List.fold_left ins sm (arg_docs ~errs ~subst ~buf ei) in + let sm = List.fold_left ins sm (exit_docs ~errs ~subst ~buf ~has_sexit ei)in + let sm = List.fold_left ins sm (env_docs ~errs ~subst ~buf ~has_senv ei) in + let sm = List.fold_left ins sm (xref_docs ~errs ei) in + sm + +let text ~errs ei = + let man = Cmdliner_info.Cmd.man @@ Cmdliner_info.Eval.cmd ei in + let sm = Cmdliner_manpage.smap_of_blocks man in + let sm = ensure_s_name ei sm in + let sm = ensure_s_synopsis ei sm in + let sm = insert_cmd_man_docs ei ~errs sm in + Cmdliner_manpage.smap_to_blocks sm + +let title ei = + let main = Cmdliner_info.Eval.main ei in + let exec = String.capitalize_ascii (Cmdliner_info.Cmd.name main) in + let cmd = Cmdliner_info.Eval.cmd ei in + let parents = Cmdliner_info.Eval.parents ei in + let name = String.uppercase_ascii (invocation ~sep:"-" ~parents cmd) in + let center_header = esc @@ strf "%s Manual" exec in + let left_footer = + let version = match Cmdliner_info.Cmd.version main with + | None -> "" | Some v -> " " ^ v + in + esc @@ strf "%s%s" exec version + in + name, 1, "", left_footer, center_header + +let man ~errs ei = title ei, text ~errs ei + +let pp_man ~errs fmt ppf ei = + Cmdliner_manpage.print + ~errs ~subst:(cmd_info_subst ei) fmt ppf (man ~errs ei) + +(* Plain synopsis for usage *) + +let pp_plain_synopsis ~errs ppf ei = + let buf = Buffer.create 100 in + let subst = cmd_info_subst ei in + let cmd = Cmdliner_info.Eval.cmd ei in + let parents = Cmdliner_info.Eval.parents ei in + let synopsis = synopsis ~parents cmd in + let syn = Cmdliner_manpage.doc_to_plain ~errs ~subst buf synopsis in + Format.fprintf ppf "@[%s@]" syn diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_docgen.mli b/src/reason-parser/vendor/cmdliner/cmdliner_docgen.mli new file mode 100644 index 000000000..e57929d05 --- /dev/null +++ b/src/reason-parser/vendor/cmdliner/cmdliner_docgen.mli @@ -0,0 +1,11 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +val pp_man : + errs:Format.formatter -> Cmdliner_manpage.format -> Format.formatter -> + Cmdliner_info.Eval.t -> unit + +val pp_plain_synopsis : + errs:Format.formatter -> Format.formatter -> Cmdliner_info.Eval.t -> unit diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_eval.ml b/src/reason-parser/vendor/cmdliner/cmdliner_eval.ml new file mode 100644 index 000000000..e4b50be10 --- /dev/null +++ b/src/reason-parser/vendor/cmdliner/cmdliner_eval.ml @@ -0,0 +1,282 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2022 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +type 'a eval_ok = [ `Ok of 'a | `Version | `Help ] +type eval_error = [ `Parse | `Term | `Exn ] +type 'a eval_exit = [ `Ok of 'a | `Exit of Cmdliner_info.Exit.code ] + +let err_help s = "Term error, help requested for unknown command " ^ s +let err_argv = "argv array must have at least one element" + +let add_stdopts ei = + let docs = Cmdliner_info.Cmd.stdopts_docs @@ Cmdliner_info.Eval.cmd ei in + let vargs, vers = + match Cmdliner_info.Cmd.version @@ Cmdliner_info.Eval.main ei with + | None -> Cmdliner_info.Arg.Set.empty, None + | Some _ -> + let args, _ as vers = Cmdliner_arg.stdopt_version ~docs in + args, Some vers + in + let help = Cmdliner_arg.stdopt_help ~docs in + let args = Cmdliner_info.Arg.Set.union vargs (fst help) in + let cmd = Cmdliner_info.Cmd.add_args (Cmdliner_info.Eval.cmd ei) args in + help, vers, Cmdliner_info.Eval.with_cmd ei cmd + +let parse_error_term err ei cl = Error (`Parse err) + +type 'a eval_result = + ('a, [ Cmdliner_term.term_escape + | `Exn of exn * Printexc.raw_backtrace + | `Parse of string + | `Std_help of Cmdliner_manpage.format | `Std_version ]) result + +let run_parser ~catch ei cl f = try (f ei cl :> 'a eval_result) with +| exn when catch -> + let bt = Printexc.get_raw_backtrace () in + Error (`Exn (exn, bt)) + +let try_eval_stdopts ~catch ei cl help version = + match run_parser ~catch ei cl (snd help) with + | Ok (Some fmt) -> Some (Error (`Std_help fmt)) + | Error _ as err -> Some err + | Ok None -> + match version with + | None -> None + | Some version -> + match run_parser ~catch ei cl (snd version) with + | Ok false -> None + | Ok true -> Some (Error (`Std_version)) + | Error _ as err -> Some err + +let do_help help_ppf err_ppf ei fmt cmd = + let ei = match cmd with + | None (* help of main command requested *) -> + let env _ = assert false in + let cmd = Cmdliner_info.Eval.main ei in + let ei' = Cmdliner_info.Eval.v ~cmd ~parents:[] ~env ~err_ppf in + begin match Cmdliner_info.Eval.parents ei with + | [] -> (* [ei] is an evaluation of main, [cmd] has stdopts *) ei' + | _ -> let _, _, ei = add_stdopts ei' in ei + end + | Some cmd -> + try + (* For now we simply keep backward compat. [cmd] should be + a name from main's children. *) + let main = Cmdliner_info.Eval.main ei in + let is_cmd t = Cmdliner_info.Cmd.name t = cmd in + let children = Cmdliner_info.Cmd.children main in + let cmd = List.find is_cmd children in + let _, _, ei = add_stdopts (Cmdliner_info.Eval.with_cmd ei cmd) in + ei + with Not_found -> invalid_arg (err_help cmd) + in + Cmdliner_docgen.pp_man ~errs:err_ppf fmt help_ppf ei + +let do_result help_ppf err_ppf ei = function +| Ok v -> Ok (`Ok v) +| Error res -> + match res with + | `Std_help fmt -> + Cmdliner_docgen.pp_man ~errs:err_ppf fmt help_ppf ei; Ok `Help + | `Std_version -> + Cmdliner_msg.pp_version help_ppf ei; Ok `Version + | `Parse err -> + Cmdliner_msg.pp_err_usage err_ppf ei ~err_lines:false ~err; + Error `Parse + | `Help (fmt, cmd) -> do_help help_ppf err_ppf ei fmt cmd; Ok `Help + | `Exn (e, bt) -> Cmdliner_msg.pp_backtrace err_ppf ei e bt; (Error `Exn) + | `Error (usage, err) -> + (if usage + then Cmdliner_msg.pp_err_usage err_ppf ei ~err_lines:true ~err + else Cmdliner_msg.pp_err err_ppf ei ~err); + (Error `Term) + +let cmd_name_trie cmds = + let add acc cmd = + let i = Cmdliner_cmd.get_info cmd in + let name = Cmdliner_info.Cmd.name i in + match Cmdliner_trie.add acc name cmd with + | `New t -> t + | `Replaced (cmd', _) -> + let i' = Cmdliner_cmd.get_info cmd' and kind = "command" in + invalid_arg @@ + Cmdliner_base.err_multi_def ~kind name Cmdliner_info.Cmd.doc i i' + in + List.fold_left add Cmdliner_trie.empty cmds + +let cmd_name_dom cmds = + let cmd_name c = Cmdliner_info.Cmd.name (Cmdliner_cmd.get_info c) in + List.sort String.compare (List.rev_map cmd_name cmds) + +let find_term args cmd = + let never_term _ _ = assert false in + let stop args_rest args_rev parents cmd = + let args = List.rev_append args_rev args_rest in + match (cmd : 'a Cmdliner_cmd.t) with + | Cmd (i, t) -> + args, t, i, parents, Ok () + | Group (i, (Some t, children)) -> + args, t, i, parents, Ok () + | Group (i, (None, children)) -> + let dom = cmd_name_dom children in + let err = Cmdliner_msg.err_cmd_missing ~dom in + args, never_term, i, parents, Error err + in + let rec loop args_rev parents cmd = function + | ("--" :: _ | [] as rest) -> stop rest args_rev parents cmd + | (arg :: _ as rest) when Cmdliner_cline.is_opt arg -> + stop rest args_rev parents cmd + | arg :: args -> + match cmd with + | Cmd (i, t) -> + let args = List.rev_append args_rev (arg :: args) in + args, t, i, parents, Ok () + | Group (i, (t, children)) -> + let index = cmd_name_trie children in + match Cmdliner_trie.find index arg with + | `Ok cmd -> loop args_rev (i :: parents) cmd args + | `Not_found -> + let args = List.rev_append args_rev (arg :: args) in + let all = Cmdliner_trie.ambiguities index "" in + let hints = Cmdliner_base.suggest arg all in + let dom = cmd_name_dom children in + let kind = "command" in + let err = Cmdliner_base.err_unknown ~kind ~dom ~hints arg in + args, never_term, i, parents, Error err + | `Ambiguous -> + let args = List.rev_append args_rev (arg :: args) in + let ambs = Cmdliner_trie.ambiguities index arg in + let ambs = List.sort compare ambs in + let err = Cmdliner_base.err_ambiguous ~kind:"command" arg ~ambs in + args, never_term, i, parents, Error err + in + loop [] [] cmd args + +let env_default v = try Some (Sys.getenv v) with Not_found -> None +let remove_exec argv = + try List.tl (Array.to_list argv) with Failure _ -> invalid_arg err_argv + +let do_deprecated_msgs err_ppf cl ei = + let cmd = Cmdliner_info.Eval.cmd ei in + let msgs = Cmdliner_cline.deprecated_msgs cl in + let msgs = match Cmdliner_info.Cmd.deprecated cmd with + | None -> msgs + | Some msg -> + let name = Cmdliner_base.quote (Cmdliner_info.Cmd.name cmd) in + String.concat "" ("command " :: name :: ": " :: msg :: []) :: msgs + in + if msgs <> [] + then Cmdliner_msg.pp_err err_ppf ei ~err:(String.concat "\n" msgs) + +let eval_value + ?help:(help_ppf = Format.std_formatter) + ?err:(err_ppf = Format.err_formatter) + ?(catch = true) ?(env = env_default) ?(argv = Sys.argv) cmd + = + let args, f, cmd, parents, res = find_term (remove_exec argv) cmd in + let ei = Cmdliner_info.Eval.v ~cmd ~parents ~env ~err_ppf in + let help, version, ei = add_stdopts ei in + let term_args = Cmdliner_info.Cmd.args @@ Cmdliner_info.Eval.cmd ei in + let res = match res with + | Error msg -> (* Command lookup error, we still prioritize stdargs *) + let cl = match Cmdliner_cline.create term_args args with + | Error (_, cl) -> cl | Ok cl -> cl + in + begin match try_eval_stdopts ~catch ei cl help version with + | Some e -> e + | None -> Error (`Error (true, msg)) + end + | Ok () -> + match Cmdliner_cline.create term_args args with + | Error (e, cl) -> + begin match try_eval_stdopts ~catch ei cl help version with + | Some e -> e + | None -> Error (`Error (true, e)) + end + | Ok cl -> + match try_eval_stdopts ~catch ei cl help version with + | Some e -> e + | None -> + do_deprecated_msgs err_ppf cl ei; + run_parser ~catch ei cl f + in + do_result help_ppf err_ppf ei res + +let eval_peek_opts + ?(version_opt = false) ?(env = env_default) ?(argv = Sys.argv) t + : 'a option * ('a eval_ok, eval_error) result + = + let args, f = t in + let version = if version_opt then Some "dummy" else None in + let cmd = Cmdliner_info.Cmd.v ?version "dummy" in + let cmd = Cmdliner_info.Cmd.add_args cmd args in + let null_ppf = Format.make_formatter (fun _ _ _ -> ()) (fun () -> ()) in + let ei = Cmdliner_info.Eval.v ~cmd ~parents:[] ~env ~err_ppf:null_ppf in + let help, version, ei = add_stdopts ei in + let term_args = Cmdliner_info.Cmd.args @@ Cmdliner_info.Eval.cmd ei in + let cli_args = remove_exec argv in + let v, ret = + match Cmdliner_cline.create ~peek_opts:true term_args cli_args with + | Error (e, cl) -> + begin match try_eval_stdopts ~catch:true ei cl help version with + | Some e -> None, e + | None -> None, Error (`Error (true, e)) + end + | Ok cl -> + let ret = run_parser ~catch:true ei cl f in + let v = match ret with Ok v -> Some v | Error _ -> None in + match try_eval_stdopts ~catch:true ei cl help version with + | Some e -> v, e + | None -> v, ret + in + let ret = match ret with + | Ok v -> Ok (`Ok v) + | Error `Std_help _ -> Ok `Help + | Error `Std_version -> Ok `Version + | Error `Parse _ -> Error `Parse + | Error `Help _ -> Ok `Help + | Error `Exn _ -> Error `Exn + | Error `Error _ -> Error `Term + in + (v, ret) + +let exit_status_of_result ?(term_err = Cmdliner_info.Exit.cli_error) = function +| Ok (`Ok _ | `Help | `Version) -> Cmdliner_info.Exit.ok +| Error `Term -> term_err +| Error `Parse -> Cmdliner_info.Exit.cli_error +| Error `Exn -> Cmdliner_info.Exit.internal_error + +let eval_value' ?help ?err ?catch ?env ?argv ?term_err cmd = + match eval_value ?help ?err ?catch ?env ?argv cmd with + | Ok (`Ok _ as v) -> v + | ret -> `Exit (exit_status_of_result ?term_err ret) + +let eval ?help ?err ?catch ?env ?argv ?term_err cmd = + exit_status_of_result ?term_err @@ + eval_value ?help ?err ?catch ?env ?argv cmd + +let eval' ?help ?err ?catch ?env ?argv ?term_err cmd = + match eval_value ?help ?err ?catch ?env ?argv cmd with + | Ok (`Ok c) -> c + | r -> exit_status_of_result ?term_err r + +let pp_err ppf cmd ~msg = (* FIXME move that to Cmdliner_msgs *) + let name = Cmdliner_cmd.name cmd in + Format.fprintf ppf "%s: @[%a@]@." name Cmdliner_base.pp_lines msg + +let eval_result + ?help ?(err = Format.err_formatter) ?catch ?env ?argv ?term_err cmd + = + match eval_value ?help ~err ?catch ?env ?argv cmd with + | Ok (`Ok (Error msg)) -> pp_err err cmd ~msg; Cmdliner_info.Exit.some_error + | r -> exit_status_of_result ?term_err r + +let eval_result' + ?help ?(err = Format.err_formatter) ?catch ?env ?argv ?term_err cmd + = + match eval_value ?help ~err ?catch ?env ?argv cmd with + | Ok (`Ok (Ok c)) -> c + | Ok (`Ok (Error msg)) -> pp_err err cmd ~msg; Cmdliner_info.Exit.some_error + | r -> exit_status_of_result ?term_err r diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_eval.mli b/src/reason-parser/vendor/cmdliner/cmdliner_eval.mli new file mode 100644 index 000000000..27194b80f --- /dev/null +++ b/src/reason-parser/vendor/cmdliner/cmdliner_eval.mli @@ -0,0 +1,50 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2022 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +(** Command evaluation *) + +(** {1:eval Evaluating commands} *) + +type 'a eval_ok = [ `Ok of 'a | `Version | `Help ] +type eval_error = [ `Parse | `Term | `Exn ] +type 'a eval_exit = [ `Ok of 'a | `Exit of Cmdliner_info.Exit.code ] + +val eval_value : + ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> + ?env:(string -> string option) -> ?argv:string array -> 'a Cmdliner_cmd.t -> + ('a eval_ok, eval_error) result + +val eval_value' : + ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> + ?env:(string -> string option) -> ?argv:string array -> + ?term_err:int -> 'a Cmdliner_cmd.t -> 'a eval_exit + +val eval_peek_opts : + ?version_opt:bool -> ?env:(string -> string option) -> + ?argv:string array -> 'a Cmdliner_term.t -> + 'a option * ('a eval_ok, eval_error) result + +val eval : + ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> + ?env:(string -> string option) -> ?argv:string array -> + ?term_err:int -> unit Cmdliner_cmd.t -> Cmdliner_info.Exit.code + +val eval' : + ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> + ?env:(string -> string option) -> ?argv:string array -> + ?term_err:int -> int Cmdliner_cmd.t -> Cmdliner_info.Exit.code + +val eval_result : + ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> + ?env:(string -> string option) -> ?argv:string array -> + ?term_err:Cmdliner_info.Exit.code -> (unit, string) result Cmdliner_cmd.t -> + Cmdliner_info.Exit.code + +val eval_result' : + ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> + ?env:(string -> string option) -> ?argv:string array -> + ?term_err:Cmdliner_info.Exit.code -> + (Cmdliner_info.Exit.code, string) result Cmdliner_cmd.t -> + Cmdliner_info.Exit.code diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_exit.ml b/src/reason-parser/vendor/cmdliner/cmdliner_exit.ml new file mode 100644 index 000000000..2231518d5 --- /dev/null +++ b/src/reason-parser/vendor/cmdliner/cmdliner_exit.ml @@ -0,0 +1,4 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_exit.mli b/src/reason-parser/vendor/cmdliner/cmdliner_exit.mli new file mode 100644 index 000000000..2231518d5 --- /dev/null +++ b/src/reason-parser/vendor/cmdliner/cmdliner_exit.mli @@ -0,0 +1,4 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_info.ml b/src/reason-parser/vendor/cmdliner/cmdliner_info.ml new file mode 100644 index 000000000..561a60e51 --- /dev/null +++ b/src/reason-parser/vendor/cmdliner/cmdliner_info.ml @@ -0,0 +1,225 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +(* Exit codes *) + +module Exit = struct + type code = int + + let ok = 0 + let some_error = 123 + let cli_error = 124 + let internal_error = 125 + + type info = + { codes : code * code; (* min, max *) + doc : string; (* help. *) + docs : string; } (* title of help section where listed. *) + + let info + ?(docs = Cmdliner_manpage.s_exit_status) ?(doc = "undocumented") ?max min + = + let max = match max with None -> min | Some max -> max in + { codes = (min, max); doc; docs } + + let info_codes i = i.codes + let info_code i = fst i.codes + let info_doc i = i.doc + let info_docs i = i.docs + let info_order i0 i1 = compare i0.codes i1.codes + let defaults = + [ info ok ~doc:"on success."; + info some_error + ~doc:"on indiscriminate errors reported on standard error."; + info cli_error ~doc:"on command line parsing errors."; + info internal_error ~doc:"on unexpected internal errors (bugs)."; ] +end + +(* Environment variables *) + +module Env = struct + type var = string + type info = (* information about an environment variable. *) + { id : int; (* unique id for the env var. *) + deprecated : string option; + var : string; (* the variable. *) + doc : string; (* help. *) + docs : string; } (* title of help section where listed. *) + + let info + ?deprecated + ?(docs = Cmdliner_manpage.s_environment) ?(doc = "See option $(opt).") var + = + { id = Cmdliner_base.uid (); deprecated; var; doc; docs } + + let info_deprecated i = i.deprecated + let info_var i = i.var + let info_doc i = i.doc + let info_docs i = i.docs + let info_compare i0 i1 = Int.compare i0.id i1.id + + module Set = Set.Make (struct type t = info let compare = info_compare end) +end + +(* Arguments *) + +module Arg = struct + type absence = Err | Val of string Lazy.t | Doc of string + type opt_kind = Flag | Opt | Opt_vopt of string + + type pos_kind = (* information about a positional argument. *) + { pos_rev : bool; (* if [true] positions are counted from the end. *) + pos_start : int; (* start positional argument. *) + pos_len : int option } (* number of arguments or [None] if unbounded. *) + + let pos ~rev:pos_rev ~start:pos_start ~len:pos_len = + { pos_rev; pos_start; pos_len} + + let pos_rev p = p.pos_rev + let pos_start p = p.pos_start + let pos_len p = p.pos_len + + type t = (* information about a command line argument. *) + { id : int; (* unique id for the argument. *) + deprecated : string option; (* deprecation message *) + absent : absence; (* behaviour if absent. *) + env : Env.info option; (* environment variable for default value. *) + doc : string; (* help. *) + docv : string; (* variable name for the argument in help. *) + docs : string; (* title of help section where listed. *) + pos : pos_kind; (* positional arg kind. *) + opt_kind : opt_kind; (* optional arg kind. *) + opt_names : string list; (* names (for opt args). *) + opt_all : bool; } (* repeatable (for opt args). *) + + let dumb_pos = pos ~rev:false ~start:(-1) ~len:None + + let v ?deprecated ?(absent = "") ?docs ?(docv = "") ?(doc = "") ?env names = + let dash n = if String.length n = 1 then "-" ^ n else "--" ^ n in + let opt_names = List.map dash names in + let docs = match docs with + | Some s -> s + | None -> + match names with + | [] -> Cmdliner_manpage.s_arguments + | _ -> Cmdliner_manpage.s_options + in + { id = Cmdliner_base.uid (); deprecated; absent = Doc absent; + env; doc; docv; docs; pos = dumb_pos; opt_kind = Flag; opt_names; + opt_all = false; } + + let id a = a.id + let deprecated a = a.deprecated + let absent a = a.absent + let env a = a.env + let doc a = a.doc + let docv a = a.docv + let docs a = a.docs + let pos_kind a = a.pos + let opt_kind a = a.opt_kind + let opt_names a = a.opt_names + let opt_all a = a.opt_all + let opt_name_sample a = + (* First long or short name (in that order) in the list; this + allows the client to control which name is shown *) + let rec find = function + | [] -> List.hd a.opt_names + | n :: ns -> if (String.length n) > 2 then n else find ns + in + find a.opt_names + + let make_req a = { a with absent = Err } + let make_all_opts a = { a with opt_all = true } + let make_opt ~absent ~kind:opt_kind a = { a with absent; opt_kind } + let make_opt_all ~absent ~kind:opt_kind a = + { a with absent; opt_kind; opt_all = true } + + let make_pos ~pos a = { a with pos } + let make_pos_abs ~absent ~pos a = { a with absent; pos } + + let is_opt a = a.opt_names <> [] + let is_pos a = a.opt_names = [] + let is_req a = a.absent = Err + + let pos_cli_order a0 a1 = (* best-effort order on the cli. *) + let c = compare (a0.pos.pos_rev) (a1.pos.pos_rev) in + if c <> 0 then c else + if a0.pos.pos_rev + then compare a1.pos.pos_start a0.pos.pos_start + else compare a0.pos.pos_start a1.pos.pos_start + + let rev_pos_cli_order a0 a1 = pos_cli_order a1 a0 + + let compare a0 a1 = Int.compare a0.id a1.id + module Set = Set.Make (struct type nonrec t = t let compare = compare end) +end + +(* Commands *) + +module Cmd = struct + type t = + { name : string; (* name of the cmd. *) + version : string option; (* version (for --version). *) + deprecated : string option; (* deprecation message *) + doc : string; (* one line description of cmd. *) + docs : string; (* title of man section where listed (commands). *) + sdocs : string; (* standard options, title of section where listed. *) + exits : Exit.info list; (* exit codes for the cmd. *) + envs : Env.info list; (* env vars that influence the cmd. *) + man : Cmdliner_manpage.block list; (* man page text. *) + man_xrefs : Cmdliner_manpage.xref list; (* man cross-refs. *) + args : Arg.Set.t; (* Command arguments. *) + has_args : bool; (* [true] if has own parsing term. *) + children : t list; } (* Children, if any. *) + + let v + ?deprecated ?(man_xrefs = [`Main]) ?(man = []) ?(envs = []) + ?(exits = Exit.defaults) ?(sdocs = Cmdliner_manpage.s_common_options) + ?(docs = Cmdliner_manpage.s_commands) ?(doc = "") ?version name + = + { name; version; deprecated; doc; docs; sdocs; exits; + envs; man; man_xrefs; args = Arg.Set.empty; + has_args = true; children = [] } + + let name t = t.name + let version t = t.version + let deprecated t = t.deprecated + let doc t = t.doc + let docs t = t.docs + let stdopts_docs t = t.sdocs + let exits t = t.exits + let envs t = t.envs + let man t = t.man + let man_xrefs t = t.man_xrefs + let args t = t.args + let has_args t = t.has_args + let children t = t.children + let add_args t args = { t with args = Arg.Set.union args t.args } + let with_children cmd ~args ~children = + let has_args, args = match args with + | None -> false, cmd.args + | Some args -> true, Arg.Set.union args cmd.args + in + { cmd with has_args; args; children } +end + +(* Evaluation *) + +module Eval = struct + type t = (* information about the evaluation context. *) + { cmd : Cmd.t; (* cmd being evaluated. *) + parents : Cmd.t list; (* parents of cmd, root is last. *) + env : string -> string option; (* environment variable lookup. *) + err_ppf : Format.formatter (* error formatter *) } + + let v ~cmd ~parents ~env ~err_ppf = { cmd; parents; env; err_ppf } + + let cmd e = e.cmd + let parents e = e.parents + let env_var e v = e.env v + let err_ppf e = e.err_ppf + let main e = match List.rev e.parents with [] -> e.cmd | m :: _ -> m + let with_cmd ei cmd = { ei with cmd } +end diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_info.mli b/src/reason-parser/vendor/cmdliner/cmdliner_info.mli new file mode 100644 index 000000000..76ea15bc8 --- /dev/null +++ b/src/reason-parser/vendor/cmdliner/cmdliner_info.mli @@ -0,0 +1,139 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +(** Exit codes, environment variables, arguments, commands and eval information. + + These information types gathers untyped data used to parse command + lines report errors and format man pages. *) + +(** Exit codes. *) +module Exit : sig + type code = int + val ok : code + val some_error : code + val cli_error : code + val internal_error : code + + type info + val info : ?docs:string -> ?doc:string -> ?max:code -> code -> info + val info_code : info -> code + val info_codes : info -> code * code + val info_doc : info -> string + val info_docs : info -> string + val info_order : info -> info -> int + val defaults : info list +end + +(** Environment variables. *) +module Env : sig + type var = string + type info + val info : ?deprecated:string -> ?docs:string -> ?doc:string -> var -> info + val info_var : info -> string + val info_doc : info -> string + val info_docs : info -> string + val info_deprecated : info -> string option + + module Set : Set.S with type elt = info +end + +(** Arguments *) +module Arg : sig + + type absence = + | Err (** an error is reported. *) + | Val of string Lazy.t (** if <> "", takes the given default value. *) + | Doc of string + (** if <> "", a doc string interpreted in the doc markup language. *) + (** The type for what happens if the argument is absent from the cli. *) + + type opt_kind = + | Flag (** without value, just a flag. *) + | Opt (** with required value. *) + | Opt_vopt of string (** with optional value, takes given default. *) + (** The type for optional argument kinds. *) + + type pos_kind + val pos : rev:bool -> start:int -> len:int option -> pos_kind + val pos_rev : pos_kind -> bool + val pos_start : pos_kind -> int + val pos_len : pos_kind -> int option + + type t + val v : + ?deprecated:string -> ?absent:string -> ?docs:string -> ?docv:string -> + ?doc:string -> ?env:Env.info -> string list -> t + + val id : t -> int + val deprecated : t -> string option + val absent : t -> absence + val env : t -> Env.info option + val doc : t -> string + val docv : t -> string + val docs : t -> string + val opt_names : t -> string list (* has dashes *) + val opt_name_sample : t -> string (* warning must be an opt arg *) + val opt_kind : t -> opt_kind + val pos_kind : t -> pos_kind + + val make_req : t -> t + val make_all_opts : t -> t + val make_opt : absent:absence -> kind:opt_kind -> t -> t + val make_opt_all : absent:absence -> kind:opt_kind -> t -> t + val make_pos : pos:pos_kind -> t -> t + val make_pos_abs : absent:absence -> pos:pos_kind -> t -> t + + val is_opt : t -> bool + val is_pos : t -> bool + val is_req : t -> bool + + val pos_cli_order : t -> t -> int + val rev_pos_cli_order : t -> t -> int + + val compare : t -> t -> int + module Set : Set.S with type elt = t +end + +(** Commands. *) +module Cmd : sig + type t + val v : + ?deprecated:string -> + ?man_xrefs:Cmdliner_manpage.xref list -> ?man:Cmdliner_manpage.block list -> + ?envs:Env.info list -> ?exits:Exit.info list -> + ?sdocs:string -> ?docs:string -> ?doc:string -> ?version:string -> + string -> t + + val name : t -> string + val version : t -> string option + val deprecated : t -> string option + val doc : t -> string + val docs : t -> string + val stdopts_docs : t -> string + val exits : t -> Exit.info list + val envs : t -> Env.info list + val man : t -> Cmdliner_manpage.block list + val man_xrefs : t -> Cmdliner_manpage.xref list + val args : t -> Arg.Set.t + val has_args : t -> bool + val children : t -> t list + val add_args : t -> Arg.Set.t -> t + val with_children : t -> args:Arg.Set.t option -> children:t list -> t +end + +(** Evaluation. *) +module Eval : sig + type t + val v : + cmd:Cmd.t -> parents:Cmd.t list -> env:(string -> string option) -> + err_ppf:Format.formatter -> t + + val cmd : t -> Cmd.t + val main : t -> Cmd.t + val parents : t -> Cmd.t list + val env_var : t -> string -> string option + val err_ppf : t -> Format.formatter + val with_cmd : t -> Cmd.t -> t +end diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_manpage.ml b/src/reason-parser/vendor/cmdliner/cmdliner_manpage.ml new file mode 100644 index 000000000..63c12b2c9 --- /dev/null +++ b/src/reason-parser/vendor/cmdliner/cmdliner_manpage.ml @@ -0,0 +1,527 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +(* Manpages *) + +type block = + [ `S of string | `P of string | `Pre of string | `I of string * string + | `Noblank | `Blocks of block list ] + +type title = string * int * string * string * string + +type t = title * block list + +type xref = + [ `Main | `Cmd of string | `Tool of string | `Page of string * int ] + +(* Standard sections *) + +let s_name = "NAME" +let s_synopsis = "SYNOPSIS" +let s_description = "DESCRIPTION" +let s_commands = "COMMANDS" +let s_arguments = "ARGUMENTS" +let s_options = "OPTIONS" +let s_common_options = "COMMON OPTIONS" +let s_exit_status = "EXIT STATUS" +let s_exit_status_intro = `P "$(iname) exits with:" + +let s_environment = "ENVIRONMENT" +let s_environment_intro = + `P "These environment variables affect the execution of $(iname):" + +let s_files = "FILES" +let s_examples = "EXAMPLES" +let s_bugs = "BUGS" +let s_authors = "AUTHORS" +let s_see_also = "SEE ALSO" +let s_none = "cmdliner-none" + +(* Section order *) + +let s_created = "" +let order = + [| s_name; s_synopsis; s_description; s_created; s_commands; + s_arguments; s_options; s_common_options; s_exit_status; + s_environment; s_files; s_examples; s_bugs; s_authors; s_see_also; + s_none; |] + +let order_synopsis = 1 +let order_created = 3 + +let section_of_order i = order.(i) +let section_to_order ~on_unknown s = + let max = Array.length order - 1 in + let rec loop i = match i > max with + | true -> on_unknown + | false -> if order.(i) = s then i else loop (i + 1) + in + loop 0 + +(* Section maps + + Section maps, maps section names to their section order and reversed + content blocks (content is not reversed in `Block blocks). The sections + are listed in reversed order. Unknown sections get the order of the last + known section. *) + +type smap = (string * (int * block list)) list + +let smap_of_blocks bs = (* N.B. this flattens `Blocks, not t.r. *) + let rec loop s s_o rbs smap = function + | [] -> s, s_o, rbs, smap + | `S new_sec :: bs -> + let new_o = section_to_order ~on_unknown:s_o new_sec in + loop new_sec new_o [] ((s, (s_o, rbs)):: smap) bs + | `Blocks blist :: bs -> + let s, s_o, rbs, rmap = loop s s_o rbs smap blist (* not t.r. *) in + loop s s_o rbs rmap bs + | (`P _ | `Pre _ | `I _ | `Noblank as c) :: bs -> + loop s s_o (c :: rbs) smap bs + in + let first, (bs : block list) = match bs with + | `S s :: bs -> s, bs + | `Blocks (`S s :: blist) :: bs -> s, (`Blocks blist) :: bs + | _ -> "", bs + in + let first_o = section_to_order ~on_unknown:order_synopsis first in + let s, s_o, rc, smap = loop first first_o [] [] bs in + (s, (s_o, rc)) :: smap + +let smap_to_blocks smap = (* N.B. this leaves `Blocks content untouched. *) + let rec loop acc smap s = function + | b :: rbs -> loop (b :: acc) smap s rbs + | [] -> + let acc = if s = "" then acc else `S s :: acc in + match smap with + | [] -> acc + | (_, (_, [])) :: smap -> loop acc smap "" [] (* skip empty section *) + | (s, (_, rbs)) :: smap -> + if s = s_none + then loop acc smap "" [] (* skip *) + else loop acc smap s rbs + in + loop [] smap "" [] + +let smap_has_section smap ~sec = List.exists (fun (s, _) -> sec = s) smap +let smap_append_block smap ~sec b = + let o = section_to_order ~on_unknown:order_created sec in + let try_insert = + let rec loop max_lt_o left = function + | (s', (o, rbs)) :: right when s' = sec -> + Ok (List.rev_append ((sec, (o, b :: rbs)) :: left) right) + | (_, (o', _) as s) :: right -> + let max_lt_o = if o' < o then max o' max_lt_o else max_lt_o in + loop max_lt_o (s :: left) right + | [] -> + if max_lt_o <> -1 then Error max_lt_o else + Ok (List.rev ((sec, (o, [b])) :: left)) + in + loop (-1) [] smap + in + match try_insert with + | Ok smap -> smap + | Error insert_before -> + let rec loop left = function + | (s', (o', _)) :: _ as right when o' = insert_before -> + List.rev_append ((sec, (o, [b])) :: left) right + | s :: ss -> loop (s :: left) ss + | [] -> assert false + in + loop [] smap + +(* Formatting tools *) + +let strf = Printf.sprintf +let pf = Format.fprintf +let pp_str = Format.pp_print_string +let pp_char = Format.pp_print_char +let pp_indent ppf c = for i = 1 to c do pp_char ppf ' ' done +let pp_lines = Cmdliner_base.pp_lines +let pp_tokens = Cmdliner_base.pp_tokens + +(* Cmdliner markup handling *) + +let err e fmt = pf e ("cmdliner error: " ^^ fmt ^^ "@.") +let err_unescaped ~errs c s = err errs "unescaped %C in %S" c s +let err_malformed ~errs s = err errs "Malformed $(…) in %S" s +let err_unclosed ~errs s = err errs "Unclosed $(…) in %S" s +let err_undef ~errs id s = err errs "Undefined variable $(%s) in %S" id s +let err_illegal_esc ~errs c s = err errs "Illegal escape char %C in %S" c s +let err_markup ~errs dir s = + err errs "Unknown cmdliner markup $(%c,…) in %S" dir s + +let is_markup_dir = function 'i' | 'b' -> true | _ -> false +let is_markup_esc = function '$' | '\\' | '(' | ')' -> true | _ -> false +let markup_need_esc = function '\\' | '$' -> true | _ -> false +let markup_text_need_esc = function '\\' | '$' | ')' -> true | _ -> false + +let escape s = (* escapes [s] from doc language. *) + let max_i = String.length s - 1 in + let rec escaped_len i l = + if i > max_i then l else + if markup_text_need_esc s.[i] then escaped_len (i + 1) (l + 2) else + escaped_len (i + 1) (l + 1) + in + let escaped_len = escaped_len 0 0 in + if escaped_len = String.length s then s else + let b = Bytes.create escaped_len in + let rec loop i k = + if i > max_i then Bytes.unsafe_to_string b else + let c = String.unsafe_get s i in + if not (markup_text_need_esc c) + then (Bytes.unsafe_set b k c; loop (i + 1) (k + 1)) + else (Bytes.unsafe_set b k '\\'; Bytes.unsafe_set b (k + 1) c; + loop (i + 1) (k + 2)) + in + loop 0 0 + +let subst_vars ~errs ~subst b s = + let max_i = String.length s - 1 in + let flush start stop = match start > max_i with + | true -> () + | false -> Buffer.add_substring b s start (stop - start + 1) + in + let skip_escape k start i = + if i > max_i then err_unescaped ~errs '\\' s else k start (i + 1) + in + let rec skip_markup k start i = + if i > max_i then (err_unclosed ~errs s; k start i) else + match s.[i] with + | '\\' -> skip_escape (skip_markup k) start (i + 1) + | ')' -> k start (i + 1) + | c -> skip_markup k start (i + 1) + in + let rec add_subst start i = + if i > max_i then (err_unclosed ~errs s; loop start i) else + if s.[i] <> ')' then add_subst start (i + 1) else + let id = String.sub s start (i - start) in + let next = i + 1 in + begin match subst id with + | None -> err_undef ~errs id s; Buffer.add_string b "undefined"; + | Some v -> Buffer.add_string b v + end; + loop next next + and loop start i = + if i > max_i then flush start max_i else + let next = i + 1 in + match s.[i] with + | '\\' -> skip_escape loop start next + | '$' -> + if next > max_i then err_unescaped ~errs '$' s else + begin match s.[next] with + | '(' -> + let min = next + 2 in + if min > max_i then (err_unclosed ~errs s; loop start next) else + begin match s.[min] with + | ',' -> skip_markup loop start (min + 1) + | _ -> + let start_id = next + 1 in + flush start (i - 1); add_subst start_id start_id + end + | _ -> err_unescaped ~errs '$' s; loop start next + end; + | c -> loop start next + in + (Buffer.clear b; loop 0 0; Buffer.contents b) + +let add_markup_esc ~errs k b s start next target_need_escape target_escape = + let max_i = String.length s - 1 in + if next > max_i then err_unescaped ~errs '\\' s else + match s.[next] with + | c when not (is_markup_esc s.[next]) -> + err_illegal_esc ~errs c s; + k (next + 1) (next + 1) + | c -> + (if target_need_escape c then target_escape b c else Buffer.add_char b c); + k (next + 1) (next + 1) + +let add_markup_text ~errs k b s start target_need_escape target_escape = + let max_i = String.length s - 1 in + let flush start stop = match start > max_i with + | true -> () + | false -> Buffer.add_substring b s start (stop - start + 1) + in + let rec loop start i = + if i > max_i then (err_unclosed ~errs s; flush start max_i) else + let next = i + 1 in + match s.[i] with + | '\\' -> (* unescape *) + flush start (i - 1); + add_markup_esc ~errs loop b s start next + target_need_escape target_escape + | ')' -> flush start (i - 1); k next next + | c when markup_text_need_esc c -> + err_unescaped ~errs c s; flush start (i - 1); loop next next + | c when target_need_escape c -> + flush start (i - 1); target_escape b c; loop next next + | c -> loop start next + in + loop start start + +(* Plain text output *) + +let markup_to_plain ~errs b s = + let max_i = String.length s - 1 in + let flush start stop = match start > max_i with + | true -> () + | false -> Buffer.add_substring b s start (stop - start + 1) + in + let need_escape _ = false in + let escape _ _ = assert false in + let rec loop start i = + if i > max_i then flush start max_i else + let next = i + 1 in + match s.[i] with + | '\\' -> + flush start (i - 1); + add_markup_esc ~errs loop b s start next need_escape escape + | '$' -> + if next > max_i then err_unescaped ~errs '$' s else + begin match s.[next] with + | '(' -> + let min = next + 2 in + if min > max_i then (err_unclosed ~errs s; loop start next) else + begin match s.[min] with + | ',' -> + let markup = s.[min - 1] in + if not (is_markup_dir markup) + then (err_markup ~errs markup s; loop start next) else + let start_data = min + 1 in + (flush start (i - 1); + add_markup_text ~errs loop b s start_data need_escape escape) + | _ -> + err_malformed ~errs s; loop start next + end + | _ -> err_unescaped ~errs '$' s; loop start next + end + | c when markup_need_esc c -> + err_unescaped ~errs c s; flush start (i - 1); loop next next + | c -> loop start next + in + (Buffer.clear b; loop 0 0; Buffer.contents b) + +let doc_to_plain ~errs ~subst b s = + markup_to_plain ~errs b (subst_vars ~errs ~subst b s) + +let p_indent = 7 (* paragraph indentation. *) +let l_indent = 4 (* label indentation. *) + +let pp_plain_blocks ~errs subst ppf ts = + let b = Buffer.create 1024 in + let markup t = doc_to_plain ~errs b ~subst t in + let pp_tokens ppf t = pp_tokens ~spaces:true ppf t in + let rec blank_line = function + | `Noblank :: ts -> loop ts + | ts -> Format.pp_print_cut ppf (); loop ts + and loop = function + | [] -> () + | t :: ts -> + match t with + | `Noblank -> loop ts + | `Blocks bs -> loop (bs @ ts) + | `P s -> + pf ppf "%a@[%a@]@," pp_indent p_indent pp_tokens (markup s); + blank_line ts + | `S s -> pf ppf "@[%a@]@," pp_tokens (markup s); loop ts + | `Pre s -> + pf ppf "%a@[%a@]@," pp_indent p_indent pp_lines (markup s); + blank_line ts + | `I (label, s) -> + let label = markup label and s = markup s in + pf ppf "@[%a@[%a@]" pp_indent p_indent pp_tokens label; + begin match s with + | "" -> pf ppf "@]@," + | s -> + let ll = String.length label in + if ll < l_indent + then (pf ppf "%a@[%a@]@]@," pp_indent (l_indent - ll) pp_tokens s) + else (pf ppf "@\n%a@[%a@]@]@," + pp_indent (p_indent + l_indent) pp_tokens s) + end; + blank_line ts + in + loop ts + +let pp_plain_page ~errs subst ppf (_, text) = + pf ppf "@[%a@]" (pp_plain_blocks ~errs subst) text + +(* Groff output *) + +let markup_to_groff ~errs b s = + let max_i = String.length s - 1 in + let flush start stop = match start > max_i with + | true -> () + | false -> Buffer.add_substring b s start (stop - start + 1) + in + let need_escape = function '.' | '\'' | '-' | '\\' -> true | _ -> false in + let escape b c = Printf.bprintf b "\\N'%d'" (Char.code c) in + let rec end_text start i = Buffer.add_string b "\\fR"; loop start i + and loop start i = + if i > max_i then flush start max_i else + let next = i + 1 in + match s.[i] with + | '\\' -> + flush start (i - 1); + add_markup_esc ~errs loop b s start next need_escape escape + | '$' -> + if next > max_i then err_unescaped ~errs '$' s else + begin match s.[next] with + | '(' -> + let min = next + 2 in + if min > max_i then (err_unclosed ~errs s; loop start next) else + begin match s.[min] with + | ',' -> + let start_data = min + 1 in + flush start (i - 1); + begin match s.[min - 1] with + | 'i' -> Buffer.add_string b "\\fI" + | 'b' -> Buffer.add_string b "\\fB" + | markup -> err_markup ~errs markup s + end; + add_markup_text ~errs end_text b s start_data need_escape escape + | _ -> err_malformed ~errs s; loop start next + end + | _ -> err_unescaped ~errs '$' s; flush start (i - 1); loop next next + end + | c when markup_need_esc c -> + err_unescaped ~errs c s; flush start (i - 1); loop next next + | c when need_escape c -> + flush start (i - 1); escape b c; loop next next + | c -> loop start next + in + (Buffer.clear b; loop 0 0; Buffer.contents b) + +let doc_to_groff ~errs ~subst b s = + markup_to_groff ~errs b (subst_vars ~errs ~subst b s) + +let pp_groff_blocks ~errs subst ppf text = + let buf = Buffer.create 1024 in + let markup t = doc_to_groff ~errs ~subst buf t in + let pp_tokens ppf t = pp_tokens ~spaces:false ppf t in + let rec pp_block = function + | `Blocks bs -> List.iter pp_block bs (* not T.R. *) + | `P s -> pf ppf "@\n.P@\n%a" pp_tokens (markup s) + | `Pre s -> pf ppf "@\n.P@\n.nf@\n%a@\n.fi" pp_lines (markup s) + | `S s -> pf ppf "@\n.SH %a" pp_tokens (markup s) + | `Noblank -> pf ppf "@\n.sp -1" + | `I (l, s) -> + pf ppf "@\n.TP 4@\n%a@\n%a" pp_tokens (markup l) pp_tokens (markup s) + in + List.iter pp_block text + +let pp_groff_page ~errs subst ppf ((n, s, a1, a2, a3), t) = + pf ppf ".\\\" Pipe this output to groff -m man -K utf8 -T utf8 | less -R@\n\ + .\\\"@\n\ + .mso an.tmac@\n\ + .TH \"%s\" %d \"%s\" \"%s\" \"%s\"@\n\ + .\\\" Disable hyphenation and ragged-right@\n\ + .nh@\n\ + .ad l\ + %a@?" + n s a1 a2 a3 (pp_groff_blocks ~errs subst) t + +(* Printing to a pager *) + +let pp_to_temp_file pp_v v = + try + let exec = Filename.basename Sys.argv.(0) in + let file, oc = Filename.open_temp_file exec "out" in + let ppf = Format.formatter_of_out_channel oc in + pp_v ppf v; Format.pp_print_flush ppf (); close_out oc; + at_exit (fun () -> try Sys.remove file with Sys_error e -> ()); + Some file + with Sys_error _ -> None + +let tmp_file_for_pager () = + try + let exec = Filename.basename Sys.argv.(0) in + let file = Filename.temp_file exec "tty" in + at_exit (fun () -> try Sys.remove file with Sys_error e -> ()); + Some file + with Sys_error _ -> None + +let find_cmd cmds = + let find_win32 (cmd, _args) = + (* `where` does not support full path lookups *) + if String.equal (Filename.basename cmd) cmd + then (Sys.command (strf "where %s 1> NUL 2> NUL" cmd) = 0) + else Sys.file_exists cmd + in + let find_posix (cmd, _args) = + Sys.command (strf "command -v %s 1>/dev/null 2>/dev/null" cmd) = 0 + in + let find = if Sys.win32 then find_win32 else find_posix in + try Some (List.find find cmds) with Not_found -> None + +let pp_to_pager print ppf v = + let pager = + let cmds = ["less", ""; "more", ""] in + let cmds = try (Sys.getenv "PAGER", "") :: cmds with Not_found -> cmds in + let cmds = try (Sys.getenv "MANPAGER", "") :: cmds with Not_found -> cmds in + find_cmd cmds + in + match pager with + | None -> print `Plain ppf v + | Some (pager, opts) -> + let pager = match Sys.win32 with + | false -> "LESS=FRX " ^ pager ^ opts + | true -> "set LESS=FRX && " ^ pager ^ opts + in + let groffer = + let cmds = + ["mandoc", " -m man -K utf-8 -T utf8"; + "groff", " -m man -K utf8 -T utf8"; + "nroff", ""] + in + find_cmd cmds + in + let cmd = match groffer with + | None -> + begin match pp_to_temp_file (print `Plain) v with + | None -> None + | Some f -> Some (strf "%s < %s" pager f) + end + | Some (groffer, opts) -> + let groffer = groffer ^ opts in + begin match pp_to_temp_file (print `Groff) v with + | None -> None + | Some f when Sys.win32 -> + (* For some obscure reason the pipe below does not + work. We need to use a temporary file. + https://github.com/dbuenzli/cmdliner/issues/166 *) + begin match tmp_file_for_pager () with + | None -> None + | Some tmp -> + Some (strf "%s <%s >%s && %s <%s" groffer f tmp pager tmp) + end + | Some f -> + Some (strf "%s < %s | %s" groffer f pager) + end + in + match cmd with + | None -> print `Plain ppf v + | Some cmd -> if (Sys.command cmd) <> 0 then print `Plain ppf v + +(* Output *) + +type format = [ `Auto | `Pager | `Plain | `Groff ] + +let rec print + ?(errs = Format.err_formatter) ?(subst = fun x -> None) fmt ppf page + = + match fmt with + | `Pager -> pp_to_pager (print ~errs ~subst) ppf page + | `Plain -> pp_plain_page ~errs subst ppf page + | `Groff -> pp_groff_page ~errs subst ppf page + | `Auto -> + let fmt = + match Sys.getenv "TERM" with + | exception Not_found when Sys.win32 -> `Pager + | exception Not_found -> `Plain + | "dumb" -> `Plain + | _ -> `Pager + in + print ~errs ~subst fmt ppf page diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_manpage.mli b/src/reason-parser/vendor/cmdliner/cmdliner_manpage.mli new file mode 100644 index 000000000..679fcaac0 --- /dev/null +++ b/src/reason-parser/vendor/cmdliner/cmdliner_manpage.mli @@ -0,0 +1,84 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +(** Manpages. + + See {!Cmdliner.Manpage}. *) + +type block = + [ `S of string | `P of string | `Pre of string | `I of string * string + | `Noblank | `Blocks of block list ] + +val escape : string -> string +(** [escape s] escapes [s] from the doc language. *) + +type title = string * int * string * string * string + +type t = title * block list + +type xref = + [ `Main | `Cmd of string | `Tool of string | `Page of string * int ] + +(** {1 Standard section names} *) + +val s_name : string +val s_synopsis : string +val s_description : string +val s_commands : string +val s_arguments : string +val s_options : string +val s_common_options : string +val s_exit_status : string +val s_environment : string +val s_files : string +val s_bugs : string +val s_examples : string +val s_authors : string +val s_see_also : string +val s_none : string + +(** {1 Section maps} + + Used for handling the merging of metadata doc strings. *) + +type smap +val smap_of_blocks : block list -> smap +val smap_to_blocks : smap -> block list +val smap_has_section : smap -> sec:string -> bool +val smap_append_block : smap -> sec:string -> block -> smap +(** [smap_append_block smap sec b] appends [b] at the end of section + [sec] creating it at the right place if needed. *) + +(** {1 Content boilerplate} *) + +val s_exit_status_intro : block +val s_environment_intro : block + +(** {1 Output} *) + +type format = [ `Auto | `Pager | `Plain | `Groff ] +val print : + ?errs:Format.formatter -> ?subst:(string -> string option) -> format -> + Format.formatter -> t -> unit + +(** {1 Printers and escapes used by Cmdliner module} *) + +val subst_vars : + errs:Format.formatter -> subst:(string -> string option) -> Buffer.t -> + string -> string +(** [subst b ~subst s], using [b], substitutes in [s] variables of the form + "$(doc)" by their [subst] definition. This leaves escapes and markup + directives $(markup,…) intact. + + @raise Invalid_argument in case of illegal syntax. *) + +val doc_to_plain : + errs:Format.formatter -> subst:(string -> string option) -> Buffer.t -> + string -> string +(** [doc_to_plain b ~subst s] using [b], substitutes in [s] variables by + their [subst] definition and renders cmdliner directives to plain + text. + + @raise Invalid_argument in case of illegal syntax. *) diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_msg.ml b/src/reason-parser/vendor/cmdliner/cmdliner_msg.ml new file mode 100644 index 000000000..f6bc55a1f --- /dev/null +++ b/src/reason-parser/vendor/cmdliner/cmdliner_msg.ml @@ -0,0 +1,106 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +let strf = Printf.sprintf +let quote = Cmdliner_base.quote + +let pp = Format.fprintf +let pp_text = Cmdliner_base.pp_text +let pp_lines = Cmdliner_base.pp_lines + +(* Environment variable errors *) + +let err_env_parse env ~err = + let var = Cmdliner_info.Env.info_var env in + strf "environment variable %s: %s" (quote var) err + +(* Positional argument errors *) + +let err_pos_excess excess = + strf "too many arguments, don't know what to do with %s" + (String.concat ", " (List.map quote excess)) + +let err_pos_miss a = match Cmdliner_info.Arg.docv a with +| "" -> "a required argument is missing" +| v -> strf "required argument %s is missing" v + +let err_pos_misses = function +| [] -> assert false +| [a] -> err_pos_miss a +| args -> + let add_arg acc a = match Cmdliner_info.Arg.docv a with + | "" -> "ARG" :: acc + | argv -> argv :: acc + in + let rev_args = List.sort Cmdliner_info.Arg.rev_pos_cli_order args in + let args = List.fold_left add_arg [] rev_args in + let args = String.concat ", " args in + strf "required arguments %s are missing" args + +let err_pos_parse a ~err = match Cmdliner_info.Arg.docv a with +| "" -> err +| argv -> + match Cmdliner_info.Arg.(pos_len @@ pos_kind a) with + | Some 1 -> strf "%s argument: %s" argv err + | None | Some _ -> strf "%s… arguments: %s" argv err + +(* Optional argument errors *) + +let err_flag_value flag v = + strf "option %s is a flag, it cannot take the argument %s" + (quote flag) (quote v) + +let err_opt_value_missing f = strf "option %s needs an argument" (quote f) +let err_opt_parse f ~err = strf "option %s: %s" (quote f) err +let err_opt_repeated f f' = + if f = f' then strf "option %s cannot be repeated" (quote f) else + strf "options %s and %s cannot be present at the same time" + (quote f) (quote f') + +(* Argument errors *) + +let err_arg_missing a = + if Cmdliner_info.Arg.is_pos a then err_pos_miss a else + strf "required option %s is missing" (Cmdliner_info.Arg.opt_name_sample a) + +let err_cmd_missing ~dom = + strf "required COMMAND name is missing, must be %s." + (Cmdliner_base.alts_str ~quoted:true dom) + +(* Other messages *) + +let exec_name ei = Cmdliner_info.Cmd.name @@ Cmdliner_info.Eval.main ei + +let pp_version ppf ei = + match Cmdliner_info.Cmd.version @@ Cmdliner_info.Eval.main ei with + | None -> assert false + | Some v -> pp ppf "@[%a@]@." Cmdliner_base.pp_text v + +let pp_try_help ppf ei = + let rcmds = Cmdliner_info.Eval.(cmd ei :: parents ei) in + match List.rev_map Cmdliner_info.Cmd.name rcmds with + | [] -> assert false + | [n] -> pp ppf "@[<2>Try '%s --help' for more information.@]" n + | n :: _ as cmds -> + let cmds = String.concat " " cmds in + pp ppf "@[<2>Try '%s --help' or '%s --help' for more information.@]" + cmds n + +let pp_err ppf ei ~err = pp ppf "%s: @[%a@]@." (exec_name ei) pp_lines err + +let pp_err_usage ppf ei ~err_lines ~err = + let pp_err = if err_lines then pp_lines else pp_text in + pp ppf "@[%s: @[%a@]@,@[Usage: @[%a@]@]@,%a@]@." + (exec_name ei) pp_err err (Cmdliner_docgen.pp_plain_synopsis ~errs:ppf) ei + pp_try_help ei + +let pp_backtrace ppf ei e bt = + let bt = Printexc.raw_backtrace_to_string bt in + let bt = + let len = String.length bt in + if len > 0 then String.sub bt 0 (len - 1) (* remove final '\n' *) else bt + in + pp ppf "%s: @[internal error, uncaught exception:@\n%a@]@." + (exec_name ei) pp_lines (strf "%s\n%s" (Printexc.to_string e) bt) diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_msg.mli b/src/reason-parser/vendor/cmdliner/cmdliner_msg.mli new file mode 100644 index 000000000..ff6b4f2b9 --- /dev/null +++ b/src/reason-parser/vendor/cmdliner/cmdliner_msg.mli @@ -0,0 +1,40 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +(** Messages for the end-user. *) + +(** {1:env_err Environment variable errors} *) + +val err_env_parse : Cmdliner_info.Env.info -> err:string -> string + +(** {1:pos_err Positional argument errors} *) + +val err_pos_excess : string list -> string +val err_pos_misses : Cmdliner_info.Arg.t list -> string +val err_pos_parse : Cmdliner_info.Arg.t -> err:string -> string + +(** {1:opt_err Optional argument errors} *) + +val err_flag_value : string -> string -> string +val err_opt_value_missing : string -> string +val err_opt_parse : string -> err:string -> string +val err_opt_repeated : string -> string -> string + +(** {1:arg_err Argument errors} *) + +val err_arg_missing : Cmdliner_info.Arg.t -> string +val err_cmd_missing : dom:string list -> string + +(** {1:msgs Other messages} *) + +val pp_version : Format.formatter -> Cmdliner_info.Eval.t -> unit +val pp_try_help : Format.formatter -> Cmdliner_info.Eval.t -> unit +val pp_err : Format.formatter -> Cmdliner_info.Eval.t -> err:string -> unit +val pp_err_usage : + Format.formatter -> Cmdliner_info.Eval.t -> err_lines:bool -> err:string -> unit + +val pp_backtrace : + Format.formatter -> + Cmdliner_info.Eval.t -> exn -> Printexc.raw_backtrace -> unit diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_term.ml b/src/reason-parser/vendor/cmdliner/cmdliner_term.ml new file mode 100644 index 000000000..fd34e134e --- /dev/null +++ b/src/reason-parser/vendor/cmdliner/cmdliner_term.ml @@ -0,0 +1,90 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +type term_escape = + [ `Error of bool * string + | `Help of Cmdliner_manpage.format * string option ] + +type 'a parser = + Cmdliner_info.Eval.t -> Cmdliner_cline.t -> + ('a, [ `Parse of string | term_escape ]) result + +type 'a t = Cmdliner_info.Arg.Set.t * 'a parser + +let const v = Cmdliner_info.Arg.Set.empty, (fun _ _ -> Ok v) +let app (args_f, f) (args_v, v) = + Cmdliner_info.Arg.Set.union args_f args_v, + fun ei cl -> match (f ei cl) with + | Error _ as e -> e + | Ok f -> + match v ei cl with + | Error _ as e -> e + | Ok v -> Ok (f v) + +let map f v = app (const f) v +let product v0 v1 = app (app (const (fun x y -> (x, y))) v0) v1 + +module Syntax = struct + let ( let+ ) v f = map f v + let ( and+ ) = product +end + +(* Terms *) + +let ( $ ) = app + +type 'a ret = [ `Ok of 'a | term_escape ] + +let ret (al, v) = + al, fun ei cl -> match v ei cl with + | Ok (`Ok v) -> Ok v + | Ok (`Error _ as err) -> Error err + | Ok (`Help _ as help) -> Error help + | Error _ as e -> e + +let term_result ?(usage = false) (al, v) = + al, fun ei cl -> match v ei cl with + | Ok (Ok _ as ok) -> ok + | Ok (Error (`Msg e)) -> Error (`Error (usage, e)) + | Error _ as e -> e + +let term_result' ?usage t = + let wrap = app (const (Result.map_error (fun e -> `Msg e))) t in + term_result ?usage wrap + +let cli_parse_result (al, v) = + al, fun ei cl -> match v ei cl with + | Ok (Ok _ as ok) -> ok + | Ok (Error (`Msg e)) -> Error (`Parse e) + | Error _ as e -> e + +let cli_parse_result' t = + let wrap = app (const (Result.map_error (fun e -> `Msg e))) t in + cli_parse_result wrap + +let main_name = + Cmdliner_info.Arg.Set.empty, + (fun ei _ -> Ok (Cmdliner_info.Cmd.name @@ Cmdliner_info.Eval.main ei)) + +let choice_names = + Cmdliner_info.Arg.Set.empty, + (fun ei _ -> + (* N.B. this keeps everything backward compatible. We return the command + names of main's children *) + let name t = Cmdliner_info.Cmd.name t in + let choices = Cmdliner_info.Cmd.children (Cmdliner_info.Eval.main ei) in + Ok (List.rev_map name choices)) + +let with_used_args (al, v) : (_ * string list) t = + al, fun ei cl -> + match v ei cl with + | Ok x -> + let actual_args arg_info acc = + let args = Cmdliner_cline.actual_args cl arg_info in + List.rev_append args acc + in + let used = List.rev (Cmdliner_info.Arg.Set.fold actual_args al []) in + Ok (x, used) + | Error _ as e -> e diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_term.mli b/src/reason-parser/vendor/cmdliner/cmdliner_term.mli new file mode 100644 index 000000000..66684ca7e --- /dev/null +++ b/src/reason-parser/vendor/cmdliner/cmdliner_term.mli @@ -0,0 +1,43 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +(** Terms *) + +type term_escape = + [ `Error of bool * string + | `Help of Cmdliner_manpage.format * string option ] + +type 'a parser = + Cmdliner_info.Eval.t -> Cmdliner_cline.t -> + ('a, [ `Parse of string | term_escape ]) result +(** Type type for command line parser. given static information about + the command line and a command line to parse returns an OCaml value. *) + +type 'a t = Cmdliner_info.Arg.Set.t * 'a parser +(** The type for terms. The list of arguments it can parse and the parsing + function that does so. *) + +val const : 'a -> 'a t +val app : ('a -> 'b) t -> 'a t -> 'b t +val map : ('a -> 'b) -> 'a t -> 'b t +val product : 'a t -> 'b t -> ('a * 'b) t + +module Syntax : sig + val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t + val ( and+ ) : 'a t -> 'b t -> ('a * 'b) t +end + +val ( $ ) : ('a -> 'b) t -> 'a t -> 'b t + +type 'a ret = [ `Ok of 'a | term_escape ] + +val ret : 'a ret t -> 'a t +val term_result : ?usage:bool -> ('a, [`Msg of string]) result t -> 'a t +val term_result' : ?usage:bool -> ('a, string) result t -> 'a t +val cli_parse_result : ('a, [`Msg of string]) result t -> 'a t +val cli_parse_result' : ('a, string) result t -> 'a t +val main_name : string t +val choice_names : string list t +val with_used_args : 'a t -> ('a * string list) t diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_term_deprecated.ml b/src/reason-parser/vendor/cmdliner/cmdliner_term_deprecated.ml new file mode 100644 index 000000000..5f48443da --- /dev/null +++ b/src/reason-parser/vendor/cmdliner/cmdliner_term_deprecated.ml @@ -0,0 +1,77 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +(* Term combinators *) + +let man_format = Cmdliner_arg.man_format +let pure = Cmdliner_term.const + +(* Term information *) + +type exit_info = Cmdliner_info.Exit.info +let exit_info = Cmdliner_info.Exit.info + +let exit_status_success = Cmdliner_info.Exit.ok +let exit_status_cli_error = Cmdliner_info.Exit.cli_error +let exit_status_internal_error = Cmdliner_info.Exit.internal_error +let default_error_exits = + [ exit_info exit_status_cli_error ~doc:"on command line parsing errors."; + exit_info exit_status_internal_error + ~doc:"on unexpected internal errors (bugs)."; ] + +let default_exits = + (exit_info exit_status_success ~doc:"on success.") :: default_error_exits + +type env_info = Cmdliner_info.Env.info +let env_info = Cmdliner_info.Env.info ?deprecated:None + +type info = Cmdliner_info.Cmd.t +let info + ?(man_xrefs = []) ?man ?envs ?(exits = []) + ?(sdocs = Cmdliner_manpage.s_options) ?docs ?doc ?version name + = + Cmdliner_info.Cmd.v + ~man_xrefs ?man ?envs ~exits ~sdocs ?docs ?doc ?version name + +let name ti = Cmdliner_info.Cmd.name ti + +(* Evaluation *) + +type 'a result = +[ `Ok of 'a | `Error of [`Parse | `Term | `Exn ] | `Version | `Help ] + +let to_legacy_result = function +| Ok (#Cmdliner_eval.eval_ok as r) -> (r : 'a result) +| Error e -> `Error e + +let eval ?help ?err ?catch ?env ?argv (t, i) = + let cmd = Cmdliner_cmd.v i t in + to_legacy_result (Cmdliner_eval.eval_value ?help ?err ?catch ?env ?argv cmd) + +let eval_choice ?help ?err ?catch ?env ?argv (t, i) choices = + let sub (t, i) = Cmdliner_cmd.v i t in + let cmd = Cmdliner_cmd.group i ~default:t (List.map sub choices) in + to_legacy_result (Cmdliner_eval.eval_value ?help ?err ?catch ?env ?argv cmd) + +let eval_peek_opts ?version_opt ?env ?argv t = + let o, r = Cmdliner_eval.eval_peek_opts ?version_opt ?env ?argv t in + o, to_legacy_result r + +(* Exits *) + +let exit_status_of_result ?(term_err = 1) = function +| `Ok () | `Help | `Version -> exit_status_success +| `Error `Term -> term_err +| `Error `Exn -> exit_status_internal_error +| `Error `Parse -> exit_status_cli_error + +let exit_status_of_status_result ?term_err = function +| `Ok n -> n +| `Help | `Version | `Error _ as r -> exit_status_of_result ?term_err r + +let stdlib_exit = exit +let exit ?term_err r = stdlib_exit (exit_status_of_result ?term_err r) +let exit_status ?term_err r = + stdlib_exit (exit_status_of_status_result ?term_err r) diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_trie.ml b/src/reason-parser/vendor/cmdliner/cmdliner_trie.ml new file mode 100644 index 000000000..3444214ee --- /dev/null +++ b/src/reason-parser/vendor/cmdliner/cmdliner_trie.ml @@ -0,0 +1,80 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +module Cmap = Map.Make (Char) (* character maps. *) + +type 'a value = (* type for holding a bound value. *) +| Pre of 'a (* value is bound by the prefix of a key. *) +| Key of 'a (* value is bound by an entire key. *) +| Amb (* no value bound because of ambiguous prefix. *) +| Nil (* not bound (only for the empty trie). *) + +type 'a t = { v : 'a value; succs : 'a t Cmap.t } +let empty = { v = Nil; succs = Cmap.empty } +let is_empty t = t = empty + +(* N.B. If we replace a non-ambiguous key, it becomes ambiguous but it's + not important for our use. Also the following is not tail recursive but + the stack is bounded by key length. *) +let add t k d = + let rec loop t k len i d pre_d = match i = len with + | true -> + let t' = { v = Key d; succs = t.succs } in + begin match t.v with + | Key old -> `Replaced (old, t') + | _ -> `New t' + end + | false -> + let v = match t.v with + | Amb | Pre _ -> Amb | Key _ as v -> v | Nil -> pre_d + in + let t' = try Cmap.find k.[i] t.succs with Not_found -> empty in + match loop t' k len (i + 1) d pre_d with + | `New n -> `New { v; succs = Cmap.add k.[i] n t.succs } + | `Replaced (o, n) -> + `Replaced (o, { v; succs = Cmap.add k.[i] n t.succs }) + in + loop t k (String.length k) 0 d (Pre d (* allocate less *)) + +let find_node t k = + let rec aux t k len i = + if i = len then t else + aux (Cmap.find k.[i] t.succs) k len (i + 1) + in + aux t k (String.length k) 0 + +let find t k = + try match (find_node t k).v with + | Key v | Pre v -> `Ok v | Amb -> `Ambiguous | Nil -> `Not_found + with Not_found -> `Not_found + +let ambiguities t p = (* ambiguities of [p] in [t]. *) + try + let t = find_node t p in + match t.v with + | Key _ | Pre _ | Nil -> [] + | Amb -> + let add_char s c = s ^ (String.make 1 c) in + let rem_char s = String.sub s 0 ((String.length s) - 1) in + let to_list m = Cmap.fold (fun k t acc -> (k,t) :: acc) m [] in + let rec aux acc p = function + | ((c, t) :: succs) :: rest -> + let p' = add_char p c in + let acc' = match t.v with + | Pre _ | Amb -> acc + | Key _ -> (p' :: acc) + | Nil -> assert false + in + aux acc' p' ((to_list t.succs) :: succs :: rest) + | [] :: [] -> acc + | [] :: rest -> aux acc (rem_char p) rest + | [] -> assert false + in + aux [] p (to_list t.succs :: []) + with Not_found -> [] + +let of_list l = + let add t (s, v) = match add t s v with `New t -> t | `Replaced (_, t) -> t in + List.fold_left add empty l diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_trie.mli b/src/reason-parser/vendor/cmdliner/cmdliner_trie.mli new file mode 100644 index 000000000..decf40941 --- /dev/null +++ b/src/reason-parser/vendor/cmdliner/cmdliner_trie.mli @@ -0,0 +1,18 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +(** Tries. + + This implementation also maps any non ambiguous prefix of a + key to its value. *) + +type 'a t + +val empty : 'a t +val is_empty : 'a t -> bool +val add : 'a t -> string -> 'a -> [ `New of 'a t | `Replaced of 'a * 'a t ] +val find : 'a t -> string -> [ `Ok of 'a | `Ambiguous | `Not_found ] +val ambiguities : 'a t -> string -> string list +val of_list : (string * 'a) list -> 'a t diff --git a/src/reason-parser/vendor/cmdliner/dune b/src/reason-parser/vendor/cmdliner/dune index 7669c0b89..58daadf09 100644 --- a/src/reason-parser/vendor/cmdliner/dune +++ b/src/reason-parser/vendor/cmdliner/dune @@ -1,5 +1,4 @@ (library - (name ReasonCmdliner) + (name vendored_cmdliner) (public_name reason.cmdliner) - (wrapped false) - (flags :standard -w -3-27-32-35-50)) + (flags :standard -w -27-32-35-50)) diff --git a/src/reason-parser/vendor/cmdliner/vendored_cmdliner.ml b/src/reason-parser/vendor/cmdliner/vendored_cmdliner.ml index f75609c28..338e98789 100644 --- a/src/reason-parser/vendor/cmdliner/vendored_cmdliner.ml +++ b/src/reason-parser/vendor/cmdliner/vendored_cmdliner.ml @@ -1,1451 +1,17 @@ (*--------------------------------------------------------------------------- - Copyright (c) 2011 Daniel C. Bünzli. All rights reserved. - Distributed under a BSD3 license, see license at the end of the file. - cmdliner release 0.9.8 + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC ---------------------------------------------------------------------------*) -let str = Printf.sprintf - -(* Invalid_arg strings *) - -let err_argv = "argv array must have at least one element" -let err_not_opt = "Option argument without name" -let err_not_pos = "Positional argument with a name" -let err_help s = "Term error, help requested for unknown command " ^ s -let err_empty_list = "Empty list" -let err_incomplete_enum = "Incomplete enumeration for the type" -let err_doc_string s = - str "Variable substitution failed on documentation fragment `%s'" s - -(* A few useful definitions. *) - -let rev_compare n n' = compare n' n -let pr = Format.fprintf -let pr_str = Format.pp_print_string -let pr_char = Format.pp_print_char -let str_of_pp pp v = pp Format.str_formatter v; Format.flush_str_formatter () -let quote s = str "`%s'" s -let alts_str ?(quoted = true) alts = - let quote = if quoted then quote else (fun s -> s) in - match alts with - | [] -> invalid_arg err_empty_list - | [a] -> (quote a) - | [a; b] -> str "either %s or %s" (quote a) (quote b) - | alts -> - let rev_alts = List.rev alts in - str "one of %s or %s" - (String.concat ", " (List.rev_map quote (List.tl rev_alts))) - (quote (List.hd rev_alts)) - -let pr_white_str spaces ppf s = (* spaces and new lines with Format's funs *) - let left = ref 0 and right = ref 0 and len = String.length s in - let flush () = - Format.pp_print_string ppf (String.sub s !left (!right - !left)); - incr right; left := !right; - in - while (!right <> len) do - if s.[!right] = '\n' then (flush (); Format.pp_force_newline ppf ()) else - if spaces && s.[!right] = ' ' then (flush (); Format.pp_print_space ppf ()) - else incr right; - done; - if !left <> len then flush () - -let pr_text = pr_white_str true -let pr_lines = pr_white_str false -let pr_to_temp_file pr v = try - let exec = Filename.basename Sys.argv.(0) in - let file, oc = Filename.open_temp_file exec "out" in - let ppf = Format.formatter_of_out_channel oc in - pr ppf v; Format.pp_print_flush ppf (); close_out oc; - at_exit (fun () -> try Sys.remove file with Sys_error e -> ()); - Some file -with Sys_error _ -> None - -(* Levenshtein distance, for making spelling suggestions in case of error. *) - -let levenshtein_distance s t = - (* As found here http://rosettacode.org/wiki/Levenshtein_distance#OCaml *) - let minimum a b c = min a (min b c) in - let m = String.length s in - let n = String.length t in - (* for all i and j, d.(i).(j) will hold the Levenshtein distance between - the first i characters of s and the first j characters of t *) - let d = Array.make_matrix (m+1) (n+1) 0 in - for i = 0 to m do d.(i).(0) <- i done; - for j = 0 to n do d.(0).(j) <- j done; - for j = 1 to n do - for i = 1 to m do - if s.[i-1] = t.[j-1] then - d.(i).(j) <- d.(i-1).(j-1) (* no operation required *) - else - d.(i).(j) <- minimum - (d.(i-1).(j) + 1) (* a deletion *) - (d.(i).(j-1) + 1) (* an insertion *) - (d.(i-1).(j-1) + 1) (* a substitution *) - done; - done; - d.(m).(n) - -let suggest s candidates = - let add (min, acc) name = - let d = levenshtein_distance s name in - if d = min then min, (name :: acc) else - if d < min then d, [name] else - min, acc - in - let dist, suggs = List.fold_left add (max_int, []) candidates in - if dist < 3 (* suggest only if not too far *) then suggs else [] - -(* Tries. This implementation also maps any non ambiguous prefix of a - key to its value. *) - -module Trie : sig - type 'a t - val empty : 'a t - val is_empty : 'a t -> bool - val add : 'a t -> string -> 'a -> 'a t - val find : 'a t -> string -> [ `Ok of 'a | `Ambiguous | `Not_found ] - val ambiguities : 'a t -> string -> string list - val of_list : (string * 'a) list -> 'a t -end = struct - module Cmap = Map.Make (Char) (* character maps. *) - type 'a value = (* type for holding a bound value. *) - | Pre of 'a (* value is bound by the prefix of a key. *) - | Key of 'a (* value is bound by an entire key. *) - | Amb (* no value bound because of ambiguous prefix. *) - | Nil (* not bound (only for the empty trie). *) - - type 'a t = { v : 'a value; succs : 'a t Cmap.t } - let empty = { v = Nil; succs = Cmap.empty } - let is_empty t = t = empty - - (* N.B. If we replace a non-ambiguous key, it becomes ambiguous but it's - not important for our use. Also the following is not tail recursive but - the stack is bounded by key length. *) - let add t k d = - let rec aux t k len i d pre_d = - if i = len then { v = Key d; succs = t.succs } else - let v = match t.v with - | Amb | Pre _ -> Amb | Key _ as v -> v | Nil -> pre_d - in - let succs = - let t' = try Cmap.find k.[i] t.succs with Not_found -> empty in - Cmap.add k.[i] (aux t' k len (i + 1) d pre_d) t.succs - in - { v; succs } - in - aux t k (String.length k) 0 d (Pre d (* allocate less *)) - - let find_node t k = - let rec aux t k len i = - if i = len then t else - aux (Cmap.find k.[i] t.succs) k len (i + 1) - in - aux t k (String.length k) 0 - - let find t k = - try match (find_node t k).v with - | Key v | Pre v -> `Ok v | Amb -> `Ambiguous | Nil -> `Not_found - with Not_found -> `Not_found - - let ambiguities t p = (* ambiguities of [p] in [t]. *) - try - let t = find_node t p in - match t.v with - | Key _ | Pre _ | Nil -> [] - | Amb -> - let add_char s c = s ^ (String.make 1 c) in - let rem_char s = String.sub s 0 ((String.length s) - 1) in - let to_list m = Cmap.fold (fun k t acc -> (k,t) :: acc) m [] in - let rec aux acc p = function - | ((c, t) :: succs) :: rest -> - let p' = add_char p c in - let acc' = match t.v with - | Pre _ | Amb -> acc - | Key _ -> (p' :: acc) - | Nil -> assert false - in - aux acc' p' ((to_list t.succs) :: succs :: rest) - | [] :: [] -> acc - | [] :: rest -> aux acc (rem_char p) rest - | [] -> assert false - in - aux [] p (to_list t.succs :: []) - with Not_found -> [] - - let of_list l = List.fold_left (fun t (s, v) -> add t s v) empty l -end - -(* The following types keep untyped information about arguments and - terms. This data is used to parse the command line, report errors - and format man page information. *) - -type env_info = (* information about an environment variable. *) - { env_var : string; (* the variable. *) - env_doc : string; (* help. *) - env_docs : string; } (* title of help section where listed. *) - -type absence = (* what happens if the argument is absent from the cl. *) - | Error (* an error is reported. *) - | Val of string Lazy.t (* if <> "", takes the given default value. *) - -type opt_kind = (* kinds of optional arguments. *) - | Flag (* just a flag, without value. *) - | Opt (* value is required. *) - | Opt_vopt of string (* option value is optional, takes given default. *) - -type pos_kind = (* kinds of positional arguments. *) - | All (* all positional arguments. *) - | Nth of bool * int (* specific position. *) - | Left of bool * int (* all args on the left of a position. *) - | Right of bool * int (* all args on the right of a position. *) - -type arg_info = (* information about a command line argument. *) - { id : int; (* unique id for the argument. *) - absent : absence; (* behaviour if absent. *) - env_info : env_info option; (* environment variable. *) - doc : string; (* help. *) - docv : string; (* variable name for the argument in help. *) - docs : string; (* title of help section where listed. *) - p_kind : pos_kind; (* positional arg kind. *) - o_kind : opt_kind; (* optional arg kind. *) - o_names : string list; (* names (for opt args). *) - o_all : bool; } (* repeatable (for opt args). *) - -let arg_id = (* thread-safe UIDs, Oo.id (object end) was used before. *) - let c = ref 0 in - fun () -> - let id = !c in - incr c; if id > !c then assert false (* too many ids *) else id - -let is_opt a = a.o_names <> [] -let is_pos a = a.o_names = [] - -module Amap = Map.Make (* arg info maps. *) - (struct type t = arg_info let compare a a' = compare a.id a'.id end) - -type arg = (* unconverted argument data as found on the command line. *) - | O of (int * string * (string option)) list (* (pos, name, value) of opt. *) - | P of string list - -type cmdline = arg Amap.t (* command line, maps arg_infos to arg value. *) - -type man_block = [ (* block of manpage text. *) - | `S of string | `P of string | `Pre of string | `I of string * string - | `Noblank ] - -type term_info = - { name : string; (* name of the term. *) - version : string option; (* version (for --version). *) - tdoc : string; (* one line description of term. *) - tdocs : string; (* title of man section where listed (commands). *) - sdocs : string; (* standard options, title of section where listed. *) - man : man_block list; } (* man page text. *) - -type eval_info = (* informatin about the evaluation context. *) - { term : term_info * arg_info list; (* term being evaluated. *) - main : term_info * arg_info list; (* main term. *) - choices : (term_info * arg_info list) list; (* all term choices. *) - env : string -> string option } (* environment variable lookup. *) - -let eval_kind ei = (* evaluation with multiple terms ? *) - if ei.choices = [] then `Simple else - if (fst ei.term) == (fst ei.main) then `M_main else `M_choice - -module Manpage = struct - type title = string * int * string * string * string - type block = man_block - type t = title * block list - - let p_indent = 7 (* paragraph indentation. *) - let l_indent = 4 (* label indentation. *) - let escape subst esc buf s = - let subst s = - let len = String.length s in - if not (len > 1 && s.[1] = ',') then (subst s) else - if len = 2 then "" else - esc s.[0] (String.sub s 2 (len - 2)) - in - try - Buffer.clear buf; Buffer.add_substitute buf subst s; - let s = Buffer.contents buf in (* twice for $(i,$(mname)). *) - Buffer.clear buf; Buffer.add_substitute buf subst s; - Buffer.contents buf - with Not_found -> invalid_arg (err_doc_string s) - - let pr_tokens ?(groff = false) ppf s = - let is_space = function ' ' | '\n' | '\r' | '\t' -> true | _ -> false in - let len = String.length s in - let i = ref 0 in - try while (true) do - while (!i < len && is_space s.[!i]) do incr i done; - let start = !i in - if start = len then raise Exit; - while (!i < len && not (is_space s.[!i]) && not (s.[!i] = '-')) do - incr i - done; - pr_str ppf (String.sub s start (!i - start)); - if !i = len then raise Exit; - if s.[!i] = '-' then - (incr i; if groff then pr_str ppf "\\-" else pr_char ppf '-'); - if (!i < len && is_space s.[!i]) then - (if groff then pr_char ppf ' ' else Format.pp_print_space ppf ()) - done with Exit -> () - - (* Plain text output *) - - let plain_esc c s = match c with 'g' -> "" (* groff specific *) | _ -> s - let pr_indent ppf c = for i = 1 to c do pr_char ppf ' ' done - let pr_plain_blocks subst ppf ts = - let buf = Buffer.create 1024 in - let escape t = escape subst plain_esc buf t in - let pr_tokens ppf t = pr_tokens ppf (escape t) in - let rec aux = function - | [] -> () - | t :: ts -> - begin match t with - | `Noblank -> () - | `P s -> pr ppf "%a@[%a@]@," pr_indent p_indent pr_tokens s - | `S s -> pr ppf "@[%a@]" pr_tokens s - | `Pre s -> pr ppf "%a@[%a@]@," pr_indent p_indent pr_lines (escape s) - | `I (label, s) -> - let label = escape label in - let ll = String.length label in - pr ppf "@[%a@[%a@]" pr_indent p_indent pr_tokens label; - if s = "" then () else - if ll < l_indent then - pr ppf "%a@[%a@]@]@," pr_indent (l_indent - ll) pr_tokens s - else - pr ppf "@\n%a@[%a@]@]@," - pr_indent (p_indent + l_indent) pr_tokens s - end; - begin match ts with - | `Noblank :: ts -> aux ts - | ts -> Format.pp_print_cut ppf (); aux ts - end - in - aux ts - - let pr_plain_page subst ppf (_, text) = - pr ppf "@[%a@]" (pr_plain_blocks subst) text - - (* Groff output *) - - let groff_esc c s = match c with - | 'i' -> (str "\\fI%s\\fR" s) - | 'b' -> (str "\\fB%s\\fR" s) - | 'p' -> "" (* plain text specific *) - | _ -> s - - let pr_groff_lines ppf s = - let left = ref 0 and right = ref 0 and len = String.length s in - let flush () = - Format.pp_print_string ppf (String.sub s !left (!right - !left)); - incr right; left := !right; - in - while (!right <> len) do - if s.[!right] = '\n' then (flush (); Format.pp_force_newline ppf ()) else - if s.[!right] = '-' then (flush (); pr_str ppf "\\-") else - incr right; - done; - if !left <> len then flush () - - let pr_groff_blocks subst ppf text = - let buf = Buffer.create 1024 in - let escape t = escape subst groff_esc buf t in - let pr_tokens ppf t = pr_tokens ~groff:true ppf (escape t) in - let pr_block = function - | `P s -> pr ppf "@\n.P@\n%a" pr_tokens s - | `Pre s -> pr ppf "@\n.P@\n.nf@\n%a@\n.fi" pr_groff_lines (escape s) - | `S s -> pr ppf "@\n.SH %a" pr_tokens s - | `Noblank -> pr ppf "@\n.sp -1" - | `I (l, s) -> pr ppf "@\n.TP 4@\n%a@\n%a" pr_tokens l pr_tokens s - in - List.iter pr_block text - - let pr_groff_page subst ppf ((n, s, a1, a2, a3), t) = - pr ppf ".\\\" Pipe this output to groff -man -Tutf8 | less@\n\ - .\\\"@\n\ - .TH \"%s\" %d \"%s\" \"%s\" \"%s\"@\n\ - .\\\" Disable hyphenation and ragged-right@\n\ - .nh@\n\ - .ad l\ - %a@?" - n s a1 a2 a3 (pr_groff_blocks subst) t - - (* Printing to a pager *) - - let find_cmd cmds = - let test, null = match Sys.os_type with - | "Win32" -> "where", " NUL" - | _ -> "type", "/dev/null" - in - let cmd c = Sys.command (str "%s %s 1>%s 2>%s" test c null null) = 0 in - try Some (List.find cmd cmds) with Not_found -> None - - let pr_to_pager print ppf v = - let pager = - let cmds = ["less"; "more"] in - let cmds = try (Sys.getenv "PAGER") :: cmds with Not_found -> cmds in - let cmds = try (Sys.getenv "MANPAGER") :: cmds with Not_found -> cmds in - find_cmd cmds - in - match pager with - | None -> print `Plain ppf v - | Some pager -> - let cmd = match (find_cmd ["groff"; "nroff"]) with - | None -> - begin match pr_to_temp_file (print `Plain) v with - | None -> None - | Some f -> Some (str "%s < %s" pager f) - end - | Some c -> - begin match pr_to_temp_file (print `Groff) v with - | None -> None - | Some f -> - (* TODO use -Tutf8, but annoyingly maps U+002D to U+2212. *) - let xroff = if c = "groff" then c ^ " -Tascii -P-c" else c in - Some (str "%s -man < %s | %s" xroff f pager) - end - in - match cmd with - | None -> print `Plain ppf v - | Some cmd -> if (Sys.command cmd) <> 0 then print `Plain ppf v - - let rec print ?(subst = fun x -> x) fmt ppf page = match fmt with - | `Pager -> pr_to_pager (print ~subst) ppf page - | `Plain -> pr_plain_page subst ppf page - | `Groff -> pr_groff_page subst ppf page -end - -module Help = struct - let invocation ?(sep = ' ') ei = match eval_kind ei with - | `Simple | `M_main -> (fst ei.main).name - | `M_choice -> str "%s%c%s" (fst ei.main).name sep (fst ei.term).name - - let title ei = - let prog = String.capitalize_ascii (fst ei.main).name in - let name = String.uppercase_ascii (invocation ~sep:'-' ei) in - let left_footer = prog ^ match (fst ei.main).version with - | None -> "" | Some v -> str " %s" v - in - let center_header = str "%s Manual" prog in - name, 1, "", left_footer, center_header - - let name_section ei = - let tdoc d = if d = "" then "" else (str " - %s" d) in - [`S "NAME"; `P (str "%s%s" (invocation ~sep:'-' ei) - (tdoc (fst ei.term).tdoc)); ] - - let synopsis ei = match eval_kind ei with - | `M_main -> str "$(b,%s) $(i,COMMAND) ..." (invocation ei) - | `Simple | `M_choice -> - let rev_cmp (p, _) (p', _) = match p', p with (* best effort. *) - | p, All -> -1 | All, p -> 1 - | Left _, Right _ -> -1 | Right _, Left _ -> 1 - | Left (false, k), Nth (false, k') - | Nth (false, k), Nth (false, k') - | Nth (false, k), Right (false, k') -> if k <= k' then -1 else 1 - | Nth (false, k), Left (false, k') - | Right (false, k), Nth (false, k') -> if k >= k' then 1 else -1 - | Left (true, k), Nth (true, k') - | Nth (true, k), Nth (true, k') - | Nth (true, k), Right (true, k') -> if k >= k' then -1 else 1 - | Nth (true, k), Left (true, k') - | Right (true, k), Nth (true, k') -> if k <= k' then 1 else -1 - | p, p' -> compare p p' - in - let rec format_pos acc = function - | a :: al -> - if is_opt a then format_pos acc al else - let v = if a.docv = "" then "$(i,ARG)" else str "$(i,%s)" a.docv in - let v = if a.absent = Error then str "%s" v else str "[%s]" v in - let v = v ^ match a.p_kind with Nth _ -> "" | _ -> "..." in - format_pos ((a.p_kind, v) :: acc) al - | [] -> acc - in - let args = List.sort rev_cmp (format_pos [] (snd ei.term)) in - let args = String.concat " " (List.rev_map snd args) in - str "$(b,%s) [$(i,OPTION)]... %s" (invocation ei) args - - let get_synopsis_section ei = - let rec extract_synopsis syn = function - | `S _ :: _ as man -> List.rev syn, man - | block :: rest -> extract_synopsis (block :: syn) rest - | [] -> List.rev syn, [] - in - match (fst ei.term).man with - | `S "SYNOPSIS" as s :: rest -> extract_synopsis [s] rest (* user-defined *) - | man -> [ `S "SYNOPSIS"; `P (synopsis ei); ], man (* automatic *) - - let or_env a = match a.env_info with - | None -> "" - | Some v -> str " or $(i,%s) env" v.env_var - - let make_arg_label a = - if is_pos a then str "$(i,%s)" a.docv else - let fmt_name var = match a.o_kind with - | Flag -> fun n -> str "$(b,%s)%s" n (or_env a) - | Opt -> - fun n -> - if String.length n > 2 then str "$(b,%s)=$(i,%s)" n var else - str "$(b,%s) $(i,%s)" n var - | Opt_vopt _ -> - fun n -> - if String.length n > 2 then str "$(b,%s)[=$(i,%s)]" n var else - str "$(b,%s) [$(i,%s)]" n var - in - let var = if a.docv = "" then "VAL" else a.docv in - let names = List.sort compare a.o_names in - let s = String.concat ", " (List.rev_map (fmt_name var) names) in - s - - let arg_info_substs ~buf a doc = - let subst = function - | "docv" -> str "$(i,%s)" a.docv - | "opt" when is_opt a -> - let k = String.lowercase_ascii (List.hd (List.sort compare a.o_names)) in - str "$(b,%s)" k - | "env" when a.env_info <> None -> - begin match a.env_info with - | None -> assert false - | Some v -> str "$(i,%s)" v.env_var - end - | s -> str "$(%s)" s in - try - Buffer.clear buf; - Buffer.add_substitute buf subst doc; - Buffer.contents buf - with Not_found -> invalid_arg (err_doc_string doc) - - let make_arg_items ei = - let buf = Buffer.create 200 in - let cmp a a' = - let c = compare a.docs a'.docs in - if c <> 0 then c else - match is_opt a, is_opt a' with - | true, true -> - let key names = - let k = String.lowercase_ascii (List.hd (List.sort rev_compare names)) in - if k.[1] = '-' then String.sub k 1 (String.length k - 1) else k - in - compare (key a.o_names) (key a'.o_names) - | false, false -> - compare (String.lowercase_ascii a.docv) (String.lowercase_ascii a'.docv) - | true, false -> -1 - | false, true -> 1 - in - let format a = - let absent = match a.absent with - | Error -> "" - | Val v -> match Lazy.force v with - | "" -> "" - | v -> str "absent=%s%s" v (or_env a) - in - let optvopt = match a.o_kind with - | Opt_vopt v -> str "default=%s" v - | _ -> "" - in - let argvdoc = match optvopt, absent with - | "", "" -> "" - | s, "" | "", s -> str " (%s)" s - | s, s' -> str " (%s) (%s)" s s' - in - (a.docs, `I (make_arg_label a ^ argvdoc, (arg_info_substs ~buf a a.doc))) - in - let is_arg_item a = not (is_pos a && (a.docv = "" || a.doc = "")) in - let l = List.sort cmp (List.filter is_arg_item (snd ei.term)) in - List.rev_map format l - - let make_env_items_rev ei = - let buf = Buffer.create 200 in - let cmp a a' = - let e' = match a'.env_info with None -> assert false | Some a' -> a' in - let e = match a.env_info with None -> assert false | Some a -> a in - let c = compare e.env_docs e'.env_docs in - if c <> 0 then c else - compare e.env_var e'.env_var - in - let format a = - let e = match a.env_info with None -> assert false | Some a -> a in - (e.env_docs, - `I (str "$(i,%s)" e.env_var, arg_info_substs ~buf a e.env_doc)) - in - let is_env_item a = a.env_info <> None in - let l = List.sort cmp (List.filter is_env_item (snd ei.term)) in - List.rev_map format l - - let make_cmd_items ei = match eval_kind ei with - | `Simple | `M_choice -> [] - | `M_main -> - let add_cmd acc (ti, _) = - (ti.tdocs, `I ((str "$(b,%s)" ti.name), ti.tdoc)) :: acc - in - List.sort rev_compare (List.fold_left add_cmd [] ei.choices) - - let text ei = (* man that code is particulary unreadable. *) - let rec merge_items acc to_insert mark il = function - | `S s as sec :: ts -> - let acc = List.rev_append to_insert acc in - let acc = if mark then sec :: `Orphan_mark :: acc else sec :: acc in - let to_insert, il = List.partition (fun (n, _) -> n = s) il in - let to_insert = List.rev_map (fun (_, i) -> i) to_insert in - let to_insert = (to_insert :> [ `Orphan_mark | Manpage.block] list) in - merge_items acc to_insert (s = "DESCRIPTION") il ts - | t :: ts -> - let t = (t :> [`Orphan_mark | Manpage.block]) in - merge_items (t :: acc) to_insert mark il ts - | [] -> - let acc = List.rev_append to_insert acc in - (if mark then `Orphan_mark :: acc else acc), il - in - let rec merge_orphans acc orphans = function - | `Orphan_mark :: ts -> - let rec merge acc s = function - | [] -> (`S s) :: acc - | (s', i) :: ss -> - let i = (i :> Manpage.block) in - if s = s' then merge (i :: acc) s ss else - merge (i :: (`S s) :: acc) s' ss - in - let acc = match orphans with - | [] -> acc | (s, _) :: _ -> merge acc s orphans - in - merge_orphans acc [] ts - | (#Manpage.block as e) :: ts -> merge_orphans (e :: acc) orphans ts - | [] -> acc - in - let cmds = make_cmd_items ei in - let args = make_arg_items ei in - let envs_rev = make_env_items_rev ei in - let items_rev = List.rev_append cmds (List.rev_append args envs_rev) in - let cmp (s, _) (s', _) = match s, s with - | "ENVIRONMENT VARIABLES", _ -> 1 (* Put env vars at the end. *) - | s, "ENVIRONMENT VARIABLES" -> -1 - | s, s' -> compare s s' (* other predefined sec. names order correctly *) - in - let items = List.rev (List.stable_sort cmp items_rev) in - let synopsis, man = get_synopsis_section ei in - let rev_text, orphans = merge_items [`Orphan_mark] [] false items man in - synopsis @ merge_orphans [] orphans rev_text - - let ei_subst ei = function - | "tname" -> (fst ei.term).name - | "mname" -> (fst ei.main).name - | s -> str "$(%s)" s - - let man ei = - title ei, (name_section ei) @ (text ei) - - let print fmt ppf ei = Manpage.print ~subst:(ei_subst ei) fmt ppf (man ei) - let pr_synopsis ppf ei = - pr ppf "@[%s@]" - (Manpage.escape (ei_subst ei) - Manpage.plain_esc (Buffer.create 100) (synopsis ei)) - - let pr_version ppf ei = match (fst ei.main).version with - | None -> assert false - | Some v -> pr ppf "@[%a@]@." pr_text v -end - -(* Errors for the command line user *) - -module Err = struct - let invalid kind s exp = str "invalid %s %s, %s" kind (quote s) exp - let invalid_val = invalid "value" - let no kind s = str "no %s %s" (quote s) kind - let not_dir s = str "%s is not a directory" (quote s) - let is_dir s = str "%s is a directory" (quote s) - let element kind s exp = str "invalid element in %s (`%s'): %s" kind s exp - let sep_miss sep s = invalid_val s (str "missing a `%c' separator" sep) - let unknown kind ?(hints = []) v = - let did_you_mean s = str ", did you mean %s ?" s in - let hints = match hints with [] -> "." | hs -> did_you_mean (alts_str hs) in - str "unknown %s %s%s" kind (quote v) hints - - let ambiguous kind s ambs = - str "%s %s ambiguous and could be %s" kind (quote s) (alts_str ambs) - - let pos_excess excess = - str "too many arguments, don't know what to do with %s" - (String.concat ", " (List.map quote excess)) - - let flag_value f v = - str "option %s is a flag, it cannot take the argument %s" - (quote f) (quote v) - - let opt_value_missing f = str "option %s needs an argument" (quote f) - let opt_parse_value f e = str "option %s: %s" (quote f) e - let env_parse_value var e = str "environment variable %s: %s" (quote var) e - let opt_repeated f f' = - if f = f' then str "option %s cannot be repeated" (quote f) else - str "options %s and %s cannot be present at the same time" (quote f) - (quote f') - - let pos_parse_value a e = - if a.docv = "" then e else match a.p_kind with - | Nth _ -> str "%s argument: %s" a.docv e - | _ -> str "%s... arguments: %s" a.docv e - - let arg_missing a = - if is_opt a then - let rec long_name = function - | n :: l -> if (String.length n) > 2 || l = [] then n else long_name l - | [] -> assert false - in - str "required option %s is missing" (long_name a.o_names) - else - if a.docv = "" then str "a required argument is missing" else - str "required argument %s is missing" a.docv - - (* Error printers *) - - let print ppf ei e = pr ppf "%s: @[%a@]@." (fst ei.main).name pr_text e - let pr_backtrace err ei e bt = - let bt = - let len = String.length bt in - if len > 0 then String.sub bt 0 (len - 1) (* remove final '\n' *) else bt - in - pr err - "%s: @[internal error, uncaught exception:@\n%a@]@." - (fst ei.main).name pr_lines (str "%s\n%s" (Printexc.to_string e) bt) - - let pr_try_help ppf ei = - let exec = Help.invocation ei in - let main = (fst ei.main).name in - if exec = main then - pr ppf "@[<2>Try `%s --help' for more information.@]" exec - else - pr ppf "@[<2>Try `%s --help' or `%s --help' for more information.@]" - exec main - - let pr_usage ppf ei e = - pr ppf "@[%s: @[%a@]@,@[Usage: @[%a@]@]@,%a@]@." - (fst ei.main).name pr_text e Help.pr_synopsis ei pr_try_help ei -end - -(* Command lines. A command line stores pre-parsed information about - the command line's arguments in a more structured way. Given the - [arg_info] values mentionned in a term and Sys.argv (whithout exec - name) we parse the command line into a map of [arg_info] values to - [arg] values. This map is used by the term's closures to retrieve - and convert command line arguments (see the Arg module). *) - -module Cmdline :sig - exception Error of string - val choose_term : term_info -> (term_info * 'a) list -> string list -> - term_info * string list - val create : ?peek_opts:bool -> arg_info list -> string list -> cmdline - val opt_arg : cmdline -> arg_info -> (int * string * (string option)) list - val pos_arg : cmdline -> arg_info -> string list -end = struct - exception Error of string - - let opt_arg cl a = match try Amap.find a cl with Not_found -> assert false - with O l -> l | _ -> assert false - - let pos_arg cl a = match try Amap.find a cl with Not_found -> assert false - with P l -> l | _ -> assert false - - let choose_term ti choices = function - | [] -> ti, [] - | maybe :: args' as args -> - if String.length maybe > 1 && maybe.[0] = '-' then ti, args else - let index = - let add acc (choice, _) = Trie.add acc choice.name choice in - List.fold_left add Trie.empty choices - in - match Trie.find index maybe with - | `Ok choice -> choice, args' - | `Not_found -> - let all = Trie.ambiguities index "" in - let hints = suggest maybe all in - raise (Error (Err.unknown "command" ~hints maybe)) - | `Ambiguous -> - let ambs = List.sort compare (Trie.ambiguities index maybe) in - raise (Error (Err.ambiguous "command" maybe ambs)) - - let arg_info_indexes al = - (* from [al] returns a trie mapping the names of optional arguments to - their arg_info, a list with all arg_info for positional arguments and - a cmdline mapping each arg_info to an empty [arg]. *) - let rec aux opti posi cl = function - | a :: l -> - if is_pos a then aux opti (a :: posi) (Amap.add a (P []) cl) l else - let add t name = Trie.add t name a in - aux (List.fold_left add opti a.o_names) posi (Amap.add a (O []) cl) l - | [] -> opti, posi, cl - in - aux Trie.empty [] Amap.empty al - - let parse_opt_arg s = (* (name,value) of opt arg, assert len > 1. *) - let l = String.length s in - if s.[1] <> '-' then - if l = 2 then s, None else - String.sub s 0 2, Some (String.sub s 2 (l - 2)) - else try - let i = String.index s '=' in - String.sub s 0 i, Some (String.sub s (i + 1) (l - i - 1)) - with Not_found -> s, None - - let parse_args ~peek_opts opti cl args = - (* returns an updated [cl] cmdline according to the options found in [args] - with the trie index [opti]. Positional arguments are returned in order - in a list. *) - let rec aux k opti cl pargs = function - | [] -> cl, (List.rev pargs) - | "--" :: args -> cl, (List.rev_append pargs args) - | s :: args -> - let is_opt s = String.length s > 1 && s.[0] = '-' in - let is_short_opt s = String.length s = 2 && s.[0] = '-' in - if not (is_opt s) then aux (k+1) opti cl (s :: pargs) args else - let name, value = parse_opt_arg s in - match Trie.find opti name with - | `Ok a -> - let value, args = match value, a.o_kind with - | Some v, Flag when is_short_opt name -> None, ("-" ^ v) :: args - | Some v, _ -> value, args - | None, Flag -> value, args - | None, _ -> - match args with - | v :: rest -> if is_opt v then None, args else Some v, rest - | [] -> None, args - in - let arg = O ((k, name, value) :: opt_arg cl a) in - aux (k+1) opti (Amap.add a arg cl) pargs args - | `Not_found when peek_opts -> aux (k+1) opti cl pargs args (* skip *) - | `Not_found -> - let hints = - if String.length s <= 2 then [] else - let short_opt, long_opt = - if s.[1] <> '-' - then s, Printf.sprintf "-%s" s - else String.sub s 1 (String.length s - 1), s - in - let short_opt, _ = parse_opt_arg short_opt in - let long_opt, _ = parse_opt_arg long_opt in - let all = Trie.ambiguities opti "-" in - match List.mem short_opt all, suggest long_opt all with - | false, [] -> [] - | false, l -> l - | true, [] -> [short_opt] - | true, l -> if List.mem short_opt l then l else short_opt :: l - in - raise (Error (Err.unknown "option" ~hints name)) - | `Ambiguous -> - let ambs = List.sort compare (Trie.ambiguities opti name) in - raise (Error (Err.ambiguous "option" name ambs)) - in - aux 0 opti cl [] args - - let process_pos_args posi cl pargs = - (* returns an updated [cl] cmdline in which each positional arg mentionned - in the list index posi, is given a value according the list - of positional arguments values [pargs]. *) - if pargs = [] then cl else - let rec take n acc l = - if n = 0 then List.rev acc else - take (n - 1) (List.hd l :: acc) (List.tl l) - in - let rec aux pargs last cl max_spec = function - | a :: al -> - let arg, max_spec = match a.p_kind with - | All -> P pargs, last - | Nth (rev, k) -> - let k = if rev then last - k else k in - let max_spec = max k max_spec in - if k < 0 || k > last then P [], max_spec else - P ([List.nth pargs k]), max_spec - | Left (rev, k) -> - let k = if rev then last - k else k in - let max_spec = max k max_spec in - if k <= 0 || k > last then P [], max_spec else - P (take k [] pargs), max_spec - | Right (rev, k) -> - let k = if rev then last - k else k in - if k < 0 || k >= last then P [], last else - P (List.rev (take (last - k) [] (List.rev pargs))), last - in - aux pargs last (Amap.add a arg cl) max_spec al - | [] -> cl, max_spec - in - let last = List.length pargs - 1 in - let cl, max_spec = aux pargs last cl (-1) posi in - if last <= max_spec then cl else - let excess = List.rev (take (last - max_spec) [] (List.rev pargs)) in - raise (Error (Err.pos_excess excess)) - - let create ?(peek_opts = false) al args = - let opti, posi, cl = arg_info_indexes al in - let cl, pargs = parse_args ~peek_opts opti cl args in - if peek_opts then cl (* skip positional arguments *) else - process_pos_args posi cl pargs -end - -module Arg = struct - type 'a parser = string -> [ `Ok of 'a | `Error of string ] - type 'a printer = Format.formatter -> 'a -> unit - type 'a converter = 'a parser * 'a printer - type env = env_info - type 'a arg_converter = (eval_info -> cmdline -> 'a) - type 'a t = arg_info list * 'a arg_converter - type info = arg_info - - let env_var ?(docs = "ENVIRONMENT VARIABLES") ?(doc = "See option $(opt).") - env_var - = - { env_var = env_var; env_doc = doc; env_docs = docs } - - let ( & ) f x = f x - let parse_error e = raise (Cmdline.Error e) - let some ?(none = "") (parse, print) = - (fun s -> match parse s with `Ok v -> `Ok (Some v) | `Error _ as e -> e), - (fun ppf v -> match v with None -> pr_str ppf none| Some v -> print ppf v) - - let info ?docs ?(docv = "") ?(doc = "") ?env names = - let dash n = if String.length n = 1 then "-" ^ n else "--" ^ n in - let docs = match docs with - | None -> if names = [] then "ARGUMENTS" else "OPTIONS" - | Some s -> s - in - { id = arg_id (); absent = Val (lazy ""); - env_info = env; - doc = doc; docv = docv; docs = docs; - p_kind = All; o_kind = Flag; o_names = List.rev_map dash names; - o_all = false; } - - let env_bool_parse s = match String.lowercase_ascii s with - | "" | "false" | "no" | "n" | "0" -> `Ok false - | "true" | "yes" | "y" | "1" -> `Ok true - | s -> `Error (Err.invalid_val s (alts_str ["true"; "yes"; "false"; "no" ])) - - let parse_to_list parser s = match parser s with - | `Ok v -> `Ok [v] - | `Error _ as e -> e - - let try_env ei a parse ~absent = match a.env_info with - | None -> absent - | Some env -> - match ei.env env.env_var with - | None -> absent - | Some v -> - match parse v with - | `Ok v -> v - | `Error e -> - parse_error (Err.env_parse_value env.env_var e) - - let flag a = - if is_pos a then invalid_arg err_not_opt else - let convert ei cl = match Cmdline.opt_arg cl a with - | [] -> try_env ei a env_bool_parse ~absent:false - | [_, _, None] -> true - | [_, f, Some v] -> parse_error (Err.flag_value f v) - | (_, f, _) :: (_ ,g, _) :: _ -> parse_error (Err.opt_repeated f g) - in - [a], convert - - let flag_all a = - if is_pos a then invalid_arg err_not_opt else - let a = { a with o_all = true } in - let convert ei cl = match Cmdline.opt_arg cl a with - | [] -> try_env ei a (parse_to_list env_bool_parse) ~absent:[] - | l -> - let truth (_, f, v) = match v with - | None -> true | Some v -> parse_error (Err.flag_value f v) - in - List.rev_map truth l - in - [a], convert - - let vflag v l = - let convert _ cl = - let rec aux fv = function - | (v, a) :: rest -> - begin match Cmdline.opt_arg cl a with - | [] -> aux fv rest - | [_, f, None] -> - begin match fv with - | None -> aux (Some (f, v)) rest - | Some (g, _) -> parse_error (Err.opt_repeated g f) - end - | [_, f, Some v] -> parse_error (Err.flag_value f v) - | (_, f, _) :: (_, g, _) :: _ -> parse_error (Err.opt_repeated g f) - end - | [] -> match fv with None -> v | Some (_, v) -> v - in - aux None l - in - let flag (_, a) = if is_pos a then invalid_arg err_not_opt else a in - List.rev_map flag l, convert - - let vflag_all v l = - let convert _ cl = - let rec aux acc = function - | (fv, a) :: rest -> - begin match Cmdline.opt_arg cl a with - | [] -> aux acc rest - | l -> - let fval (k, f, v) = match v with - | None -> (k, fv) | Some v -> parse_error (Err.flag_value f v) - in - aux (List.rev_append (List.rev_map fval l) acc) rest - end - | [] -> - if acc = [] then v else List.rev_map snd (List.sort rev_compare acc) - in - aux [] l - in - let flag (_, a) = - if is_pos a then invalid_arg err_not_opt else { a with o_all = true } - in - List.rev_map flag l, convert - - let parse_opt_value parse f v = match parse v with - | `Ok v -> v | `Error e -> parse_error (Err.opt_parse_value f e) - - let opt ?vopt (parse, print) v a = - if is_pos a then invalid_arg err_not_opt else - let a = { a with absent = Val (lazy (str_of_pp print v)); - o_kind = match vopt with - | None -> Opt | Some dv -> Opt_vopt (str_of_pp print dv) } - in - let convert ei cl = match Cmdline.opt_arg cl a with - | [] -> try_env ei a parse ~absent:v - | [_, f, Some v] -> parse_opt_value parse f v - | [_, f, None] -> - begin match vopt with - | None -> parse_error (Err.opt_value_missing f) - | Some optv -> optv - end - | (_, f, _) :: (_, g, _) :: _ -> parse_error (Err.opt_repeated g f) - in - [a], convert - - let opt_all ?vopt (parse, print) v a = - if is_pos a then invalid_arg err_not_opt else - let a = { a with absent = Val (lazy ""); o_all = true; - o_kind = match vopt with - | None -> Opt | Some dv -> Opt_vopt (str_of_pp print dv) } - in - let convert ei cl = match Cmdline.opt_arg cl a with - | [] -> try_env ei a (parse_to_list parse) ~absent:v - | l -> - let parse (k, f, v) = match v with - | Some v -> (k, parse_opt_value parse f v) - | None -> match vopt with - | None -> parse_error (Err.opt_value_missing f) - | Some dv -> (k, dv) - in - List.rev_map snd (List.sort rev_compare (List.rev_map parse l)) - in - [a], convert - - (* Positional arguments *) - - let parse_pos_value parse a v = match parse v with - | `Ok v -> v | `Error e -> parse_error (Err.pos_parse_value a e) - - let pos ?(rev = false) k (parse, print) v a = - if is_opt a then invalid_arg err_not_pos else - let a = { a with p_kind = Nth (rev, k); - absent = Val (lazy (str_of_pp print v)) } - in - let convert ei cl = match Cmdline.pos_arg cl a with - | [] -> try_env ei a parse ~absent:v - | [v] -> parse_pos_value parse a v - | _ -> assert false - in - [a], convert - - let pos_list kind (parse, _) v a = - if is_opt a then invalid_arg err_not_pos else - let a = { a with p_kind = kind } in - let convert ei cl = match Cmdline.pos_arg cl a with - | [] -> try_env ei a (parse_to_list parse) ~absent:v - | l -> List.rev (List.rev_map (parse_pos_value parse a) l) - in - [a], convert - - let pos_all c v a = pos_list All c v a - let pos_left ?(rev = false) k = pos_list (Left (rev, k)) - let pos_right ?(rev = false) k = pos_list (Right (rev, k)) - - (* Arguments as terms *) - - let absent_error al = List.rev_map (fun a -> { a with absent = Error }) al - let value a = a - let required (al, convert) = - let al = absent_error al in - let convert ei cl = match convert ei cl with - | Some v -> v - | None -> parse_error (Err.arg_missing (List.hd al)) - in - al, convert - - let non_empty (al, convert) = - let al = absent_error al in - let convert ei cl = match convert ei cl with - | [] -> parse_error (Err.arg_missing (List.hd al)) - | l -> l - in - al, convert - - let last (al, convert) = - let convert ei cl = match convert ei cl with - | [] -> parse_error (Err.arg_missing (List.hd al)) - | l -> List.hd (List.rev l) - in - al, convert - - (* Predefined converters. *) - - let bool = - (fun s -> try `Ok (bool_of_string s) with Invalid_argument _ -> - `Error (Err.invalid_val s (alts_str ["true"; "false"]))), - Format.pp_print_bool - - let char = - (fun s -> if String.length s = 1 then `Ok s.[0] else - `Error (Err.invalid_val s "expected a character")), - pr_char - - let parse_with t_of_str exp s = - try `Ok (t_of_str s) with Failure _ -> `Error (Err.invalid_val s exp) - - let int = - parse_with int_of_string "expected an integer", Format.pp_print_int - - let int32 = - parse_with Int32.of_string "expected a 32-bit integer", - (fun ppf -> pr ppf "%ld") - - let int64 = - parse_with Int64.of_string "expected a 64-bit integer", - (fun ppf -> pr ppf "%Ld") - - let nativeint = - parse_with Nativeint.of_string "expected a processor-native integer", - (fun ppf -> pr ppf "%nd") - - let float = - parse_with float_of_string "expected a floating point number", - Format.pp_print_float - - let string = (fun s -> `Ok s), pr_str - let enum sl = - if sl = [] then invalid_arg err_empty_list else - let t = Trie.of_list sl in - let parse s = match Trie.find t s with - | `Ok _ as r -> r - | `Ambiguous -> - let ambs = List.sort compare (Trie.ambiguities t s) in - `Error (Err.ambiguous "enum value" s ambs) - | `Not_found -> - let alts = List.rev (List.rev_map (fun (s, _) -> s) sl) in - `Error (Err.invalid_val s ("expected " ^ (alts_str alts))) - in - let print ppf v = - let sl_inv = List.rev_map (fun (s,v) -> (v,s)) sl in - try pr_str ppf (List.assoc v sl_inv) - with Not_found -> invalid_arg err_incomplete_enum - in - parse, print - - let file = - (fun s -> if Sys.file_exists s then `Ok s else - `Error (Err.no "file or directory" s)), - pr_str - - let dir = - (fun s -> - if Sys.file_exists s then - if Sys.is_directory s then `Ok s else `Error (Err.not_dir s) - else - `Error (Err.no "directory" s)), - pr_str - - let non_dir_file = - (fun s -> - if Sys.file_exists s then - if not (Sys.is_directory s) then `Ok s else `Error (Err.is_dir s) - else - `Error (Err.no "file" s)), - pr_str - - let split_and_parse sep parse s = - let parse sub = match parse sub with - | `Error e -> failwith e | `Ok v -> v in - let rec split accum j = - let i = try String.rindex_from s j sep with Not_found -> -1 in - if (i = -1) then - let p = String.sub s 0 (j + 1) in - if p <> "" then parse p :: accum else accum - else - let p = String.sub s (i + 1) (j - i) in - let accum' = if p <> "" then parse p :: accum else accum in - split accum' (i - 1) - in - split [] (String.length s - 1) - - let list ?(sep = ',') (parse, pr_e) = - let parse s = try `Ok (split_and_parse sep parse s) with - | Failure e -> `Error (Err.element "list" s e) - in - let rec print ppf = function - | v :: l -> pr_e ppf v; if (l <> []) then (pr_char ppf sep; print ppf l) - | [] -> () - in - parse, print - - let array ?(sep = ',') (parse, pr_e) = - let parse s = try `Ok (Array.of_list (split_and_parse sep parse s)) with - | Failure e -> `Error (Err.element "array" s e) - in - let print ppf v = - let max = Array.length v - 1 in - for i = 0 to max do pr_e ppf v.(i); if i <> max then pr_char ppf sep done - in - parse, print - - let split_left sep s = - try - let i = String.index s sep in - let len = String.length s in - Some ((String.sub s 0 i), (String.sub s (i + 1) (len - i - 1))) - with Not_found -> None - - let pair ?(sep = ',') (pa0, pr0) (pa1, pr1) = - let parser s = match split_left sep s with - | None -> `Error (Err.sep_miss sep s) - | Some (v0, v1) -> - match pa0 v0, pa1 v1 with - | `Ok v0, `Ok v1 -> `Ok (v0, v1) - | `Error e, _ | _, `Error e -> `Error (Err.element "pair" s e) - in - let printer ppf (v0, v1) = pr ppf "%a%c%a" pr0 v0 sep pr1 v1 in - parser, printer - - let t2 = pair - let t3 ?(sep = ',') (pa0, pr0) (pa1, pr1) (pa2, pr2) = - let parse s = match split_left sep s with - | None -> `Error (Err.sep_miss sep s) - | Some (v0, s) -> - match split_left sep s with - | None -> `Error (Err.sep_miss sep s) - | Some (v1, v2) -> - match pa0 v0, pa1 v1, pa2 v2 with - | `Ok v0, `Ok v1, `Ok v2 -> `Ok (v0, v1, v2) - | `Error e, _, _ | _, `Error e, _ | _, _, `Error e -> - `Error (Err.element "triple" s e) - in - let print ppf (v0, v1, v2) = - pr ppf "%a%c%a%c%a" pr0 v0 sep pr1 v1 sep pr2 v2 - in - parse, print - - let t4 ?(sep = ',') (pa0, pr0) (pa1, pr1) (pa2, pr2) (pa3, pr3) = - let parse s = match split_left sep s with - | None -> `Error (Err.sep_miss sep s) - | Some(v0, s) -> - match split_left sep s with - | None -> `Error (Err.sep_miss sep s) - | Some (v1, s) -> - match split_left sep s with - | None -> `Error (Err.sep_miss sep s) - | Some (v2, v3) -> - match pa0 v0, pa1 v1, pa2 v2, pa3 v3 with - | `Ok v1, `Ok v2, `Ok v3, `Ok v4 -> `Ok (v1, v2, v3, v4) - | `Error e, _, _, _ | _, `Error e, _, _ | _, _, `Error e, _ - | _, _, _, `Error e -> `Error (Err.element "quadruple" s e) - in - let print ppf (v0, v1, v2, v3) = - pr ppf "%a%c%a%c%a%c%a" pr0 v0 sep pr1 v1 sep pr2 v2 sep pr3 v3 - in - parse, print - - (* Documentation formatting helpers *) - - let doc_quote = quote - let doc_alts = alts_str - let doc_alts_enum ?quoted enum = alts_str ?quoted (List.map fst enum) -end - +module Manpage = Cmdliner_manpage module Term = struct - type info = term_info - type +'a t = arg_info list * (eval_info -> cmdline -> 'a) - type 'a result = [ - | `Ok of 'a | `Error of [`Parse | `Term | `Exn ] | `Version | `Help ] - - exception Term of - [ `Help of [`Pager | `Plain | `Groff] * string option - | `Error of bool * string ] - - let info ?(sdocs = "OPTIONS") ?(man = []) ?(docs = "COMMANDS") ?(doc = "") - ?version name = - { name = name; version = version; tdoc = doc; tdocs = docs; sdocs = sdocs; - man = man } - - let name ti = ti.name - let const v = [], (fun _ _ -> v) - let pure (* deprecated *) = const - let app (al, f) (al', v) = - List.rev_append al al', - fun ei cl -> (f ei cl) (v ei cl) - - let ( $ ) = app - - type 'a ret = - [ `Help of [`Pager | `Plain | `Groff] * string option - | `Error of (bool * string) - | `Ok of 'a ] - - let ret (al, v) = - al, fun ei cl -> match v ei cl with - | `Ok v -> v - | `Error (u,e) -> raise (Term (`Error (u,e))) - | `Help h -> raise (Term (`Help h)) - - let main_name = [], (fun ei _ -> (fst ei.main).name) - let choice_names = - [], fun ei _ -> List.rev_map (fun e -> (fst e).name) ei.choices - - let man_format = - let fmts = ["pager", `Pager; "groff", `Groff; "plain", `Plain] in - let doc = "Show output in format $(docv) (pager, plain or groff)."in - Arg.(value & opt (enum fmts) `Pager & info ["man-format"] ~docv:"FMT" ~doc) - - (* Evaluation *) - - let remove_exec argv = - try List.tl (Array.to_list argv) with Failure _ -> invalid_arg err_argv - - let add_std_opts ei = - let docs = (fst ei.term).sdocs in - let args, v_lookup = - if (fst ei.main).version = None then [], None else - let (a, lookup) = - Arg.flag (Arg.info ["version"] ~docs ~doc:"Show version information.") - in - a, Some lookup - in - let args, h_lookup = - let (a, lookup) = - let fmt = Arg.enum ["pager",`Pager; "groff",`Groff; "plain",`Plain] in - let doc = "Show this help in format $(docv) (pager, plain or groff)."in - let a = Arg.info ["help"] ~docv:"FMT" ~docs ~doc in - Arg.opt ~vopt:(Some `Pager) (Arg.some fmt) None a - in - List.rev_append a args, lookup - in - h_lookup, v_lookup, - { ei with term = (fst ei.term), List.rev_append args (snd ei.term) } - - let eval_term help err ei f args = - let help_arg, vers_arg, ei = add_std_opts ei in - try - let cl = Cmdline.create (snd ei.term) args in - match help_arg ei cl, vers_arg with - | Some fmt, _ -> Help.print fmt help ei; `Help - | None, Some v_arg when v_arg ei cl -> Help.pr_version help ei; `Version - | _ -> `Ok (f ei cl) - with - | Cmdline.Error e -> Err.pr_usage err ei e; `Error `Parse - | Term (`Error (usage, e)) -> - if usage then Err.pr_usage err ei e else Err.print err ei e; - `Error `Term - | Term (`Help (fmt, cmd)) -> - let ei = match cmd with - | Some cmd -> - let cmd = - try List.find (fun (i, _) -> i.name = cmd) ei.choices - with Not_found -> invalid_arg (err_help cmd) - in - {ei with term = cmd } - | None -> { ei with term = ei.main } - in - let _, _, ei = add_std_opts ei in - Help.print fmt help ei; `Help - - let env_default v = try Some (Sys.getenv v) with Not_found -> None - - let eval ?(help = Format.std_formatter) ?(err = Format.err_formatter) - ?(catch = true) ?(env = env_default) ?(argv = Sys.argv) ((al, f), ti) = - let term = ti, al in - let ei = { term = term; main = term; choices = []; env = env } in - try eval_term help err ei f (remove_exec argv) with - | e when catch -> - Err.pr_backtrace err ei e (Printexc.get_backtrace ()); `Error `Exn - - let eval_choice ?(help = Format.std_formatter) ?(err = Format.err_formatter) - ?(catch = true) ?(env = env_default) ?(argv = Sys.argv) - (((al, f) as t), ti) choices = - let ei_choices = List.rev_map (fun ((al, _), ti) -> ti, al) choices in - let main = (ti, al) in - let ei = { term = main; main = main; choices = ei_choices; env = env } in - try - let chosen, args = Cmdline.choose_term ti ei_choices (remove_exec argv) in - let find_chosen (_, ti) = ti = chosen in - let (al, f), _ = List.find find_chosen ((t, ti) :: choices) in - let ei = { ei with term = (chosen, al) } in - eval_term help err ei f args - with - | Cmdline.Error e -> (* may be raised by choose_term. *) - Err.pr_usage err ei e; `Error `Parse - | e when catch -> - Err.pr_backtrace err ei e (Printexc.get_backtrace ()); `Error `Exn - - let eval_peek_opts ?(version_opt = false) ?(env = env_default) - ?(argv = Sys.argv) (al, f) = - let args = remove_exec argv in - let version = if version_opt then Some "dummy" else None in - let term = info ?version "dummy", al in - let ei = { term = term; main = term; choices = []; env = env } in - let help_arg, vers_arg, ei = add_std_opts ei in - try - let cl = Cmdline.create ~peek_opts:true (snd ei.term) args in - match help_arg ei cl, vers_arg with - | Some fmt, _ -> - (try (Some (f ei cl), `Help) with e -> None, `Help) - | None, Some v_arg when v_arg ei cl -> - (try (Some (f ei cl), `Version) with e -> None, `Version) - | _ -> - let v = f ei cl in - Some v, `Ok v - with - | Cmdline.Error _ -> None, (`Error `Parse) - | Term _ -> None, (`Error `Term) - | e -> None, (`Error `Exn) + include Cmdliner_term + include Cmdliner_term_deprecated end - -(*--------------------------------------------------------------------------- - Copyright (c) 2011 Daniel C. Bünzli - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - 2. Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - 3. Neither the name of Daniel C. Bünzli nor the names of - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - ---------------------------------------------------------------------------*) +module Cmd = struct + module Exit = Cmdliner_info.Exit + module Env = Cmdliner_info.Env + include Cmdliner_cmd + include Cmdliner_eval +end +module Arg = Cmdliner_arg diff --git a/src/reason-parser/vendor/cmdliner/vendored_cmdliner.mli b/src/reason-parser/vendor/cmdliner/vendored_cmdliner.mli index ee196bcf6..7e886cdf8 100644 --- a/src/reason-parser/vendor/cmdliner/vendored_cmdliner.mli +++ b/src/reason-parser/vendor/cmdliner/vendored_cmdliner.mli @@ -1,60 +1,56 @@ (*--------------------------------------------------------------------------- - Copyright (c) 2011 Daniel C. Bünzli. All rights reserved. - Distributed under a BSD3 license, see license at the end of the file. - cmdliner release 0.9.8 + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC ---------------------------------------------------------------------------*) (** Declarative definition of command line interfaces. - [Cmdliner] provides a simple and compositional mechanism - to convert command line arguments to OCaml values and pass them to - your functions. The module automatically handles syntax errors, - help messages and UNIX man page generation. It supports programs - with single or multiple commands - (like [darcs] or [git]) and respect most of the - {{:http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap12.html} - POSIX} and - {{:http://www.gnu.org/software/libc/manual/html_node/Argument-Syntax.html} - GNU} conventions. + Consult the {{!page-tutorial}tutorial}, details about the supported + {{!page-cli}command line syntax} and {{!page-examples}examples} of + use. - Consult the {{!basics}basics}, details about the supported - {{!cmdline}command line syntax} and {{!examples} examples} of - use. Open the module to use it, it defines only three modules in - your scope. - - {e Release 0.9.8 - Daniel Bünzli } *) - -(** {1:top Interface} *) + Open the module to use it, it defines only three modules in your + scope. *) (** Man page specification. - Man page generation is automatically handled by [Cmdliner]. The - {!block} type is used to define a man page's content. + Man page generation is automatically handled by [Cmdliner], + consult the {{!page-tool_man.manual}details}. - The {!print} function can be useful if the client wants to define - other man pages (e.g. to implement a help command). *) + The {!Manpage.block} type is used to define a man page's + content. It's a good idea to follow the + {{!Manpage.standard_sections}standard} manual page structure. + + {b References.} + {ul + {- [man-pages(7)], {{:http://man7.org/linux/man-pages/man7/man-pages.7.html} + {e Conventions for writing Linux man pages}}.}} *) module Manpage : sig (** {1:man Man pages} *) type block = [ `S of string | `P of string | `Pre of string | `I of string * string - | `Noblank ] + | `Noblank | `Blocks of block list ] (** The type for a block of man page text. {ul - {- [`S s] introduces a new section [s].} + {- [`S s] introduces a new section [s], see the + {{!standard_sections}standard section names}.} {- [`P t] is a new paragraph with text [t].} {- [`Pre t] is a new preformatted paragraph with text [t].} {- [`I (l,t)] is an indented paragraph with label - [l] and text [t].} - {- [`Noblank] suppresses the blank line introduced between two blocks.}} + [l] and text [t].} + {- [`Noblank] suppresses the blank line introduced between two blocks.} + {- [`Blocks bs] splices the blocks [bs].}} Except in [`Pre], whitespace and newlines are not significant - and are all collapsed to a single space. In labels [l] and text - strings [t], the syntax ["$(i,italic text)"] and ["$(b,bold - text)"] can be used to respectively produce italic and bold - text. *) + and are all collapsed to a single space. All block strings + support the {{!page-tool_man.doclang}documentation markup language}.*) + + val escape : string -> string + (** [escape s] escapes [s] so that it doesn't get interpreted by the + {{!page-tool_man.doclang}documentation markup language}. *) type title = string * int * string * string * string (** The type for man page titles. Describes the man page @@ -63,20 +59,114 @@ module Manpage : sig type t = title * block list (** The type for a man page. A title and the page text as a list of blocks. *) - val print : ?subst:(string -> string) -> - [`Pager | `Plain | `Groff ] -> Format.formatter -> t -> unit - (** [print ~subst fmt ppf page] prints [page] on [ppf] in the format [fmt]. - If [fmt] is [`Pager] the function tries to write the formatted - result in a pager, if that fails the format [`Plain] is written - on [ppf]. [subst] can be used to perform variable substitution, - see {!Buffer.add_substitute} (defaults to the identity). *) + type xref = + [ `Main | `Cmd of string | `Tool of string | `Page of string * int ] + (** The type for man page cross-references. + {ul + {- [`Main] refers to the man page of the program itself.} + {- [`Cmd cmd] refers to the man page of the program's [cmd] + command (which must exist).} + {- [`Tool bin] refers to the command line tool named [bin].} + {- [`Page (name, sec)] refers to the man page [name(sec)].}} *) + + (** {1:standard_sections Standard section names and content} + + The following are standard man page section names, roughly ordered + in the order they conventionally appear. See also + {{:http://man7.org/linux/man-pages/man7/man-pages.7.html}[man man-pages]} + for more elaborations about what sections should contain. *) + + val s_name : string + (** The [NAME] section. This section is automatically created by + [Cmdliner] for your. *) + + val s_synopsis : string + (** The [SYNOPSIS] section. By default this section is automatically + created by [Cmdliner] for you, unless it is the first section of + your term's man page, in which case it will replace it with yours. *) + + val s_description : string + (** The [DESCRIPTION] section. This should be a description of what + the tool does and provide a little bit of usage and + documentation guidance. *) + + val s_commands : string + (** The [COMMANDS] section. By default subcommands get listed here. *) + + val s_arguments : string + (** The [ARGUMENTS] section. By default positional arguments get + listed here. *) + + val s_options : string + (** The [OPTIONS] section. By default optional arguments get + listed here. *) + + val s_common_options : string + (** The [COMMON OPTIONS] section. By default help and version options get + listed here. For programs with multiple commands, optional arguments + common to all commands can be added here. *) + + val s_exit_status : string + (** The [EXIT STATUS] section. By default term status exit codes + get listed here. *) + + val s_environment : string + (** The [ENVIRONMENT] section. By default environment variables get + listed here. *) + + val s_environment_intro : block + (** [s_environment_intro] is the introduction content used by cmdliner + when it creates the {!s_environment} section. *) + + val s_files : string + (** The [FILES] section. *) + + val s_bugs : string + (** The [BUGS] section. *) + + val s_examples : string + (** The [EXAMPLES] section. *) + + val s_authors : string + (** The [AUTHORS] section. *) + + val s_see_also : string + (** The [SEE ALSO] section. *) + + val s_none : string + (** [s_none] is a special section named ["cmdliner-none"] that can be used + whenever you do not want something to be listed. *) + + (** {1:output Output} + + The {!print} function can be useful if the client wants to define + other man pages (e.g. to implement a help command). *) + + type format = [ `Auto | `Pager | `Plain | `Groff ] + (** The type for man page output specification. + {ul + {- [`Auto], formats like [`Pager] or [`Plain] whenever the [TERM] + environment variable is [dumb] or unset.} + {- [`Pager], tries to write to a discovered pager, if that fails + uses the [`Plain] format.} + {- [`Plain], formats to plain text.} + {- [`Groff], formats to groff commands.}} *) + + val print : + ?errs:Format.formatter -> + ?subst:(string -> string option) -> format -> Format.formatter -> t -> unit + (** [print ~errs ~subst fmt ppf page] prints [page] on [ppf] in the + format [fmt]. [subst] can be used to perform variable + substitution,(defaults to the identity). [errs] is used to print + formatting errors, it defaults to {!Format.err_formatter}. *) end (** Terms. - A term is evaluated by a program to produce a {{!result}result}. - A term made of terms referring to {{!Arg}command line arguments} - implicitly defines a command line syntax. *) + A term is evaluated by a program to produce a {{!Term.result}result}, + which can be turned into an {{!Term.exits}exit status}. A term made of terms + referring to {{!Arg}command line arguments} implicitly defines a + command line syntax. *) module Term : sig (** {1:terms Terms} *) @@ -87,11 +177,6 @@ module Term : sig val const : 'a -> 'a t (** [const v] is a term that evaluates to [v]. *) - (**/**) - val pure : 'a -> 'a t - (** @deprecated use {!const} instead. *) - (**/**) - val ( $ ) : ('a -> 'b) t -> 'a t -> 'b t (** [f $ v] is a term that evaluates to the result of applying the evaluation of [v] to the one of [f]. *) @@ -99,46 +184,154 @@ module Term : sig val app : ('a -> 'b) t -> 'a t -> 'b t (** [app] is {!($)}. *) + val map : ('a -> 'b) -> 'a t -> 'b t + (** [map f t] is [app (const f) t]. *) + + val product : 'a t -> 'b t -> ('a * 'b) t + (** [product t0 t1] is [app (app (map (fun x y -> (x, y)) t0) t1)] *) + + (** [let] operators. *) + module Syntax : sig + val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t + (** [( let+ )] is {!map}. *) + + val ( and+ ) : 'a t -> 'b t -> ('a * 'b) t + (** [( and* )] is {!product}. *) + end + + (** {1 Interacting with Cmdliner's evaluation} *) + + val term_result : ?usage:bool -> ('a, [`Msg of string]) result t -> 'a t + (** [term_result ~usage t] evaluates to + {ul + {- [`Ok v] if [t] evaluates to [Ok v]} + {- [`Error `Term] with the error message [e] and usage shown according + to [usage] (defaults to [false]), if [t] evaluates to + [Error (`Msg e)].}} + + See also {!term_result'}. *) + + val term_result' : ?usage:bool -> ('a, string) result t -> 'a t + (** [term_result'] is like {!term_result} but with a [string] + error case. *) + + val cli_parse_result : ('a, [`Msg of string]) result t -> 'a t + (** [cli_parse_result t] is a term that evaluates to: + {ul + {- [`Ok v] if [t] evaluates to [Ok v].} + {- [`Error `Parse] with the error message [e] + if [t] evaluates to [Error (`Msg e)].}} + + See also {!cli_parse_result'}. *) + + val cli_parse_result' : ('a, string) result t -> 'a t + (** [cli_parse_result'] is like {!cli_parse_result} but with a [string] + error case. *) + + val main_name : string t + (** [main_name] is a term that evaluates to the main command name; + that is the name of the tool. *) + + val choice_names : string list t + (** [choice_names] is a term that evaluates to the names of the commands + that are children of the main command. *) + + val with_used_args : 'a t -> ('a * string list) t + (** [with_used_args t] is a term that evaluates to [t] tupled + with the arguments from the command line that where used to + evaluate [t]. *) + type 'a ret = - [ `Help of [`Pager | `Plain | `Groff] * string option - | `Error of (bool * string) - | `Ok of 'a ] - (** The type for command return values. See {!ret}. *) + [ `Help of Manpage.format * string option + | `Error of (bool * string) + | `Ok of 'a ] + (** The type for command return values. See {!val-ret}. *) val ret : 'a ret t -> 'a t (** [ret v] is a term whose evaluation depends on the case to which [v] evaluates. With : {ul - {- [`Ok r], it evaluates to [r].} - {- [`Error (usage,e)], the evaluation fails and [Cmdliner] prints + {- [`Ok v], it evaluates to [v].} + {- [`Error (usage, e)], the evaluation fails and [Cmdliner] prints the error [e] and the term's usage if [usage] is [true].} - {- [`Help (format, name)], the evaluation fails and [Cmdliner] prints the - term's man page in the given [format] (or the man page for a - specific [name] term in case of multiple term evaluation).}} *) + {- [`Help (format, name)], the evaluation fails and [Cmdliner] prints + a manpage in format [format]. If [name] is [None] this is the + the main command's manpage. If [name] is [Some c] this is + the man page of the sub command [c] of the main command.}} - val main_name : string t - (** [main_name] is a term that evaluates to the "main" term's name. *) + {b Note.} While not deprecated you are encouraged not use this API. *) - val choice_names : string list t - (** [choice_names] is a term that evaluates to the names of the terms - to choose from. *) + (** {1:deprecated Deprecated Term evaluation interface} - val man_format : [`Pager | `Plain | `Groff] t - (** [man_format] is a term that defines a [--man-format] option and - evaluates to a value that can be used with {!Manpage.print}. *) + This interface is deprecated in favor of {!Cmdliner.Cmd}. Follow + the compiler deprecation warning hints to transition. *) - (** {1:tinfo Term information} + (** {2:tinfo Term information} Term information defines the name and man page of a term. For simple evaluation this is the name of the program and its man page. For multiple term evaluation, this is the name of a command and its man page. *) + [@@@alert "-deprecated"] (* Need to be able to mention them ! *) + + type exit_info + [@@ocaml.deprecated "Use Cmd.Exit.info instead."] + (** The type for exit status information. *) + + val exit_info : ?docs:string -> ?doc:string -> ?max:int -> int -> exit_info + [@@ocaml.deprecated "Use Cmd.Exit.info instead."] + (** [exit_info ~docs ~doc min ~max] describe the range of exit + statuses from [min] to [max] (defaults to [min]). [doc] is the + man page information for the statuses, defaults to ["undocumented"]. + [docs] is the title of the man page section in which the statuses + will be listed, it defaults to {!Manpage.s_exit_status}. + + In [doc] the {{!page-tool_man.doclang}documentation markup language} + can be used with following variables: + {ul + {- [$(status)], the value of [min].} + {- [$(status_max)], the value of [max].} + {- The variables mentioned in {!val-info}}} *) + + val default_exits : exit_info list + [@@ocaml.deprecated + "Use Cmd.Exit.defaults or Cmd.info's defaults ~exits value instead."] + (** [default_exits] is information for exit status {!exit_status_success} + added to {!default_error_exits}. *) + + val default_error_exits : exit_info list + [@@ocaml.deprecated "List.filter the Cmd.Exit.defaults value instead."] + (** [default_error_exits] is information for exit statuses + {!exit_status_cli_error} and {!exit_status_internal_error}. *) + + type env_info + [@@ocaml.deprecated "Use Cmd.Env.info instead."] + (** The type for environment variable information. *) + + val env_info : ?docs:string -> ?doc:string -> string -> env_info + [@@ocaml.deprecated "Use Cmd.Env.info instead."] + (** [env_info ~docs ~doc var] describes an environment variable + [var]. [doc] is the man page information of the environment + variable, defaults to ["undocumented"]. [docs] is the title of + the man page section in which the environment variable will be + listed, it defaults to {!Cmdliner.Manpage.s_environment}. + + In [doc] the {{!page-tool_man.doclang}documentation markup language} + can be used with following variables: + {ul + {- [$(env)], the value of [var].} + {- The variables mentioned in {!val-info}}} *) + type info + [@@ocaml.deprecated "Use Cmd.info instead."] (** The type for term information. *) - val info : ?sdocs:string -> ?man:Manpage.block list -> + val info : + ?man_xrefs:Manpage.xref list -> ?man:Manpage.block list -> + ?envs:env_info list -> ?exits:exit_info list -> ?sdocs:string -> ?docs:string -> ?doc:string -> ?version:string -> string -> info + [@@ocaml.deprecated "Use Cmd.info instead."] (** [info sdocs man docs doc version name] is a term information such that: {ul @@ -150,42 +343,54 @@ module Term : sig description is also used in the list of commands of the main term's man page.} {- [docs], only for commands, the title of the section of the main - term's man page where it should be listed (defaults to ["COMMANDS"]).} - {- [man] is the text of the man page for the term. In the text, - the variables ["$(tname)"] and ["$(mname)"] can respectively be - used to refer to the value of [name] and the main term's name. - } + term's man page where it should be listed (defaults to + {!Manpage.s_commands}).} {- [sdocs] defines the title of the section in which the - standard [--help] and [--version] arguments are listed.}} *) + standard [--help] and [--version] arguments are listed + (defaults to {!Manpage.s_options}).} + {- [exits] is a list of exit statuses that the term evaluation + may produce.} + {- [envs] is a list of environment variables that influence + the term's evaluation.} + {- [man] is the text of the man page for the term.} + {- [man_xrefs] are cross-references to other manual pages. These + are used to generate a {!Manpage.s_see_also} section.}} + [doc], [man], [envs] support the {{!page-tool_man.doclang}documentation + markup language} in which the following variables are recognized: + {ul + {- [$(tname)] the term's name.} + {- [$(mname)] the main term's name.}} *) val name : info -> string + [@@ocaml.deprecated "Use Cmd.name instead."] (** [name ti] is the name of the term information. *) - (** {1:evaluation Evaluation} *) + (** {2:evaluation Evaluation} *) - type 'a result = [ - | `Ok of 'a | `Error of [`Parse | `Term | `Exn ] | `Version | `Help ] + type 'a result = + [ `Ok of 'a | `Error of [`Parse | `Term | `Exn ] | `Version | `Help ] (** The type for evaluation results. {ul {- [`Ok v], the term evaluated successfully and [v] is the result.} {- [`Version], the version string of the main term was printed on the help formatter.} {- [`Help], man page about the term was printed on the help formatter.} - {- [`Error `Parse], a command line parse error occured and was + {- [`Error `Parse], a command line parse error occurred and was reported on the error formatter.} - {- [`Error `Term], a term evaluation error occured and was reported - on the error formatter (see {!Term.ret}).} + {- [`Error `Term], a term evaluation error occurred and was reported + on the error formatter (see {!Term.val-ret}').} {- [`Error `Exn], an exception [e] was caught and reported on the error formatter (see the [~catch] parameter of {!eval}).}} *) - val eval : ?help:Format.formatter -> - ?err:Format.formatter -> ?catch:bool -> - ?env:(string -> string option) -> - ?argv:string array -> ('a t * info) -> 'a result + val eval : + ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> + ?env:(string -> string option) -> ?argv:string array -> ('a t * info) -> + 'a result + [@@ocaml.deprecated "Use Cmd.v and one of Cmd.eval* instead."] (** [eval help err catch argv (t,i)] is the evaluation result of [t] with command line arguments [argv] (defaults to {!Sys.argv}). - If [catch] is [true] (default) uncaught exeptions + If [catch] is [true] (default) uncaught exceptions are intercepted and their stack trace is written to the [err] formatter. @@ -196,12 +401,12 @@ module Term : sig [env] is used for environment variable lookup, the default uses {!Sys.getenv}. *) - val eval_choice : ?help:Format.formatter -> - ?err:Format.formatter -> ?catch:bool -> - ?env:(string -> string option) -> - ?argv:string array -> 'a t * info -> ('a t * info) list -> - 'a result - (** [eval_choice help err catch argv default (t,i) choices] is like {!eval} + val eval_choice : + ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> + ?env:(string -> string option) -> ?argv:string array -> + 'a t * info -> ('a t * info) list -> 'a result + [@@ocaml.deprecated "Use Cmd.group and one of Cmd.eval* instead."] + (** [eval_choice help err catch argv (t,i) choices] is like {!eval} except that if the first argument on the command line is not an option name it will look in [choices] for a term whose information has this name and evaluate it. @@ -210,10 +415,10 @@ module Term : sig is unspecified the "main" term [t] is evaluated. [i] defines the name and man page of the program. *) - val eval_peek_opts : ?version_opt:bool -> - ?env:(string -> string option) -> - ?argv:string array -> 'a t -> - 'a option * 'a result + val eval_peek_opts : + ?version_opt:bool -> ?env:(string -> string option) -> + ?argv:string array -> 'a t -> 'a option * 'a result + [@@ocaml.deprecated "Use Cmd.eval_peek_opts instead."] (** [eval_peek_opts version_opt argv t] evaluates [t], a term made of optional arguments only, with the command line [argv] (defaults to {!Sys.argv}). In this evaluation, unknown optional @@ -236,6 +441,363 @@ module Term : sig contrasts to {!eval} and {!eval_choice} no side effects like error reporting or help output occurs. + {b Note.} Positional arguments can't be peeked without the full + specification of the command line: we can't tell apart a + positional argument from the value of an unknown optional + argument. *) + + (** {2:exits Turning evaluation results into exit codes} + + {b Note.} If you are using the following functions to handle + the evaluation result of a term you should add {!default_exits} to + the term's information {{!val-info}[~exits]} argument. + + {b WARNING.} You should avoid status codes strictly greater than 125 + as those may be used by + {{:https://www.gnu.org/software/bash/manual/html_node/Exit-Status.html} + some} shells. *) + + val exit_status_success : int + [@@ocaml.deprecated "Use Cmd.Exit.ok instead."] + (** [exit_status_success] is 0, the exit status for success. *) + + val exit_status_cli_error : int + [@@ocaml.deprecated "Use Cmd.Exit.cli_error instead."] + (** [exit_status_cli_error] is 124, an exit status for command line + parsing errors. *) + + val exit_status_internal_error : int + [@@ocaml.deprecated "Use Cmd.Exit.internal_error instead."] + (** [exit_status_internal_error] is 125, an exit status for unexpected + internal errors. *) + + val exit_status_of_result : ?term_err:int -> unit result -> int + [@@ocaml.deprecated "Use Cmd.eval instead."] + (** [exit_status_of_result ~term_err r] is an [exit(3)] status + code determined from [r] as follows: + {ul + {- {!exit_status_success} if [r] is one of [`Ok ()], [`Version], [`Help]} + {- [term_err] if [r] is [`Error `Term], [term_err] defaults to [1].} + {- {!exit_status_cli_error} if [r] is [`Error `Parse]} + {- {!exit_status_internal_error} if [r] is [`Error `Exn]}} *) + + val exit_status_of_status_result : ?term_err:int -> int result -> int + [@@ocaml.deprecated "Use Cmd.eval' instead."] + (** [exit_status_of_status_result] is like {!exit_status_of_result} + except for [`Ok n] where [n] is used as the status exit code. *) + + val exit : ?term_err:int -> unit result -> unit + [@@ocaml.deprecated "Use Stdlib.exit and Cmd.eval instead."] + (** [exit ~term_err r] is + [Stdlib.exit @@ exit_status_of_result ~term_err r] *) + + val exit_status : ?term_err:int -> int result -> unit + [@@ocaml.deprecated "Use Stdlib.exit and Cmd.eval' instead."] + (** [exit_status ~term_err r] is + [Stdlib.exit @@ exit_status_of_status_result ~term_err r] *) + + (**/**) + val pure : 'a -> 'a t + [@@ocaml.deprecated "Use Term.const instead."] + (** @deprecated use {!const} instead. *) + + val man_format : Manpage.format t + [@@ocaml.deprecated "Use Arg.man_format instead."] + (** @deprecated Use {!Arg.man_format} instead. *) + (**/**) +end + +(** Commands. + + Command line syntaxes are implicitely defined by {!Term}s. A command + value binds a syntax and its documentation to a command name. + + A command can group a list of sub commands (and recursively). In this + case your tool defines a tree of commands, each with its own command + line syntax. The root of that tree is called the {e main command}; + it represents your tool and its name. *) +module Cmd : sig + + (** {1:info Command information} + + Command information defines the name and documentation of a command. *) + + (** Exit codes and their information. *) + module Exit : sig + + (** {1:codes Exit codes} *) + + type code = int + (** The type for exit codes. + + {b Warning.} You should avoid status codes strictly greater than 125 + as those may be used by + {{:https://www.gnu.org/software/bash/manual/html_node/Exit-Status.html} + some} shells. *) + + val ok : code + (** [ok] is [0], the exit status for success. *) + + val some_error : code + (** [some_error] is [123], an exit status for indisciminate errors + reported on stderr. *) + + val cli_error : code + (** [cli_error] is [124], an exit status for command line parsing + errors. *) + + val internal_error : code + (** [internal_error] is [125], an exit status for unexpected internal + errors. *) + + (** {1:info Exit code information} *) + + type info + (** The type for exit code information. *) + + val info : ?docs:string -> ?doc:string -> ?max:code -> code -> info + (** [exit_info ~docs ~doc min ~max] describe the range of exit + statuses from [min] to [max] (defaults to [min]). [doc] is the + man page information for the statuses, defaults to ["undocumented"]. + [docs] is the title of the man page section in which the statuses + will be listed, it defaults to {!Manpage.s_exit_status}. + + In [doc] the {{!page-tool_man.doclang}documentation markup language} + can be used with following variables: + {ul + {- [$(status)], the value of [min].} + {- [$(status_max)], the value of [max].} + {- The variables mentioned in the {!Cmd.val-info}}} *) + + val info_code : info -> code + (** [info_code i] is the minimal code of [i]. *) + + val defaults : info list + (** [defaults] are exit code information for {!ok}, {!some_error} + {!cli_error} and {!internal_error}. *) + end + + (** Environment variable and their information. *) + module Env : sig + + (** {1:envvars Environment variables} *) + + type var = string + (** The type for environment names. *) + + (** {1:info Environment variable information} *) + + [@@@alert "-deprecated"] + type info = Term.env_info (* because of Arg. *) + (** The type for environment variable information. *) + [@@@alert "+deprecated"] + + val info : ?deprecated:string -> ?docs:string -> ?doc:string -> var -> info + (** [info ~docs ~doc var] describes an environment variable + [var] such that: + {ul + {- [doc] is the man page information of the environment + variable, defaults to ["undocumented"].} + {- [docs] is the title of the man page section in which the environment + variable will be listed, it defaults to + {!Cmdliner.Manpage.s_environment}.} + {- [deprecated], if specified the environment is deprecated and the + string is a message output on standard error when the environment + variable gets used to lookup the default value of an argument.}} + In [doc] the {{!page-tool_man.doclang}documentation markup language} + can be used with following variables: + {ul + {- [$(env)], the value of [var].} + {- The variables mentioned in {!val-info}.}} *) + end + + type info + (** The type for information about commands. *) + + val info : + ?deprecated:string -> ?man_xrefs:Manpage.xref list -> + ?man:Manpage.block list -> ?envs:Env.info list -> ?exits:Exit.info list -> + ?sdocs:string -> ?docs:string -> ?doc:string -> ?version:string -> + string -> info + (** [info ?sdocs ?man ?docs ?doc ?version name] is a term information + such that: + {ul + {- [name] is the name of the command.} + {- [version] is the version string of the command line tool, this + is only relevant for the main command and ignored otherwise.} + {- [deprecated], if specified the command is deprecated and the + string is a message output on standard error when the command + is used.} + {- [doc] is a one line description of the command used + for the [NAME] section of the command's man page and in command + group listings.} + {- [docs], for commands that are part of a group, the title of the + section of the parent's command man page where it should be listed + (defaults to {!Manpage.s_commands}).} + {- [sdocs] defines the title of the section in which the + standard [--help] and [--version] arguments are listed + (defaults to {!Manpage.s_common_options}).} + {- [exits] is a list of exit statuses that the command evaluation + may produce, defaults to {!Exit.defaults}.} + {- [envs] is a list of environment variables that influence + the command's evaluation.} + {- [man] is the text of the man page for the command.} + {- [man_xrefs] are cross-references to other manual pages. These + are used to generate a {!Manpage.s_see_also} section.}} + + [doc], [man], [envs] support the {{!page-tool_man.doclang}documentation + markup language} in which the following variables are recognized: + {ul + {- [$(tname)] the (term's) command's name.} + {- [$(mname)] the main command name.} + {- [$(iname)] the command invocation from main command to the + command name.}} + *) + + (** {1:cmds Commands} *) + + type 'a t + (** The type for commands whose evaluation result in a value of + type ['a]. *) + + val v : info -> 'a Term.t -> 'a t + (** [v i t] is a command with information [i] and command line syntax + parsed by [t]. *) + + val group : ?default:'a Term.t -> info -> 'a t list -> 'a t + (** [group i ?default cmds] is a command with information [i] that + groups sub commands [cmds]. [default] is the command line syntax + to parse if no sub command is specified on the command line. If + [default] is [None] (default), the tool errors when no sub + command is specified. *) + + val name : 'a t -> string + (** [name c] is the name of [c]. *) + + (** {1:eval Evaluation} + + These functions are meant to be composed with {!Stdlib.exit}. + The following exit codes may be returned by all these functions: + {ul + {- {!Exit.cli_error} if a parse error occurs.} + {- {!Exit.internal_error} if the [~catch] argument is [true] (default) + and an uncaught exception is raised.} + {- The value of [~term_err] (defaults to {!Exit.cli_error}) if + a term error occurs.}} + + These exit codes are described in {!Exit.defaults} which is the + default value of the [?exits] argument of function {!val-info}. *) + + val eval : + ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> + ?env:(string -> string option) -> ?argv:string array -> + ?term_err:Exit.code -> unit t -> Exit.code + (** [eval cmd] is {!Exit.ok} if [cmd] evaluates to [()]. + See {!eval_value} for other arguments. *) + + val eval' : + ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> + ?env:(string -> string option) -> ?argv:string array -> + ?term_err:Exit.code -> Exit.code t -> Exit.code + (** [eval' cmd] is [c] if [cmd] evaluates to the exit code [c]. + See {!eval_value} for other arguments. *) + + val eval_result : + ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> + ?env:(string -> string option) -> ?argv:string array -> + ?term_err:Exit.code -> (unit, string) result t -> Exit.code + (** [eval_result cmd] is: + {ul + {- {!Exit.ok} if [cmd] evaluates to [Ok ()].} + {- {!Exit.some_error} if [cmd] evaluates to [Error msg]. In this + case [msg] is printed on [err].}} + See {!eval_value} for other arguments. *) + + val eval_result' : + ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> + ?env:(string -> string option) -> ?argv:string array -> + ?term_err:Exit.code -> (Exit.code, string) result t -> Exit.code + (** [eval_result' cmd] is: + {ul + {- [c] if [cmd] evaluates to [Ok c].} + {- {!Exit.some_error} if [cmd] evaluates to [Error msg]. In this + case [msg] is printed on [err].}} + See {!eval_value} for other arguments. *) + + (** {2:eval_low Low level evaluation} + + This interface gives more information on command evaluation results + and lets you choose how to map evaluation results to exit codes. *) + + type 'a eval_ok = + [ `Ok of 'a (** The term of the command evaluated to this value. *) + | `Version (** The version of the main cmd was requested. *) + | `Help (** Help was requested. *) ] + (** The type for successful evaluation results. *) + + type eval_error = + [ `Parse (** A parse error occurred. *) + | `Term (** A term evaluation error occurred. *) + | `Exn (** An uncaught exception occurred. *) ] + (** The type for erroring evaluation results. *) + + type 'a eval_exit = + [ `Ok of 'a (** The term of the command evaluated to this value. *) + | `Exit of Exit.code (** The evaluation wants to exit with this code. *) ] + + val eval_value : + ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> + ?env:(string -> string option) -> ?argv:string array -> 'a t -> + ('a eval_ok, eval_error) result + (** [eval ~help ~err ~catch ~env ~argv cmd] is the evaluation result + of [cmd] with: + {ul + {- [argv] the command line arguments to parse (defaults to {!Sys.argv})} + {- [env] the function used for environment variable lookup (defaults + to {!Sys.getenv}).} + {- [catch] if [true] (default) uncaught exceptions + are intercepted and their stack trace is written to the [err] + formatter} + {- [help] is the formatter used to print help or version messages + (defaults to {!Format.std_formatter})} + {- [err] is the formatter used to print error messages + (defaults to {!Format.err_formatter}).}} *) + + val eval_value' : + ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> + ?env:(string -> string option) -> ?argv:string array -> ?term_err:int -> + 'a t -> 'a eval_exit + (** [eval_value'] is like {!eval_value}, but if the command term + does not evaluate, returns an exit code like the + {{!eval}evaluation} function do (which can be {!Exit.ok} in case + help or version was requested). *) + + val eval_peek_opts : + ?version_opt:bool -> ?env:(string -> string option) -> + ?argv:string array -> 'a Term.t -> + 'a option * ('a eval_ok, eval_error) result + (** [eval_peek_opts version_opt argv t] evaluates [t], a term made + of optional arguments only, with the command line [argv] + (defaults to {!Sys.argv}). In this evaluation, unknown optional + arguments and positional arguments are ignored. + + The evaluation returns a pair. The first component is + the result of parsing the command line [argv] stripped from + any help and version option if [version_opt] is [true] (defaults + to [false]). It results in: + {ul + {- [Some _] if the command line would be parsed correctly given the + {e partial} knowledge in [t].} + {- [None] if a parse error would occur on the options of [t]}} + + The second component is the result of parsing the command line + [argv] without stripping the help and version options. It + indicates what the evaluation would result in on [argv] given + the partial knowledge in [t] (for example it would return + [`Help] if there's a help option in [argv]). However in + contrasts to {!val-eval_value} no side effects like error + reporting or help output occurs. + {b Note.} Positional arguments can't be peeked without the full specification of the command line: we can't tell apart a positional argument from the value of an unknown optional @@ -248,8 +810,8 @@ end to the arguments provided on the command line. Basic constraints, like the argument type or repeatability, are - specified by defining a value of type {!t}. Further contraints can - be specified during the {{!argterms}conversion} to a term. *) + specified by defining a value of type {!Arg.t}. Further constraints can + be specified during the {{!Arg.argterms}conversion} to a term. *) module Arg : sig (** {1:argconv Argument converters} @@ -259,19 +821,66 @@ module Arg : sig are provided for many types of the standard library. *) type 'a parser = string -> [ `Ok of 'a | `Error of string ] - (** The type for argument parsers. *) + [@@ocaml.deprecated "Use Arg.conv or Arg.conv' instead."] + (** The type for argument parsers. + + {b Deprecated.} Use parser signatures of {!val-conv} or {!val-conv'}. *) type 'a printer = Format.formatter -> 'a -> unit (** The type for converted argument printers. *) - type 'a converter = 'a parser * 'a printer - (** The type for argument converters. *) - - val some : ?none:string -> 'a converter -> 'a option converter - (** [some none c] is like the converter [c] except it returns - [Some] value. It is used for command line arguments - that default to [None] when absent. [none] is what to print to - document the absence (defaults to [""]). *) + [@@@alert "-deprecated"] (* Need to be able to mention them ! *) + type 'a conv = 'a parser * 'a printer + (** The type for argument converters. + + {b Warning.} Do not use directly, use {!val-conv} or {!val-conv'}. + This type will become abstract in the next major version of cmdliner. *) + [@@@alert "+deprecated"] (* Need to be able to mention them ! *) + + val conv : + ?docv:string -> (string -> ('a, [`Msg of string]) result) * 'a printer -> + 'a conv + (** [conv ~docv (parse, print)] is an argument converter + parsing values with [parse] and printing them with + [print]. [docv] is a documentation meta-variable used in the + documentation to stand for the argument value, defaults to + ["VALUE"]. *) + + val conv' : + ?docv:string -> (string -> ('a, string) result) * 'a printer -> + 'a conv + (** [conv'] is like {!val-conv} but the [Error] case has an unlabelled + string. *) + + val conv_parser : 'a conv -> (string -> ('a, [`Msg of string]) result) + (** [conv_parser c] is the parser of [c]. *) + + val conv_printer : 'a conv -> 'a printer + (** [conv_printer c] is the printer of [c]. *) + + val conv_docv : 'a conv -> string + (** [conv_docv c] is [c]'s documentation meta-variable. + + {b Warning.} Currently always returns ["VALUE"] in the future + will return the value given to {!val-conv} or {!val-conv'}. *) + + val parser_of_kind_of_string : + kind:string -> (string -> 'a option) -> + (string -> ('a, [`Msg of string]) result) + (** [parser_of_kind_of_string ~kind kind_of_string] is an argument + parser using the [kind_of_string] function for parsing and [kind] + to report errors (e.g. could be ["an integer"] for an [int] parser.). *) + + val some' : ?none:'a -> 'a conv -> 'a option conv + (** [some' ?none c] is like the converter [c] except it returns + [Some] value. It is used for command line arguments that default + to [None] when absent. If provided, [none] is used with [conv]'s + printer to document the value taken on absence; to document + a more complex behaviour use the [absent] argument of {!val-info}. *) + + val some : ?none:string -> 'a conv -> 'a option conv + (** [some ?none c] is like [some'] but [none] is described as a + string that will be rendered in bold. *) (** {1:arginfo Arguments and their information} @@ -281,53 +890,51 @@ module Arg : sig if the argument is absent from the command line and the variable is defined. *) - type env - (** The type for environment variables and their documentation. *) - - val env_var : ?docs:string -> ?doc:string -> string -> env - (** [env_var docs doc var] is an environment variables [var]. [doc] - is the man page information of the environment variable; the - variables mentioned in {!info} can be used in this documentation - string. [doc] defaults to ["See option $(opt)."]. [docs] is the - title of the man page section in which the environment variable - will be listed, it defaults to ["ENVIRONMENT VARIABLES"]. *) - type 'a t (** The type for arguments holding data of type ['a]. *) type info (** The type for information about command line arguments. *) - val info : ?docs:string -> ?docv:string -> ?doc:string -> ?env:env -> - string list -> info + val info : + ?deprecated:string -> ?absent:string -> ?docs:string -> ?docv:string -> + ?doc:string -> ?env:Cmd.Env.info -> string list -> info (** [info docs docv doc env names] defines information for an argument. - - [names] defines the names under which an optional argument - can be referred to. Strings of length [1] (["c"]) define short - option names (["-c"]), longer strings (["count"]) define long - option names (["--count"]). [names] must be empty for positional - arguments. - - [env] defines the name of an environment variable which is - looked up for defining the argument if it is absent from the - command line. See {{!envlookup}environment variables} for - details. {ul - {- [doc] is the man page information of the argument. The - variable ["$(docv)"] can be used to refer to the value of - [docv] (see below). The variable ["$(opt)"] will refer to a - long option of [names] or a short one if there is no long - option. The variable ["$(env)"] will refer to the environment - variable specified by [env] (if any). {{!doc_helpers}These - functions} can help with formatting argument values.} + {- [names] defines the names under which an optional argument + can be referred to. Strings of length [1] (["c"]) define + short option names (["-c"]), longer strings (["count"]) + define long option names (["--count"]). [names] must be empty + for positional arguments.} + {- [env] defines the name of an environment variable which is + looked up for defining the argument if it is absent from the + command line. See {{!page-cli.envlookup}environment variables} for + details.} + {- [doc] is the man page information of the argument. + The {{!page-tool_man.doclang}documentation language} can be used and + the following variables are recognized: + {ul + {- ["$(docv)"] the value of [docv] (see below).} + {- ["$(opt)"], one of the options of [names], preference + is given to a long one.} + {- ["$(env)"], the environment var specified by [env] (if any).}} + {{!doc_helpers}These functions} can help with formatting argument + values.} {- [docv] is for positional and non-flag optional arguments. It is a variable name used in the man page to stand for their value.} {- [docs] is the title of the man page section in which the argument will be listed. For optional arguments this defaults - to ["OPTIONS"]. For positional arguments this defaults - to ["ARGUMENTS"]. However a positional argument is only listed - if it has both a [doc] and [docv] specified.}} *) + to {!Manpage.s_options}. For positional arguments this defaults + to {!Manpage.s_arguments}. However a positional argument is only + listed if it has both a [doc] and [docv] specified.} + {- [deprecated], if specified the argument is deprecated and the + string is a message output on standard error when the argument + is used.} + {- [absent], if specified a documentation string that indicates + what happens when the argument is absent. The document language + can be used like in [doc]. This overrides the automatic default + value rendering that is performed by the combinators.}} *) val ( & ) : ('a -> 'b) -> 'a -> 'b (** [f & v] is [f v], a right associative composition operator for @@ -347,11 +954,11 @@ module Arg : sig val flag_all : info -> bool list t (** [flag_all] is like {!flag} except the flag may appear more than once. The argument holds a list that contains one [true] value per - occurence of the flag. It holds the empty list if the flag + occurrence of the flag. It holds the empty list if the flag is absent from the command line. *) val vflag : 'a -> ('a * info) list -> 'a t - (** [vflag v \[v]{_0}[,i]{_0}[;...\]] is an ['a] argument defined + (** [vflag v \[v]{_0}[,i]{_0}[;…\]] is an ['a] argument defined by an optional flag that may appear {e at most} once on the command line under one of the names specified in the [i]{_k} values. The argument holds [v] if the flag is absent from the @@ -365,13 +972,13 @@ module Arg : sig (** [vflag_all v l] is like {!vflag} except the flag may appear more than once. The argument holds the list [v] if the flag is absent from the command line. Otherwise it holds a list that contains one - corresponding value per occurence of the flag, in the order found on + corresponding value per occurrence of the flag, in the order found on the command line. {b Note.} Environment variable lookup is unsupported for for these arguments. *) - val opt : ?vopt:'a -> 'a converter -> 'a -> info -> 'a t + val opt : ?vopt:'a -> 'a conv -> 'a -> info -> 'a t (** [opt vopt c v i] is an ['a] argument defined by the value of an optional argument that may appear {e at most} once on the command line under one of the names specified by [i]. The argument holds @@ -381,19 +988,26 @@ module Arg : sig If [vopt] is provided the value of the optional argument is itself optional, taking the value [vopt] if unspecified on the command line. *) - val opt_all : ?vopt:'a -> 'a converter -> 'a list -> info -> 'a list t + val opt_all : ?vopt:'a -> 'a conv -> 'a list -> info -> 'a list t (** [opt_all vopt c v i] is like {!opt} except the optional argument may appear more than once. The argument holds a list that contains one value - per occurence of the flag in the order found on the command line. + per occurrence of the flag in the order found on the command line. It holds the list [v] if the flag is absent from the command line. *) (** {1:posargs Positional arguments} The information of a positional argument must have no name or [Invalid_argument] is raised. Positional arguments indexing - is zero-based. *) + is zero-based. - val pos : ?rev:bool -> int -> 'a converter -> 'a -> info -> 'a t + {b Warning.} The following combinators allow to specify and + extract a given positional argument with more than one term. + This should not be done as it will likely confuse end users and + documentation generation. These over-specifications may be + prevented by raising [Invalid_argument] in the future. But for now + it is the client's duty to make sure this doesn't happen. *) + + val pos : ?rev:bool -> int -> 'a conv -> 'a -> info -> 'a t (** [pos rev n c v i] is an ['a] argument defined by the [n]th positional argument of the command line as converted by [c]. If the positional argument is absent from the command line @@ -403,13 +1017,13 @@ module Arg : sig position is [max-n] where [max] is the position of the last positional argument present on the command line. *) - val pos_all : 'a converter -> 'a list -> info -> 'a list t + val pos_all : 'a conv -> 'a list -> info -> 'a list t (** [pos_all c v i] is an ['a list] argument that holds all the positional arguments of the command line as converted by [c] or [v] if there are none. *) - val pos_left : ?rev:bool -> int -> 'a converter -> 'a list -> info -> - 'a list t + val pos_left : + ?rev:bool -> int -> 'a conv -> 'a list -> info -> 'a list t (** [pos_left rev n c v i] is an ['a list] argument that holds all the positional arguments as converted by [c] found on the left of the [n]th positional argument or [v] if there are none. @@ -418,8 +1032,8 @@ module Arg : sig position is [max-n] where [max] is the position of the last positional argument present on the command line. *) - val pos_right : ?rev:bool -> int -> 'a converter -> 'a list -> info -> - 'a list t + val pos_right : + ?rev:bool -> int -> 'a conv -> 'a list -> info -> 'a list t (** [pos_right] is like {!pos_left} except it holds all the positional arguments found on the right of the specified positional argument. *) @@ -443,81 +1057,87 @@ module Arg : sig val last : 'a list t -> 'a Term.t (** [last a] is a term that fails if [a]'s list is empty and evaluates to the value of the last element of the list otherwise. Use this - for lists of flags or options where the last occurence takes precedence + for lists of flags or options where the last occurrence takes precedence over the others. *) + (** {1:predef Predefined arguments} *) + + val man_format : Manpage.format Term.t + (** [man_format] is a term that defines a [--man-format] option and + evaluates to a value that can be used with {!Manpage.print}. *) + (** {1:converters Predefined converters} *) - val bool : bool converter + val bool : bool conv (** [bool] converts values with {!bool_of_string}. *) - val char : char converter + val char : char conv (** [char] converts values by ensuring the argument has a single char. *) - val int : int converter + val int : int conv (** [int] converts values with {!int_of_string}. *) - val nativeint : nativeint converter + val nativeint : nativeint conv (** [nativeint] converts values with {!Nativeint.of_string}. *) - val int32 : int32 converter + val int32 : int32 conv (** [int32] converts values with {!Int32.of_string}. *) - val int64 : int64 converter + val int64 : int64 conv (** [int64] converts values with {!Int64.of_string}. *) - val float : float converter + val float : float conv (** [float] converts values with {!float_of_string}. *) - val string : string converter + val string : string conv (** [string] converts values with the identity function. *) - val enum : (string * 'a) list -> 'a converter + val enum : (string * 'a) list -> 'a conv (** [enum l p] converts values such that unambiguous prefixes of string names in [l] map to the corresponding value of type ['a]. - {b Warning.} The type ['a] must be comparable with {!Pervasives.compare}. + {b Warning.} The type ['a] must be comparable with {!Stdlib.compare}. @raise Invalid_argument if [l] is empty. *) - val file : string converter + val file : string conv (** [file] converts a value with the identity function and checks with {!Sys.file_exists} that a file with that name exists. *) - val dir : string converter + val dir : string conv (** [dir] converts a value with the identity function and checks with {!Sys.file_exists} and {!Sys.is_directory} that a directory with that name exists. *) - val non_dir_file : string converter + val non_dir_file : string conv (** [non_dir_file] converts a value with the identity function and checks with {!Sys.file_exists} and {!Sys.is_directory} that a non directory file with that name exists. *) - val list : ?sep:char -> 'a converter -> 'a list converter + val list : ?sep:char -> 'a conv -> 'a list conv (** [list sep c] splits the argument at each [sep] (defaults to [',']) character and converts each substrings with [c]. *) - val array : ?sep:char -> 'a converter -> 'a array converter + val array : ?sep:char -> 'a conv -> 'a array conv (** [array sep c] splits the argument at each [sep] (defaults to [',']) character and converts each substring with [c]. *) - val pair : ?sep:char -> 'a converter -> 'b converter -> ('a * 'b) converter + val pair : ?sep:char -> 'a conv -> 'b conv -> ('a * 'b) conv (** [pair sep c0 c1] splits the argument at the {e first} [sep] character (defaults to [',']) and respectively converts the substrings with [c0] and [c1]. *) - val t2 : ?sep:char -> 'a converter -> 'b converter -> ('a * 'b) converter + val t2 : ?sep:char -> 'a conv -> 'b conv -> ('a * 'b) conv (** {!t2} is {!pair}. *) - val t3 : ?sep:char -> 'a converter ->'b converter -> 'c converter -> - ('a * 'b * 'c) converter + val t3 : ?sep:char -> 'a conv ->'b conv -> 'c conv -> ('a * 'b * 'c) conv (** [t3 sep c0 c1 c2] splits the argument at the {e first} two [sep] characters (defaults to [',']) and respectively converts the substrings with [c0], [c1] and [c2]. *) - val t4 : ?sep:char -> 'a converter ->'b converter -> 'c converter -> - 'd converter -> ('a * 'b * 'c * 'd) converter + val t4 : + ?sep:char -> 'a conv -> 'b conv -> 'c conv -> 'd conv -> + ('a * 'b * 'c * 'd) conv (** [t4 sep c0 c1 c2 c3] splits the argument at the {e first} three [sep] characters (defaults to [',']) respectively converts the substrings with [c0], [c1], [c2] and [c3]. *) @@ -528,717 +1148,43 @@ module Arg : sig (** [doc_quote s] quotes the string [s]. *) val doc_alts : ?quoted:bool -> string list -> string - (** [doc_alts alts] documents the alternative tokens [alts] according - the number of alternatives. If [quoted] is [true] (default) - the tokens are quoted. The resulting string can be used in - sentences of the form ["$(docv) must be %s"]. + (** [doc_alts alts] documents the alternative tokens [alts] + according the number of alternatives. If [quoted] is: + {ul + {- [None], the tokens are enclosed in manpage markup directives + to render them in bold (manpage convention).} + {- [Some true], the tokens are quoted with {!doc_quote}.} + {- [Some false], the tokens are written as is}} + The resulting string can be used in sentences of + the form ["$(docv) must be %s"]. - @raise Invalid_argument if [alts] is the empty string. *) + @raise Invalid_argument if [alts] is the empty list. *) val doc_alts_enum : ?quoted:bool -> (string * 'a) list -> string (** [doc_alts_enum quoted alts] is [doc_alts quoted (List.map fst alts)]. *) -end -(** - {1:basics Basics} - - With [Cmdliner] your program evaluates a term. A {e term} - is a value of type {!Term.t}. The type parameter indicates - the type of the result of the evaluation. - - One way to create terms is by lifting regular OCaml values with - {!Term.const}. Terms can be applied to terms evaluating to - functional values with {!Term.( $ )}. For example for the function: -{[let revolt () = print_endline "Revolt!"]} - the term : -{[ -open Cmdliner;; - -let revolt_t = Term.(const revolt $ const ())]} - is a term that evaluates to the result (and effect) of the [revolt] - function. - Terms are evaluated with {!Term.eval}: -{[let () = match Term.eval (revolt_t, Term.info "revolt") with -| `Error _ -> exit 1 | _ -> exit 0]} - This defines a command line program named ["revolt"], without command line - arguments arguments, that just prints ["Revolt!"] on [stdout]. -{[> ./revolt -Revolt!]} - The combinators in the {!Arg} module allow to extract command - line argument data as terms. These terms can then be applied to - lifted OCaml functions to be evaluated by the program. - - Terms corresponding to command line argument data that are part of - a term evaluation implicitly define a command line syntax. We - show this on an concrete example. - - Consider the [chorus] function that prints repeatedly a - given message : -{[let chorus count msg = - for i = 1 to count do print_endline msg done]} - we want to make it available from the command line - with the synopsis: -{[chorus [-c COUNT | --count=COUNT] [MSG]]} - where [COUNT] defaults to [10] and [MSG] defaults to ["Revolt!"]. - We first define a term corresponding to the [--count] - option: -{[ -let count = - let doc = "Repeat the message $(docv) times." in - Arg.(value & opt int 10 & info ["c"; "count"] ~docv:"COUNT" ~doc) -]} - This says that [count] is a term that evaluates to the - value of an optional argument of type [int] that - defaults to [10] if unspecified and whose option name is - either [-c] or [--count]. The arguments [doc] and [docv] are used to - generate the option's man page information. - - The term for the positional argument [MSG] is: -{[ -let msg = - let doc = "Overrides the default message to print." - let env = Arg.env "CHORUS_MSG" ~doc in - let doc = "The message to print." in - Arg.(value & pos 0 string "Revolt!" & info [] ~env ~docv:"MSG" ~doc) -]} - which says that [msg] is a term whose value is the positional - argument at index [0] of type [string] and defaults to ["Revolt!"] - or the value of the environment variable [CHORUS_MSG] if the - argument is unspecified on the command line. Here again [doc] and - [docv] are used for the man page information. - - The term for executing [chorus] with these command line arguments - is : -{[ -let chorus_t = Term.(const chorus $ count $ msg) -]} - and we are now ready to define our program: -{[ -let info = - let doc = "print a customizable message repeatedly" in - let man = [ `S "BUGS"; `P "Email bug reports to .";] in - Term.info "chorus" ~version:"1.6.1" ~doc ~man - -let () = match Term.eval (chorus_t, info) with `Error _ -> exit 1 | _ -> exit 0 -]} - The [info] value created with {!Term.info} gives more information - about the term we execute and is used to generate the program's - man page. Since we provided a [~version] string, the program will - automatically respond to the [--version] option by printing this - string. - - A program using {!Term.eval} always responds to the - [--help] option by showing the man page about the program generated - using the information you provided with {!Term.info} and {!Arg.info}. - Here is the output generated by our example : -{v > ./chorus --help -NAME - chorus - print a customizable message repeatedly - -SYNOPSIS - chorus [OPTION]... [MSG] - -ARGUMENTS - MSG (absent=Revolt! or CHORUS_MSG env) - The message to print. - -OPTIONS - -c COUNT, --count=COUNT (absent=10) - Repeat the message COUNT times. - - --help[=FMT] (default=pager) - Show this help in format FMT (pager, plain or groff). - - --version - Show version information. - -BUGS - Email bug reports to . -v} - - If a pager is available, this output is written to a pager. - This help is also available in plain text or in the - {{:http://www.gnu.org/software/groff/groff.html}groff} man page format by - invoking the program with the option [--help=plain] or [--help=groff]. - - For examples of more complex command line definitions look and - run the {{!examples}examples}. - - {2:multiterms Multiple terms} - - [Cmdliner] also provides support for programs like [darcs] or - [git] that have multiple commands each with their own syntax: - {[prog COMMAND [OPTION]... ARG...]} - A command is defined by coupling a term with - {{!Term.tinfo}term information}. The term information defines the - command name and its man page. Given a list of commands the function - {!Term.eval_choice} will execute the term corresponding to the - [COMMAND] argument or or a specific "main" term if there is - no [COMMAND] argument. - - {2:manual Manual} - - Man page sections are printed in the order specified by - {!Term.info}. The man page information of an argument is listed in - alphabetical order at the end of the text of the section specified - by its {{!Arg.info}argument information}. Positional arguments are - also listed iff both the [docv] and [doc] string is specified in - their argument information. - - If an argument information mentions a section not specified in - {!Term.info}, an empty section is created for it. This section is - inserted just after the ["SYNOPSIS"] section or after a section - named ["DESCRIPTION"] if there is one. - - The ["SYNOPSIS"] section of a man page is generated automatically - from a term's information and its arguments. To substitute your - own instead, start the term's information man page with - a ["SYNOPSIS"] section. - - Ideally all manual strings should be UTF-8 encoded. However at the - moment Groff (at least [1.19.2]) doesn't seem to cope with UTF-8 - input and UTF-8 characters beyond the ASCII set will look garbled. - Regarding UTF-8 output, generating the man page with [-Tutf8] maps - the hyphen-minus [U+002D] to the minus sign [U+2212] which makes it - difficult to search it in the pager, so [-Tascii] is used for now. - Conclusion is that it may be better to stick to the ASCII set for now. - Please contact the author if something seems wrong in this reasoning - or if you know a work around this. - - {2:misc Miscellaneous} - - {ul - {- The option name [--help], (and [--version] if you specify a - version string) is reserved by the module. Using it as a term or - option name may result in undefined behaviour.} - {- The evaluation of a term in which the same option name is defined - by more than one argument is undefined.}} - - {1:cmdline Command line syntax} - - For programs evaluating a single term the most general form of invocation - is: - {ul{- [prog [OPTION]... [ARG]...]}} - The program automatically reponds to the [--help] option by - printing the help. If a version string is provided in - the {{!Term.tinfo}term information}, it also automatically responds - to the [--version] option by printing this string. - - Command line arguments are either {{!optargs}{e optional}} or - {{!posargs}{e positional}}. Both can be freely interleaved but - since [Cmdliner] accepts many optional forms this may result in - ambiguities. The special {{!posargs} token [--]} can be used to resolve - them. - - Programs evaluating multiple terms also add this form of invocation: - {ul{- [prog COMMAND [OPTION]... [ARG]...]}} - Commands automatically respond to the [--help] option - by printing their help. The [COMMAND] string must - be the first string following the program name and may be specified - by a prefix as long as it is not ambiguous. - - {2:optargs Optional arguments} - - An optional argument is specified on the command line by a {e - name} possibly followed by a {e value}. - - The name of an option can be short or long. - {ul - {- A {e short} name is a dash followed by a single alphanumeric - character: ["-h"], ["-q"], ["-I"].} - {- A {e long} name is two dashes followed by alphanumeric - characters and dashes: ["--help"], ["--silent"], ["--ignore-case"].}} - - More than one name may refer to the same optional argument. For - example in a given program the names ["-q"], ["--quiet"] and - ["--silent"] may all stand for the same boolean argument - indicating the program to be quiet. Long names - can be specified by any non ambiguous prefix. - - The value of an option can be specified in three different ways. - {ul - {- As the next token on the command line: ["-o a.out"], - ["--output a.out"].} - {- Glued to a short name: ["-oa.out"].} - {- Glued to a long name after an equal character: - ["--output=a.out"].}} - Glued forms are especially useful if - the value itself starts with a dash as is the case for negative numbers, - ["--min=-10"]. - - An optional argument without a value is either a {e flag} - (see {!Arg.flag}, {!Arg.vflag}) or an optional argument with an optional - value (see the [~vopt] argument of {!Arg.opt}). - - Short flags can be grouped together to share a single dash and the group - can end with a short option. For example assuming ["-v"] and ["-x"] - are flags and ["-f"] is a short option: - {ul - {- ["-vx"] will be parsed as ["-v -x"].} - {- ["-vxfopt"] will be parsed as ["-v -x -fopt"].} - {- ["-vxf opt"] will be parsed as ["-v -x -fopt"].} - {- ["-fvx"] will be parsed as ["-f=vx"].}} - - {2:posargs Positional arguments} - - Positional arguments are tokens on the command line that are not - option names and are not the value of an optional argument. They - are numbered from left to right starting with zero. - - Since positional arguments may be mistaken as the optional value - of an optional argument or they may need to look like option - names, anything that follows the special token ["--"] on the command - line is considered to be a positional argument. - - {2:envlookup Environment variables} - - Non-required command line arguments can be backed up by an environment - variable. If the argument is absent from the command line and - that the environment variable is defined, its value is parsed - using the argument converter and defines the value of the - argument. - - For {!Arg.flag} and {!Arg.flag_all} that do not have an argument - converter a boolean is parsed from the lowercased variable value - as follows: - {ul - {- [""], ["false"], ["no"], ["n"] or ["0"] is [false].} - {- ["true"], ["yes"], ["y"] or ["1"] is [true].} - {- Any other string is an error.}} - - Note that environment variables are not supported for {!Arg.vflag} - and {!Arg.vflag_all}. - - {1:examples Examples} - - These examples are in the [test] directory of the distribution. - - {2:exrm A [rm] command} - - We define the command line interface of a - [rm] command with the synopsis: -{[ -rm [OPTION]... FILE... -]} - The [-f], [-i] and [-I] flags define the prompt behaviour of [rm], - represented in our program by the [prompt] type. If more than one - of these flags is present on the command line the last one takes - precedence. - - To implement this behaviour we map the presence of these flags - to values of the [prompt] type by using {!Arg.vflag_all}. This - argument will contain all occurences of the flag on the command - line and we just take the {!Arg.last} one to define our term value - (if there's no occurence the last value of the default list [[Always]] is - taken, i.e. the default is [Always]). -{[ -(* Implementation of the command, we just print the args. *) - -type prompt = Always | Once | Never -let prompt_str = function -| Always -> "always" | Once -> "once" | Never -> "never" - -let rm prompt recurse files = - Printf.printf "prompt = %s\nrecurse = %b\nfiles = %s\n" - (prompt_str prompt) recurse (String.concat ", " files) - -(* Command line interface *) - -open Cmdliner;; - -let files = Arg.(non_empty & pos_all file [] & info [] ~docv:"FILE") -let prompt = - let doc = "Prompt before every removal." in - let always = Always, Arg.info ["i"] ~doc in - let doc = "Ignore nonexistent files and never prompt." in - let never = Never, Arg.info ["f"; "force"] ~doc in - let doc = "Prompt once before removing more than three files, or when - removing recursively. Less intrusive than $(b,-i), while - still giving protection against most mistakes." - in - let once = Once, Arg.info ["I"] ~doc in - Arg.(last & vflag_all [Always] [always; never; once]) - -let recursive = - let doc = "Remove directories and their contents recursively." in - Arg.(value & flag & info ["r"; "R"; "recursive"] ~doc) - -let cmd = - let doc = "remove files or directories" in - let man = [ - `S "DESCRIPTION"; - `P "$(tname) removes each specified $(i,FILE). By default it does not - remove directories, to also remove them and their contents, use the - option $(b,--recursive) ($(b,-r) or $(b,-R))."; - `P "To remove a file whose name starts with a `-', for example - `-foo', use one of these commands:"; - `P "rm -- -foo"; `Noblank; - `P "rm ./-foo"; - `P "$(tname) removes symbolic links, not the files referenced by the - links."; - `S "BUGS"; `P "Report bugs to ."; - `S "SEE ALSO"; `P "$(b,rmdir)(1), $(b,unlink)(2)" ] - in - Term.(const rm $ prompt $ recursive $ files), - Term.info "rm" ~version:"1.6.1" ~doc ~man - -let () = match Term.eval cmd with `Error _ -> exit 1 | _ -> exit 0 -]} - {2:excp A [cp] command} - - We define the command line interface of a - [cp] command with the synopsis: -{[cp [OPTION]... SOURCE... DEST ]} - The [DEST] argument must be a directory if there is more than - one [SOURCE]. This constraint is too complex to be expressed by the - combinators of {!Arg}. Hence we just give it the {!Arg.string} type - and verify the constraint at the beginning of the [cp] - implementation. If unsatisfied we return an [`Error] and - by using {!Term.ret} on the lifted result [cp_t] of [cp], - [Cmdliner] handles the error reporting. -{[ -(* Implementation, we check the dest argument and print the args *) - -let cp verbose recurse force srcs dest = - if List.length srcs > 1 && - (not (Sys.file_exists dest) || not (Sys.is_directory dest)) - then - `Error (false, dest ^ " is not a directory") - else - `Ok (Printf.printf - "verbose = %b\nrecurse = %b\nforce = %b\nsrcs = %s\ndest = %s\n" - verbose recurse force (String.concat ", " srcs) dest) - -(* Command line interface *) - -open Cmdliner;; - -let verbose = - let doc = "Print file names as they are copied." in - Arg.(value & flag & info ["v"; "verbose"] ~doc) - -let recurse = - let doc = "Copy directories recursively." in - Arg.(value & flag & info ["r"; "R"; "recursive"] ~doc) - -let force = - let doc = "If a destination file cannot be opened, remove it and try again."in - Arg.(value & flag & info ["f"; "force"] ~doc) - -let srcs = - let doc = "Source file(s) to copy." in - Arg.(non_empty & pos_left ~rev:true 0 file [] & info [] ~docv:"SOURCE" ~doc) - -let dest = - let doc = "Destination of the copy. Must be a directory if there is more - than one $(i,SOURCE)." in - Arg.(required & pos ~rev:true 0 (some string) None & info [] ~docv:"DEST" - ~doc) - -let cmd = - let doc = "copy files" in - let man = [ - `S "BUGS"; - `P "Email them to ."; - `S "SEE ALSO"; - `P "$(b,mv)(1), $(b,scp)(1), $(b,umask)(2), $(b,symlink)(7)" ] - in - Term.(ret (const cp $ verbose $ recurse $ force $ srcs $ dest)), - Term.info "cp" ~version:"1.6.1" ~doc ~man - -let () = match Term.eval cmd with `Error _ -> exit 1 | _ -> exit 0 -]} - -{2:extail A [tail] command} - -We define the command line interface of a [tail] command with the -synopsis: -{[tail [OPTION]... [FILE]...]} - -The [--lines] option whose value specifies the number of last lines to -print has a special syntax where a [+] prefix indicates to start -printing from that line number. In the program this is represented by -the [loc] type. We define a custom [loc] {{!Arg.argconv}argument converter} -for this option. - -The [--follow] option has an optional enumerated value. The argument -converter [follow], created with {!Arg.enum} parses the option value -into the enumeration. By using {!Arg.some} and the [~vopt] argument of -{!Arg.opt}, the term corresponding to the option [--follow] evaluates to -[None] if [--follow] is absent from the command line, to [Some Descriptor] -if present but without a value and to [Some v] if present with a value -[v] specified. - -{[ -(* Implementation of the command, we just print the args. *) - -type loc = bool * int -type verb = Verbose | Quiet -type follow = Name | Descriptor - -let str = Printf.sprintf -let opt_str sv = function None -> "None" | Some v -> str "Some(%s)" (sv v) -let loc_str (rev, k) = if rev then str "%d" k else str "+%d" k -let follow_str = function Name -> "name" | Descriptor -> "descriptor" -let verb_str = function Verbose -> "verbose" | Quiet -> "quiet" - -let tail lines follow verb pid files = - Printf.printf "lines = %s\nfollow = %s\nverb = %s\npid = %s\nfiles = %s\n" - (loc_str lines) (opt_str follow_str follow) (verb_str verb) - (opt_str string_of_int pid) (String.concat ", " files) - -(* Command line interface *) - -open Cmdliner;; - -let lines = - let loc = - let parse s = try - if s <> "" && s.[0] <> '+' then `Ok (true, int_of_string s) else - `Ok (false, int_of_string (String.sub s 1 (String.length s - 1))) - with Failure _ -> `Error "unable to parse integer" - in - parse, fun ppf p -> Format.fprintf ppf "%s" (loc_str p) - in - Arg.(value & opt loc (true, 10) & info ["n"; "lines"] ~docv:"N" - ~doc:"Output the last $(docv) lines or use $(i,+)$(docv) to start - output after the $(i,N)-1th line.") -let follow = - let doc = "Output appended data as the file grows. $(docv) specifies how the - file should be tracked, by its `name' or by its `descriptor'." in - let follow = Arg.enum ["name", Name; "descriptor", Descriptor] in - Arg.(value & opt (some follow) ~vopt:(Some Descriptor) None & - info ["f"; "follow"] ~docv:"ID" ~doc) - -let verb = - let doc = "Never output headers giving file names." in - let quiet = Quiet, Arg.info ["q"; "quiet"; "silent"] ~doc in - let doc = "Always output headers giving file names." in - let verbose = Verbose, Arg.info ["v"; "verbose"] ~doc in - Arg.(last & vflag_all [Quiet] [quiet; verbose]) - -let pid = - let doc = "With -f, terminate after process $(docv) dies." in - Arg.(value & opt (some int) None & info ["pid"] ~docv:"PID" ~doc) - -let files = Arg.(value & (pos_all non_dir_file []) & info [] ~docv:"FILE") - -let cmd = - let doc = "display the last part of a file" in - let man = [ - `S "DESCRIPTION"; - `P "$(tname) prints the last lines of each $(i,FILE) to standard output. If - no file is specified reads standard input. The number of printed - lines can be specified with the $(b,-n) option."; - `S "BUGS"; - `P "Report them to ."; - `S "SEE ALSO"; - `P "$(b,cat)(1), $(b,head)(1)" ] - in - Term.(const tail $ lines $ follow $ verb $ pid $ files), - Term.info "tail" ~version:"1.6.1" ~doc ~man - -let () = match Term.eval cmd with `Error _ -> exit 1 | _ -> exit 0 -]} - -{2:exdarcs A [darcs] command} - -We define the command line interface of a [darcs] command with the synopsis: -{[darcs [COMMAND] ...]} - -The [--debug], [-q], [-v] and [--prehook] options are available in -each command. To avoid having to pass them individually to each -command we gather them in a record of type [copts]. By lifting the -record constructor [copts] into the term [copts_t] we now have a term -that we can pass to the commands to stand for an argument of type -[copts]. These options are documented in a section called [COMMON -OPTIONS], since we also want to put [--help] and [--version] in this -section, the term information of commands makes a judicious use of the -[sdocs] parameter of {!Term.info}. - -The [help] command shows help about commands or other topics. The help -shown for commands is generated by [Cmdliner] by making an approriate -use of {!Term.ret} on the lifted [help] function. - -If the program is invoked without a command we just want to show the -help of the program as printed by [Cmdliner] with [--help]. This is -done by the [no_cmd] term. - -{[ -(* Implementations, just print the args. *) - -type verb = Normal | Quiet | Verbose -type copts = { debug : bool; verb : verb; prehook : string option } - -let str = Printf.sprintf -let opt_str sv = function None -> "None" | Some v -> str "Some(%s)" (sv v) -let opt_str_str = opt_str (fun s -> s) -let verb_str = function - | Normal -> "normal" | Quiet -> "quiet" | Verbose -> "verbose" - -let pr_copts oc copts = Printf.fprintf oc - "debug = %b\nverbosity = %s\nprehook = %s\n" - copts.debug (verb_str copts.verb) (opt_str_str copts.prehook) - -let initialize copts repodir = Printf.printf - "%arepodir = %s\n" pr_copts copts repodir - -let record copts name email all ask_deps files = Printf.printf - "%aname = %s\nemail = %s\nall = %b\nask-deps = %b\nfiles = %s\n" - pr_copts copts (opt_str_str name) (opt_str_str email) all ask_deps - (String.concat ", " files) - -let help copts man_format cmds topic = match topic with -| None -> `Help (`Pager, None) (* help about the program. *) -| Some topic -> - let topics = "topics" :: "patterns" :: "environment" :: cmds in - let conv, _ = Cmdliner.Arg.enum (List.rev_map (fun s -> (s, s)) topics) in - match conv topic with - | `Error e -> `Error (false, e) - | `Ok t when t = "topics" -> List.iter print_endline topics; `Ok () - | `Ok t when List.mem t cmds -> `Help (man_format, Some t) - | `Ok t -> - let page = (topic, 7, "", "", ""), [`S topic; `P "Say something";] in - `Ok (Cmdliner.Manpage.print man_format Format.std_formatter page) - -open Cmdliner;; - -(* Help sections common to all commands *) - -let copts_sect = "COMMON OPTIONS" -let help_secs = [ - `S copts_sect; - `P "These options are common to all commands."; - `S "MORE HELP"; - `P "Use `$(mname) $(i,COMMAND) --help' for help on a single command.";`Noblank; - `P "Use `$(mname) help patterns' for help on patch matching."; `Noblank; - `P "Use `$(mname) help environment' for help on environment variables."; - `S "BUGS"; `P "Check bug reports at http://bugs.example.org.";] - -(* Options common to all commands *) - -let copts debug verb prehook = { debug; verb; prehook } -let copts_t = - let docs = copts_sect in - let debug = - let doc = "Give only debug output." in - Arg.(value & flag & info ["debug"] ~docs ~doc) - in - let verb = - let doc = "Suppress informational output." in - let quiet = Quiet, Arg.info ["q"; "quiet"] ~docs ~doc in - let doc = "Give verbose output." in - let verbose = Verbose, Arg.info ["v"; "verbose"] ~docs ~doc in - Arg.(last & vflag_all [Normal] [quiet; verbose]) - in - let prehook = - let doc = "Specify command to run before this $(mname) command." in - Arg.(value & opt (some string) None & info ["prehook"] ~docs ~doc) - in - Term.(const copts $ debug $ verb $ prehook) - -(* Commands *) - -let initialize_cmd = - let repodir = - let doc = "Run the program in repository directory $(docv)." in - Arg.(value & opt file Filename.current_dir_name & info ["repodir"] - ~docv:"DIR" ~doc) - in - let doc = "make the current directory a repository" in - let man = [ - `S "DESCRIPTION"; - `P "Turns the current directory into a Darcs repository. Any - existing files and subdirectories become ..."] @ help_secs - in - Term.(const initialize $ copts_t $ repodir), - Term.info "initialize" ~sdocs:copts_sect ~doc ~man - -let record_cmd = - let pname = - let doc = "Name of the patch." in - Arg.(value & opt (some string) None & info ["m"; "patch-name"] ~docv:"NAME" - ~doc) - in - let author = - let doc = "Specifies the author's identity." in - Arg.(value & opt (some string) None & info ["A"; "author"] ~docv:"EMAIL" - ~doc) - in - let all = - let doc = "Answer yes to all patches." in - Arg.(value & flag & info ["a"; "all"] ~doc) - in - let ask_deps = - let doc = "Ask for extra dependencies." in - Arg.(value & flag & info ["ask-deps"] ~doc) - in - let files = Arg.(value & (pos_all file) [] & info [] ~docv:"FILE or DIR") in - let doc = "create a patch from unrecorded changes" in - let man = - [`S "DESCRIPTION"; - `P "Creates a patch from changes in the working tree. If you specify - a set of files ..."] @ help_secs - in - Term.(const record $ copts_t $ pname $ author $ all $ ask_deps $ files), - Term.info "record" ~doc ~sdocs:copts_sect ~man - -let help_cmd = - let topic = - let doc = "The topic to get help on. `topics' lists the topics." in - Arg.(value & pos 0 (some string) None & info [] ~docv:"TOPIC" ~doc) - in - let doc = "display help about darcs and darcs commands" in - let man = - [`S "DESCRIPTION"; - `P "Prints help about darcs commands and other subjects..."] @ help_secs - in - Term.(ret - (const help $ copts_t $ Term.man_format $ Term.choice_names $topic)), - Term.info "help" ~doc ~man - -let default_cmd = - let doc = "a revision control system" in - let man = help_secs in - Term.(ret (const (fun _ -> `Help (`Pager, None)) $ copts_t)), - Term.info "darcs" ~version:"1.6.1" ~sdocs:copts_sect ~doc ~man - -let cmds = [initialize_cmd; record_cmd; help_cmd] - -let () = match Term.eval_choice default_cmd cmds with -| `Error _ -> exit 1 | _ -> exit 0 -]} -*) + (** {1:deprecated Deprecated} *) -(*--------------------------------------------------------------------------- - Copyright (c) 2011 Daniel C. Bünzli - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - 2. Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - 3. Neither the name of Daniel C. Bünzli nor the names of - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - ---------------------------------------------------------------------------*) + [@@@alert "-deprecated"] + + type 'a converter = 'a conv + [@@ocaml.deprecated "Use Arg.conv' function instead."] + (** See {!Arg.conv'}. *) + + val pconv : + ?docv:string -> 'a parser * 'a printer -> 'a conv + [@@ocaml.deprecated "Use Arg.conv or Arg.conv' function instead."] + (** [pconv] is like {!val-conv} or {!val-conv'}, but uses a + deprecated {!parser} signature. *) + + + type env = Cmd.Env.info + [@@ocaml.deprecated "Use Cmd.Env.info instead."] + (** See {!Cmd.Env.type-info} *) + + val env_var : + ?deprecated:string -> ?docs:string -> ?doc:string -> Cmd.Env.var -> + Cmd.Env.info + [@@ocaml.deprecated "Use Cmd.Env.info instead."] + (** See {!Cmd.Env.val-info}. *) +end diff --git a/src/refmt/refmt.ml b/src/refmt/refmt.ml index e8c257786..721b035d7 100644 --- a/src/refmt/refmt.ml +++ b/src/refmt/refmt.ml @@ -105,12 +105,12 @@ let top_level_info = let man = [`S "DESCRIPTION"; `P "refmt lets you format Reason files, parse them, and convert them between OCaml syntax and Reason syntax."] in let version = "Reason " ^ Package.version ^ " @ " ^ Package.git_short_version in - Term.info "refmt" ~version ~doc ~man + Cmd.info "refmt" ~version ~doc ~man let refmt_t = let open Term in let open Refmt_args in - const refmt $ interface + let term = const refmt $ interface $ recoverable $ explicit_arity $ parse_ast @@ -119,8 +119,8 @@ let refmt_t = $ heuristics_file $ in_place $ input + in + Cmd.v top_level_info (Term.ret term) let () = - match Term.eval ((Term.ret refmt_t), top_level_info) with - | `Error _ -> exit 1 - | _ -> exit 0 + exit (Cmd.eval refmt_t) diff --git a/src/refmt/refmt_args.ml b/src/refmt/refmt_args.ml index adafe21bc..2767eea8a 100644 --- a/src/refmt/refmt_args.ml +++ b/src/refmt/refmt_args.ml @@ -1,5 +1,5 @@ -module Cmdliner = Vendored_cmdliner -open Cmdliner + +open Vendored_cmdliner let interface = let doc = "parse AST as an interface" in @@ -43,7 +43,7 @@ let print = let print_width = let docv = "COLS" in let doc = "wrapping width for printing the AST" in - let env = Arg.env_var "REFMT_PRINT_WIDTH" ~doc in + let env = Cmd.Env.info "REFMT_PRINT_WIDTH" ~doc in Arg.(value & opt (int) (80) & info ["w"; "print-width"] ~docv ~doc ~env) let heuristics_file = From 87c9d802bf1a1450838341ee7d937c0f85e71e1e Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Sat, 20 Jul 2024 18:08:58 -0700 Subject: [PATCH 2/7] fix --- src/refmt/refmt.ml | 8 +++++--- test/comments-ml.t/run.t | 6 +++--- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/src/refmt/refmt.ml b/src/refmt/refmt.ml index 721b035d7..e2704353a 100644 --- a/src/refmt/refmt.ml +++ b/src/refmt/refmt.ml @@ -107,7 +107,7 @@ let version = "Reason " ^ Package.version ^ " @ " ^ Package.git_short_version in Cmd.info "refmt" ~version ~doc ~man -let refmt_t = +let refmt_t: [ `Error of bool * string | `Ok of unit ] Cmd.t = let open Term in let open Refmt_args in let term = const refmt $ interface @@ -120,7 +120,9 @@ let refmt_t = $ in_place $ input in - Cmd.v top_level_info (Term.ret term) + Cmd.v top_level_info term let () = - exit (Cmd.eval refmt_t) + match Cmd.eval_value' refmt_t with + | `Exit _ -> exit 1 + | _ -> exit 0 diff --git a/test/comments-ml.t/run.t b/test/comments-ml.t/run.t index 19671337b..f2978d2fb 100644 --- a/test/comments-ml.t/run.t +++ b/test/comments-ml.t/run.t @@ -1,8 +1,8 @@ Format basic $ refmt --print re ./input.re > ./formatted.re - refmt: FILENAMES... arguments: no `./input.re' file - Usage: refmt [OPTION]... [FILENAMES]... - Try `refmt --help' for more information. + refmt: FILENAMES… arguments: no './input.re' file + Usage: refmt [OPTION]… [FILENAMES]… + Try 'refmt --help' for more information. [1] Type-check basics From 5953c1019789e98620dc9762311f8a33c6c5bb17 Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Sat, 20 Jul 2024 18:17:58 -0700 Subject: [PATCH 3/7] fix for 4.06 --- src/reason-parser/vendor/cmdliner/cmdliner_info.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_info.ml b/src/reason-parser/vendor/cmdliner/cmdliner_info.ml index 561a60e51..75b4e2019 100644 --- a/src/reason-parser/vendor/cmdliner/cmdliner_info.ml +++ b/src/reason-parser/vendor/cmdliner/cmdliner_info.ml @@ -58,7 +58,7 @@ module Env = struct let info_var i = i.var let info_doc i = i.doc let info_docs i = i.docs - let info_compare i0 i1 = Int.compare i0.id i1.id + let info_compare i0 i1 = compare i0.id i1.id module Set = Set.Make (struct type t = info let compare = info_compare end) end @@ -152,7 +152,7 @@ module Arg = struct let rev_pos_cli_order a0 a1 = pos_cli_order a1 a0 - let compare a0 a1 = Int.compare a0.id a1.id + let compare a0 a1 = compare a0.id a1.id module Set = Set.Make (struct type nonrec t = t let compare = compare end) end From 583ad241a2d694c08f03411aa59571e05bf05fbb Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Sat, 20 Jul 2024 18:28:04 -0700 Subject: [PATCH 4/7] more 4.06 fixes --- src/reason-parser/vendor/cmdliner/cmdliner_term.ml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_term.ml b/src/reason-parser/vendor/cmdliner/cmdliner_term.ml index fd34e134e..f0d94b10b 100644 --- a/src/reason-parser/vendor/cmdliner/cmdliner_term.ml +++ b/src/reason-parser/vendor/cmdliner/cmdliner_term.ml @@ -26,10 +26,12 @@ let app (args_f, f) (args_v, v) = let map f v = app (const f) v let product v0 v1 = app (app (const (fun x y -> (x, y))) v0) v1 +(* module Syntax = struct let ( let+ ) v f = map f v let ( and+ ) = product end +*) (* Terms *) From 9948081bc42514afca70d7ffb63dd0b0cea61043 Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Sat, 20 Jul 2024 18:32:17 -0700 Subject: [PATCH 5/7] wip --- src/reason-parser/vendor/cmdliner/cmdliner_term.mli | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_term.mli b/src/reason-parser/vendor/cmdliner/cmdliner_term.mli index 66684ca7e..003978c3d 100644 --- a/src/reason-parser/vendor/cmdliner/cmdliner_term.mli +++ b/src/reason-parser/vendor/cmdliner/cmdliner_term.mli @@ -24,10 +24,12 @@ val app : ('a -> 'b) t -> 'a t -> 'b t val map : ('a -> 'b) -> 'a t -> 'b t val product : 'a t -> 'b t -> ('a * 'b) t +(* module Syntax : sig val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t val ( and+ ) : 'a t -> 'b t -> ('a * 'b) t end + *) val ( $ ) : ('a -> 'b) t -> 'a t -> 'b t From 572991b1da97bc5a0aa8f9bebd7ed9a58f00b7e3 Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Sat, 20 Jul 2024 18:37:18 -0700 Subject: [PATCH 6/7] more --- src/reason-parser/vendor/cmdliner/vendored_cmdliner.mli | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/reason-parser/vendor/cmdliner/vendored_cmdliner.mli b/src/reason-parser/vendor/cmdliner/vendored_cmdliner.mli index 7e886cdf8..fcaaca7a0 100644 --- a/src/reason-parser/vendor/cmdliner/vendored_cmdliner.mli +++ b/src/reason-parser/vendor/cmdliner/vendored_cmdliner.mli @@ -191,6 +191,7 @@ module Term : sig (** [product t0 t1] is [app (app (map (fun x y -> (x, y)) t0) t1)] *) (** [let] operators. *) +(* module Syntax : sig val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t (** [( let+ )] is {!map}. *) @@ -198,6 +199,7 @@ module Term : sig val ( and+ ) : 'a t -> 'b t -> ('a * 'b) t (** [( and* )] is {!product}. *) end +*) (** {1 Interacting with Cmdliner's evaluation} *) From 7ee46424d8e1109d31addef67ddae84d05f6f702 Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Sat, 20 Jul 2024 18:47:18 -0700 Subject: [PATCH 7/7] more --- src/reason-parser/vendor/cmdliner/cmdliner_term.ml | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/reason-parser/vendor/cmdliner/cmdliner_term.ml b/src/reason-parser/vendor/cmdliner/cmdliner_term.ml index f0d94b10b..c65b74695 100644 --- a/src/reason-parser/vendor/cmdliner/cmdliner_term.ml +++ b/src/reason-parser/vendor/cmdliner/cmdliner_term.ml @@ -52,8 +52,11 @@ let term_result ?(usage = false) (al, v) = | Ok (Error (`Msg e)) -> Error (`Error (usage, e)) | Error _ as e -> e +let map_error f = function + | Ok x -> Ok x + | Error e -> Error (f e) let term_result' ?usage t = - let wrap = app (const (Result.map_error (fun e -> `Msg e))) t in + let wrap = app (const (map_error (fun e -> `Msg e))) t in term_result ?usage wrap let cli_parse_result (al, v) = @@ -63,7 +66,7 @@ let cli_parse_result (al, v) = | Error _ as e -> e let cli_parse_result' t = - let wrap = app (const (Result.map_error (fun e -> `Msg e))) t in + let wrap = app (const (map_error (fun e -> `Msg e))) t in cli_parse_result wrap let main_name =