From 96c7e6bf82234084117ae43766e1349b6ec86343 Mon Sep 17 00:00:00 2001 From: Brian Ward Date: Mon, 16 Mar 2026 10:44:39 -0400 Subject: [PATCH 01/12] Update vendored cmdliner to 2.1.1 --- shell/vendor_cmdliner.sh | 23 +- src/core/cmdliner/cmdliner_arg.ml | 612 +++++++--- src/core/cmdliner/cmdliner_arg.mli | 154 ++- src/core/cmdliner/cmdliner_base.ml | 463 +++----- src/core/cmdliner/cmdliner_base.mli | 76 +- src/core/cmdliner/cmdliner_cline.ml | 420 ++++--- src/core/cmdliner/cmdliner_cline.mli | 21 +- src/core/cmdliner/cmdliner_cmd.ml | 46 +- src/core/cmdliner/cmdliner_cmd.mli | 15 +- src/core/cmdliner/cmdliner_completion.ml | 140 +++ src/core/cmdliner/cmdliner_completion.mli | 9 + src/core/cmdliner/cmdliner_def.ml | 560 +++++++++ src/core/cmdliner/cmdliner_def.mli | 304 +++++ src/core/cmdliner/cmdliner_docgen.ml | 328 +++--- src/core/cmdliner/cmdliner_docgen.mli | 7 +- src/core/cmdliner/cmdliner_eval.ml | 405 ++++--- src/core/cmdliner/cmdliner_eval.mli | 18 +- src/core/cmdliner/cmdliner_info.ml | 225 ---- src/core/cmdliner/cmdliner_info.mli | 139 --- src/core/cmdliner/cmdliner_manpage.ml | 203 ++-- src/core/cmdliner/cmdliner_manpage.mli | 56 +- src/core/cmdliner/cmdliner_msg.ml | 112 +- src/core/cmdliner/cmdliner_msg.mli | 27 +- src/core/cmdliner/cmdliner_term.ml | 43 +- src/core/cmdliner/cmdliner_term.mli | 9 +- src/core/cmdliner/cmdliner_term_deprecated.ml | 77 -- src/core/cmdliner/cmdliner_trie.ml | 31 +- src/core/cmdliner/cmdliner_trie.mli | 6 +- src/core/cmdliner/opamCmdliner.ml | 9 +- src/core/cmdliner/opamCmdliner.mli | 1039 ++++++++--------- .../cmdliner/patches/add_dune_files.patch | 20 + .../cmdliner/patches/rename_for_opam.patch | 20 + src/core/cmdliner/tool/cmdliner_data.ml | 368 ++++++ src/core/cmdliner/tool/dune | 4 + src/core/cmdliner/tool/opamCmdliner_tool.ml | 729 ++++++++++++ 35 files changed, 4470 insertions(+), 2248 deletions(-) create mode 100644 src/core/cmdliner/cmdliner_completion.ml create mode 100644 src/core/cmdliner/cmdliner_completion.mli create mode 100644 src/core/cmdliner/cmdliner_def.ml create mode 100644 src/core/cmdliner/cmdliner_def.mli delete mode 100644 src/core/cmdliner/cmdliner_info.ml delete mode 100644 src/core/cmdliner/cmdliner_info.mli delete mode 100644 src/core/cmdliner/cmdliner_term_deprecated.ml create mode 100644 src/core/cmdliner/patches/add_dune_files.patch create mode 100644 src/core/cmdliner/patches/rename_for_opam.patch create mode 100644 src/core/cmdliner/tool/cmdliner_data.ml create mode 100644 src/core/cmdliner/tool/dune create mode 100644 src/core/cmdliner/tool/opamCmdliner_tool.ml diff --git a/shell/vendor_cmdliner.sh b/shell/vendor_cmdliner.sh index 1335e25a546..d3139627cf4 100755 --- a/shell/vendor_cmdliner.sh +++ b/shell/vendor_cmdliner.sh @@ -1,23 +1,18 @@ -#!/bin/sh +#!/bin/bash set -euo pipefail cd src/core/cmdliner -rm -rf *.ml *.mli dune +rm -rf *.ml *.mli dune tool +trap "rm -rf tmp-vendor" EXIT git clone https://github.com/dbuenzli/cmdliner tmp-vendor -git -C tmp-vendor switch --detach v1.3.0 +git -C tmp-vendor switch --detach v2.1.1 mv tmp-vendor/src/*.{ml,mli} . -rm -rf tmp-vendor +mkdir -p tool +mv tmp-vendor/src/tool/*.ml tool/ -mv cmdliner.ml opamCmdliner.ml -mv cmdliner.mli opamCmdliner.mli -rm cmdliner_exit.ml{,i} - -cat > dune << EOF -(library - (name opamCmdliner) - (public_name opam-core.cmdliner) - (flags :standard -w -27-32-35-50)) -EOF +for f in patches/*.patch; do + git apply "$f" +done diff --git a/src/core/cmdliner/cmdliner_arg.ml b/src/core/cmdliner/cmdliner_arg.ml index c6ae9e9963d..9d7e79a3088 100644 --- a/src/core/cmdliner/cmdliner_arg.ml +++ b/src/core/cmdliner/cmdliner_arg.ml @@ -5,113 +5,113 @@ 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 +module Fmt = Cmdliner_base.Fmt + 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 *) +(* Invalid_argument strings *) -type 'a parser = string -> [ `Ok of 'a | `Error of string ] -type 'a printer = Format.formatter -> 'a -> unit +let err_not_opt = "Option argument without name" +let err_not_pos = "Positional argument with a name" +let err_incomplete_enum ss = + Printf.sprintf + "Arg.enum: missing printable string for a value, other strings are: %s" + (String.concat ", " ss) -type 'a conv = 'a parser * 'a printer -type 'a converter = 'a conv +(* Parse error strings *) -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 err_no kind s = Fmt.str "no %a %s" Fmt.code_or_quote s kind +let err_not_dir s = + Fmt.str "%a %a" Fmt.code_or_quote s Fmt.ereason "is not a directory" -let conv' ?docv (parse, print) = - let parse s = match parse s with Ok v -> `Ok v | Error e -> `Error e in - parse, print +let err_is_dir s = + Fmt.str "%a %a" Fmt.code_or_quote s Fmt.ereason "is a directory" -let pconv ?docv conv = conv +let err_element kind s exp = + Fmt.str "%a element in %s (%a): %s" + Fmt.invalid () kind Fmt.code_or_quote s exp -let conv_parser (parse, _) = - fun s -> match parse s with `Ok v -> Ok v | `Error e -> Error (`Msg e) +let err_invalid kind s exp = + Fmt.str "@[%a %s %a, %s@]" Fmt.invalid () kind Fmt.code_or_quote s exp -let conv_printer (_, print) = print -let conv_docv _ = default_docv +let err_invalid_val = err_invalid "value" +let err_sep_miss sep s = + err_invalid_val s (Fmt.str "%a a '%c' separator" Fmt.missing () sep) -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 err_invalid_enum var s enums = + let pp_docv ppf var = + if not (var = "ENUM" || var = "") then Fmt.pf ppf "%a " Fmt.code_var var + in + Fmt.str "@[%a@ %avalue %a, expected@ %a@]" Fmt.invalid () pp_docv var + Fmt.code_or_quote s Cmdliner_base.pp_alts enums + +(* Argument converters *) -let some = Cmdliner_base.some -let some' = Cmdliner_base.some' +module Completion = Cmdliner_def.Arg_completion +module Conv = Cmdliner_def.Arg_conv +type 'a conv = 'a Conv.t +let some = Cmdliner_def.Arg_conv.some +let some' = Cmdliner_def.Arg_conv.some' +let none = Cmdliner_def.Arg_conv.none (* 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 +type info = Cmdliner_def.Arg_info.t +let info = Cmdliner_def.Arg_info.make (* Arguments *) let ( & ) f x = f x +let parse_error e = Error (`Parse e) -let err e = Error (`Parse e) +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 = doc_alts ~quoted:true ["true"; "yes"; "false"; "no" ] in + Error (err_invalid_val s alts) 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 +| Ok v -> Ok [v] | Error _ as e -> e + +let try_env ei a parse ~absent = match Cmdliner_def.Arg_info.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 + let var = Cmdliner_def.Env.info_var env in + match Cmdliner_def.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 + | Error e -> parse_error (Cmdliner_msg.err_env_parse env ~err:e) + | Ok _ as v -> 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 arg_to_args a complete = Cmdliner_def.Arg_info.Set.singleton a complete +let list_to_args f l complete = + let add acc v = Cmdliner_def.Arg_info.Set.add (f v) complete acc in + List.fold_left add Cmdliner_def.Arg_info.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 + if Cmdliner_def.Arg_info.is_pos a then invalid_arg err_not_opt else + let convert ei cl = match Cmdliner_def.Cline.get_opt_arg cl a with + | [] -> try_env ei a 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) + | [_, f, Some v] -> parse_error (Cmdliner_msg.err_flag_value f v) + | (_, f, _) :: (_ ,g, _) :: _ -> + parse_error (Cmdliner_msg.err_opt_repeated f g) in - arg_to_args a, convert + Cmdliner_term.make (arg_to_args a (Conv none)) 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:[] + if Cmdliner_def.Arg_info.is_pos a then invalid_arg err_not_opt else + let a = Cmdliner_def.Arg_info.make_all_opts a in + let convert ei cl = match Cmdliner_def.Cline.get_opt_arg cl a with + | [] -> try_env ei a (parse_to_list env_bool_parse) ~absent:[] | l -> try let truth (_, f, v) = match v with @@ -119,15 +119,15 @@ let flag_all a = | Some v -> failwith (Cmdliner_msg.err_flag_value f v) in Ok (List.rev_map truth l) - with Failure e -> err e + with Failure e -> parse_error e in - arg_to_args a, convert + Cmdliner_term.make (arg_to_args a (Conv none)) 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 + begin match Cmdliner_def.Cline.get_opt_arg cl a with | [] -> aux fv rest | [_, f, None] -> begin match fv with @@ -140,18 +140,18 @@ let vflag v l = end | [] -> match fv with None -> v | Some (_, v) -> v in - try Ok (aux None l) with Failure e -> err e + try Ok (aux None l) with Failure e -> parse_error e in let flag (_, a) = - if Cmdliner_info.Arg.is_pos a then invalid_arg err_not_opt else a + if Cmdliner_def.Arg_info.is_pos a then invalid_arg err_not_opt else a in - list_to_args flag l, convert + Cmdliner_term.make (list_to_args flag l (Conv none)) 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 + begin match Cmdliner_def.Cline.get_opt_arg cl a with | [] -> aux acc rest | l -> let fval (k, f, v) = match v with @@ -163,153 +163,412 @@ let vflag_all v l = | [] -> if acc = [] then v else List.rev_map snd (List.sort rev_compare acc) in - try Ok (aux [] l) with Failure e -> err e + try Ok (aux [] l) with Failure e -> parse_error 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 + if Cmdliner_def.Arg_info.is_pos a then invalid_arg err_not_opt else + Cmdliner_def.Arg_info.make_all_opts a in - list_to_args flag l, convert + Cmdliner_term.make (list_to_args flag l (Conv none)) 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) +| 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)) +let opt ?vopt conv v a = + if Cmdliner_def.Arg_info.is_pos a then invalid_arg err_not_opt else + let absent = match Cmdliner_def.Arg_info.absent a with + | Cmdliner_def.Arg_info.Doc d as a when d <> "" -> a + | _ -> Cmdliner_def.Arg_info.Val (lazy (str_of_pp (Conv.pp conv) v)) in let kind = match vopt with - | None -> Cmdliner_info.Arg.Opt - | Some dv -> Cmdliner_info.Arg.Opt_vopt (str_of_pp print dv) + | None -> Cmdliner_def.Arg_info.Opt + | Some dv -> Cmdliner_def.Arg_info.Opt_vopt (str_of_pp (Conv.pp conv) dv) + in + let docv = match Cmdliner_def.Arg_info.docv a with + | "" -> Conv.docv conv | docv -> docv 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 + let a = Cmdliner_def.Arg_info.make_opt ~docv ~absent ~kind a in + let convert ei cl = match Cmdliner_def.Cline.get_opt_arg cl a with + | [] -> try_env ei a (Conv.parser conv) ~absent:v | [_, f, Some v] -> - (try Ok (parse_opt_value parse f v) with Failure e -> err e) + (try Ok (parse_opt_value (Conv.parser conv) f v) with + | Failure e -> parse_error e) | [_, f, None] -> begin match vopt with - | None -> err (Cmdliner_msg.err_opt_value_missing f) + | None -> parse_error (Cmdliner_msg.err_opt_value_missing f) | Some optv -> Ok optv end - | (_, f, _) :: (_, g, _) :: _ -> err (Cmdliner_msg.err_opt_repeated g f) + | (_, f, _) :: (_, g, _) :: _ -> + parse_error (Cmdliner_msg.err_opt_repeated g f) in - arg_to_args a, convert + Cmdliner_term.make (arg_to_args a (Conv conv)) 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 "") +let opt_all ?vopt conv v a = + if Cmdliner_def.Arg_info.is_pos a then invalid_arg err_not_opt else + let absent = match Cmdliner_def.Arg_info.absent a with + | Cmdliner_def.Arg_info.Doc d as a when d <> "" -> a + | _ -> Cmdliner_def.Arg_info.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) + | None -> Cmdliner_def.Arg_info.Opt + | Some dv -> Cmdliner_def.Arg_info.Opt_vopt (str_of_pp (Conv.pp conv) 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 + let docv = match Cmdliner_def.Arg_info.docv a with + | "" -> Conv.docv conv | docv -> docv + in + let a = Cmdliner_def.Arg_info.make_opt_all ~docv ~absent ~kind a in + let convert ei cl = match Cmdliner_def.Cline.get_opt_arg cl a with + | [] -> try_env ei a (parse_to_list (Conv.parser conv)) ~absent:v | l -> let parse (k, f, v) = match v with - | Some v -> (k, parse_opt_value parse f v) + | Some v -> (k, parse_opt_value (Conv.parser conv) 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 + | Failure e -> parse_error e in - arg_to_args a, convert + Cmdliner_term.make (arg_to_args a (Conv conv)) 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 +| Ok v -> v +| Error err -> failwith (Cmdliner_msg.err_pos_parse a ~err) + +let pos ?(rev = false) k conv v a = + if Cmdliner_def.Arg_info.is_opt a then invalid_arg err_not_pos else + let absent = match Cmdliner_def.Arg_info.absent a with + | Cmdliner_def.Arg_info.Doc d as a when d <> "" -> a + | _ -> Cmdliner_def.Arg_info.Val (lazy (str_of_pp (Conv.pp conv) v)) + in + let pos = Cmdliner_def.Arg_info.pos ~rev ~start:k ~len:(Some 1) in + let docv = match Cmdliner_def.Arg_info.docv a with + | "" -> Conv.docv conv | docv -> docv + in + let a = Cmdliner_def.Arg_info.make_pos_abs ~docv ~absent ~pos a in + let convert ei cl = match Cmdliner_def.Cline.get_pos_arg cl a with + | [] -> try_env ei a (Conv.parser conv) ~absent:v | [v] -> - (try Ok (parse_pos_value parse a v) with Failure e -> err e) + (try Ok (parse_pos_value (Conv.parser conv) a v) with + | Failure e -> parse_error e) | _ -> assert false in - arg_to_args a, convert + Cmdliner_term.make (arg_to_args a (Conv conv)) 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 +let pos_list pos conv v a = + if Cmdliner_def.Arg_info.is_opt a then invalid_arg err_not_pos else + let docv = match Cmdliner_def.Arg_info.docv a with + | "" -> Conv.docv conv | docv -> docv + in + let a = Cmdliner_def.Arg_info.make_pos ~docv ~pos a in + let convert ei cl = match Cmdliner_def.Cline.get_pos_arg cl a with + | [] -> try_env ei a (parse_to_list (Conv.parser conv)) ~absent:v | l -> - try Ok (List.rev (List.rev_map (parse_pos_value parse a) l)) with - | Failure e -> err e + try Ok (List.rev (List.rev_map (parse_pos_value (Conv.parser conv) a) l)) + with + | Failure e -> parse_error e in - arg_to_args a, convert + Cmdliner_term.make (arg_to_args a (Conv conv)) convert -let all = Cmdliner_info.Arg.pos ~rev:false ~start:0 ~len:None +let all = Cmdliner_def.Arg_info.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) + pos_list (Cmdliner_def.Arg_info.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) + pos_list (Cmdliner_def.Arg_info.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 + let make_req a v acc = + let req_a = Cmdliner_def.Arg_info.make_req a in + Cmdliner_def.Arg_info.Set.add req_a v acc in - Cmdliner_info.Arg.Set.fold make_req args Cmdliner_info.Arg.Set.empty + Cmdliner_def.Arg_info.Set.fold make_req args Cmdliner_def.Arg_info.Set.empty let value a = a let err_arg_missing args = - err @@ Cmdliner_msg.err_arg_missing (Cmdliner_info.Arg.Set.choose args) + parse_error @@ + Cmdliner_msg.err_arg_missing (fst (Cmdliner_def.Arg_info.Set.choose args)) -let required (args, convert) = - let args = absent_error args in - let convert ei cl = match convert ei cl with +let required t = + let args = absent_error (Cmdliner_term.argset t) in + let convert ei cl = match (Cmdliner_term.parser t) ei cl with | Ok (Some v) -> Ok v | Ok None -> err_arg_missing args | Error _ as e -> e in - args, convert + Cmdliner_term.make args convert -let non_empty (al, convert) = - let args = absent_error al in - let convert ei cl = match convert ei cl with +let non_empty t = + let args = absent_error (Cmdliner_term.argset t) in + let convert ei cl = match (Cmdliner_term.parser t) ei cl with | Ok [] -> err_arg_missing args | Ok l -> Ok l | Error _ as e -> e in - args, convert + Cmdliner_term.make args convert -let last (args, convert) = - let convert ei cl = match convert ei cl with - | Ok [] -> err_arg_missing args +let last t = + let convert ei cl = match (Cmdliner_term.parser t) ei cl with + | Ok [] -> err_arg_missing (Cmdliner_term.argset t) | Ok l -> Ok (List.hd (List.rev l)) | Error _ as e -> e in - args, convert + Cmdliner_term.make (Cmdliner_term.argset t) convert + +(* Predefined converters. *) + +let add_prefix_completion ~token name = + if Cmdliner_base.string_starts_with ~prefix:token name + then Some (Completion.string name) else None + +let bool = + let alts = ["true"; "false"] in + let parser s = try Ok (bool_of_string s) with + | Invalid_argument _ -> Error (err_invalid_enum "" s alts) + in + let completion = + let func _ctx ~token = + Ok (List.filter_map (add_prefix_completion ~token) alts) + in + Completion.make func + in + Conv.make ~docv:"BOOL" ~parser ~pp:Format.pp_print_bool ~completion () + +let char = + let parser s = match String.length s = 1 with + | true -> Ok s.[0] + | false -> Error (err_invalid_val s "expected a character") + in + Conv.make ~docv:"CHAR" ~parser ~pp:Fmt.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 = + let parser = parse_with int_of_string "expected an integer" in + Conv.make ~docv:"INT" ~parser ~pp:Format.pp_print_int () + +let int32 = + let parser = parse_with Int32.of_string "expected a 32-bit integer" in + let pp ppf = Fmt.pf ppf "%ld" in + Conv.make ~docv:"INT32" ~parser ~pp () + +let int64 = + let parser = parse_with Int64.of_string "expected a 64-bit integer" in + let pp ppf = Fmt.pf ppf "%Ld" in + Conv.make ~docv:"INT64" ~parser ~pp () + +let nativeint = + let err = "expected a processor-native integer" in + let parser = parse_with Nativeint.of_string err in + let pp ppf = Fmt.pf ppf "%nd" in + Conv.make ~docv:"NATIVEINT" ~parser ~pp () + +let float = + let parser = parse_with float_of_string "expected a floating point number" in + Conv.make ~docv:"DOUBLE" ~parser ~pp:Format.pp_print_float () + +let string = Conv.make ~docv:"" ~parser:Result.ok ~pp:Fmt.string () + +let enum ?(docv = "ENUM") sl = + if sl = [] then invalid_arg Cmdliner_base.err_empty_list else + let t = Cmdliner_trie.of_list sl in + let parser s = + let legacy_prefixes = Cmdliner_trie.legacy_prefixes ~env:Sys.getenv_opt in + match Cmdliner_trie.find ~legacy_prefixes t s with + | Ok _ as v -> v + | Error `Ambiguous (* Only on legacy prefixes *) -> + let ambs = List.sort compare (Cmdliner_trie.ambiguities t s) in + Error (Cmdliner_base.err_ambiguous ~kind:"enum value" s ~ambs) + | Error `Not_found -> + let alts = List.rev (List.rev_map (fun (s, _) -> s) sl) in + Error (err_invalid_enum docv s alts) + in + let pp ppf v = + let sl_inv = List.rev_map (fun (s,v) -> (v,s)) sl in + try Fmt.string ppf (List.assoc v sl_inv) + with Not_found -> invalid_arg (err_incomplete_enum (List.map fst sl)) + in + let completion = + let func _ctx ~token = + Ok (List.filter_map (fun (n, _) -> add_prefix_completion ~token n) sl) + in + Completion.make func + in + Conv.make ~docv ~parser ~pp ~completion () + +let path = + let parser s = Ok s in + let pp ppf s = Fmt.string ppf (Filename.quote s) in + let completion = Completion.complete_paths in + Conv.make ~docv:"PATH" ~parser ~pp ~completion () + +let filepath = + let parser s = Ok s in + let pp ppf s = Fmt.string ppf (Filename.quote s) in + let completion = Completion.complete_files in + Conv.make ~docv:"FILE" ~parser ~pp ~completion () + +let dirpath = + let parser s = Ok s in + let pp ppf s = Fmt.string ppf (Filename.quote s) in + let completion = Completion.complete_dirs in + Conv.make ~docv:"DIR" ~parser ~pp ~completion () + +let file = + let parser s = + if s = "-" then Ok s else + if Sys.file_exists s then Ok s else + Error (err_no "file or directory" s) + in + let completion = Completion.complete_files in + Conv.make ~docv:"PATH" ~parser ~pp:Fmt.string ~completion () + +let dir = + let parser 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) + in + let completion = Completion.complete_dirs in + Conv.make ~docv:"DIR" ~parser ~pp:Fmt.string ~completion () + +let non_dir_file = + let parser s = + if s = "-" then Ok s else + 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) + in + let completion = Completion.complete_files in + Conv.make ~docv:"FILE" ~parser ~pp:Fmt.string ~completion () + +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 = ',') conv = + let parser s = try Ok (split_and_parse sep (Conv.parser conv) s) with + | Failure e -> Error (err_element "list" s e) + in + let rec pp ppf = function + | [] -> () + | v :: l -> + (Conv.pp conv) ppf v; if (l <> []) then (Fmt.char ppf sep; pp ppf l) + in + let docv = Printf.sprintf "%s[%c…]" (Conv.docv conv) sep in + Conv.make ~docv ~parser ~pp () + +let array ?(sep = ',') conv = + let parser s = + try Ok (Array.of_list (split_and_parse sep (Conv.parser conv) s)) with + | Failure e -> Error (err_element "array" s e) + in + let pp ppf v = + let max = Array.length v - 1 in + for i = 0 to max do + Conv.pp conv ppf v.(i); if i <> max then Fmt.char ppf sep + done + in + let docv = Printf.sprintf "%s[%c…]" (Conv.docv conv) sep in + Conv.make ~docv ~parser ~pp () + +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 = ',') conv0 conv1 = + let parser s = match split_left sep s with + | None -> Error (err_sep_miss sep s) + | Some (v0, v1) -> + match (Conv.parser conv0) v0, (Conv.parser conv1) v1 with + | Ok v0, Ok v1 -> Ok (v0, v1) + | Error e, _ | _, Error e -> Error (err_element "pair" s e) + in + let pp ppf (v0, v1) = + Fmt.pf ppf "%a%c%a" (Conv.pp conv0) v0 sep (Conv.pp conv1) v1 + in + let docv = Printf.sprintf "%s%c%s" (Conv.docv conv0) sep (Conv.docv conv1) in + Conv.make ~docv ~parser ~pp () + +let t2 = pair +let t3 ?(sep = ',') conv0 conv1 conv2 = + let parser 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 (Conv.parser conv0) v0, (Conv.parser conv1) v1, + (Conv.parser conv2) 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 pp ppf (v0, v1, v2) = + let pp = Conv.pp in + Fmt.pf ppf "%a%c%a%c%a" (pp conv0) v0 sep (pp conv1) v1 sep (pp conv2) v2 + in + let docv = + let docv = Conv.docv in + Printf.sprintf "%s%c%s%c%s" (docv conv0) sep (docv conv1) sep (docv conv2) + in + Conv.make ~docv ~parser ~pp () + +let t4 ?(sep = ',') conv0 conv1 conv2 conv3 = + let parser 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 (Conv.parser conv0) v0, (Conv.parser conv1) v1, + (Conv.parser conv2) v2, (Conv.parser conv3) 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 pp ppf (v0, v1, v2, v3) = + let pp = Conv.pp in + Fmt.pf ppf "%a%c%a%c%a%c%a" (pp conv0) v0 sep (pp conv1) v1 sep (pp conv2) + v2 sep (pp conv3) v3 + in + let docv = + let docv = Conv.docv in + Printf.sprintf "%s%c%s%c%s%c%s" + (docv conv0) sep (docv conv1) sep (docv conv2) sep (docv conv3) + in + Conv.make ~docv ~parser ~pp () (* Predefined arguments *) @@ -317,12 +576,13 @@ 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_enum = enum ~docv:man_fmt_docv 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." + Printf.sprintf + "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 = @@ -339,23 +599,27 @@ let stdopt_help ~docs = value & opt ~vopt:(Some `Auto) (some man_fmts_enum) None & info ["help"] ~docv ~docs ~doc -(* Predefined converters. *) +(* Deprecated *) -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 +type 'a printer = 'a Conv.fmt +let docv_default = "VALUE" +let conv' ?docv (parser, pp) = Conv.make ~docv:docv_default ~parser ~pp () +let conv ?docv (parser, pp) = + let parser s = match parser s with + | Ok _ as v -> v | Error (`Msg e) -> Error e + in + Conv.make ~docv:docv_default ~parser ~pp () + +let conv_printer = Conv.pp +let conv_docv = Conv.docv +let conv_parser conv = + fun s -> match Conv.parser conv s with + | Ok _ as v -> v | Error e -> Error (`Msg e) + +let err_invalid s kind = + `Msg (Printf.sprintf "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 diff --git a/src/core/cmdliner/cmdliner_arg.mli b/src/core/cmdliner/cmdliner_arg.mli index 1166b13b409..cebd6117faf 100644 --- a/src/core/cmdliner/cmdliner_arg.mli +++ b/src/core/cmdliner/cmdliner_arg.mli @@ -5,39 +5,69 @@ (** 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 +(* Converters *) -val conv : - ?docv:string -> (string -> ('a, [`Msg of string]) result) * 'a printer -> - 'a conv +type 'a conv -val conv' : - ?docv:string -> (string -> ('a, string) result) * 'a printer -> 'a conv +module Completion : sig + type 'a directive -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 value : ?doc:string -> 'a -> 'a directive + val string : ?doc:string -> string -> 'a directive + val files : 'a directive + val dirs : 'a directive + val restart : 'a directive + val message : string -> 'a directive + val raw : string -> 'a directive -val parser_of_kind_of_string : - kind:string -> (string -> 'a option) -> - (string -> ('a, [`Msg of string]) result) + type ('ctx, 'a) func = + 'ctx option -> token:string -> ('a directive list, string) result + + type 'a complete = + | Complete : 'ctx Cmdliner_term.t option * ('ctx, 'a) func -> 'a complete + + type 'a t + + val make : ?context:'ctx Cmdliner_term.t -> ('ctx, 'a) func -> 'a t + + val complete : 'a t -> 'a complete + val complete_none : 'a t + val complete_files : 'a t + val complete_dirs : 'a t + val complete_paths : 'a t + val complete_restart : 'a t +end + +module Conv : sig + type 'a parser = string -> ('a, string) result + type 'a fmt = Format.formatter -> 'a -> unit + type 'a t = 'a conv + val make : + ?completion:'a Completion.t -> docv:string -> parser:'a parser -> + pp:'a fmt -> unit -> 'a t + + val of_conv : + ?completion:'a Completion.t -> ?docv:string -> ?parser:'a parser -> + ?pp:'a fmt -> 'a t -> 'a t -val some : ?none:string -> 'a converter -> 'a option converter -val some' : ?none:'a -> 'a converter -> 'a option converter + val docv : 'a conv -> string + val parser : 'a conv -> 'a parser + val pp : 'a conv -> 'a fmt + val completion : 'a t -> 'a Completion.t +end -type env = Cmdliner_info.Env.info -val env_var : ?deprecated:string -> ?docs:string -> ?doc:string -> string -> env +val some : ?none:string -> 'a conv -> 'a option conv +val some' : ?none:'a -> 'a conv -> 'a option conv + +(* Arguments *) 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 + ?deprecated:string -> ?absent:string -> ?docs:string -> + ?doc_envs:Cmdliner_def.Env.info list -> ?docv:string -> ?doc:string -> + ?env:Cmdliner_def.Env.info -> string list -> info val ( & ) : ('a -> 'b) -> 'a -> 'b @@ -45,54 +75,68 @@ 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 opt : ?vopt:'a -> 'a conv -> 'a -> info -> 'a t +val opt_all : ?vopt:'a -> 'a conv -> '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 +val pos : ?rev:bool -> int -> 'a conv -> 'a -> info -> 'a t +val pos_all : 'a conv -> 'a list -> info -> 'a list t +val pos_left : ?rev:bool -> int -> 'a conv -> 'a list -> info -> 'a list t +val pos_right : ?rev:bool -> int -> 'a conv -> 'a list -> info -> 'a list t -(** {1 As terms} *) +(* 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} *) +(* 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 - +(* Predifined converters *) + +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 : ?docv:string -> (string * 'a) list -> 'a conv +val path : string conv +val filepath : string conv +val dirpath : string 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 converter ->'b converter -> 'c converter -> 'd converter -> - ('a * 'b * 'c * 'd) converter + ?sep:char -> 'a conv ->'b conv -> 'c conv -> 'd conv -> + ('a * 'b * 'c * 'd) conv val doc_quote : string -> string val doc_alts : ?quoted:bool -> string list -> string val doc_alts_enum : ?quoted:bool -> (string * 'a) list -> string + +(* Deprecated *) + +type 'a printer = Format.formatter -> 'a -> unit +val conv' : ?docv:string -> 'a Conv.parser * 'a Conv.fmt -> 'a conv +val conv : + ?docv:string -> (string -> ('a, [`Msg of string]) result) * 'a Conv.fmt -> + '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) diff --git a/src/core/cmdliner/cmdliner_base.ml b/src/core/cmdliner/cmdliner_base.ml index f1c659ca862..840a8a325ec 100644 --- a/src/core/cmdliner/cmdliner_base.ml +++ b/src/core/cmdliner/cmdliner_base.ml @@ -16,7 +16,10 @@ let uid = let id = !c in incr c; if id > !c then assert false (* too many ids *) else id -(* Edit distance *) +(* Edit distance + + The stdlib has much better in but this will be only >= 5.4, maybe + in twenty years. *) let edit_distance s0 s1 = let minimum (a : int) (b : int) (c : int) : int = min a (min b c) in @@ -44,298 +47,208 @@ let suggest s candidates = let dist, suggs = List.fold_left add (max_int, []) candidates in if dist < 3 (* suggest only if not too far *) then suggs else [] +(* Stdlib compatibility *) + +let is_space = function ' ' | '\n' | '\r' | '\t' -> true | _ -> false + +let string_starts_with ~prefix s = (* available in 4.13 *) + let prefix_len = String.length prefix in + let s_len = String.length s in + if prefix_len > s_len then false else + let rec loop i = + if i = prefix_len then true + else if String.get prefix i = String.get s i then loop (i + 1) + else false + in + loop 0 + +let string_drop_first n s = + if n <= 0 then s else + if n >= String.length s then "" else + String.sub s n (String.length s - n) + (* 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 +module Fmt = struct + type 'a t = Format.formatter -> 'a -> unit + let str = Format.asprintf + let pf = Format.fprintf + let nop ppf _ = () + let sp = Format.pp_print_space + let cut = Format.pp_print_cut + let string = Format.pp_print_string + let char = Format.pp_print_char + let comma ppf () = char ppf ','; sp ppf () + let indent ppf c = for i = 1 to c do char ppf ' ' done + let list ?sep pp_v ppf l = Format.pp_print_list ?pp_sep:sep pp_v ppf l + let text = Format.pp_print_text + let 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 tokens ~spaces ppf s = (* collapse white and hint spaces (maybe) *) + let i_max = String.length s - 1 in + let flush start stop = string 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 sp ppf () else char ppf ' '; + if next_start > i_max then () else loop next_start next_start) + in + loop 0 0 + + (* Text styling *) + + type styler = Ansi | Plain + let styler' = + ref begin match Sys.getenv_opt "NO_COLOR" with + | Some s when s <> "" -> Plain + | _ -> + match Sys.getenv_opt "TERM" with + | Some "dumb" -> Plain + | None when Sys.backend_type <> Other "js_of_ocaml" -> Plain + | _ -> Ansi + end + + let set_styler styler = styler' := styler + let styler () = !styler' + + let sgr_of_style = function + | `Bold -> "01" + | `Underline -> "04" + | `Fg `Red -> string_of_int (30 + 1) + | `Fg `Yellow -> string_of_int (30 + 3) + + let sgrs_of_styles styles = String.concat ";" (List.map sgr_of_style styles) + let ansi_esc = "\x1B[" + let sgr_reset = "\x1B[m" + + let ansi styles ppf s = + let sgrs = String.concat "" [ansi_esc; sgrs_of_styles styles; "m"] in + Format.pp_print_as ppf 0 sgrs; + string ppf s; + Format.pp_print_as ppf 0 sgr_reset + + let st styles ppf s = match !styler' with + | Plain -> string ppf s + | Ansi -> ansi styles ppf s + + let code ppf v = st [`Bold] ppf v + let code_var ppf v = st [`Underline] ppf v + let code_or_quote ppf v = match !styler' with + | Plain -> char ppf '\''; string ppf v; char ppf '\'' + | Ansi -> ansi [`Bold] ppf v + + let ereason ppf s = match !styler' with + | Plain -> string ppf s + | Ansi -> ansi [`Fg `Red] ppf s + + let wreason ppf s = match !styler' with + | Plain -> string ppf s + | Ansi -> ansi [`Fg `Yellow] ppf s + + let missing ppf () = ereason ppf "missing" + let invalid ppf () = ereason ppf "invalid" + let unknown ppf () = ereason ppf "unknown" + let deprecated ppf () = wreason ppf "deprecated" + + let puterr ppf () = st [`Bold; `Fg `Red] ppf "Error"; char ppf ':' + + let styled_text ppf s = + (* Detects ANSI escapes and prints them as 0 width. Collapses spaces + and newlines to single space except for blank lines which are + preserved. *) + let rec loop ppf s i max = + if i > max then () else + let ansi = s.[i] = '\x1B' && i + 1 < max && s.[i+1] = '[' in + if not ansi then match s.[i] with + | ' ' when i = max || s.[i+1] = ' ' || s.[i+1] = '\n' -> + loop ppf s (i + 1) max + | ' ' -> sp ppf (); loop ppf s (i + 1) max + | '\n' when i = max || s.[i+1] = ' ' -> loop ppf s (i + 1) max + | '\n' when s.[i+1] = '\n' -> + Format.pp_force_newline ppf (); + if i > 0 && s.[i-1] <> '\n' then Format.pp_force_newline ppf (); + loop ppf s (i + 1) max + | '\n' -> sp ppf (); loop ppf s (i + 1) max + | c -> char ppf s.[i]; loop ppf s (i + 1) max + else begin + let k = ref (i + 2) in + while (!k <= max && s.[!k] <> 'm') do incr k done; + let esc = String.sub s i (!k - i + 1) in + Format.pp_print_as ppf 0 esc; + loop ppf s (!k + 1) max + end + in + loop ppf s 0 (String.length s - 1) +end (* Converter (end-user) error messages *) -let quote s = strf "'%s'" s -let alts_str ?quoted alts = +let err_multi_def ~kind name doc v v' = (* programming error *) + strf "%s %s defined twice (doc strings are '%s' and '%s')" + kind name (doc v) (doc v') + +let quote s = strf "'%s'" s (* Exposed in the API do not change *) +let _alts_str ~styled ?quoted ppf alts = let quote = match quoted with - | None -> strf "$(b,%s)" - | Some quoted -> if quoted then quote else (fun s -> s) + | None -> fun ppf s -> Fmt.pf ppf "$(b,%s)" s + | Some quoted -> + if not quoted then Fmt.string else + if styled then Fmt.code_or_quote else + fun ppf s -> Fmt.pf ppf "'%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) + | [a] -> quote ppf a + | [a; b] -> Fmt.pf ppf "either@ %a@ or@ %a" 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)) + Fmt.pf ppf "one@ of@ %a@ or@ %a" + Fmt.(list ~sep:comma quote) (List.rev (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 alts_str ?quoted alts = (* Exposed in the API do not change *) + Fmt.str "@[%a@]" (_alts_str ~styled:false ?quoted) alts + +let pp_alts ppf alts = + _alts_str ~styled:true ~quoted:true ppf alts let err_ambiguous ~kind s ~ambs = - strf "%s %s ambiguous and could be %s" kind (quote s) - (alts_str ~quoted:true ambs) + Fmt.str "@[%s %a %a@ and@ could@ be@ %a@]" + kind Fmt.code_or_quote s Fmt.ereason "ambiguous" pp_alts 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 + let hints ppf () = match hints, dom with + | [], [] -> () + | [], dom -> Fmt.pf ppf ". Must@ be@ %a" pp_alts dom + | hints, _ -> Fmt.pf ppf ". Did@ you@ mean@ %a?" pp_alts hints 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) + Fmt.str "@[%a %s@ %a%a@]" Fmt.unknown () kind Fmt.code_or_quote v hints () diff --git a/src/core/cmdliner/cmdliner_base.mli b/src/core/cmdliner/cmdliner_base.mli index 3b12e735156..59295082d30 100644 --- a/src/core/cmdliner/cmdliner_base.mli +++ b/src/core/cmdliner/cmdliner_base.mli @@ -12,49 +12,49 @@ 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 is_space : char -> bool +val string_starts_with : prefix:string -> string -> bool +val string_drop_first : int -> string -> string + +(* Formatters *) + +module Fmt : sig + type 'a t = Format.formatter -> 'a -> unit + val str : ('a, Format.formatter, unit, string) format4 -> 'a + val pf : Format.formatter -> ('a, Format.formatter, unit) format -> 'a + val nop : 'a t + val sp : unit t + val comma : unit t + val cut : unit t + val char : char t + val string : string t + val indent : int t + val list : ?sep:unit t -> 'a t -> 'a list t + val styled_text : string t + val lines : string t + val tokens : spaces:bool -> string t + val text : string t + val code : string t + val code_var : string t + val code_or_quote : string t + val ereason : string t + val missing : unit t + val invalid : unit t + val deprecated : unit t + val puterr : unit t + + type styler = Ansi | Plain + val styler : unit -> styler +end + +(* Error message helpers *) val quote : string -> string +val pp_alts : string list Fmt.t val alts_str : ?quoted:bool -> string list -> string +val err_empty_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/core/cmdliner/cmdliner_cline.ml b/src/core/cmdliner/cmdliner_cline.ml index cc817024ad0..0fd0667fdb0 100644 --- a/src/core/cmdliner/cmdliner_cline.ml +++ b/src/core/cmdliner/cmdliner_cline.ml @@ -5,81 +5,101 @@ (* 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 = + Cmdliner_def.Arg_info.t values mentioned in a term and Sys.argv + (without exec name) we parse the command line into + [Cmdliner_def.Cline.t] which is map of [Cmdliner_def.Arg_info.t] + values to [Cmdliner_def.Cline.arg] values. This map is used by the + term's closures to retrieve and convert command line arguments (see + the [Cmdliner_arg] module). *) + +(* Completion *) + +let complete_prefix = "--__complete=" +let has_complete_prefix s = + Cmdliner_base.string_starts_with ~prefix:complete_prefix s + +let get_token_to_complete s = + Cmdliner_base.string_drop_first (String.length complete_prefix) s + +let is_opt_to_complete s = (* assert (has_complete_prefix s) *) + String.length s > String.length complete_prefix && + s.[String.length complete_prefix] = '-' + +let maybe_token_to_complete ~for_completion s = + if not for_completion || not (has_complete_prefix s) then None else + Some (get_token_to_complete s) + +(* Command lines *) + +let err_multi_opt_name_def name arg_info arg_info' = + Cmdliner_base.err_multi_def ~kind:"option name" name + Cmdliner_def.Arg_info.doc arg_info arg_info' + +let arg_info_indexes arg_infos = (* 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 + a Cmdliner_def.Cline.t mapping each arg_info to an empty [arg]. *) + let rec loop optidx posidx cline = function + | [] -> optidx, posidx, cline + | arg_info :: l -> + match Cmdliner_def.Arg_info.is_pos arg_info with + | true -> + let cline = Cmdliner_def.Cline.add arg_info (P []) cline in + loop optidx (arg_info :: posidx) cline l | false -> - let add t name = match Cmdliner_trie.add t name a with + let add t name = match Cmdliner_trie.add t name arg_info with | `New t -> t - | `Replaced (a', _) -> invalid_arg (err_multi_opt_name_def name a a') + | `Replaced (a', _) -> + invalid_arg (err_multi_opt_name_def name arg_info a') in - let names = Cmdliner_info.Arg.opt_names a in + let names = Cmdliner_def.Arg_info.opt_names arg_info in let optidx = List.fold_left add optidx names in - loop optidx posidx (Amap.add a (O []) cl) l + let cline = Cmdliner_def.Cline.add arg_info (O []) cline in + loop optidx posidx cline l in - loop Cmdliner_trie.empty [] Amap.empty (Cmdliner_info.Arg.Set.elements args) + let cline = Cmdliner_def.Cline.empty in + let arg_infos = Cmdliner_def.Arg_info.Set.elements arg_infos in + loop Cmdliner_trie.empty [] cline arg_infos (* Optional argument parsing *) +(* Note on option completion. Technically when trying to complete an + option we could try to avoid mentioning names that have already be + mentioned and that are not repeatable. Sometimes not being able to + complete what we know exists ends up being more confusing than + enlightening so we don't do that for now. + + Also the code is quite messy, perhaps we should cleanly separate + parsing for completion and parsing for evaluation. *) + 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 parse_opt_arg s = + (* (name, value) of opt arg, assert len > 1. except if complete *) + let is_completion = has_complete_prefix s in + let s = if is_completion then get_token_to_complete s else s in let l = String.length s in + if l <= 1 then "-", None, is_completion else 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 *) + if l = 2 then s, None, is_completion else + String.sub s 0 2, Some (String.sub s 2 (l - 2)) (* with glued opt arg *), + is_completion 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 + String.sub s 0 i, Some (String.sub s (i + 1) (l - i - 1)), is_completion + with Not_found -> s, None, is_completion let hint_matching_opt optidx s = - (* hint options that could match [s] in [optidx]. FIXME explain this is - a bit obscure. *) + (* hint option names that could match [s] in [optidx]. *) 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 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, [] -> [] @@ -87,117 +107,239 @@ let hint_matching_opt optidx s = | 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] +let parse_opt_value ~for_completion cline arg_info name value args = + (* Either we got a value glued in [value] or we need to get one in [args] + in this case we need to take care of a possible completion token *) + match Cmdliner_def.Arg_info.opt_kind arg_info with + | Flag -> (* Flags have no values but we may get dash sharing in [value] *) + begin match value with + | None -> None, None, args + | Some v when is_short_opt name -> (* short flag dash sharing *) + None, None, ("-" ^ v) :: args + | Some _ -> (* an error but this is reported during typed parsing *) + None, value, args + end + | _ -> + match value with + | Some _ -> None, value, args + | None -> (* Get it from the next argument. *) + match args with + | [] -> None, None, args + | v :: rest when for_completion && has_complete_prefix v -> + let v = get_token_to_complete v in + if is_opt v then (* not an option value *) None, None, args else + let comp = + Cmdliner_def.Complete.make ~token:v (Opt_value arg_info) + in + Some comp, None, rest + | v :: rest -> + if is_opt v then None, None, args else None, Some v, rest + +let try_complete_opt_value cline arg_info name value args = + (* At that point we found a matching option name so this should be mostly + about completing a glued option value, but there are twists. *) + match Cmdliner_def.Arg_info.opt_kind arg_info with + | Cmdliner_def.Arg_info.Flag -> + begin match value with + | Some v when is_short_opt name -> + (* short flag dash sharing, push the completion *) + let args = (complete_prefix ^ "-" ^ v) :: args in + None, None, args + | Some v -> + (* This is actually a parse error, flags have no value. We + make it an option completion but the completions will + eventually be empty (the prefix won't match) *) + Some (Cmdliner_def.Complete.make ~token:(name ^ v) Opt_name), + None, args + | None -> + (* We have in fact a fully completed flag turn it into an + option completion. *) + Some (Cmdliner_def.Complete.make ~token:name Opt_name), None, args + end + | _ -> + begin match value with + | Some token -> + Some (Cmdliner_def.Complete.make ~token (Opt_value arg_info)), None, + args + | None -> + (* We have a fully completed option name, we don't try to + lookup what happens in the next argument which should + hold the value if any, we just turn it into an option + completion. *) + Some (Cmdliner_def.Complete.make ~token:name Opt_name), None, args + end + +let parse_opt_args + ~peek_opts ~legacy_prefixes ~for_completion optidx cline args + = + (* returns an updated [cline] 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) + let rec loop errs k comp cline pargs = function + | [] -> List.rev errs, comp, cline, false, List.rev pargs + | "--" :: args -> + List.rev errs, comp, cline, true, (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 + let do_parse = + is_opt s && + (if not for_completion then true else + if not (has_complete_prefix s) then true else + is_opt_to_complete s) + in + if not do_parse then loop errs (k + 1) comp cline (s :: pargs) args else + let name, value, is_completion = parse_opt_arg s in + match Cmdliner_trie.find ~legacy_prefixes optidx name with + | Ok arg_info -> + let acomp, value, args = + if is_completion + then try_complete_opt_value cline arg_info name value args + else parse_opt_value ~for_completion cline arg_info name value args + in + let comp = match acomp with Some _ -> acomp | None -> comp in + let arg : Cmdliner_def.Cline.arg = + O ((k, name, value) :: + Cmdliner_def.Cline.get_opt_arg cline arg_info) 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 cline = Cmdliner_def.Cline.add arg_info arg cline in + loop errs (k + 1) comp cline pargs args + | Error (`Not_found | `Ambiguous) when for_completion -> + if not is_completion then + (* Drop the data, if the user thought this was an opt with + an argument this may confuse positional args but there's + not much we can do. *) + loop errs (k + 1) comp cline pargs args + else + let token = name ^ Option.value ~default:"" value in + let comp = Some (Cmdliner_def.Complete.make ~token Opt_name) in + loop errs (k + 1) comp cline pargs args + | Error `Not_found when peek_opts -> + loop errs (k + 1) comp cline pargs args + | Error `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 -> + loop (err :: errs) (k + 1) comp cline pargs args + | Error `Ambiguous (* Only on legacy prefixes *) -> 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 + loop (err :: errs) (k + 1) comp cline 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 + let errs, comp, cline, has_dashdash, pargs = loop [] 0 None cline [] args in + if errs = [] then Ok (comp, cline, has_dashdash, pargs) else + match comp with + | Some _ -> Ok (comp, cline, has_dashdash, pargs) + | None -> + let err = String.concat "\n" errs in + Error (err, cline, has_dashdash, pargs) + +(* Positional argument parsing *) + +let take_range ~for_completion start stop l = + let rec loop i comp acc = function + | [] -> comp, (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 + if i < start then loop (i + 1) comp acc vs else + if i <= stop then match maybe_token_to_complete ~for_completion v with + | Some _ as comp -> loop (i + 1) comp (v :: acc) vs + | None -> loop (i + 1) comp (v :: acc) vs + else comp, List.rev acc in - loop 0 [] l + loop 0 None [] 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 +let parse_pos_args ~for_completion posidx comp cline ~has_dashdash pargs = + (* returns an updated [cline] 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) + let misses = List.filter Cmdliner_def.Arg_info.is_req posidx in + if misses = [] then Ok (comp, cline) else + match comp with + | Some _ -> Ok (comp, cline) + | None -> Error (Cmdliner_msg.err_pos_misses misses, cline) 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 + let rec loop misses comp cline max_spec = function + | [] -> misses, comp, cline, max_spec + | arg_info :: al -> + let apos = Cmdliner_def.Arg_info.pos_kind arg_info in + let rev = Cmdliner_def.Arg_info.pos_rev apos in + let start = pos rev (Cmdliner_def.Arg_info.pos_start apos) in + let stop = match Cmdliner_def.Arg_info.pos_len apos with | None -> pos rev last - | Some n -> pos rev (Cmdliner_info.Arg.pos_start apos + n - 1) + | Some n -> pos rev (Cmdliner_def.Arg_info.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 comp, args = match take_range ~for_completion start stop pargs with + | None, args -> comp, args + | Some token, args -> + let comp = + Cmdliner_def.Complete.make ~after_dashdash:has_dashdash ~token + (Opt_name_or_pos_value arg_info) + in + Some comp, args + 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 + let cline = Cmdliner_def.Cline.add arg_info (P args) cline in + let misses = match Cmdliner_def.Arg_info.is_req arg_info && args = [] with + | true -> arg_info :: 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 + loop misses comp cline max_spec al in - Amap.fold add cl [] + let misses, comp, cline, max_spec = loop [] comp cline (-1) posidx in + if misses <> [] then begin + if Option.is_some comp then Ok (comp, cline) else + Error (Cmdliner_msg.err_pos_misses misses, cline) + end else + if last <= max_spec then Ok (comp, cline) else + if Option.is_some comp then Ok (comp, cline) else + let comp, excess = take_range ~for_completion (max_spec + 1) last pargs in + match comp with + | None -> Error (Cmdliner_msg.err_pos_excess excess, cline) + | Some token -> + let comp = + Cmdliner_def.Complete.make ~after_dashdash:has_dashdash ~token Opt_name + in + Ok (Some comp, cline) + +let create ?(peek_opts = false) ~legacy_prefixes ~for_completion al args = + let optidx, posidx, cline = arg_info_indexes al in + match + parse_opt_args ~for_completion ~peek_opts ~legacy_prefixes optidx cline args + with + | Ok (comp, cline, _has_dashdash, _pargs) when peek_opts -> + begin match comp with + | None -> `Ok cline + | Some comp -> `Complete (comp, cline) + end + | Ok (comp, cline, has_dashdash, pargs) -> + begin match + parse_pos_args ~for_completion posidx comp cline ~has_dashdash pargs + with + | Ok (None, _) | Error _ when for_completion -> + (* Normally we should have found a completion token This + may fail to happen if pos args are ill defined: we may miss the + completion token. Just make sure we do a completion. *) + begin match List.find_opt has_complete_prefix pargs with + | None -> assert false + | Some arg -> + match maybe_token_to_complete ~for_completion:true arg with + | None -> assert false + | Some token -> + let comp = + Cmdliner_def.Complete.make + ~after_dashdash:has_dashdash ~token Opt_name + in + `Complete (comp, cline) + end + | Ok (None, cline) -> `Ok cline + | Ok (Some comp, cline) -> `Complete (comp, cline) + | Error v -> `Error v + end + | Error (errs, cline, has_dashdash, pargs) -> + match + parse_pos_args ~for_completion posidx None cline ~has_dashdash pargs + with + | Ok (Some comp, cline) -> `Complete (comp, cline) + | _ -> `Error (errs, cline) diff --git a/src/core/cmdliner/cmdliner_cline.mli b/src/core/cmdliner/cmdliner_cline.mli index f9075b01d62..b1e6c3158d5 100644 --- a/src/core/cmdliner/cmdliner_cline.mli +++ b/src/core/cmdliner/cmdliner_cline.mli @@ -5,16 +5,15 @@ (** Command lines. *) -type t - -val create : - ?peek_opts:bool -> Cmdliner_info.Arg.Set.t -> string list -> - (t, string * t) result +val is_opt : string -> bool +val has_complete_prefix : string -> bool +val get_token_to_complete : string -> string -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 *) +(** {1:cli Command lines} *) -val is_opt : string -> bool -val deprecated_msgs : t -> string list +val create : + ?peek_opts:bool -> legacy_prefixes:bool -> for_completion:bool -> + Cmdliner_def.Arg_info.Set.t -> string list -> + [ `Ok of Cmdliner_def.Cline.t + | `Complete of Cmdliner_def.Complete.t * Cmdliner_def.Cline.t + | `Error of string * Cmdliner_def.Cline.t ] diff --git a/src/core/cmdliner/cmdliner_cmd.ml b/src/core/cmdliner/cmdliner_cmd.ml index 0cff096bcdf..5a8db32df8b 100644 --- a/src/core/cmdliner/cmdliner_cmd.ml +++ b/src/core/cmdliner/cmdliner_cmd.ml @@ -5,26 +5,48 @@ (* Commands *) -(* Command info *) - -type info = Cmdliner_info.Cmd.t -let info = Cmdliner_info.Cmd.v +type info = Cmdliner_def.Cmd_info.t +let info = Cmdliner_def.Cmd_info.make 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 +let make info t = + let info = Cmdliner_def.Cmd_info.add_args info (Cmdliner_term.argset t) in + Cmd (info, Cmdliner_term.parser t) + +let v = make + +let get_info = function Cmd (info, _) | Group (info, _) -> info +let get_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 group ?default info cmds = let args, parser = match default with - | None -> None, None | Some (args, p) -> Some args, Some p + | None -> None, None + | Some t -> Some (Cmdliner_term.argset t), Some (Cmdliner_term.parser t) 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 info = Cmdliner_def.Cmd_info.with_children info ~args ~children in + Group (info, (parser, cmds)) + +let name c = Cmdliner_def.Cmd_info.name (get_info c) + +let name_trie cmds = + let add acc cmd = + let info = get_info cmd in + let name = Cmdliner_def.Cmd_info.name info in + match Cmdliner_trie.add acc name cmd with + | `New t -> t + | `Replaced (cmd', _) -> + let info' = get_info cmd' and kind = "command" in + invalid_arg @@ + Cmdliner_base.err_multi_def ~kind name + Cmdliner_def.Cmd_info.doc info info' + in + List.fold_left add Cmdliner_trie.empty cmds -let name c = Cmdliner_info.Cmd.name (get_info c) +let list_names cmds = + let cmd_name c = Cmdliner_def.Cmd_info.name (get_info c) in + List.sort String.compare (List.rev_map cmd_name cmds) diff --git a/src/core/cmdliner/cmdliner_cmd.mli b/src/core/cmdliner/cmdliner_cmd.mli index f2e3062caa9..9f644f880aa 100644 --- a/src/core/cmdliner/cmdliner_cmd.mli +++ b/src/core/cmdliner/cmdliner_cmd.mli @@ -5,20 +5,23 @@ (** Commands and their information. *) -type info = Cmdliner_info.Cmd.t +type info = Cmdliner_def.Cmd_info.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 + ?deprecated:string -> ?man_xrefs:Cmdliner_manpage.xref list -> + ?man:Cmdliner_manpage.block list -> ?envs:Cmdliner_def.Env.info list -> + ?exits:Cmdliner_def.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 make : info -> 'a Cmdliner_term.t -> 'a t 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 name_trie : 'a t list -> 'a t Cmdliner_trie.t +val list_names : 'a t list -> string list val get_info : 'a t -> info +val get_children_infos : 'a t -> info list diff --git a/src/core/cmdliner/cmdliner_completion.ml b/src/core/cmdliner/cmdliner_completion.ml new file mode 100644 index 00000000000..4d4efea1fea --- /dev/null +++ b/src/core/cmdliner/cmdliner_completion.ml @@ -0,0 +1,140 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2025 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +(* Output protocol *) + +let cons_if b v l = if b then v :: l else l + +type directive = +| Dirs | Files | Group of string * (string * string) list +| Restart | Message of string + +let pp_protocol ppf dirs = + let pp_line ppf s = Cmdliner_base.Fmt.(string ppf s; cut ppf ()) in + let pp_text ppf s = Cmdliner_base.Fmt.(pf ppf "@[%a@]@," styled_text s) in + let vnum = 1 (* Protocol version number *) in + let pp_item ppf (name, doc) = + pp_line ppf "item"; + pp_line ppf name; pp_text ppf doc; + pp_line ppf "item-end"; + in + let pp_dir ppf = function + | Dirs -> pp_line ppf "dirs" + | Files -> pp_line ppf "files" + | Restart -> pp_line ppf "restart" + | Group (name, items) -> + pp_line ppf "group"; + pp_line ppf name; + Cmdliner_base.Fmt.(list ~sep:nop pp_item) ppf items; + | Message msg -> + pp_line ppf "message"; pp_text ppf msg; pp_line ppf "message-end" + in + Cmdliner_base.Fmt.pf ppf "@[%d@,%a@]" vnum + Cmdliner_base.Fmt.(list ~sep:nop pp_dir) dirs + +let add_subcommands_group ~err_ppf ~subst eval comp directives = + if not (Cmdliner_def.Complete.subcmds comp) then directives else + let prefix = Cmdliner_def.Complete.token comp in + let maybe_item cmd = + let name = Cmdliner_def.Cmd_info.name cmd in + if not (Cmdliner_base.string_starts_with ~prefix name) then None else + (* FIXME subst is wrong here. *) + let doc = Cmdliner_def.Cmd_info.styled_doc ~errs:err_ppf ~subst cmd in + Some (name, doc) + in + let subcmds = Cmdliner_def.Eval.subcmds eval in + Group ("Subcommands", List.filter_map maybe_item subcmds) :: directives + +let add_options_group ~err_ppf ~subst eval comp directives = + let prefix = Cmdliner_def.Complete.token comp in + let maybe_items arg_info = + let names = Cmdliner_def.Arg_info.opt_names arg_info in + let subst = Cmdliner_def.Arg_info.doclang_subst ~subst arg_info in + let doc = Cmdliner_def.Arg_info.styled_doc ~errs:err_ppf ~subst arg_info in + let add_name n = + if not (Cmdliner_base.string_starts_with ~prefix n) then None else + Some (n, doc) + in + List.filter_map add_name names + in + let maybe_opt = prefix = "" || prefix.[0] = '-' in + if Cmdliner_def.Complete.after_dashdash comp || not maybe_opt + then directives else + let cmd_info = Cmdliner_def.Eval.cmd eval in + let set = Cmdliner_def.Cmd_info.args cmd_info in + if Cmdliner_def.Arg_info.Set.is_empty set then directives else + let options = Cmdliner_def.Arg_info.Set.elements set in + Group ("Options", List.concat (List.map maybe_items options)) :: directives + +let add_argument_value_directives directives eval arg_info comp cline = + let (Conv conv) = + let arg_infos = Cmdliner_def.Cmd_info.args (Cmdliner_def.Eval.cmd eval) in + Option.get (Cmdliner_def.Arg_info.Set.find_opt arg_info arg_infos) + in + let value_dirs = + let completion = Cmdliner_def.Arg_conv.completion conv in + match Cmdliner_def.Arg_completion.complete completion with + | Complete (ctx, func) -> + let ctx = match ctx with + | None -> None + | Some ctx -> + match (Cmdliner_term.parser ctx) eval cline with + | Ok ctx -> Some ctx + | Error _ -> None + | exception exn -> None + in + func ctx ~token:(Cmdliner_def.Complete.token comp) + in + match value_dirs with + | Error msg -> `Directives [Message msg] + | Ok ds -> + let pp = Cmdliner_def.Arg_conv.pp conv in + let rec loop values msgs ~files ~dirs ~restart ~raw = function + | [] -> + begin match raw with + | Some r -> `Raw r + | None -> + if Cmdliner_def.Complete.after_dashdash comp && restart + then `Directives [Restart] else + let dd = + cons_if dirs Dirs @@ + cons_if files Files @@ + cons_if (values <> []) (Group ("Values", List.rev values)) [] + in + `Directives (List.rev_append msgs (List.rev_append dd directives)) + end + | d :: ds -> + match d with + | Cmdliner_def.Arg_completion.String (s, doc) -> + loop ((s, doc) :: values) msgs ~files ~dirs ~restart ~raw ds + | Value (v, doc) -> + let s = Cmdliner_base.Fmt.str "@[%a@]" pp v in + loop ((s, doc) :: values) msgs ~files ~dirs ~restart ~raw ds + | Files -> loop values msgs ~files:true ~dirs ~restart ~raw ds + | Dirs -> loop values msgs ~files ~dirs:true ~restart ~raw ds + | Restart -> loop values msgs ~files ~dirs ~restart:true ~raw ds + | Message msg -> + loop values (Message msg :: msgs) ~files ~dirs ~restart ~raw ds + | Raw r -> loop values msgs ~files ~dirs ~restart ~raw:(Some r) ds + in + loop [] [] ~files:false ~dirs:false ~restart:false ~raw:None ds + +let output ~out_ppf ~err_ppf eval comp cline = + let subst = Cmdliner_def.Eval.doclang_subst eval in + let dirs = add_subcommands_group ~err_ppf ~subst eval comp [] in + let res = match Cmdliner_def.Complete.kind comp with + | Opt_value arg_info -> + add_argument_value_directives dirs eval arg_info comp cline + | Opt_name_or_pos_value arg_info -> + let dirs = add_options_group ~err_ppf ~subst eval comp dirs in + add_argument_value_directives dirs eval arg_info comp cline + | Opt_name -> + `Directives (add_options_group ~err_ppf ~subst eval comp dirs) + in + if out_ppf == Format.std_formatter + then set_binary_mode_out stdout true; + match res with + | `Raw raw -> Cmdliner_base.Fmt.pf out_ppf "%s@?" raw + | `Directives dirs -> Cmdliner_base.Fmt.pf out_ppf "%a@?" pp_protocol dirs diff --git a/src/core/cmdliner/cmdliner_completion.mli b/src/core/cmdliner/cmdliner_completion.mli new file mode 100644 index 00000000000..5124ffaf8cb --- /dev/null +++ b/src/core/cmdliner/cmdliner_completion.mli @@ -0,0 +1,9 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2025 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +val output : + out_ppf:Format.formatter -> err_ppf:Format.formatter -> + Cmdliner_def.Eval.t -> Cmdliner_def.Complete.t -> Cmdliner_def.Cline.t -> + unit diff --git a/src/core/cmdliner/cmdliner_def.ml b/src/core/cmdliner/cmdliner_def.ml new file mode 100644 index 00000000000..bac550e28ac --- /dev/null +++ b/src/core/cmdliner/cmdliner_def.ml @@ -0,0 +1,560 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +let strf = Printf.sprintf + +(* 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)."; ] + + let doclang_subst ~subst i = function + | "status" -> Some (string_of_int (info_code i)) + | "status_max" -> Some (string_of_int (snd i.codes)) + | id -> subst id +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 + + let doclang_subst ~subst i = function + | "env" -> Some (strf "$(b,%s)" (Cmdliner_manpage.escape i.var)) + | id -> subst id + + let styled_deprecated ~errs ~subst i = match i.deprecated with + | None -> "" | Some msg -> Cmdliner_manpage.doc_to_styled ~errs ~subst msg + + let styled_doc ~errs ~subst i = + Cmdliner_manpage.doc_to_styled ~errs ~subst i.doc + + module Set = Set.Make (struct type t = info let compare = info_compare end) +end + +(* Argument information *) + +module Arg_info = 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 + let dumb_pos = pos ~rev:false ~start:(-1) ~len:None + + 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. *) + doc_envs : Env.info list; (* environment that needs to be added to docs *) + 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 make + ?deprecated ?(absent = "") ?docs ?(doc_envs = []) ?(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; doc_envs; docs; pos = dumb_pos; + opt_kind = Flag; opt_names; opt_all = false; } + + let id i = i.id + let deprecated i = i.deprecated + let absent i = i.absent + let env i = i.env + let doc i = i.doc + let docv i = i.docv + let doc_envs i = i.doc_envs + let docs i = i.docs + let pos_kind i = i.pos + let opt_kind i = i.opt_kind + let opt_names i = i.opt_names + let opt_all i = i.opt_all + let opt_name_sample i = + (* 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 i.opt_names + | n :: ns -> if (String.length n) > 2 then n else find ns + in + find i.opt_names + + let make_req i = { i with absent = Err } + let make_all_opts i = { i with opt_all = true } + let make_opt ~docv ~absent ~kind:opt_kind i = + { i with absent; opt_kind; docv } + + let make_opt_all ~docv ~absent ~kind:opt_kind i = + { i with absent; opt_kind; opt_all = true; docv } + + let make_pos ~docv ~pos i = { i with pos; docv } + let make_pos_abs ~docv ~absent ~pos i = { i with absent; pos; docv } + + let is_opt i = i.opt_names <> [] + let is_pos i = i.opt_names = [] + let is_req i = i.absent = Err + + let pos_cli_order (a0 : t) (a1 : t) = (* best-effort order on the cli. *) + let c = Bool.compare (a0.pos.pos_rev) (a1.pos.pos_rev) in + if c <> 0 then c else + if a0.pos.pos_rev + then Int.compare a1.pos.pos_start a0.pos.pos_start + else Int.compare a0.pos.pos_start a1.pos.pos_start + + let rev_pos_cli_order a0 a1 = pos_cli_order a1 a0 + + let doclang_subst ~subst (i : t) = function + | "docv" -> + let docv = if i.docv = "" then "VAL" else i.docv in + Some (strf "$(i,%s)" (Cmdliner_manpage.escape docv)) + | "opt" when is_opt i -> + Some (strf "$(b,%s)" (Cmdliner_manpage.escape (opt_name_sample i))) + | id -> + match env i with + | Some e -> Env.doclang_subst ~subst e id + | None -> subst id + + let styled_deprecated ~errs ~subst (i : t) = match i.deprecated with + | None -> "" | Some msg -> Cmdliner_manpage.doc_to_styled ~errs ~subst msg + + let styled_doc ~errs ~subst (i : t) = + Cmdliner_manpage.doc_to_styled ~errs ~subst i.doc + + let compare (a0 : t) (a1 : t) = Int.compare a0.id a1.id + module Map = Map.Make (struct type nonrec t = t let compare = compare end) + + (* Due to terms appearing in the completion API, we have an annoying + recursive type definition which we resolve here. Most of these + types do not belong this module. *) + + type term_escape = + [ `Error of bool * string + | `Help of Cmdliner_manpage.format * string option ] + + type 'a completion_directive = + | Message of string | String of string * string | Value of 'a * string + | Files | Dirs | Restart | Raw of string + + type ('ctx, 'a) completion_func = + 'ctx option -> token:string -> ('a completion_directive list, string) result + + type 'a parser = string -> ('a, string) result + type 'a complete = + | Complete : 'ctx term option * ('ctx, 'a) completion_func -> 'a complete + + and 'a completion = { complete : 'a complete } + + and 'a conv = + { docv : string; + parser : 'a parser; + pp : 'a Cmdliner_base.Fmt.t; + completion : 'a completion; } + + and e_conv = Conv : 'a conv -> e_conv + and arg_set = e_conv Map.t + and cmd = + { 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; (* Command arguments. *) + has_args : bool; (* [true] if has own parsing term. *) + children : cmd list; } (* Children, if any. *) + + and eval = (* information about the evaluation context. *) + { cmd : cmd; (* cmd being evaluated. *) + ancestors : cmd list; (* ancestors of cmd, root is last. *) + subcmds : cmd list; (* subcommands (if any) *) + env : string -> string option; (* environment variable lookup. *) + err_ppf : Format.formatter (* error formatter *) } + + and cline = cline_arg Map.t + and cline_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 + + and 'a term_parser = + eval -> cline -> ('a, [ `Parse of string | term_escape ]) result + + and 'a term = arg_set * 'a term_parser + + (* Sets of arguments stored as maps to their completion *) + + module Set = struct + include Map + type t = e_conv Map.t + let find_opt k m = try Some (Map.find k m) with Not_found -> None + let elements m = List.map fst (bindings m) + let union a b = + Map.merge (fun k v v' -> + match v, v' with + | Some v, _ | _, Some v -> Some v + | None, None -> assert false) a b + end +end + +(* Commands *) + +module Cmd_info = struct + type t = Arg_info.cmd + let make + ?deprecated ?(man_xrefs = [`Main]) ?(man = []) ?(envs = []) + ?(exits = Exit.defaults) ?(sdocs = Cmdliner_manpage.s_common_options) + ?(docs = Cmdliner_manpage.s_commands) ?(doc = "") ?version name : t + = + { name; version; deprecated; doc; docs; sdocs; exits; + envs; man; man_xrefs; args = Arg_info.Set.empty; + has_args = true; children = [] } + + let name (i : t) = i.name + let version (i : t) = i.version + let deprecated (i : t) = i.deprecated + let doc (i : t) = i.doc + let docs (i : t) = i.docs + let stdopts_docs (i : t) = i.sdocs + let exits (i : t) = i.exits + let envs (i : t) = i.envs + let man (i : t) = i.man + let man_xrefs (i : t) = i.man_xrefs + let args (i : t) = i.args + let has_args (i : t) = i.has_args + let children (i : t) = i.children + let add_args (i : t) args = { i with args = Arg_info.Set.union args i.args } + let with_children (i : t) ~args ~children = + let has_args, args = match args with + | None -> false, i.args + | Some args -> true, Arg_info.Set.union args i.args + in + { i with has_args; args; children } + + let styled_deprecated ~errs ~subst (i : t) = match i.deprecated with + | None -> "" | Some msg -> Cmdliner_manpage.doc_to_styled ~errs ~subst msg + + let styled_doc ~errs ~subst (i : t) = + Cmdliner_manpage.doc_to_styled ~errs ~subst i.doc + + let escaped_name (i : t) = Cmdliner_manpage.escape i.name +end + +(* Command lines *) + +module Cline = struct + type arg = Arg_info.cline_arg = + | O of (int * string * (string option)) list + | P of string list + + type t = Arg_info.cline + + let empty = Arg_info.Map.empty + let add = Arg_info.Map.add + let fold = Arg_info.Map.fold + let get_arg cline a : arg = + try Arg_info.Map.find a cline with Not_found -> assert false + + let get_opt_arg cline a = + match get_arg cline a with O l -> l | _ -> assert false + + let get_pos_arg cline a = + match get_arg cline a with P l -> l | _ -> assert false + + let actual_args cline a = match get_arg cline 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) + + (* Deprecations *) + + type deprecated = Arg_info.t * arg + + let deprecated ~env cline = + let add ~env info arg acc = + let deprecation_invoked = match (arg : arg) with + | O [] | P [] -> (* nothing on the cli for the argument *) + begin match Arg_info.env info with + | None -> false + | Some ienv -> + (* the parse uses the env var if defined which may be + deprecated *) + Option.is_some (Env.info_deprecated ienv) && + Option.is_some (env (Env.info_var ienv)) + end + | _ -> Option.is_some (Arg_info.deprecated info) + in + if deprecation_invoked then (info, arg) :: acc else acc + in + List.rev (fold (add ~env) cline []) + + let pp_deprecated ~subst ppf (info, arg) = + let open Cmdliner_base in + let plural l = if List.length l > 1 then "s" else "" in + let subst = Arg_info.doclang_subst ~subst info in + match (arg : arg) with + | O [] | P [] -> + let env = Option.get (Arg_info.env info) in + let msg = Env.styled_deprecated ~errs:ppf ~subst env in + Fmt.pf ppf "@[%a @[environment variable %a: %a@]@]" + Fmt.deprecated () Fmt.code (Env.info_var env) + Fmt.styled_text msg + | O os -> + let plural = plural os in + let names = List.map (fun (_, n, _) -> n) os in + let msg = Arg_info.styled_deprecated ~errs:ppf ~subst info in + Fmt.pf ppf "@[%a @[option%s %a: %a@]@]" + Fmt.deprecated () plural Fmt.(list ~sep:sp code_or_quote) names + Fmt.styled_text msg + | P args -> + let plural = plural args in + let msg = + Arg_info.styled_deprecated ~errs:ppf ~subst info + in + Fmt.pf ppf "@[%a @[argument%s %a: %a@]@]" + Fmt.deprecated () plural Fmt.(list ~sep:sp code_or_quote) args + Fmt.styled_text msg +end + +(* Evaluation *) + +module Eval = struct + type t = Arg_info.eval + + let make ~ancestors ~cmd ~subcmds ~env ~err_ppf : t = + { ancestors; cmd; subcmds; env; err_ppf } + + let cmd (i : t) = i.cmd + let ancestors (i : t) = i.ancestors + let subcmds (i : t) = i.subcmds + let env_var (i : t) v = i.env v + let err_ppf (i : t) = i.err_ppf + let main (i : t) = match List.rev i.ancestors with [] -> i.cmd | m :: _ -> m + let with_cmd (i : t) cmd = { i with cmd } + + let doclang_name n = strf "$(b,%s)" (Cmd_info.escaped_name n) + let doclang_names names = + strf "$(b,%s)" (Cmdliner_manpage.escape (String.concat " " names)) + + let doclang_subst (i : t) = function + | "tname" | "cmd.name" -> Some (doclang_name i.cmd) + | "mname" | "tool" -> Some (doclang_name (main i)) + | "cmd.parent" -> + let ancestors = ancestors i in + if ancestors = [] then Some (doclang_name (main i)) else + Some (doclang_names (List.rev_map Cmd_info.name ancestors)) + | "iname" | "cmd" -> + Some (doclang_names (List.rev_map Cmd_info.name (cmd i :: ancestors i))) + | _ -> None +end + +(* Terms *) + +module Term = struct + type escape = Arg_info.term_escape + type 'a parser = 'a Arg_info.term_parser + type 'a t = 'a Arg_info.term + let some (aset, parser) = + aset, (fun eval cline -> Result.map Option.some (parser eval cline)) +end + +module Arg_completion = struct + type 'a directive = 'a Arg_info.completion_directive = + | Message of string | String of string * string | Value of 'a * string + | Files | Dirs | Restart | Raw of string + + let value ?(doc = "") v = Value (v, doc) + let string ?(doc = "") s = String (s, doc) + let files = Files + let dirs = Dirs + let restart = Restart + let message msg = Message msg + let raw s = Raw s + + type ('ctx, 'a) func = + 'ctx option -> token:string -> ('a directive list, string) result + + type 'a complete = 'a Arg_info.complete = + | Complete : 'ctx Term.t option * ('ctx, 'a) func -> 'a complete + + type 'a t = 'a Arg_info.completion + + let make ?context func : 'a t = { complete = Complete (context, func) } + let complete (c : 'a t) = c.complete + + let complete_files : 'a t = + { complete = Complete (None, fun _ ~token:_ -> Ok [Files]) } + + let complete_dirs : 'a t = + { complete = Complete (None, fun _ ~token:_ -> Ok [Dirs]) } + + let complete_paths : 'a t = + { complete = Complete (None, fun _ ~token:_ -> Ok [Files; Dirs]) } + + let complete_restart : 'a t = + { complete = Complete (None, fun _ ~token:_ -> Ok [Restart]) } + + let complete_none : 'a t = + { complete = Complete (None, fun _ ~token:_ -> Ok []) } + + let directive_some : 'a directive -> 'a option directive = function + | Value (v, doc) -> Value (Some v, doc) + | (Message _ | String _ | Files | Dirs | Restart | Raw _ as v) -> v + + let complete_some (c : 'a t) : 'a option t = match c.complete with + | Complete (ctx, func) -> + let func ctx ~token = + let some_result directives = List.map directive_some directives in + Result.map some_result (func ctx ~token) + in + { complete = Complete (ctx, func) } +end + +(* Converters *) + +module Arg_conv = struct + type 'a parser = 'a Arg_info.parser + type 'a fmt = 'a Cmdliner_base.Fmt.t + type 'a t = 'a Arg_info.conv + + let make + ?(completion = Arg_completion.complete_none) ~docv ~parser ~pp () : 'a t = + { docv; parser; pp; completion } + + let of_conv ?completion ?docv ?parser ?pp (conv : 'a t) : 'a t + = + let completion = Option.value ~default:conv.completion completion in + let docv = Option.value ~default:conv.docv docv in + let parser = Option.value ~default:conv.parser parser in + let pp = Option.value ~default:conv.pp pp in + { docv; parser; pp; completion } + + let docv (c : 'a t) = c.docv + let parser (c : 'a t) = c.parser + let pp (c : 'a t) = c.pp + let completion (c : 'a t) = c.completion + + let none : 'a t = + { docv = ""; + parser = (fun _ -> assert false); + pp = (fun _ _ -> assert false); + completion = Arg_completion.complete_none } + + let some ?(none = "") conv = + let parser s = Result.map Option.some (parser conv s) in + let pp ppf v = match v with + | None -> Format.pp_print_string ppf none + | Some v -> pp conv ppf v + in + let completion = Arg_completion.complete_some (completion conv) in + { conv with parser; pp; completion } + + let some' ?none conv = + let parser s = Result.map Option.some (parser conv s) in + let pp ppf = function + | None -> (match none with None -> () | Some v -> (pp conv) ppf v) + | Some v -> pp conv ppf v + in + let completion = Arg_completion.complete_some conv.completion in + { conv with parser; pp; completion } +end + +(* Completion *) + +module Complete = struct + type kind = + | Opt_value of Arg_info.t + | Opt_name_or_pos_value of Arg_info.t + | Opt_name + + type t = + { token : string; + after_dashdash : bool; + subcmds : bool; (* Note this is adjusted in Cmdliner_eval *) + kind : kind } + + let make ?(after_dashdash = false) ?(subcmds = false) ~token kind = + { token; after_dashdash; subcmds; kind; } + + let token c = c.token + let after_dashdash c = c.after_dashdash + let subcmds c = c.subcmds + let kind c = c.kind + let add_subcmds c = { c with subcmds = true } +end diff --git a/src/core/cmdliner/cmdliner_def.mli b/src/core/cmdliner/cmdliner_def.mli new file mode 100644 index 00000000000..4d7e71f54c6 --- /dev/null +++ b/src/core/cmdliner/cmdliner_def.mli @@ -0,0 +1,304 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +(** Core definitions. *) + +(** 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 + val doclang_subst : + subst:Cmdliner_manpage.subst -> info -> Cmdliner_manpage.subst + (** [doclang_subst ~subst info] adds the substitution of [info] to + [subst]. *) +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 + val doclang_subst : + subst:Cmdliner_manpage.subst -> info -> Cmdliner_manpage.subst + (** [doclang_subst ~subst info] adds the substitution of [info] to + [subst]. *) + + val styled_deprecated : + errs:Format.formatter -> subst:Cmdliner_manpage.subst -> info -> string + + val styled_doc : + errs:Format.formatter -> subst:Cmdliner_manpage.subst -> info -> string + + module Set : Set.S with type elt = info +end + +(** Argument information. *) +module Arg_info : 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 make : + ?deprecated:string -> ?absent:string -> ?docs:string -> + ?doc_envs:Env.info list -> ?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 doc_envs : t -> Env.info list + 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 : docv:string -> absent:absence -> kind:opt_kind -> t -> t + val make_opt_all : docv:string -> absent:absence -> kind:opt_kind -> t -> t + val make_pos : docv:string -> pos:pos_kind -> t -> t + val make_pos_abs : docv:string -> 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 + + val doclang_subst : + subst:Cmdliner_manpage.subst -> t -> Cmdliner_manpage.subst + (** [doclang_subst ~subst info] adds the substitution of [info] to + [subst]. Note this includes the substitutions for [env] if present. *) + + val styled_deprecated : + errs:Format.formatter -> subst:Cmdliner_manpage.subst -> t -> string + + val styled_doc : + errs:Format.formatter -> subst:Cmdliner_manpage.subst -> t -> string + + type 'a conv + type e_conv = Conv : 'a conv -> e_conv + + module Set : sig + type arg := t + type t + val is_empty : t -> bool + val empty : t + val add : arg -> e_conv -> t -> t + val choose : t -> arg * e_conv + val partition : (arg -> e_conv -> bool) -> t -> t * t + val filter : (arg -> e_conv -> bool) -> t -> t + val iter : (arg -> e_conv -> unit) -> t -> unit + val singleton : arg -> e_conv -> t + val fold : (arg -> e_conv -> 'acc -> 'acc) -> t -> 'acc -> 'acc + val elements : t -> arg list + val union : t -> t -> t + val find_opt : arg -> t -> e_conv option + end +end + +(** Command information. *) +module Cmd_info : sig + type t + val make : + ?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_info.Set.t + val has_args : t -> bool + val children : t -> t list + val add_args : t -> Arg_info.Set.t -> t + val with_children : t -> args:Arg_info.Set.t option -> children:t list -> t + val styled_deprecated : + errs:Format.formatter -> subst:Cmdliner_manpage.subst -> t -> string + + val styled_doc : + errs:Format.formatter -> subst:Cmdliner_manpage.subst -> t -> string +end + +(** Untyped command line parses. *) +module Cline : sig + type arg = + | O of (int * string * (string option)) list (* (pos, name, value) of opt. *) + | P of string list (** *) + (** Unconverted argument data as found on the command line. *) + + type t (* command line, maps arg_infos to arg value. *) + val empty : t + val add : Arg_info.t -> arg -> t -> t + val get_arg : t -> Arg_info.t -> arg + val get_opt_arg : t -> Arg_info.t -> (int * string * (string option)) list + val get_pos_arg : t -> Arg_info.t -> string list + val actual_args : t -> Arg_info.t -> string list + (** Actual command line arguments from the command line *) + + val fold : (Arg_info.t -> arg -> 'b -> 'b) -> t -> 'b -> 'b + + (** {1:deprecations Deprecations} *) + + type deprecated + (** The type for deprecation invocations. This include both environment + variable deprecations and argument deprecations. *) + + val deprecated : + env:(string -> string option) -> t -> deprecated list + (** [deprecated ~env cli] are the deprecated invocations that occur + when parsing [cli]. *) + + val pp_deprecated : + subst:Cmdliner_manpage.subst -> deprecated Cmdliner_base.Fmt.t + (** [pp_deprecated] formats deprecations. *) +end + +(** Evaluation. *) +module Eval : sig + type t + val make : + ancestors:Cmd_info.t list -> cmd:Cmd_info.t -> subcmds:Cmd_info.t list -> + env:(string -> string option) -> err_ppf:Format.formatter -> t + + val cmd : t -> Cmd_info.t + val main : t -> Cmd_info.t + val ancestors : t -> Cmd_info.t list (* root is last *) + val subcmds : t -> Cmd_info.t list + val env_var : t -> string -> string option + val err_ppf : t -> Format.formatter + val with_cmd : t -> Cmd_info.t -> t + val doclang_subst : t -> Cmdliner_manpage.subst +end + +(** Terms, typed cli fragment definitions. *) +module Term : sig + type escape = + [ `Error of bool * string + | `Help of Cmdliner_manpage.format * string option ] + + type 'a parser = + Eval.t -> Cline.t -> ('a, [ `Parse of string | escape ]) result + + type 'a t = Arg_info.Set.t * 'a parser +end + +(** Completion strategies *) +module Arg_completion : sig + type 'a directive = + | Message of string | String of string * string | Value of 'a * string + | Files | Dirs | Restart | Raw of string + + val value : ?doc:string -> 'a -> 'a directive + val string : ?doc:string -> string -> 'a directive + val files : 'a directive + val dirs : 'a directive + val restart : 'a directive + val message : string -> 'a directive + val raw : string -> 'a directive + + type ('ctx, 'a) func = + 'ctx option -> token:string -> ('a directive list, string) result + + type 'a complete = + | Complete : 'ctx Term.t option * ('ctx, 'a) func -> 'a complete + + type 'a t + + val make : ?context:'ctx Term.t -> ('ctx, 'a) func -> 'a t + val complete : 'a t -> 'a complete + val complete_none : 'a t + val complete_files : 'a t + val complete_dirs : 'a t + val complete_paths : 'a t + val complete_restart : 'a t +end + +(** Textual OCaml value converters *) +module Arg_conv : sig + type 'a parser = string -> ('a, string) result + type 'a fmt = 'a Cmdliner_base.Fmt.t + type 'a t = 'a Arg_info.conv + val make : + ?completion:'a Arg_completion.t -> docv:string -> parser:'a parser -> + pp:'a fmt -> unit -> 'a t + + val of_conv : + ?completion:'a Arg_completion.t -> ?docv:string -> + ?parser:'a parser -> ?pp:'a fmt -> 'a t -> 'a t + + val docv : 'a t -> string + val parser : 'a t -> 'a parser + val pp : 'a t -> 'a fmt + val completion : 'a t -> 'a Arg_completion.t + + val some : ?none:string -> 'a t -> 'a option t + val some' : ?none:'a -> 'a t -> 'a option t + + val none : 'a t +end + +(** Complete instruction. *) +module Complete : sig + type kind = + | Opt_value of Arg_info.t + | Opt_name_or_pos_value of Arg_info.t + | Opt_name + + type t + val make : ?after_dashdash:bool -> ?subcmds:bool -> token:string -> kind -> t + val token : t -> string + val after_dashdash : t -> bool + val subcmds : t -> bool + val kind : t -> kind + val add_subcmds : t -> t +end diff --git a/src/core/cmdliner/cmdliner_docgen.ml b/src/core/cmdliner/cmdliner_docgen.ml index 3a36df5c4b9..ef49a211af1 100644 --- a/src/core/cmdliner/cmdliner_docgen.ml +++ b/src/core/cmdliner/cmdliner_docgen.ml @@ -7,7 +7,7 @@ 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 + match Cmdliner_def.Arg_info.is_opt a0, Cmdliner_def.Arg_info.is_opt a1 with | true, true -> (* optional by name *) let key names = let k = List.hd (List.sort rev_compare names) in @@ -15,17 +15,16 @@ let order_args a0 a1 = 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) + (key @@ Cmdliner_def.Arg_info.opt_names a0) + (key @@ Cmdliner_def.Arg_info.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) + (String.lowercase_ascii @@ Cmdliner_def.Arg_info.docv a0) + (String.lowercase_ascii @@ Cmdliner_def.Arg_info.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. @@ -45,49 +44,19 @@ let sorted_items_to_blocks ~boilerplate:b items = | [] -> [] | (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 +let invocation ?(sep = " ") ?(ancestors = []) cmd = + let names = List.rev_map Cmdliner_def.Cmd_info.name (cmd :: ancestors) 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 = match Cmdliner_def.Arg_info.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 + let v = + (if Cmdliner_def.Arg_info.is_req a then strf "%s" else strf "[%s]") v + in + match Cmdliner_def.Arg_info.(pos_len @@ pos_kind a) with | None -> v ^ "…" | Some 1 -> v | Some n -> @@ -95,68 +64,84 @@ let synopsis_pos_arg a = 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 -> + let var = match Cmdliner_def.Arg_info.docv a with "" -> "VAL" | v -> v in + match Cmdliner_def.Arg_info.opt_kind a with + | Cmdliner_def.Arg_info.Flag -> strf "$(b,%s)" (esc n) + | Cmdliner_def.Arg_info.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 _ -> + | Cmdliner_def.Arg_info.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 +let deprecated cmd = match Cmdliner_def.Cmd_info.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 synopsis ?(show_help = false) ?ancestors cmd = + let show_help = if show_help then " [$(b,--help)]" else "" in + match Cmdliner_def.Cmd_info.children cmd with + | [] -> + let rev_cli_order (a0, _) (a1, _) = + Cmdliner_def.Arg_info.rev_pos_cli_order a0 a1 + in + let args = Cmdliner_def.Cmd_info.args cmd in + let oargs, pargs = + Cmdliner_def.Arg_info.(Set.partition (fun a _ -> is_opt a) 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)) + Cmdliner_def.Arg_info.docs a = Cmdliner_manpage.s_options && + not (List.exists drop_names (Cmdliner_def.Arg_info.opt_names a)) + in + let oargs = Cmdliner_def.Arg_info.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 = + let syn = + synopsis_opt_arg a (Cmdliner_def.Arg_info.opt_name_sample a) + in + if Cmdliner_def.Arg_info.is_req a + then syn + else strf "[%s]" syn + 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 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)) + let pargs = + let pargs = Cmdliner_def.Arg_info.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 - 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 + strf "%s$(b,%s)%s %s%s" + (deprecated cmd) (invocation ?ancestors cmd) show_help oargs pargs + | _cmds -> + let subcmd = match Cmdliner_def.Cmd_info.has_args cmd with + | false -> "$(i,COMMAND)" | true -> "[$(i,COMMAND)]" + in + strf "%s$(b,%s)%s %s …" (deprecated cmd) (invocation ?ancestors cmd) + show_help subcmd + +let cmd_doc cmd = + let depr = match Cmdliner_def.Cmd_info.deprecated cmd with + | None -> "" | Some msg -> msg ^ " " + in + depr ^ Cmdliner_def.Cmd_info.doc cmd -let cmd_docs ei = match Cmdliner_info.(Cmd.children (Eval.cmd ei)) with +let cmd_docs ei = match Cmdliner_def.(Cmd_info.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 + (Cmdliner_def.Cmd_info.docs cmd, `I (syn, cmd_doc cmd)) :: acc in let by_sec_by_rev_name (s0, `I (c0, _)) (s1, `I (c1, _)) = let c = compare s0 s1 in @@ -170,36 +155,36 @@ let cmd_docs ei = match Cmdliner_info.(Cmd.children (Eval.cmd ei)) with (* 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) + let s = match Cmdliner_def.Arg_info.is_pos a with + | true -> strf "$(i,%s)" (esc @@ Cmdliner_def.Arg_info.docv a) | false -> - let names = List.sort compare (Cmdliner_info.Arg.opt_names a) in + let names = List.sort compare (Cmdliner_def.Arg_info.opt_names a) in String.concat ", " (List.rev_map (synopsis_opt_arg a) names) in - match Cmdliner_info.Arg.deprecated a with + match Cmdliner_def.Arg_info.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 + let subst = Cmdliner_def.Arg_info.doclang_subst ~subst a in + let or_env ~value a = match Cmdliner_def.Arg_info.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) + strf "%s $(b,%s) env" value (esc @@ Cmdliner_def.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 absent = match Cmdliner_def.Arg_info.absent a with + | Cmdliner_def.Arg_info.Err -> "required" + | Cmdliner_def.Arg_info.Doc "" -> strf "%s" (or_env ~value:false a) + | Cmdliner_def.Arg_info.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 -> + | Cmdliner_def.Arg_info.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) + let optvopt = match Cmdliner_def.Arg_info.opt_kind a with + | Cmdliner_def.Arg_info.Opt_vopt v -> strf "default=$(b,%s)" (esc v) | _ -> "" in let argvdoc = match optvopt, absent with @@ -207,28 +192,36 @@ let arg_to_man_item ~errs ~subst ~buf a = | s, "" | "", s -> strf " (%s)" s | s, s' -> strf " (%s) (%s)" s s' in - let doc = Cmdliner_info.Arg.doc a in + let deprecated = match Cmdliner_def.Arg_info.deprecated a with + | None -> "" | Some msg -> msg ^ " " + in + let doc = deprecated ^ Cmdliner_def.Arg_info.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)) + (Cmdliner_def.Arg_info.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 + let c = compare + (Cmdliner_def.Arg_info.docs a0) + (Cmdliner_def.Arg_info.docs a1) + in if c <> 0 then c else let c = - match Cmdliner_info.Arg.deprecated a0, Cmdliner_info.Arg.deprecated a1 + match + Cmdliner_def.Arg_info.deprecated a0, + Cmdliner_def.Arg_info.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 = "")) + let keep_arg a _ acc = + if not Cmdliner_def.Arg_info.(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 = Cmdliner_def.Cmd_info.args @@ Cmdliner_def.Eval.cmd ei in + let args = Cmdliner_def.Arg_info.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 @@ -241,16 +234,16 @@ let exit_boilerplate sec = match sec = Cmdliner_manpage.s_exit_status with 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 add_exit_item acc einfo = + let subst = Cmdliner_def.Exit.doclang_subst ~subst einfo in + let min, max = Cmdliner_def.Exit.info_codes einfo in + let doc = Cmdliner_def.Exit.info_doc einfo 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 + (Cmdliner_def.Exit.info_docs einfo, 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 = Cmdliner_def.Cmd_info.exits @@ Cmdliner_def.Eval.cmd ei in + let exits = List.sort Cmdliner_def.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 @@ -264,31 +257,38 @@ let env_boilerplate sec = match sec = Cmdliner_manpage.s_environment with 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 + if Cmdliner_def.Env.Set.mem e seen then acc else + let seen = Cmdliner_def.Env.Set.add e seen in + let var = strf "$(b,%s)" @@ esc (Cmdliner_def.Env.info_var e) in + let var, deprecated = match Cmdliner_def.Env.info_deprecated e with + | None -> var, "" | Some msg -> "(Deprecated) " ^ var, msg ^ " " in + let doc = deprecated ^ Cmdliner_def.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 + let envs = (Cmdliner_def.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 + let add_arg_envs a _ acc = + let envs = Cmdliner_def.Arg_info.doc_envs a in + let envs = match Cmdliner_def.Arg_info.env a with + | None -> envs | Some e -> e :: envs + in + let subst = Cmdliner_def.Arg_info.doclang_subst ~subst a in + List.fold_left (add_env_item ~subst) acc envs + in + let add_env acc e = + let subst = Cmdliner_def.Env.doclang_subst ~subst e in + add_env_item ~subst 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 args = Cmdliner_def.Cmd_info.args @@ Cmdliner_def.Eval.cmd ei in + let tenvs = Cmdliner_def.Cmd_info.envs @@ Cmdliner_def.Eval.cmd ei in + let init = Cmdliner_def.Env.Set.empty, [] in + let acc = Cmdliner_def.Arg_info.Set.fold add_arg_envs 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 @@ -298,22 +298,22 @@ let env_docs ~errs ~subst ~buf ~has_senv ei = (* xref doc *) let xref_docs ~errs ei = - let main = Cmdliner_info.Eval.main ei in + let main = Cmdliner_def.Eval.main ei in let to_xref = function - | `Main -> Cmdliner_info.Cmd.name main, 1 + | `Main -> Cmdliner_def.Cmd_info.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 + let cmds = Cmdliner_def.Cmd_info.children main in + let mname = Cmdliner_def.Cmd_info.name main in + let is_cmd cmd = Cmdliner_def.Cmd_info.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 + let xrefs = Cmdliner_def.Cmd_info.man_xrefs @@ Cmdliner_def.Eval.cmd ei in + let xrefs = match main == Cmdliner_def.Eval.cmd ei with | true -> List.filter (fun x -> x <> `Main) xrefs (* filter out default *) | false -> xrefs in @@ -326,24 +326,24 @@ let xref_docs ~errs ei = 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 cmd = Cmdliner_def.Eval.cmd ei in + let ancestors = Cmdliner_def.Eval.ancestors ei in + let tname = (deprecated cmd) ^ invocation ~sep:"-" ~ancestors cmd in + let tdoc = 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 + let cmd = Cmdliner_def.Eval.cmd ei in + let ancestors = Cmdliner_def.Eval.ancestors ei in + let synopsis = `P (synopsis ~ancestors 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 subst = Cmdliner_def.Eval.doclang_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 @@ -355,7 +355,7 @@ let insert_cmd_man_docs ~errs ei sm = sm let text ~errs ei = - let man = Cmdliner_info.Cmd.man @@ Cmdliner_info.Eval.cmd ei in + let man = Cmdliner_def.Cmd_info.man @@ Cmdliner_def.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 @@ -363,14 +363,14 @@ let text ~errs ei = 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 main = Cmdliner_def.Eval.main ei in + let exec = String.capitalize_ascii (Cmdliner_def.Cmd_info.name main) in + let cmd = Cmdliner_def.Eval.cmd ei in + let ancestors = Cmdliner_def.Eval.ancestors ei in + let name = String.uppercase_ascii (invocation ~sep:"-" ~ancestors cmd) in let center_header = esc @@ strf "%s Manual" exec in let left_footer = - let version = match Cmdliner_info.Cmd.version main with + let version = match Cmdliner_def.Cmd_info.version main with | None -> "" | Some v -> " " ^ v in esc @@ strf "%s%s" exec version @@ -379,17 +379,15 @@ let title ei = 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) +let pp_man ~env ~errs fmt ppf ei = + let subst = Cmdliner_def.Eval.doclang_subst ei in + Cmdliner_manpage.print ~env ~errs ~subst 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 +let styled_usage_synopsis ~errs ei = + let subst = Cmdliner_def.Eval.doclang_subst ei in + let cmd = Cmdliner_def.Eval.cmd ei in + let ancestors = Cmdliner_def.Eval.ancestors ei in + let synopsis = synopsis ~show_help:true ~ancestors cmd in + Cmdliner_manpage.doc_to_styled ~errs ~subst synopsis diff --git a/src/core/cmdliner/cmdliner_docgen.mli b/src/core/cmdliner/cmdliner_docgen.mli index e57929d0539..7e37ffec422 100644 --- a/src/core/cmdliner/cmdliner_docgen.mli +++ b/src/core/cmdliner/cmdliner_docgen.mli @@ -4,8 +4,9 @@ ---------------------------------------------------------------------------*) val pp_man : + env:(string -> string option) -> errs:Format.formatter -> Cmdliner_manpage.format -> Format.formatter -> - Cmdliner_info.Eval.t -> unit + Cmdliner_def.Eval.t -> unit -val pp_plain_synopsis : - errs:Format.formatter -> Format.formatter -> Cmdliner_info.Eval.t -> unit +val styled_usage_synopsis : + errs:Format.formatter -> Cmdliner_def.Eval.t -> string diff --git a/src/core/cmdliner/cmdliner_eval.ml b/src/core/cmdliner/cmdliner_eval.ml index e4b50be10a1..1227899fbc8 100644 --- a/src/core/cmdliner/cmdliner_eval.ml +++ b/src/core/cmdliner/cmdliner_eval.ml @@ -5,231 +5,296 @@ 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 ] +type 'a eval_exit = [ `Ok of 'a | `Exit of Cmdliner_def.Exit.code ] + +type eval_result_error = + [ Cmdliner_term.term_escape + | `Exn of exn * Printexc.raw_backtrace + | `Parse of string + | `Std_help of Cmdliner_manpage.format + | `Std_version ] + +type 'a eval_result = + ('a, [ eval_result_error + | `Complete of Cmdliner_def.Complete.t * Cmdliner_def.Cline.t]) result 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 add_stdopts eval = + let docs = Cmdliner_def.Cmd_info.stdopts_docs (Cmdliner_def.Eval.cmd eval) in let vargs, vers = - match Cmdliner_info.Cmd.version @@ Cmdliner_info.Eval.main ei with - | None -> Cmdliner_info.Arg.Set.empty, None + match Cmdliner_def.Cmd_info.version (Cmdliner_def.Eval.main eval) with + | None -> Cmdliner_def.Arg_info.Set.empty, None | Some _ -> - let args, _ as vers = Cmdliner_arg.stdopt_version ~docs in - args, Some vers + let vers = Cmdliner_arg.stdopt_version ~docs in + (Cmdliner_term.argset vers), 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 args = + Cmdliner_def.Arg_info.Set.union vargs (Cmdliner_term.argset help) + in + let cmd = Cmdliner_def.Cmd_info.add_args (Cmdliner_def.Eval.cmd eval) args in + help, vers, Cmdliner_def.Eval.with_cmd eval cmd -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 run_parser ~catch eval cl f = + try (f eval cl :> ('a, eval_result_error) 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 +let try_eval_stdopts ~catch eval cline help version : 'a eval_result option = + match run_parser ~catch eval cline (Cmdliner_term.parser help) with | Ok (Some fmt) -> Some (Error (`Std_help fmt)) - | Error _ as err -> Some err + | Error (`Parse _) -> + (* only [FMT] errored, there was a `--help`, show help anyways *) + Some (Error (`Std_help `Auto)) + | Error _ as err -> (Some err :> 'a eval_result option) | Ok None -> match version with | None -> None | Some version -> - match run_parser ~catch ei cl (snd version) with + match (run_parser ~catch eval cline (Cmdliner_term.parser version)) + with | Ok false -> None | Ok true -> Some (Error (`Std_version)) - | Error _ as err -> Some err + | Error _ as err -> (Some err :> 'a eval_result option) -let do_help help_ppf err_ppf ei fmt cmd = - let ei = match cmd with +let do_help ~env help_ppf err_ppf eval fmt cmd_name = + let eval = match cmd_name 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 + let cmd = Cmdliner_def.Eval.main eval in + let subcmds = Cmdliner_def.Eval.subcmds eval in + let eval' = + Cmdliner_def.Eval.make ~ancestors:[] ~cmd ~subcmds ~env ~err_ppf + in + begin match Cmdliner_def.Eval.ancestors eval with + | [] -> (* [ei] is an evaluation of main, [cmd] has stdopts *) eval' + | _ -> let _, _, eval' = add_stdopts eval' in eval' 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 main = Cmdliner_def.Eval.main eval in + let is_cmd t = Cmdliner_def.Cmd_info.name t = cmd in + let children = Cmdliner_def.Cmd_info.children main in let cmd = List.find is_cmd children in - let _, _, ei = add_stdopts (Cmdliner_info.Eval.with_cmd ei cmd) in - ei + let _, _, eval = add_stdopts (Cmdliner_def.Eval.with_cmd eval cmd) in + eval with Not_found -> invalid_arg (err_help cmd) in - Cmdliner_docgen.pp_man ~errs:err_ppf fmt help_ppf ei + Cmdliner_docgen.pp_man ~env ~errs:err_ppf fmt help_ppf eval -let do_result help_ppf err_ppf ei = function +let do_result ~env help_ppf err_ppf eval = 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 + Cmdliner_docgen.pp_man ~env ~errs:err_ppf fmt help_ppf eval; Ok `Help | `Std_version -> - Cmdliner_msg.pp_version help_ppf ei; Ok `Version + Cmdliner_msg.pp_version help_ppf eval; 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) + Cmdliner_msg.pp_usage_and_err err_ppf eval ~err; Error `Parse + | `Complete (comp, cline) -> + Cmdliner_completion.output ~out_ppf:help_ppf ~err_ppf eval comp cline; + Ok `Help + | `Help (fmt, cmd_name) -> + do_help ~env help_ppf err_ppf eval fmt cmd_name; Ok `Help + | `Exn (e, bt) -> + Cmdliner_msg.pp_backtrace err_ppf eval 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 + then Cmdliner_msg.pp_usage_and_err err_ppf eval ~err + else Cmdliner_msg.pp_err err_ppf eval ~err); + Error `Term -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 do_deprecated_msgs ~env err_ppf cl eval = + let cmd_info = Cmdliner_def.Eval.cmd eval in + let deprecated = Cmdliner_def.Cline.deprecated ~env cl in + match Cmdliner_def.Cmd_info.deprecated cmd_info, deprecated with + | None, [] -> () + | depr_cmd, deprs -> + let open Cmdliner_base in + let pp_sep ppf () = + if Option.is_some depr_cmd && deprs <> [] then Fmt.cut ppf (); + in + let subst = Cmdliner_def.Eval.doclang_subst eval in + let pp_cmd_msg ppf cmd = + match + Cmdliner_def.Cmd_info.styled_deprecated ~subst ~errs:err_ppf cmd + with + | "" -> () + | msg -> + let name = Cmdliner_def.Cmd_info.name cmd in + Fmt.pf ppf "@[%a command %a:@[ %a@]@]" + Fmt.deprecated () Fmt.code_or_quote name Fmt.styled_text msg + in + let pp_deprs = Fmt.list (Cmdliner_def.Cline.pp_deprecated ~subst) in + Fmt.pf err_ppf "@[%a @[%a%a%a@]@]@." + Cmdliner_msg.pp_exec_msg eval pp_cmd_msg cmd_info + pp_sep () pp_deprs deprs -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 +let find_cmd_and_parser ~legacy_prefixes ~for_completion args cmd = + (* This finds the command to use if it's a group and [for_completion] + is [true] whether we may need to add the subcommand names to the + completions. *) + let stop ~ancestors ~cmd args = match (cmd : 'a Cmdliner_cmd.t) with + | Cmd (_, parser) -> ancestors, cmd, args, Ok parser + | Group (_, (Some parser, _)) -> ancestors, cmd, args, Ok parser + | Group (_, (None, children)) -> + let dom = Cmdliner_cmd.list_names children in + let err = Cmdliner_msg.err_cmd_missing ~dom in + let try_stdopts = true in + ancestors, cmd, args, Error (`Parse (try_stdopts, 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 rec loop ~ancestors ~current_cmd = function + | "--" :: _ | [] as args -> stop ~ancestors ~cmd:current_cmd args + | arg :: _ as args when for_completion && + Cmdliner_cline.has_complete_prefix arg -> + begin match current_cmd with + | Cmd _ -> (* arg completion *) stop ~ancestors ~cmd:current_cmd args + | Group (_, (parser, _)) -> + let is_opt = Cmdliner_cline.(is_opt (get_token_to_complete arg)) in + if not is_opt then ancestors, current_cmd, args, Error `Complete else + stop ~ancestors ~cmd:current_cmd args + end + | arg :: _ as args when Cmdliner_cline.is_opt arg -> + stop ~ancestors ~cmd:current_cmd args + | arg :: rest as args -> + match current_cmd with + | Cmd (i, parser) -> ancestors, current_cmd, args, Ok parser + | Group (i, (_, children)) -> + let cmd_index = Cmdliner_cmd.name_trie children in + match Cmdliner_trie.find ~legacy_prefixes cmd_index arg with + | Ok cmd -> loop ~ancestors:(i :: ancestors) ~current_cmd:cmd rest + | Error `Not_found -> + let all = Cmdliner_trie.ambiguities cmd_index "" in let hints = Cmdliner_base.suggest arg all in - let dom = cmd_name_dom children in + let dom = Cmdliner_cmd.list_names 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 try_stdopts = + (* When one writes [cmd no_such_cmd --help] it's better + to show the unknown command error message rather + than get into the help of the parent command. Otherwise + one gets confused into thinking the command exists and/or + annoyed not to be reading the right man page. *) + false + in + ancestors, current_cmd, args, Error (`Parse (try_stdopts, err)) + | Error `Ambiguous (* Only on legacy prefixes *) -> + let ambs = Cmdliner_trie.ambiguities cmd_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 + let try_stdopts = false in + ancestors, current_cmd, args, Error (`Parse (try_stdopts, 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 + loop ~ancestors:[] ~current_cmd:cmd args -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 cli_args_of_argv argv = match Array.to_list argv with +| exec :: "--__complete" :: args -> true, args +| exec :: args -> false, args +| [] -> invalid_arg err_argv let eval_value ?help:(help_ppf = Format.std_formatter) ?err:(err_ppf = Format.err_formatter) - ?(catch = true) ?(env = env_default) ?(argv = Sys.argv) cmd + ?(catch = true) ?(env = Sys.getenv_opt) ?(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)) + let legacy_prefixes = Cmdliner_trie.legacy_prefixes ~env in + let for_completion, args = cli_args_of_argv argv in + let ancestors, cmd, args, parser = + find_cmd_and_parser ~legacy_prefixes ~for_completion args cmd + in + let help, version, eval = + let subcmds = Cmdliner_cmd.get_children_infos cmd in + let cmd = Cmdliner_cmd.get_info cmd in + let eval = Cmdliner_def.Eval.make ~ancestors ~cmd ~subcmds ~env ~err_ppf in + add_stdopts eval + in + let cline = + let args_info = Cmdliner_def.Cmd_info.args (Cmdliner_def.Eval.cmd eval) in + Cmdliner_cline.create ~legacy_prefixes ~for_completion args_info args + in + let res = match parser with + | Error (`Parse (try_stdopts, msg)) -> + (* Command lookup error, we may still prioritize stdargs *) + begin match cline with + | `Complete c -> Error (`Complete c) + | `Error (_, cl) | `Ok cl -> + let stdopts = + if try_stdopts + then try_eval_stdopts ~catch eval cl help version else None + in + begin match stdopts with + | None -> Error (`Error (true, msg)) + | Some e -> e + end end - | Ok () -> - match Cmdliner_cline.create term_args args with - | Error (e, cl) -> - begin match try_eval_stdopts ~catch ei cl help version with + | Error `Complete -> + begin match cline with + | `Complete (comp, cline) -> + let comp = Cmdliner_def.Complete.add_subcmds comp in + Error (`Complete (comp, cline)) + | `Ok _ | `Error _ -> assert false + end + | Ok parser -> + begin match cline with + | `Complete c -> Error (`Complete c) + | `Error (e, cl) -> + begin match try_eval_stdopts ~catch eval 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 + | `Ok cl -> + match try_eval_stdopts ~catch eval cl help version with | Some e -> e | None -> - do_deprecated_msgs err_ppf cl ei; - run_parser ~catch ei cl f + do_deprecated_msgs ~env err_ppf cl eval; + (run_parser ~catch eval cl parser :> 'a eval_result) + end in - do_result help_ppf err_ppf ei res + do_result ~env help_ppf err_ppf eval res let eval_peek_opts - ?(version_opt = false) ?(env = env_default) ?(argv = Sys.argv) t + ?(version_opt = false) ?(env = Sys.getenv_opt) ?(argv = Sys.argv) t : 'a option * ('a eval_ok, eval_error) result = - let args, f = t in + let legacy_prefixes = Cmdliner_trie.legacy_prefixes ~env in + let for_completion, args = cli_args_of_argv argv 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 + let cmd_info, parser = + let args, parser = Cmdliner_term.argset t, Cmdliner_term.parser t in + let cmd_info = Cmdliner_def.Cmd_info.make ?version "dummy" in + Cmdliner_def.Cmd_info.add_args cmd_info args, parser + in + let help, version, eval = + let err_ppf = Format.make_formatter (fun _ _ _ -> ()) (fun () -> ()) in + let ancestors = [] and cmd = cmd_info and subcmds = [] in + let eval = Cmdliner_def.Eval.make ~ancestors ~cmd ~subcmds ~env ~err_ppf in + add_stdopts eval + in + let cline = + let arg_infos = Cmdliner_def.Cmd_info.args (Cmdliner_def.Eval.cmd eval) in + Cmdliner_cline.create + ~peek_opts:true ~legacy_prefixes ~for_completion arg_infos args + in + let v, ret = match cline with + | `Complete comp -> None, (Error (`Complete comp)) + | `Error (e, cl) -> + begin match try_eval_stdopts ~catch:true eval cl help version with + | Some e -> None, e + | None -> None, Error (`Error (true, e)) + end + | `Ok cl -> + let ret = run_parser ~catch:true eval cl parser in + let v = match ret with Ok v -> Some v | Error _ -> None in + begin match try_eval_stdopts ~catch:true eval cl help version with + | Some e -> v, e + | None -> v, (ret :> 'a eval_result) + end in let ret = match ret with | Ok v -> Ok (`Ok v) @@ -237,16 +302,17 @@ let eval_peek_opts | Error `Std_version -> Ok `Version | Error `Parse _ -> Error `Parse | Error `Help _ -> Ok `Help + | Error `Complete _ -> 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 +let exit_status_of_result ?(term_err = Cmdliner_def.Exit.cli_error) = function +| Ok (`Ok _ | `Help | `Version) -> Cmdliner_def.Exit.ok | Error `Term -> term_err -| Error `Parse -> Cmdliner_info.Exit.cli_error -| Error `Exn -> Cmdliner_info.Exit.internal_error +| Error `Parse -> Cmdliner_def.Exit.cli_error +| Error `Exn -> Cmdliner_def.Exit.internal_error let eval_value' ?help ?err ?catch ?env ?argv ?term_err cmd = match eval_value ?help ?err ?catch ?env ?argv cmd with @@ -262,15 +328,16 @@ let eval' ?help ?err ?catch ?env ?argv ?term_err cmd = | 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 pp_err ppf cmd ~msg = + (* Here instead of Cmdliner_msgs to avoid circular dep *) let name = Cmdliner_cmd.name cmd in - Format.fprintf ppf "%s: @[%a@]@." name Cmdliner_base.pp_lines msg + Cmdliner_base.Fmt.pf ppf "%s: @[%a@]@." name Cmdliner_base.Fmt.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 + | Ok (`Ok (Error msg)) -> pp_err err cmd ~msg; Cmdliner_def.Exit.some_error | r -> exit_status_of_result ?term_err r let eval_result' @@ -278,5 +345,5 @@ let eval_result' = 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 + | Ok (`Ok (Error msg)) -> pp_err err cmd ~msg; Cmdliner_def.Exit.some_error | r -> exit_status_of_result ?term_err r diff --git a/src/core/cmdliner/cmdliner_eval.mli b/src/core/cmdliner/cmdliner_eval.mli index 27194b80f6b..882f6cc8e9a 100644 --- a/src/core/cmdliner/cmdliner_eval.mli +++ b/src/core/cmdliner/cmdliner_eval.mli @@ -5,11 +5,9 @@ (** 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 ] +type 'a eval_exit = [ `Ok of 'a | `Exit of Cmdliner_def.Exit.code ] val eval_value : ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> @@ -29,22 +27,22 @@ val eval_peek_opts : 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 + ?term_err:int -> unit Cmdliner_cmd.t -> Cmdliner_def.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 + ?term_err:int -> int Cmdliner_cmd.t -> Cmdliner_def.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 + ?term_err:Cmdliner_def.Exit.code -> (unit, string) result Cmdliner_cmd.t -> + Cmdliner_def.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 + ?term_err:Cmdliner_def.Exit.code -> + (Cmdliner_def.Exit.code, string) result Cmdliner_cmd.t -> + Cmdliner_def.Exit.code diff --git a/src/core/cmdliner/cmdliner_info.ml b/src/core/cmdliner/cmdliner_info.ml deleted file mode 100644 index 561a60e51c8..00000000000 --- a/src/core/cmdliner/cmdliner_info.ml +++ /dev/null @@ -1,225 +0,0 @@ -(*--------------------------------------------------------------------------- - 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/core/cmdliner/cmdliner_info.mli b/src/core/cmdliner/cmdliner_info.mli deleted file mode 100644 index 76ea15bc8e3..00000000000 --- a/src/core/cmdliner/cmdliner_info.mli +++ /dev/null @@ -1,139 +0,0 @@ -(*--------------------------------------------------------------------------- - 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/core/cmdliner/cmdliner_manpage.ml b/src/core/cmdliner/cmdliner_manpage.ml index 63c12b2c902..51ed48bc2a9 100644 --- a/src/core/cmdliner/cmdliner_manpage.ml +++ b/src/core/cmdliner/cmdliner_manpage.ml @@ -5,8 +5,10 @@ (* Manpages *) +type section_name = string + type block = - [ `S of string | `P of string | `Pre of string | `I of string * string + [ `S of section_name | `P of string | `Pre of string | `I of string * string | `Noblank | `Blocks of block list ] type title = string * int * string * string * string @@ -26,11 +28,11 @@ 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_exit_status_intro = `P "$(cmd) exits with:" let s_environment = "ENVIRONMENT" let s_environment_intro = - `P "These environment variables affect the execution of $(iname):" + `P "These environment variables affect the execution of $(cmd):" let s_files = "FILES" let s_examples = "EXAMPLES" @@ -135,16 +137,11 @@ let smap_append_block smap ~sec b = (* 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 +module Fmt = Cmdliner_base.Fmt (* Cmdliner markup handling *) -let err e fmt = pf e ("cmdliner error: " ^^ fmt ^^ "@.") +let err e fmt = 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 @@ -263,7 +260,7 @@ let add_markup_text ~errs k b s start target_need_escape target_escape = (* Plain text output *) -let markup_to_plain ~errs b s = +let markup_to_plain ~styled ~errs b s = let max_i = String.length s - 1 in let flush start stop = match start > max_i with | true -> () @@ -271,7 +268,8 @@ let markup_to_plain ~errs b s = in let need_escape _ = false in let escape _ _ = assert false in - let rec loop start i = + let rec end_text start i = Buffer.add_string b "\x1B[m"; 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 @@ -287,11 +285,23 @@ let markup_to_plain ~errs b s = 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) + if not (is_markup_dir markup) + then (err_markup ~errs markup s; loop start next) else begin + flush start (i - 1); + if not styled then + add_markup_text ~errs loop b s start_data need_escape escape + else + begin + begin match markup with + | 'i' -> Buffer.add_string b "\x1B[04m"; + | 'b' -> Buffer.add_string b "\x1B[01m" + | _ -> assert false + end; + add_markup_text ~errs end_text b s start_data + need_escape escape + end + end | _ -> err_malformed ~errs s; loop start next end @@ -304,7 +314,13 @@ let markup_to_plain ~errs b s = (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) + markup_to_plain ~styled:false ~errs b (subst_vars ~errs ~subst b s) + +let doc_to_styled ?buffer:(b = Buffer.create 255) ~errs ~subst s = + let styled = Cmdliner_base.Fmt.styler () = Cmdliner_base.Fmt.Ansi in + markup_to_plain ~styled ~errs b (subst_vars ~errs ~subst b s) + + let p_indent = 7 (* paragraph indentation. *) let l_indent = 4 (* label indentation. *) @@ -312,7 +328,7 @@ 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 pp_tokens ppf t = Fmt.tokens ~spaces:true ppf t in let rec blank_line = function | `Noblank :: ts -> loop ts | ts -> Format.pp_print_cut ppf (); loop ts @@ -323,30 +339,31 @@ let pp_plain_blocks ~errs subst ppf ts = | `Noblank -> loop ts | `Blocks bs -> loop (bs @ ts) | `P s -> - pf ppf "%a@[%a@]@," pp_indent p_indent pp_tokens (markup s); + Fmt.pf ppf "%a@[%a@]@," Fmt.indent p_indent pp_tokens (markup s); blank_line ts - | `S s -> pf ppf "@[%a@]@," pp_tokens (markup s); loop ts + | `S s -> Fmt.pf ppf "@[%a@]@," pp_tokens (markup s); loop ts | `Pre s -> - pf ppf "%a@[%a@]@," pp_indent p_indent pp_lines (markup s); + Fmt.pf ppf "%a@[%a@]@," Fmt.indent p_indent Fmt.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; + Fmt.pf ppf "@[%a@[%a@]" Fmt.indent p_indent pp_tokens label; begin match s with - | "" -> pf ppf "@]@," + | "" -> Fmt.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) + then (Fmt.pf ppf "%a@[%a@]@]@," + Fmt.indent (l_indent - ll) pp_tokens s) + else (Fmt.pf ppf "@\n%a@[%a@]@]@," + Fmt.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 + Fmt.pf ppf "@[%a@]" (pp_plain_blocks ~errs subst) text (* Groff output *) @@ -357,7 +374,10 @@ let markup_to_groff ~errs b s = | 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 escape b = function + | '-' -> Printf.bprintf b "\\-" (* Make man-db and debian tools happy *) + | 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 @@ -400,20 +420,21 @@ let doc_to_groff ~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 pp_tokens ppf t = Fmt.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" + | `P s -> Fmt.pf ppf "@\n.P@\n%a" pp_tokens (markup s) + | `Pre s -> Fmt.pf ppf "@\n.P@\n.nf@\n%a@\n.fi" Fmt.lines (markup s) + | `S s -> Fmt.pf ppf "@\n.SH %a" pp_tokens (markup s) + | `Noblank -> Fmt.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) + Fmt.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\ + Fmt.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\ @@ -456,72 +477,84 @@ let find_cmd cmds = 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 +let getenv_empty_is_none env var = match env var with +| None | Some "" -> None | Some _ as v -> v + +let find_pager env = + let cmds = ["less", ""; "more", ""] in + let cmds = match getenv_empty_is_none env "PAGER" with + | Some pager -> (pager, "") :: cmds | None -> cmds in - match pager with + let cmds = match getenv_empty_is_none env "MANPAGER" with + | Some manpager -> (manpager, "") :: cmds | None -> cmds + in + find_cmd cmds + +let pp_to_pager env print ppf v = + let run cmd = Sys.command cmd = 0 in + let plain_pager pager = match pp_to_temp_file (print `Plain) v with + | None -> false + | Some f -> run (strf "%s < %s" pager f) + in + let groffed_pager pager = + 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 + match groffer with + | None -> false + | Some (groffer, opts) -> + let groffer = groffer ^ opts in + match pp_to_temp_file (print `Groff) v with + | None -> false + | Some f -> + (* This used to go through a pipe on non-Windows + platforms, but this would hide errors with the groffer + and inhibit the graceful degradation to plain text + since POSIX shells do not "pipefail" *) + match tmp_file_for_pager () with + | None -> false + | Some tmp -> + run (strf "%s <%s >%s && %s <%s" groffer f tmp pager tmp) + in + match find_pager env 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", ""] + let pager = + let set_less_env = match env "LESS" with + | None -> if Sys.win32 then "set LESS=FRX && " else "LESS=FRX " + | Some _ -> "" (* Sys.command will pass it *) in - find_cmd cmds + set_less_env ^ pager ^ opts 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 + if groffed_pager pager then () else + if plain_pager pager then () else + print `Plain ppf v (* Output *) +type subst = string -> string option + type format = [ `Auto | `Pager | `Plain | `Groff ] let rec print - ?(errs = Format.err_formatter) ?(subst = fun x -> None) fmt ppf page + ?(env = Sys.getenv_opt) ?(errs = Format.err_formatter) + ?(subst = fun x -> None) fmt ppf page = match fmt with - | `Pager -> pp_to_pager (print ~errs ~subst) ppf page + | `Pager -> pp_to_pager env (print ~env ~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 + match env "TERM" with + | None when Sys.win32 -> `Pager + | None -> `Plain + | Some "dumb" -> `Plain | _ -> `Pager in - print ~errs ~subst fmt ppf page + print ~env ~errs ~subst fmt ppf page diff --git a/src/core/cmdliner/cmdliner_manpage.mli b/src/core/cmdliner/cmdliner_manpage.mli index 679fcaac0c1..9b149ca2d5f 100644 --- a/src/core/cmdliner/cmdliner_manpage.mli +++ b/src/core/cmdliner/cmdliner_manpage.mli @@ -7,8 +7,10 @@ See {!Cmdliner.Manpage}. *) +type section_name = string + type block = - [ `S of string | `P of string | `Pre of string | `I of string * string + [ `S of section_name | `P of string | `Pre of string | `I of string * string | `Noblank | `Blocks of block list ] val escape : string -> string @@ -23,21 +25,21 @@ type xref = (** {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 +val s_name : section_name +val s_synopsis : section_name +val s_description : section_name +val s_commands : section_name +val s_arguments : section_name +val s_options : section_name +val s_common_options : section_name +val s_exit_status : section_name +val s_environment : section_name +val s_files : section_name +val s_bugs : section_name +val s_examples : section_name +val s_authors : section_name +val s_see_also : section_name +val s_none : section_name (** {1 Section maps} @@ -46,8 +48,8 @@ val s_none : string 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 +val smap_has_section : smap -> sec:section_name -> bool +val smap_append_block : smap -> sec:section_name -> block -> smap (** [smap_append_block smap sec b] appends [b] at the end of section [sec] creating it at the right place if needed. *) @@ -58,16 +60,19 @@ val s_environment_intro : block (** {1 Output} *) +type subst = string -> string option +(** The type for variable substitution functions. *) + type format = [ `Auto | `Pager | `Plain | `Groff ] val print : - ?errs:Format.formatter -> ?subst:(string -> string option) -> format -> + ?env:(string -> string option) -> + ?errs:Format.formatter -> ?subst:subst -> 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 + errs:Format.formatter -> subst:subst -> 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. @@ -75,10 +80,13 @@ val subst_vars : @raise Invalid_argument in case of illegal syntax. *) val doc_to_plain : - errs:Format.formatter -> subst:(string -> string option) -> Buffer.t -> - string -> string + errs:Format.formatter -> subst:subst -> 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. *) + Raises Invalid_argument in case of illegal syntax. *) + +val doc_to_styled : + ?buffer:Buffer.t -> errs:Format.formatter -> subst:subst -> string -> string +(** [doc_to_styled] is like {!doc_to_plain} but uses ANSI escapes. *) diff --git a/src/core/cmdliner/cmdliner_msg.ml b/src/core/cmdliner/cmdliner_msg.ml index f6bc55a1f69..877b53b29cf 100644 --- a/src/core/cmdliner/cmdliner_msg.ml +++ b/src/core/cmdliner/cmdliner_msg.ml @@ -3,98 +3,96 @@ 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 +module Fmt = Cmdliner_base.Fmt (* 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 + let var = Cmdliner_def.Env.info_var env in + Fmt.str "@[environment variable %a: %s@]" Fmt.code_or_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)) + Fmt.str "@[%a, don't know what to do with %a@]" + Fmt.ereason "too many arguments" + Fmt.(list ~sep:comma code_or_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_miss a = match Cmdliner_def.Arg_info.docv a with +| "" -> Fmt.str "@[a required argument is %a@]" Fmt.missing () +| v -> Fmt.str "@[required argument %a is %a@]" Fmt.code_var v Fmt.missing () 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 + let add_arg acc a = match Cmdliner_def.Arg_info.docv a with | "" -> "ARG" :: acc | argv -> argv :: acc in - let rev_args = List.sort Cmdliner_info.Arg.rev_pos_cli_order args in + let rev_args = List.sort Cmdliner_def.Arg_info.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 + Fmt.str "@[required arguments %a@ are@ %a@]" + Fmt.(list ~sep:comma code_var) args Fmt.missing () -let err_pos_parse a ~err = match Cmdliner_info.Arg.docv a with +let err_pos_parse a ~err = match Cmdliner_def.Arg_info.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 + match Cmdliner_def.Arg_info.(pos_len @@ pos_kind a) with + | Some 1 -> Fmt.str "@[%a argument: %s@]" Fmt.code_var argv err + | None | Some _ -> Fmt.str "@[%a… arguments: %s@]" Fmt.code_var 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) + Fmt.str "@[option %a is a flag, it@ %a@ %a@]" + Fmt.code_or_quote flag Fmt.ereason "cannot take the argument" + Fmt.code_or_quote v + +let err_opt_value_missing f = + Fmt.str "@[option %a %a@]" Fmt.code_or_quote f Fmt.ereason "needs an argument" + +let err_opt_parse f ~err = + Fmt.str "@[option %a: %a@]" Fmt.code_or_quote f Fmt.styled_text err -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') + if f = f' then + Fmt.str "@[option %a %a@]" + Fmt.code_or_quote f Fmt.ereason "cannot be repeated" + else + Fmt.str "@[options %a and %a@ %a@]" + Fmt.code_or_quote f Fmt.code_or_quote f' + Fmt.ereason "cannot be present at the same time" (* 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) + if Cmdliner_def.Arg_info.is_pos a then err_pos_miss a else + Fmt.str "@[required option %a is %a@]" + Fmt.code (Cmdliner_def.Arg_info.opt_name_sample a) Fmt.missing () let err_cmd_missing ~dom = - strf "required COMMAND name is missing, must be %s." - (Cmdliner_base.alts_str ~quoted:true dom) + Fmt.str "@[required %a name is %a,@ must@ be@ %a@]" + Fmt.code_var "COMMAND" Fmt.missing () Cmdliner_base.pp_alts 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 + match Cmdliner_def.Cmd_info.version (Cmdliner_def.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 + | Some v -> Fmt.pf ppf "@[%s@]@." v + +let exec_name ei = Cmdliner_def.Cmd_info.name (Cmdliner_def.Eval.main ei) + +let pp_exec_msg ppf ei = Fmt.pf ppf "%s:" (exec_name ei) + +let pp_err ppf ei ~err = + Fmt.pf ppf "@[%a @[%a@]@]@." pp_exec_msg ei Fmt.styled_text err + +let pp_usage_and_err ppf ei ~err = + Fmt.pf ppf "@[Usage: @[%a@]@]@." + Fmt.styled_text (Cmdliner_docgen.styled_usage_synopsis ~errs:ppf ei); + pp_err ppf ei ~err let pp_backtrace ppf ei e bt = let bt = Printexc.raw_backtrace_to_string bt in @@ -102,5 +100,7 @@ let pp_backtrace ppf ei e 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) + Fmt.pf ppf "@[%a @[internal error, %a:@\n%a@]@]@." + pp_exec_msg ei + Fmt.ereason "uncaught exception" + Fmt.lines (String.concat "\n" [Printexc.to_string e; bt]) diff --git a/src/core/cmdliner/cmdliner_msg.mli b/src/core/cmdliner/cmdliner_msg.mli index ff6b4f2b977..455f092e083 100644 --- a/src/core/cmdliner/cmdliner_msg.mli +++ b/src/core/cmdliner/cmdliner_msg.mli @@ -7,13 +7,13 @@ (** {1:env_err Environment variable errors} *) -val err_env_parse : Cmdliner_info.Env.info -> err:string -> string +val err_env_parse : Cmdliner_def.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 +val err_pos_misses : Cmdliner_def.Arg_info.t list -> string +val err_pos_parse : Cmdliner_def.Arg_info.t -> err:string -> string (** {1:opt_err Optional argument errors} *) @@ -24,17 +24,22 @@ val err_opt_repeated : string -> string -> string (** {1:arg_err Argument errors} *) -val err_arg_missing : Cmdliner_info.Arg.t -> string +val err_arg_missing : Cmdliner_def.Arg_info.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_version : Cmdliner_def.Eval.t Cmdliner_base.Fmt.t + + +val pp_exec_msg : Cmdliner_def.Eval.t Cmdliner_base.Fmt.t + +val pp_err : + Format.formatter -> Cmdliner_def.Eval.t -> err:string -> unit + +val pp_usage_and_err : + Format.formatter -> Cmdliner_def.Eval.t -> err:string -> unit val pp_backtrace : - Format.formatter -> - Cmdliner_info.Eval.t -> exn -> Printexc.raw_backtrace -> unit + Format.formatter -> Cmdliner_def.Eval.t -> exn -> Printexc.raw_backtrace -> + unit diff --git a/src/core/cmdliner/cmdliner_term.ml b/src/core/cmdliner/cmdliner_term.ml index fd34e134e79..c7728faded8 100644 --- a/src/core/cmdliner/cmdliner_term.ml +++ b/src/core/cmdliner/cmdliner_term.ml @@ -3,19 +3,17 @@ SPDX-License-Identifier: ISC ---------------------------------------------------------------------------*) -type term_escape = - [ `Error of bool * string - | `Help of Cmdliner_manpage.format * string option ] +type term_escape = Cmdliner_def.Term.escape +type 'a parser = 'a Cmdliner_def.Term.parser +type +'a t = 'a Cmdliner_def.Term.t -type 'a parser = - Cmdliner_info.Eval.t -> Cmdliner_cline.t -> - ('a, [ `Parse of string | term_escape ]) result +let make args p = (args, p) +let argset (args, _) = args +let parser (_, parser) = parser -type 'a t = Cmdliner_info.Arg.Set.t * 'a parser - -let const v = Cmdliner_info.Arg.Set.empty, (fun _ _ -> Ok v) +let const v = Cmdliner_def.Arg_info.Set.empty, (fun _ _ -> Ok v) let app (args_f, f) (args_v, v) = - Cmdliner_info.Arg.Set.union args_f args_v, + Cmdliner_def.Arg_info.Set.union args_f args_v, fun ei cl -> match (f ei cl) with | Error _ as e -> e | Ok f -> @@ -65,26 +63,35 @@ let cli_parse_result' t = cli_parse_result wrap let main_name = - Cmdliner_info.Arg.Set.empty, - (fun ei _ -> Ok (Cmdliner_info.Cmd.name @@ Cmdliner_info.Eval.main ei)) + Cmdliner_def.Arg_info.Set.empty, + (fun ei _ -> Ok (Cmdliner_def.Cmd_info.name @@ Cmdliner_def.Eval.main ei)) let choice_names = - Cmdliner_info.Arg.Set.empty, + Cmdliner_def.Arg_info.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 + let name t = Cmdliner_def.Cmd_info.name t in + let choices = + Cmdliner_def.Cmd_info.children (Cmdliner_def.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 + let actual_args arg_info _ acc = + let args = Cmdliner_def.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 + let used = + List.rev (Cmdliner_def.Arg_info.Set.fold actual_args al []) + in Ok (x, used) | Error _ as e -> e + + +let env = + Cmdliner_def.Arg_info.Set.empty, + (fun ei _ -> Ok (Cmdliner_def.Eval.env_var ei)) diff --git a/src/core/cmdliner/cmdliner_term.mli b/src/core/cmdliner/cmdliner_term.mli index 66684ca7e40..871b3836ab9 100644 --- a/src/core/cmdliner/cmdliner_term.mli +++ b/src/core/cmdliner/cmdliner_term.mli @@ -10,15 +10,19 @@ type term_escape = | `Help of Cmdliner_manpage.format * string option ] type 'a parser = - Cmdliner_info.Eval.t -> Cmdliner_cline.t -> + Cmdliner_def.Eval.t -> Cmdliner_def.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 +type +'a t = 'a Cmdliner_def.Term.t (** The type for terms. The list of arguments it can parse and the parsing function that does so. *) +val make : Cmdliner_def.Arg_info.Set.t -> 'a parser -> 'a t +val argset : 'a t -> Cmdliner_def.Arg_info.Set.t +val parser : 'a t -> 'a parser + val const : 'a -> 'a t val app : ('a -> 'b) t -> 'a t -> 'b t val map : ('a -> 'b) -> 'a t -> 'b t @@ -41,3 +45,4 @@ 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 +val env : (string -> string option) t diff --git a/src/core/cmdliner/cmdliner_term_deprecated.ml b/src/core/cmdliner/cmdliner_term_deprecated.ml deleted file mode 100644 index 5f48443dad1..00000000000 --- a/src/core/cmdliner/cmdliner_term_deprecated.ml +++ /dev/null @@ -1,77 +0,0 @@ -(*--------------------------------------------------------------------------- - 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/core/cmdliner/cmdliner_trie.ml b/src/core/cmdliner/cmdliner_trie.ml index 3444214ee97..4b520ff4fd0 100644 --- a/src/core/cmdliner/cmdliner_trie.ml +++ b/src/core/cmdliner/cmdliner_trie.ml @@ -3,13 +3,13 @@ SPDX-License-Identifier: ISC ---------------------------------------------------------------------------*) -module Cmap = Map.Make (Char) (* character maps. *) +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 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 } @@ -45,10 +45,14 @@ let find_node t k = 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 find ~legacy_prefixes t k = match (find_node t k).v with +| Key v -> Ok v +| Pre v when legacy_prefixes -> Ok v +| Pre v -> Error `Not_found +| Amb when legacy_prefixes -> Error `Ambiguous +| Amb -> Error `Not_found +| Nil -> Error `Not_found +| exception Not_found -> Error `Not_found let ambiguities t p = (* ambiguities of [p] in [t]. *) try @@ -78,3 +82,10 @@ let ambiguities t p = (* ambiguities of [p] in [t]. *) 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 + +let legacy_prefixes ~env = match env "CMDLINER_LEGACY_PREFIXES" with +| None -> false +| Some s -> + match String.lowercase_ascii s with + | "true" | "yes" | "y" | "1" -> true + | _ -> false diff --git a/src/core/cmdliner/cmdliner_trie.mli b/src/core/cmdliner/cmdliner_trie.mli index decf409413a..ab79a7944e7 100644 --- a/src/core/cmdliner/cmdliner_trie.mli +++ b/src/core/cmdliner/cmdliner_trie.mli @@ -13,6 +13,10 @@ 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 find : + legacy_prefixes:bool -> 'a t -> string -> + ('a, [`Ambiguous | `Not_found ]) result val ambiguities : 'a t -> string -> string list val of_list : (string * 'a) list -> 'a t + +val legacy_prefixes : env:(string -> string option) -> bool diff --git a/src/core/cmdliner/opamCmdliner.ml b/src/core/cmdliner/opamCmdliner.ml index 338e98789c3..b1c77ee5c12 100644 --- a/src/core/cmdliner/opamCmdliner.ml +++ b/src/core/cmdliner/opamCmdliner.ml @@ -4,13 +4,10 @@ ---------------------------------------------------------------------------*) module Manpage = Cmdliner_manpage -module Term = struct - include Cmdliner_term - include Cmdliner_term_deprecated -end +module Term = Cmdliner_term module Cmd = struct - module Exit = Cmdliner_info.Exit - module Env = Cmdliner_info.Env + module Exit = Cmdliner_def.Exit + module Env = Cmdliner_def.Env include Cmdliner_cmd include Cmdliner_eval end diff --git a/src/core/cmdliner/opamCmdliner.mli b/src/core/cmdliner/opamCmdliner.mli index 7e886cdf857..64e2cf1157b 100644 --- a/src/core/cmdliner/opamCmdliner.mli +++ b/src/core/cmdliner/opamCmdliner.mli @@ -5,21 +5,22 @@ (** Declarative definition of command line interfaces. - Consult the {{!page-tutorial}tutorial}, details about the supported - {{!page-cli}command line syntax} and {{!page-examples}examples} of - use. - - Open the module to use it, it defines only three modules in your + Consult the {{!page-tutorial}tutorial}, the + {{!page-cookbook}cookbook}, program + {{!page-cookbook.blueprints}blueprints} and + {{!page-cookbook.tip_src_structure}source structure}, details about the + supported {{!page-cli}command line syntax} and + {{!page-examples}examples} of use. + + Open the module to use it, it defines only these modules in your scope. *) -(** Man page specification. - - Man page generation is automatically handled by [Cmdliner], - consult the {{!page-tool_man.manual}details}. +(** Man pages. - 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. + Man page generation is automatically handled by [Cmdliner], see + the {{!page-tool_man.manual}details}. 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 @@ -29,21 +30,19 @@ module Manpage : sig (** {1:man Man pages} *) + type section_name = string + (** The type for section names (titles). See + {{!standard_sections}standard section names}. *) + type block = - [ `S of string | `P of string | `Pre of string | `I of string * string - | `Noblank | `Blocks of block list ] + [ `S of section_name (** Start a new section with given name. *) + | `P of string (** Paragraph with given text. *) + | `Pre of string (** Preformatted paragraph with given text. *) + | `I of string * string (** Indented paragraph with given label and text. *) + | `Noblank (** Suppress blank line introduced between two blocks. *) + | `Blocks of block list (** Splice given blocks. *) ] (** The type for a block of man page text. - {ul - {- [`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.} - {- [`Blocks bs] splices the blocks [bs].}} - Except in [`Pre], whitespace and newlines are not significant and are all collapsed to a single space. All block strings support the {{!page-tool_man.doclang}documentation markup language}.*) @@ -60,14 +59,12 @@ module Manpage : sig (** The type for a man page. A title and the page text as a list of blocks. *) 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)].}} *) + [ `Main (** Refer to the man page of the program itself. *) + | `Cmd of string (** Refer to the command [cmd] of the tool, which must + exist. *) + | `Tool of string (** Tool refer to the given command line tool. *) + | `Page of string * int (** Refer to the manpage [name(sec)]. *) ] + (** The type for man page cross-references. *) (** {1:standard_sections Standard section names and content} @@ -76,41 +73,42 @@ module Manpage : sig {{: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 + val s_name : section_name (** The [NAME] section. This section is automatically created by - [Cmdliner] for your. *) + [Cmdliner] for your command. *) - val s_synopsis : string + val s_synopsis : section_name (** 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. *) + created by [Cmdliner] for your command, 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 + val s_description : section_name (** The [DESCRIPTION] section. This should be a description of what - the tool does and provide a little bit of usage and + the tool does and provide a little bit of command line usage and documentation guidance. *) - val s_commands : string + val s_commands : section_name (** The [COMMANDS] section. By default subcommands get listed here. *) - val s_arguments : string + val s_arguments : section_name (** The [ARGUMENTS] section. By default positional arguments get listed here. *) - val s_options : string + val s_options : section_name (** The [OPTIONS] section. By default optional arguments get listed here. *) - val s_common_options : string + val s_common_options : section_name (** 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 + val s_exit_status : section_name (** The [EXIT STATUS] section. By default term status exit codes get listed here. *) - val s_environment : string + val s_environment : section_name (** The [ENVIRONMENT] section. By default environment variables get listed here. *) @@ -118,22 +116,22 @@ module Manpage : sig (** [s_environment_intro] is the introduction content used by cmdliner when it creates the {!s_environment} section. *) - val s_files : string + val s_files : section_name (** The [FILES] section. *) - val s_bugs : string + val s_bugs : section_name (** The [BUGS] section. *) - val s_examples : string + val s_examples : section_name (** The [EXAMPLES] section. *) - val s_authors : string + val s_authors : section_name (** The [AUTHORS] section. *) - val s_see_also : string + val s_see_also : section_name (** The [SEE ALSO] section. *) - val s_none : string + val s_none : section_name (** [s_none] is a special section named ["cmdliner-none"] that can be used whenever you do not want something to be listed. *) @@ -142,47 +140,52 @@ module Manpage : sig 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.}} *) + type format = + [ `Auto (** Format like [`Pager] or [`Plain] whenever the [TERM] + environment variable is [dumb] or unset. *) + | `Pager (** {{!page-cli.help}Tries} to use a pager or falls back + to [`Plain]. *) + | `Plain (** Format to plain text. *) + | `Groff (** Format to groff commands. *) ] + (** The type for man page output specification. *) val print : - ?errs:Format.formatter -> + ?env:(string -> string option) -> ?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}. *) + (** [print ~env ~errs ~subst fmt ppf page] prints [page] on [ppf] in the + format [fmt]. + {ul + {- [env] is used to lookup environment for driving paging when the + format is [`Pager]. Defaults to {!Sys.getenv_opt}.} + {- [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 {{!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. *) + A term made of terms referring to {{!Arg.argterms}command line arguments} + implicitly defines a command line syntax fragment. Terms are associated + to command values {!Cmd.t} which are + {{!Cmd.section-eval}evaluated} to eventually produce an + {{!Cmd.Exit.code}exit code}. + + Nowadays terms are best defined using the {!Cmdliner.Term.Syntax}. + See examples in the {{!page-cookbook.blueprints}blueprints}. *) module Term : sig (** {1:terms Terms} *) type +'a t - (** The type for terms evaluating to values of type 'a. *) + (** The type for terms evaluating to values of type ['a]. *) val const : 'a -> 'a t (** [const v] is a term that evaluates to [v]. *) - 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]. *) - val app : ('a -> 'b) t -> 'a t -> 'b t - (** [app] is {!($)}. *) + (** [app f v] is a term that evaluates to the result applying + the evaluation of [v] to the one of [f]. *) val map : ('a -> 'b) -> 'a t -> 'b t (** [map f t] is [app (const f) t]. *) @@ -190,24 +193,34 @@ module Term : sig 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. *) + val ( $ ) : ('a -> 'b) t -> 'a t -> 'b t + (** [f $ v] is {!app}[ f v]. *) + + (** [let] operators. + + See how to use them in the {{!page-cookbook.blueprints}blueprints}. *) 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}. *) + (** [( and+ )] is {!product}. *) end - (** {1 Interacting with Cmdliner's evaluation} *) + (** {1 Interacting with {!Cmd.t} evaluation} + + These special terms allow to interact with the + {{!Cmd.section-eval_low}low-level evaluation process} performed + on commands. *) val term_result : ?usage:bool -> ('a, [`Msg of string]) result t -> 'a t - (** [term_result ~usage t] evaluates to + (** [term_result] is such that: {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)].}} + {- [term_result ~usage (Ok v)] {{!Cmd.eval_value}evaluates} + to [Ok (`Ok v)].} + {- [term_result ~usage (Error (`Msg e))] + {{!Cmd.eval_value}evaluates} to [Error `Term] with the error message + [e] and usage shown according to [usage] (defaults to [false])}} See also {!term_result'}. *) @@ -216,17 +229,17 @@ module Term : sig error case. *) val cli_parse_result : ('a, [`Msg of string]) result t -> 'a t - (** [cli_parse_result t] is a term that evaluates to: + (** [cli_parse_result] is such that: {ul - {- [`Ok v] if [t] evaluates to [Ok v].} - {- [`Error `Parse] with the error message [e] - if [t] evaluates to [Error (`Msg e)].}} - + {- [cli_parse_result (Ok v)] {{!Cmd.eval_value}evaluates} + [Ok (`Ok v)).} + {- [cli_parse_result (Error (`Msg e))]] {{!Cmd.eval_value}evaluates} + [Error `Parse].}} 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. *) + (** [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; @@ -257,262 +270,22 @@ module Term : sig {- [`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.}} - - {b Note.} While not deprecated you are encouraged not use this API. *) - - (** {1:deprecated Deprecated Term evaluation interface} - - This interface is deprecated in favor of {!Cmdliner.Cmd}. Follow - the compiler deprecation warning hints to transition. *) - - (** {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 : - ?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 - {- [name] is the name of the program or the command.} - {- [version] is the version string of the program, ignored - for commands.} - {- [doc] is a one line description of the program or command used - for the [NAME] section of the term's man page. For commands this - 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 - {!Manpage.s_commands}).} - {- [sdocs] defines the title of the section in which the - 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. *) - - (** {2:evaluation Evaluation} *) - - 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 occurred and was - reported on the error formatter.} - {- [`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 - [@@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 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}). - - [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 - [@@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. - - If the command name is unknown an error is reported. If the name - 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 - [@@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 - 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 {!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} + the man page of the subcommand [c] of the main command.}} *) - {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. *) - (**/**) + val env : (string -> string option) t + (** [env] is the [env] argument given to {{!Cmd.section-eval}command + evaluation functions}. If you need to refine the environment + lookup done by Cmdliner's machinery you should use this rather + than direct calls to {!Sys.getenv_opt}. *) end (** Commands. - Command line syntaxes are implicitely defined by {!Term}s. A command - value binds a syntax and its documentation to a command name. + Command line syntaxes are implicitely defined by {!Term.t} + values. A command value binds a term and its documentation to a + command name. - A command can group a list of sub commands (and recursively). In this + A command can group a list of subcommands (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. *) @@ -535,12 +308,16 @@ module Cmd : sig {{:https://www.gnu.org/software/bash/manual/html_node/Exit-Status.html} some} shells. *) + (** {2:predefined Predefined codes} + + These are documented by {!defaults}. *) + 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. *) + (** [some_error] is [123], an exit status for indiscriminate errors + reported on [stderr]. *) val cli_error : code (** [cli_error] is [124], an exit status for command line parsing @@ -555,25 +332,28 @@ module Cmd : sig 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 : + ?docs:Manpage.section_name -> ?doc:string -> ?max:code -> code -> info + (** [info ~docs ~doc min ~max] describe the range of exit + statuses from [min] to [max] (defaults to [min]). + {ul + {- [doc] is the man page information for the statuses, + defaults to ["undocumented"]. 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 documentation of + {!Cmd.val-info}}}} + {- [docs] is the title of the man page section in which the statuses + will be listed, it defaults to {!Manpage.s_exit_status}.}} *) 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} + (** [defaults] are exit code information for {!ok}, {!some_error}, {!cli_error} and {!internal_error}. *) end @@ -583,32 +363,41 @@ module Cmd : sig (** {1:envvars Environment variables} *) type var = string - (** The type for environment names. *) + (** The type for environment variable names. *) (** {1:info Environment variable information} *) - [@@@alert "-deprecated"] - type info = Term.env_info (* because of Arg. *) + type info (** The type for environment variable information. *) - [@@@alert "+deprecated"] - val info : ?deprecated:string -> ?docs:string -> ?doc:string -> var -> info + val info : + ?deprecated:string -> ?docs:Manpage.section_name -> ?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"].} + variable, 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 {!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: + {- [deprecated], if specified the environment variable is + deprecated. Use of the variable warns on dep[stderr] This + message which should be a capitalized sentence is + preprended to [doc] and output on standard error when the + environment variable ends up being used.}} + + In [doc] and [deprecated] the {{!page-tool_man.doclang}documentation + markup language} can be used with following variables: + {ul + {- [$(opt)], if any the option name of the argument the variable is + looked up for.} {- [$(env)], the value of [var].} - {- The variables mentioned in {!val-info}.}} *) + {- The variables mentioned in the doc string of {!Cmd.val-info}.}} *) + + val info_var : info -> var + (** [info_var info] is the variable described by [info]. *) end type info @@ -617,17 +406,19 @@ module Cmd : sig 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 + ?sdocs:Manpage.section_name -> ?docs:Manpage.section_name -> ?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.} + {- [deprecated], if specified the command is deprecated. Use of the + variable warns on [stderr]. This + message which should be a capitalized sentence is + preprended to [doc] and output on standard error when the + environment variable ends up being 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.} @@ -645,14 +436,21 @@ module Cmd : sig {- [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: + [doc], [deprecated], [man], [envs], [exits] 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.}} - *) + {- [$(tool)] the main, topmost, command name.} + {- [$(cmd)] the command invocation from main command to the + command name.} + {- [$(cmd.name)] the command's name.} + {- [$(cmd.parent)] the command's parent or the main command if none.}} + + Previously some of these names were refered to as [$(tname)], + [$(mname)] and [$(iname)], they still work but do not use them, + they are obscure. *) + (** {1:cmds Commands} *) @@ -660,22 +458,29 @@ module Cmd : sig (** 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 + val make : info -> 'a Term.t -> 'a t + (** [make i t] is a command with information [i] and command line syntax parsed by [t]. *) + val v : info -> 'a Term.t -> 'a t + (** [v] is an old name for {!make} which should be preferred. *) + 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. *) + groups subcommands [cmds]. [default] is the command line syntax + to parse if no subcommand is specified on the command line. If + [default] is [None] (default), the tool errors when no subcommand + is specified. *) val name : 'a t -> string (** [name c] is the name of [c]. *) (** {1:eval Evaluation} + Read {!page-cookbook.cmds_which_eval} in the cookbook if you + struggle to choose between this menagerie of evaluation + functions. + These functions are meant to be composed with {!Stdlib.exit}. The following exit codes may be returned by all these functions: {ul @@ -686,7 +491,7 @@ module Cmd : sig 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}. *) + default value of the [?exits] argument of the function {!val-info}. *) val eval : ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> @@ -727,7 +532,8 @@ module Cmd : sig (** {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. *) + and lets you choose how to map evaluation results to exit codes. + All evaluation functions are wrappers around {!eval_value}. *) type 'a eval_ok = [ `Ok of 'a (** The term of the command evaluated to this value. *) @@ -741,10 +547,6 @@ module Cmd : sig | `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 -> @@ -758,25 +560,37 @@ module Cmd : sig {- [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})} + {- [help] is the formatter used to print help, version messages + or completions, (defaults to {!Format.std_formatter}). Note + that the completion protocol needs to output ['\n'] line ending, + if you are outputing to a channel make sure it is in binary + mode to avoid newline translation (this is done automatically + before completion when [help] is {!Format.std_formatter}).} {- [err] is the formatter used to print error messages (defaults to {!Format.err_formatter}).}} *) + 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. *) ] + (** The type for evaluation exits. *) + 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). *) + does not evaluate to [Ok (`Ok v)], returns an exit code like the + higher-level {{!val-eval}evaluation} functions 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 + (** {b WARNING.} You are highly encouraged not to use this + function it may be removed in the future. + + [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. @@ -801,7 +615,7 @@ module Cmd : sig {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. *) + argument. *) end (** Terms for command line arguments. @@ -814,135 +628,273 @@ end be specified during the {{!Arg.argterms}conversion} to a term. *) module Arg : sig -(** {1:argconv Argument converters} + (** {1:argconv Argument converters} *) - An argument converter transforms a string argument of the command - line to an OCaml value. {{!converters}Predefined converters} - are provided for many types of the standard library. *) + (** Argument completion. + + This module provides a type to describe how positional and + optional argument values of {{!Arg.type-conv}argument + converters} can be completed. It defines which completion + directives from the {{!page-cli.completion_protocol}protocol} + get emitted by your tool for the argument. + + {b Note.} Subcommand and option name are completed + automatically by the library itself and + {{!Cmdliner.Arg.predef}prefined argument converters} already + have completions built-in whenever appropriate. *) + module Completion : sig + + (** {1:directives Completion directives} *) - type 'a parser = string -> [ `Ok of 'a | `Error of string ] - [@@ocaml.deprecated "Use Arg.conv or Arg.conv' instead."] - (** The type for argument parsers. + type 'a directive + (** The type for a completion directive for values of type ['a]. *) + + val value : ?doc:string -> 'a -> 'a directive + (** [value v ~doc] indicates that the token to complete could be + replaced by the value [v] as serialized by the argument's + formatter {!Conv.pp}. [doc] is ANSI styled UTF-8 text + documenting the value, defaults to [""]. *) + + val string : ?doc:string -> string -> 'a directive + (** [string s ~doc] indicates that the token to complete could be + replaced by the string [s]. [doc] is ANSI styled UTF-8 text + documenting the value, defaults to [""]. *) + + val files : 'a directive + (** [files] indicates that the token to complete could be replaced + with files that the shell deems suitable. *) + + val dirs : 'a directive + (** [dirs] indicates that the token to complete could be replaced with + directories that the shell deems suitable. *) + + val restart : 'a directive + (** [restart] indicates that the shell should restart the completion + after the positional disambiguation token [--]. + + This is typically used for tools that end-up invoking other + tools like [sudo -- TOOL [ARG]…]. For the latter a restart + completion should be added on all positional arguments. If + you allow [TOOL] to be only a restricted set of tools known to + your program you'd eschew [restart] on the first postional + argument but add it to the remaining ones. + + {b Warning.} A [restart] directive is eventually emited only + if the completion is requested after a [--] token. In this + case other completions returned alongside by {!func} are + ignored. Educate your users to use the [--], for example + mention them in {{!page-cookbook.manpage_synopsis}user defined + synopses}, it is good cli specification hygiene as it properly + delineates argument scopes. *) + + val message : string -> 'a directive + (** [message s] is a multi-line, ANSI styled, UTF-8 message reported + to end users. *) + + val raw : string -> 'a directive + (** [raw s] takes over the whole {{!page-cli.completion_protocol}protocol} + output (including subcommand and option name completion) with [s], + you are in charge. Any other directive in the result of {!func} + is ignored. + + {b Warning.} The protocol is unstable, it is not advised to + output it yourself. However this can be useful to invoke + another tool according to the protocol in the completion + function and treat its result as the requested completion. *) + + (** {1:completion Completion} *) + + type ('ctx, 'a) func = + 'ctx option -> token:string -> ('a directive list, string) result + (** The type for completion functions. + + Given an optional context determined from a partial command + line parse and a token to complete it returns a list of + completion directives or an error which is reported to + end-users by using a protocol {!message}. + + The context is [None] if no context was given to {!make} or if + the context failed to parse on the current command line. *) + + type 'a complete = + | Complete : 'ctx Term.t option * ('ctx, 'a) func -> 'a complete (** *) + (** The type for completing. + + A completion context specification which captures a partial + command line parse (for example the path to a configuration + file) and a completion function. *) + + type 'a t + (** The type for completing values parsed into values of type ['a]. *) + + val make : ?context:'ctx Term.t -> ('ctx, 'a) func -> 'a t + (** [make ~context func] uses [func] to complete. + + [context] defines a commmand line fragment that is evaluated + before performing the completion. It the evaluation is + successful the result is given to the completion + function. Otherwise [None] is given. + + {b Warning.} [context] must be part of the term of the command + in which you use the completion otherwise the context will + always be [None] in the function. *) + + val complete : 'a t -> 'a complete + (** [complete c] completes with [c]. *) + + val complete_files : 'a t + (** [complete_files] holds a context insensitive function that + always returns [Ok \[]{!files}[\]]. *) + + val complete_dirs : 'a t + (** [complete_dirs] holds a context insensitive function that + always returns [Ok \[]{!dirs}[\]]. *) + + val complete_paths : 'a t + (** [complete_paths] holds a context insensitive function that + always returns [Ok \[]{!files}[;]{!dirs}[\]]. *) + + val complete_restart : 'a t + (** [complete_dirs] holds a context insensitive function that + always returns [Ok \[]{!restart}[\]]. *) + end - {b Deprecated.} Use parser signatures of {!val-conv} or {!val-conv'}. *) + (** Argument converters. - type 'a printer = Format.formatter -> 'a -> unit - (** The type for converted argument printers. *) + An argument converter transforms a string argument of the command + line to an OCaml value. {{!converters}Predefined converters} + are provided for many types of the standard library. *) + module Conv : sig - [@@@alert "-deprecated"] (* Need to be able to mention them ! *) - type 'a conv = 'a parser * 'a printer - (** The type for argument converters. + (** {1:converters 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 ! *) + type 'a parser = string -> ('a, string) result + (** The type for parsing arguments to values of type ['a]. *) - 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. *) + type 'a fmt = Format.formatter -> 'a -> unit + (** The type for formatting values of type ['a]. *) - val conv_parser : 'a conv -> (string -> ('a, [`Msg of string]) result) - (** [conv_parser c] is the parser of [c]. *) + type 'a t + (** The type for converting arguments to values of type ['a]. *) - val conv_printer : 'a conv -> 'a printer - (** [conv_printer c] is the printer of [c]. *) + val make : + ?completion:'a Completion.t -> docv:string -> parser:'a parser -> + pp:'a fmt -> unit -> 'a t + (** [make ~docv ~parser ~pp ()] is an argument converter with + given properties. See corresponding accessors for semantics. *) - val conv_docv : 'a conv -> string - (** [conv_docv c] is [c]'s documentation meta-variable. + val of_conv : + ?completion:'a Completion.t -> ?docv:string -> + ?parser:'a parser -> ?pp:'a fmt -> 'a t -> 'a t + (** [of_conv conv ()] is a new converter with given unspecified + properties defaulting to those of [conv]. *) - {b Warning.} Currently always returns ["VALUE"] in the future - will return the value given to {!val-conv} or {!val-conv'}. *) + (** {1:properties Properties} *) - 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 docv : 'a t -> string + (** [docv c] is [c]'s documentation meta-variable. This value can + be refered to as [$(docv)] in the documentation strings of + arguments. It can be overriden by the {!val-info} value of an + argument. *) + + val parser : 'a t -> 'a parser + (** [parser c] is [c]'s argument parser. *) + + val pp : 'a t -> 'a fmt + (** [pp c] is [c]'s argument formatter. *) + + val completion : 'a t -> 'a Completion.t + (** [completion c] is [c]'s completion. *) + end + + type 'a conv = 'a Conv.t + (** The type for argument converters. See the + {{!predef}predefined converters}. *) 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}. *) + to [None] when absent. If provided, [none] is used with [c]'s + formatter to document the value taken on absence; to document + a more complex behaviour use the [absent] argument of {!val-info}. + If you cannot construct an ['a] value use {!some}. *) 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. *) + string that will be rendered in bold. Use the [absent] argument + of {!val-info} to document more complex behaviours. *) -(** {1:arginfo Arguments and their information} - - Argument information defines the man page information of an - argument and, for optional arguments, its names. An environment - variable can also be specified to read the argument value from - if the argument is absent from the command line and the variable - is defined. *) + (** {1:arginfo Arguments} *) type 'a t (** The type for arguments holding data of type ['a]. *) type info - (** The type for information about command line arguments. *) + (** The type for information about command line arguments. + + Argument information defines the man page information of an + argument and, for optional arguments, its names. An environment + variable can also be specified to read get the argument value from + if the argument is absent from the command line and the variable + is defined. *) val info : - ?deprecated:string -> ?absent:string -> ?docs:string -> ?docv:string -> - ?doc:string -> ?env:Cmd.Env.info -> string list -> info + ?deprecated:string -> ?absent:string -> ?docs:Manpage.section_name -> + ?doc_envs:Cmd.Env.info list -> ?docv:string -> ?doc:string -> + ?env:Cmd.Env.info -> string list -> info (** [info docs docv doc env names] defines information for an argument. {ul {- [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 + can be referred to. Strings of length [1] like ["c"]) define + short option names ["-c"], longer strings like ["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.} + It is a variable name used in the man page to stand for their value. + If unspecified is taken from the argument converter's, see + {!Conv.docv}.} + {- [doc_envs] is a list of environment variable that are + added to the manual of the command when the argument is used.} {- [docs] is the title of the man page section in which the argument will be listed. For optional arguments this defaults 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.} + {- [deprecated], if specified the argument is deprecated. Use of the + variable warns on [stderr]. This + message which should be a capitalized sentence is + preprended to [doc] and output on standard error when the + environment variable ends up being 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.}} *) + value rendering that is performed by the combinators.}} + + In [doc], [deprecated], [absent] the + {{!page-tool_man.doclang}documentation markup language} can be + used with following variables: + + {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).}} *) val ( & ) : ('a -> 'b) -> 'a -> 'b (** [f & v] is [f v], a right associative composition operator for specifying argument terms. *) -(** {1:optargs Optional arguments} +(** {2:optargs Optional arguments} - The information of an optional argument must have at least + The {{!type-info}information} of an optional argument must have at least one name or [Invalid_argument] is raised. *) val flag : info -> bool t @@ -965,8 +917,9 @@ module Arg : sig command line and the value [v]{_k} if the name under which it appears is in [i]{_k}. - {b Note.} Environment variable lookup is unsupported for - for these arguments. *) + {b Note.} Automatic environment variable lookup is unsupported for + for these arguments but an [env] in an info will be documented. + Use an option and {!Term.env} for manually looking something up. *) val vflag_all : 'a list -> ('a * info) list -> 'a list t (** [vflag_all v l] is like {!vflag} except the flag may appear more @@ -975,8 +928,9 @@ module Arg : sig 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. *) + {b Note.} Automatic environment variable lookup is unsupported for + for these arguments but an [env] in an info will be documented. + Use an option and {!Term.env} for manually looking something up. *) val opt : ?vopt:'a -> 'a conv -> 'a -> info -> 'a t (** [opt vopt c v i] is an ['a] argument defined by the value of @@ -985,8 +939,11 @@ module Arg : sig [v] if the option is absent from the command line. Otherwise it has the value of the option as converted by [c]. - If [vopt] is provided the value of the optional argument is itself - optional, taking the value [vopt] if unspecified on the command line. *) + If [vopt] is provided the value of the optional argument is + itself optional, taking the value [vopt] if unspecified on the + command line. {b Warning} using [vopt] is + {{!page-cookbook.tip_avoid_default_option_values}not + recommended}. *) 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 @@ -994,9 +951,9 @@ module Arg : sig 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} + (** {2:posargs Positional arguments} - The information of a positional argument must have no name + The {{!type-info}information} of a positional argument must have no name or [Invalid_argument] is raised. Positional arguments indexing is zero-based. @@ -1037,17 +994,17 @@ module Arg : sig (** [pos_right] is like {!pos_left} except it holds all the positional arguments found on the right of the specified positional argument. *) - (** {1:argterms Arguments as terms} *) + (** {2:argterms Converting to terms} *) val value : 'a t -> 'a Term.t (** [value a] is a term that evaluates to [a]'s value. *) val required : 'a option t -> 'a Term.t (** [required a] is a term that fails if [a]'s value is [None] and - evaluates to the value of [Some] otherwise. Use this for required - positional arguments (it can also be used for defining required - optional arguments, but from a user interface perspective this - shouldn't be done, it is a contradiction in terms). *) + evaluates to the value of [Some] otherwise. Use this in combination + with {!Arg.some'} for required + positional arguments. {b Warning} using this on optional arguments + is {{!page-cookbook.tip_avoid_required_opt}not recommended}. *) val non_empty : 'a list t -> 'a list Term.t (** [non_empty a] is term that fails if [a]'s list is empty and @@ -1060,7 +1017,7 @@ module Arg : sig for lists of flags or options where the last occurrence takes precedence over the others. *) - (** {1:predef Predefined arguments} *) + (** {2:predef Predefined arguments} *) val man_format : Manpage.format Term.t (** [man_format] is a term that defines a [--man-format] option and @@ -1092,28 +1049,16 @@ module Arg : sig val string : string conv (** [string] converts values with the identity function. *) - 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]. + val enum : ?docv:string -> (string * 'a) list -> 'a conv + (** [enum l p] converts values such that string names in [l] map to + the corresponding value of type ['a]. [docv] is the converter's + documentation meta-variable, it defaults to [ENUM]. A + {{!Completion.make}completion} is added for the names. {b Warning.} The type ['a] must be comparable with {!Stdlib.compare}. @raise Invalid_argument if [l] is empty. *) - 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 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 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 conv -> 'a list conv (** [list sep c] splits the argument at each [sep] (defaults to [',']) character and converts each substrings with [c]. *) @@ -1142,6 +1087,46 @@ module Arg : sig characters (defaults to [',']) respectively converts the substrings with [c0], [c1], [c2] and [c3]. *) + (** {2:files Files and directories} *) + + val path : string conv + (** [path] is like {!string} but prints using {!Filename.quote} + and completes both files and directories. *) + + val filepath : string conv + (** [filepath] is like {!string} but prints using {!Filename.quote} + and completes files. *) + + val dirpath : string conv + (** [dirpath] is like {!string} but prints using {!Filename.quote} + and completes directories. *) + + (** {b Note.} The following converters report errors whenever the + requested file system object does not exist. This is only mildly + useful since nothing guarantees they will still exist at the + time you act upon them. So you will have to treat these error + cases anyways in your tool function. It is also unhelpful if the file + system object may be created by your tool. Rather use + {!filepath} and {!dirpath}. *) + + 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. The + string ["-"] is parsed without checking: it represents [stdio]. + It completes both files directories. *) + + 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. It completes directories. *) + + 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. The string ["-"] is + parsed without checking it represents [stdio]. It completes + files. *) + (** {1:doc_helpers Documentation formatting helpers} *) val doc_quote : string -> string @@ -1163,28 +1148,36 @@ module Arg : sig val doc_alts_enum : ?quoted:bool -> (string * 'a) list -> string (** [doc_alts_enum quoted alts] is [doc_alts quoted (List.map fst alts)]. *) - (** {1:deprecated Deprecated} *) + (** {1:deprecated Deprecated} + + These identifiers are silently deprecated. For now there is no + plan to remove them. But you should prefer to use the {!Conv} + interface in new code. *) - [@@@alert "-deprecated"] + type 'a printer = 'a Conv.fmt + (** Deprecated. Use {!Conv.fmt}. *) - type 'a converter = 'a conv - [@@ocaml.deprecated "Use Arg.conv' function instead."] - (** See {!Arg.conv'}. *) + val conv' : ?docv:string -> 'a Conv.parser * 'a Conv.fmt -> 'a conv + (** Deprecated. Use {!Conv.make} instead. *) - 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. *) + val conv : + ?docv:string -> (string -> ('a, [`Msg of string]) result) * 'a Conv.fmt -> + 'a conv + (** Deprecated. Use {!Conv.make} instead. *) + val conv_parser : 'a conv -> (string -> ('a, [`Msg of string]) result) + (** Deprecated. Use {!Conv.val-parser}. *) - type env = Cmd.Env.info - [@@ocaml.deprecated "Use Cmd.Env.info instead."] - (** See {!Cmd.Env.type-info} *) + val conv_printer : 'a conv -> 'a Conv.fmt + (** Deprecated. Use {!Conv.val-pp}. *) + + val conv_docv : 'a conv -> string + (** Deprecated. Use {!Conv.val-docv}. *) - 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}. *) + val parser_of_kind_of_string : + kind:string -> (string -> 'a option) -> + (string -> ('a, [`Msg of string]) result) + (** Deprecated. [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.). *) end diff --git a/src/core/cmdliner/patches/add_dune_files.patch b/src/core/cmdliner/patches/add_dune_files.patch new file mode 100644 index 00000000000..40be41ebc16 --- /dev/null +++ b/src/core/cmdliner/patches/add_dune_files.patch @@ -0,0 +1,20 @@ +diff --git c/src/core/cmdliner/dune i/src/core/cmdliner/dune +new file mode 100644 +index 000000000..1b684cc42 +--- /dev/null ++++ i/src/core/cmdliner/dune +@@ -0,0 +1,4 @@ ++(library ++ (name opamCmdliner) ++ (public_name opam-core.cmdliner) ++ (flags :standard -w -27-32-35-50)) +diff --git c/src/core/cmdliner/tool/dune i/src/core/cmdliner/tool/dune +new file mode 100644 +index 000000000..d078fa1b7 +--- /dev/null ++++ i/src/core/cmdliner/tool/dune +@@ -0,0 +1,4 @@ ++(executable ++ (name opamCmdliner_tool) ++ (libraries opamCmdliner) ++ (flags :standard -w -27-32-35-50-39)) diff --git a/src/core/cmdliner/patches/rename_for_opam.patch b/src/core/cmdliner/patches/rename_for_opam.patch new file mode 100644 index 00000000000..7bfceccd55d --- /dev/null +++ b/src/core/cmdliner/patches/rename_for_opam.patch @@ -0,0 +1,20 @@ +diff --git c/src/core/cmdliner/cmdliner.ml i/src/core/cmdliner/opamCmdliner.ml +similarity index 100% +rename from src/core/cmdliner/cmdliner.ml +rename to src/core/cmdliner/opamCmdliner.ml +diff --git c/src/core/cmdliner/cmdliner.mli i/src/core/cmdliner/opamCmdliner.mli +similarity index 100% +rename from src/core/cmdliner/cmdliner.mli +rename to src/core/cmdliner/opamCmdliner.mli +diff --git c/src/core/cmdliner/tool/cmdliner_main.ml i/src/core/cmdliner/tool/opamCmdliner_tool.ml +similarity index 99% +rename from src/core/cmdliner/tool/cmdliner_main.ml +rename to src/core/cmdliner/tool/opamCmdliner_tool.ml +index e42ac0d92..1cf473fd0 100644 +--- c/src/core/cmdliner/tool/cmdliner_main.ml ++++ i/src/core/cmdliner/tool/opamCmdliner_tool.ml +@@ -1,3 +1,4 @@ ++module Cmdliner = OpamCmdliner + (*--------------------------------------------------------------------------- + Copyright (c) 2025 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC diff --git a/src/core/cmdliner/tool/cmdliner_data.ml b/src/core/cmdliner/tool/cmdliner_data.ml new file mode 100644 index 00000000000..02aa171c973 --- /dev/null +++ b/src/core/cmdliner/tool/cmdliner_data.ml @@ -0,0 +1,368 @@ +let strf = Printf.sprintf + +let bash_generic_completion fun_name = strf +{|%s() { + local words cword + # Equivalent of COMP_WORDS, COMP_CWORD but allow us to exclude '=' as a word separator + _get_comp_words_by_ref -n = words cword + + local prefix="${words[cword]}" + local w=("${words[@]}") # Keep words intact for restart completion + w[cword]="--__complete=${words[cword]}" + local line="${w[@]:0:1} --__complete ${w[@]:1}" + local version type group item text_line item_doc msg + { + read version + if [[ $version != "1" ]]; then + printf "\nUnsupported cmdliner completion protocol: $version" >&2 + return 1 + fi + while read type; do + if [[ $type == "group" ]]; then + read group + elif [[ $type == "dirs" || $type == "files" ]] && (type compopt &> /dev/null); then + # trim option prefix in cases like --file= or -f + local pattern="$prefix" + local reply_prefix="" + if [[ $pattern == --* ]]; then + pattern="${prefix#*=}" + elif [[ $pattern == -* ]]; then + pattern="${prefix:2}" + reply_prefix="${prefix:0:2}" + fi + + # enable filename completion features like trailing slash for dirs + compopt -o filenames -o nospace + + # need to run compgen with -d or -f flag + local flag="${type:0:1}" + local completions=( $(compgen -$flag "$pattern") ) + for c in "${completions[@]}"; do + COMPREPLY+=("${reply_prefix}${c}") + done + elif [[ $type == "message" ]]; then + msg=""; + while read text_line; do + if [[ "$text_line" == "message-end" ]]; then + msg=${msg#?} # remove first newline + break + fi + msg+=$'\n'"$text_line" + done + printf "$msg" >&2 + elif [[ $type == "item" ]]; then + read item; + item_doc=""; + while read text_line; do + if [[ "$text_line" == "item-end" ]]; then + item_doc=${item_doc#?} # remove first newline + break + fi + item_doc+=$'\n'"$text_line" + done + # Sadly it seems bash does not support doc strings, so we only + # add item to to the reply. If you know any better get in touch. + if [[ $group == "Values" ]] && [[ $prefix == -* ]] && [[ $prefix != --* ]]; then + # properly complete short options + item="${prefix:0:2}$item" + fi + COMPREPLY+=($item) + elif [[ $type == "restart" ]]; then + # N.B. only emitted if there is a -- token + for ((i = 0; i < ${#words[@]}; i++)); do + if [[ "${words[i]}" == "--" ]]; then + _command_offset $((i+1)) + return + fi + done + fi + done } < <(eval $line) + return 0 +} +|} fun_name + +let zsh_generic_completion fun_name = strf +{|function %s { + local w=("${words[@]}") # Keep words intact for restart completion + local prefix="${words[CURRENT]}" + w[CURRENT]="--__complete=${words[CURRENT]}" + local line="${w[@]:0:1} --__complete ${w[@]:1}" + local -a completions + local version type group item text_line item_doc msg + eval $line | { + read -r version + if [[ $version != "1" ]]; then + _message -r "Unsupported cmdliner completion protocol: $version" + return 1 + fi + while IFS= read -r type; do + if [[ "$type" == "group" ]]; then + if [ -n "$completions" ]; then + _describe -V unsorted completions -U + completions=() + fi + read -r group + elif [[ "$type" == "message" ]]; then + msg=""; + while read text_line; do + if [[ "$text_line" == "message-end" ]]; then + msg=${msg#?} # remove first newline + break + fi + msg+=$'\n'"$text_line" + done + _message -r "$msg" + elif [[ "$type" == "item" ]]; then + read -r item; + item_doc=""; + while read -r text_line; do + if [[ "$text_line" == "item-end" ]]; then + item_doc=${item_doc#?} # remove first space + break + fi + # Sadly it seems impossible to make multiline + # doc strings. Get in touch if you know any better. + item_doc+=" $text_line" + done + # Handle glued forms, the completion item is the full option + if [[ "$group" == "Values" ]]; then + if [[ "$prefix" == --* ]]; then + item="${prefix%%=*}=${item}" + elif [[ "$prefix" == -* ]]; then + item="${prefix:0:2}${item}" + fi + fi + item_doc="${item_doc//$'\e'\[(01m|04m|m)/}" + completions+=("${item}":"${item_doc}") + elif [[ "$type" == "dirs" || "$type" == "files" ]]; then + local pre="" + local pat="$prefix" + if [[ "$prefix" == --* ]]; then + pre="${prefix%%=*}=" + pat="${prefix#*=}" + elif [[ "$prefix" == -* ]]; then + pre="${prefix:0:2}" + pat="${prefix:2}" + fi + if [[ "$type" == "dirs" ]]; then + _path_files -/ -P "$pre" "$pat" + else + _path_files -f -P "$pre" "$pat" + fi + elif [[ "$type" == "restart" ]]; then + # N.B. only emitted if there is a -- token + while [[ $words[1] != "--" ]]; do + shift words + (( CURRENT-- )) + done + shift words + (( CURRENT-- )) + _normal + fi + done + } + if [ -n "$completions" ]; then + _describe -V unsorted completions -U + fi +} +|} fun_name + +let pwsh_generic_completion fun_name = strf +{|<# +Note: PowerShell swallows all errors in tab completion functions. +If you are hacking on this file and get unexpected results (like +file completions where you don't expect them), inspect the most +recent errors with `Get-Error -Newest N` for some small N. +#> + +$Global:%s = { + param( + $wordToComplete, + $commandAst, + $cursorPosition + ) + + $exe = $commandAst.CommandElements[0].Extent.Text + $otherArgs = "" + + $seenWordToComplete = $false + foreach ($elem in $commandAst.CommandElements | Select-Object -Skip 1) { + $text = $elem.Extent.Text + if ($otherArgs -ne "") { + $otherArgs += " " + } + # wordToComplete has had quoting removed, so we need to remove it before comparison + if ($text -replace "[`"']", "" -eq $wordToComplete) { + $otherArgs += "--__complete=$text" + $seenWordToComplete = $true + } + else { + $otherArgs += $text + } + } + # usually if wordToComplete is not in commandAst, it's because it's an empty string + if (-not $seenWordToComplete) { + $otherArgs += " --__complete=$wordToComplete" + } + + $completions = Invoke-Expression "$exe --__complete $otherArgs" + + $version = $completions[0] + if ($version -ne "1") { + throw "Unsupported cmdliner completion protocol: $version" + } + + $prefix = "" + $pattern = $wordToComplete + if ($wordToComplete -match '^\-\-') { + # take everything before '=' as prefix for long options + $parts = $wordToComplete -split '=', 2 + $prefix = $parts[0] + '=' + $pattern = $parts[1] + } + elseif ($wordToComplete -match '^\-') { + # take first two characters of wordToComplete as prefix for short options + $prefix = $wordToComplete.Substring(0, [math]::Min(2, $wordToComplete.Length)) + $pattern = $wordToComplete.Substring(2) + } + + $CompletionResults = [System.Collections.Generic.List[System.Management.Automation.CompletionResult]]::new() + + $idx = 1 + $group = "" + while ($idx -lt $completions.Count) { + $type = $completions[$idx] + $idx += 1 + + switch ($type) { + "group" { + $group = $completions[$idx] + $idx += 1 + } + "item" { + $item = $completions[$idx] + $idx += 1 + + $itemDoc = "" + while ($true) { + $line = $completions[$idx] + $idx += 1 + if ($line -eq "item-end") { + break + } + if ($itemDoc -ne "") { + $itemDoc += "`n" + } + $itemDoc += $line + } + # avoid null tooltip error + if ($itemDoc -eq "") { + $itemDoc = $item + } + + $completionItem = $item + + if ($group -eq "Values") { + # quote replies with powershell separators + if ($completionItem -match "[,|;]") { + $completionItem = '"' + $completionItem + '"' + } + # re-add prefix for things like --foo= + $completionItem = $prefix + $completionItem + } + + $CompletionResults.Add( + [System.Management.Automation.CompletionResult]::new( + $completionItem, + $item, + 'ParameterValue', + $itemDoc)) + } + "files" { + [Management.Automation.CompletionCompleters]::CompleteFilename( + $pattern + ) | ForEach-Object { + $CompletionResults.Add( + [System.Management.Automation.CompletionResult]::new( + $prefix + $_.CompletionText, + $_.ListItemText, + $_.ResultType, + $_.ToolTip)) + } + } + "dirs" { + [Management.Automation.CompletionCompleters]::CompleteFilename( + $pattern + ) | Where-Object { + Test-Path $_.CompletionText -PathType Container + } | ForEach-Object { + $CompletionResults.Add( + [System.Management.Automation.CompletionResult]::new( + $prefix + $_.CompletionText, + $_.ListItemText, + $_.ResultType, + $_.ToolTip)) + } + } + "restart" { + $newCommand = "" + $seenDoubleDash = $false + + $newCursorPosition = 0 + for ($i = 1; $i -lt $commandAst.CommandElements.Count; $i++) { + $elem = $commandAst.CommandElements[$i] + if ($seenDoubleDash) { + if ($newCommand -ne "") { + $newCommand += " " + } + $newCommand += $elem.Extent.Text + if ($elem.Extent.Text -eq $wordToComplete) { + $newCursorPosition = $newCommand.Length + } + } + if ($elem.Extent.Text -eq "--") { + $seenDoubleDash = $true + } + } + + if ($newCursorPosition -eq 0) { + $newCommand += " " + $newCursorPosition = $newCommand.Length + } + + $newCommandCompletions = TabExpansion2 -inputScript $newCommand -cursorColumn $newCursorPosition + + $newCommandCompletions.CompletionMatches | ForEach-Object { + $CompletionResults.Add($_) + } + } + "message" { + $msg = "" + while ($true) { + $line = $completions[$idx] + $idx += 1 + if ($line -eq "message-end") { + break + } + if ($msg -ne "") { + $msg += "`n" + } + $msg += $line + } + Write-Output "$msg" | Out-Host + } + default { + throw "Unknown completion type: $type" + } + } + } + + if ($CompletionResults.Count -gt 0) { + return $CompletionResults + } + else { + # supress default behavior (file completion) when there are no completions + return $null + } +} +|} fun_name \ No newline at end of file diff --git a/src/core/cmdliner/tool/dune b/src/core/cmdliner/tool/dune new file mode 100644 index 00000000000..d078fa1b7e2 --- /dev/null +++ b/src/core/cmdliner/tool/dune @@ -0,0 +1,4 @@ +(executable + (name opamCmdliner_tool) + (libraries opamCmdliner) + (flags :standard -w -27-32-35-50-39)) diff --git a/src/core/cmdliner/tool/opamCmdliner_tool.ml b/src/core/cmdliner/tool/opamCmdliner_tool.ml new file mode 100644 index 00000000000..6dae3df1dea --- /dev/null +++ b/src/core/cmdliner/tool/opamCmdliner_tool.ml @@ -0,0 +1,729 @@ +module Cmdliner = OpamCmdliner +(*--------------------------------------------------------------------------- + Copyright (c) 2025 The cmdliner programmers. All rights reserved. + SPDX-License-Identifier: ISC + ---------------------------------------------------------------------------*) + +let strf = Printf.sprintf +let error_to_failure = function Ok v -> v | Error e -> failwith e + +let find_sub ?(start = 0) ~sub s = + (* naive algorithm, worst case O(length sub * length s) *) + let len_sub = String.length sub in + let len_s = String.length s in + let max_idx_sub = len_sub - 1 in + let max_idx_s = if len_sub <> 0 then len_s - len_sub else len_s - 1 in + let rec loop i k = + if i > max_idx_s then None else + if k > max_idx_sub then Some i else + if k > 0 then + if String.get sub k = String.get s (i + k) + then loop i (k + 1) else loop (i + 1) 0 + else + if String.get sub 0 = String.get s i + then loop i 1 else loop (i + 1) 0 + in + loop start 0 + +let rec mkdir dir = (* Can be replaced by Sys.mkdir once we drop OCaml < 4.12 *) + (* On Windows -p does not exist we do it ourselves on all platforms. *) + let err_cmd exit cmd = + raise (Sys_error (strf "exited with %d: %s\n" exit cmd)) + in + let run_cmd args = + let cmd = String.concat " " (List.map Filename.quote args) in + let cmd = if Sys.win32 then strf {|"%s"|} cmd else cmd in + let exit = Sys.command cmd in + if exit = 0 then () else err_cmd exit cmd + in + let parent = Filename.dirname dir in + (if String.equal dir parent then () else mkdir (Filename.dirname dir)); + (if Sys.file_exists dir then () else run_cmd ["mkdir"; dir]) + +let read_file file = + (* In_channel is < 4.14 *) + let read file ic = + try + (* This fails on `stdin` or large files on 32-bit. Once we require + 4.14 In_channel.input_all handles these quirks. *) + let len = in_channel_length ic in + let buf = Bytes.create len in + really_input ic buf 0 len; close_in ic; + Ok (Bytes.unsafe_to_string buf) + with + | Sys_error e -> Error (Printf.sprintf "%s: %s" file e) + in + let binary_stdin () = set_binary_mode_in stdin true in + try match file with + | "-" -> binary_stdin (); read file stdin + | file -> + let ic = open_in_bin file in + let finally () = close_in_noerr ic in + Fun.protect ~finally @@ fun () -> read file ic + with Sys_error e -> Error e + +let write_file file s = + (* Out_channel is < 4.14 *) + let write file s oc = try Ok (output_string oc s) with + | Sys_error e -> Error (Printf.sprintf "%s: %s" file e) + in + let binary_stdout () = set_binary_mode_out stdout true in + try match file with + | "-" -> binary_stdout (); write file s stdout + | file -> + let oc = open_out_bin file in + let finally () = close_out_noerr oc in + Fun.protect ~finally @@ fun () -> write file s oc + with Sys_error e -> Error e + +let with_binary_stdout f = + try let () = set_binary_mode_out stdout true in f () with + | Sys_error e | Failure e -> prerr_endline e; Cmdliner.Cmd.Exit.some_error + +let exec_stdout tool ~args = + (* The cmd munging logic can be replaced by Filename.quote_command once we + drop OCaml < 4.10 *) + let quote_tool tool = + Filename.quote @@ + if Sys.win32 then String.map (function '/' -> '\\' | c -> c) tool else tool + in + try + let tmp = Filename.temp_file "cmd" "stdout" in + let tool = quote_tool tool and args = List.map Filename.quote args in + let cmd = String.concat " " (tool :: args) in + let exec = String.concat " > " [cmd; Filename.quote tmp] in + let exec = if Sys.win32 then strf {|"%s"|} exec else exec in + match Sys.command exec with + | 0 -> + let ic = open_in_bin tmp in + let finally () = + close_in_noerr ic; + try Sys.remove tmp with Sys_error _ -> () (* not that important *) + in + let len = in_channel_length ic in + Fun.protect ~finally @@ fun () -> + let stdout = really_input_string ic len in + Ok stdout + | exit -> Error (strf "%s: exited with %d" exec exit) + with + | Sys_error e -> Error e + +(* Opam .install file updating *) + +let update_opam_install_section ~opam_src ~section moves = + (* Can fail in all sorts of ways if the '$(section):' string appears + in the file moves of [opam_src] *) + let move_to_string (src, dst) = Printf.sprintf " %S {%S}" src dst in + let open_section ~section opam_src = + let section = section ^ ":" in + match find_sub ~sub:section opam_src with + | None -> (strf "%s\n%s [" opam_src section), " ]" + | Some start -> + match String.index_from_opt opam_src start '[' with + | None -> + failwith (strf "Could not open section %s in opam file" section) + | Some i -> + let j = i + 1 in + String.sub opam_src 0 j, + String.sub opam_src j (String.length opam_src - j) + in + let before, after = open_section ~section opam_src in + let moves = List.rev_map move_to_string moves in + let moves = String.concat "\n" ("" :: moves) in + String.concat "" [before; moves; after] + +let maybe_update_opam_install_file ~update_opam_install section moves = + match update_opam_install with + | None -> () + | Some "-" -> failwith "- is stdin, it cannot be updated" + | Some file -> + let opam_src = + if not (Sys.file_exists file) then "" else + read_file file |> error_to_failure + in + let src = update_opam_install_section ~opam_src ~section moves in + write_file file src |> error_to_failure + +(* Cmdliner based tool introspection. + + Note this is a bit hackish but does the job. At some point we could + investigate cleaner protocols with the `--cmdliner` reserved option. *) + +let split_toolname toolexec = + let tool, name = Scanf.sscanf toolexec "%s@:%s" (fun n e -> n, e) in + let name = + if name <> "" then name else + let name = Filename.basename tool in + match Filename.chop_suffix_opt ~suffix:".exe" tool with + | None -> name | Some name -> name + in + tool, name + +let get_tool_commands tool = + (* We get that by using the completion protocol, see doc/cli.mld *) + try + let subcommands cmd = + let rec find_subs = function + | "group" :: "Subcommands" :: lines -> + let rec subs acc = function + | "group" :: _ | [] -> acc + | "item" :: sub :: lines -> + let sub = if cmd = "" then sub else String.concat " " [cmd; sub]in + subs (sub :: acc) lines + | _ :: lines -> subs acc lines + in + subs [] lines + | _ :: lines -> find_subs lines + | [] -> [] + in + let subs = if cmd = "" then [] else String.split_on_char ' ' cmd in + let args = "--__complete" :: (subs @ ["--__complete="]) in + let comps = exec_stdout tool ~args |> error_to_failure in + let comps = String.split_on_char '\n' comps in + match comps with + | "1" :: comps -> find_subs comps + | version :: comps -> + failwith (strf "Unsupported cmdliner completion protocol: %S" version) + | [] -> + failwith "Could not parse cmdliner completion protocol" + in + let rec loop acc = function + | cmd :: cmds -> + let subs = subcommands cmd in + loop (if cmd <> "" then cmd :: acc else acc) (List.rev_append subs cmds) + | [] -> List.sort String.compare acc + in + Ok (loop [] [""]) + with Failure e -> Error e + +let get_tool_command_man tool ~name cmd = + let man_basename = + let exec = if cmd = "" then name else String.concat " " [name; cmd] in + (String.map (function ' ' -> '-' | c -> c) exec) + in + let add_section man = + let rec extract_section = function + | line :: lines -> + begin match Scanf.sscanf line ".TH %s %d" (fun _ n -> n) with + | n -> Ok (n, man_basename, man) + | exception Scanf.Scan_failure _ -> extract_section lines + end + | [] -> + Error (strf "%s command: Could not extract section from manual" + (tool ^ " " ^ cmd)) + in + extract_section (String.split_on_char '\n' man) + in + let subs = if cmd = "" then [] else String.split_on_char ' ' cmd in + let args = subs @ ["--help=groff"] in + match exec_stdout tool ~args with + | Error _ as e -> e + | Ok man -> add_section man + +let get_tool_manpages tool ~name = match get_tool_commands tool with +| Error _ as e -> e +| Ok cmds -> + try + let man cmd = get_tool_command_man tool ~name cmd |> error_to_failure in + Ok (List.sort compare (List.map man ("" :: cmds))) + with + | Failure e -> Error e + +(* File path actions *) + +let log_action act p = Printf.printf "%s \x1B[1m%s\x1B[0m\n%!" act p + +let mkdir ~dry_run p = + if not (Sys.file_exists p) then begin + log_action "Creating directory" p; + if not dry_run then mkdir p + end + +let write_file ~dry_run p contents = + log_action "Writing" p; + if not dry_run then begin match write_file p contents with + | Ok () -> () + | Error e -> failwith e + end + +(* Shells completion *) + +module type SHELL = sig + val name : string + val sharedir : string + val generic_script_name : string + val generic_completion : string + val tool_script_name : toolname:string -> string + val tool_completion : toolname:string -> standalone:bool -> string +end + +type shell = (module SHELL) + +module Bash = struct + let name = "bash" + let sharedir = "bash-completion/completions" + let generic_script_name = "_cmdliner_generic" + let generic_completion = + Cmdliner_data.bash_generic_completion "_cmdliner_generic" + + let tool_script_name ~toolname = toolname + let tool_completion ~toolname ~standalone = + if not standalone then + strf +{|if ! declare -F _cmdliner_generic > /dev/null; then + _completion_loader _cmdliner_generic +fi +complete -F _cmdliner_generic %s +|} toolname + else + let munge s = String.map (function '-' -> '_' | c -> c) s in + let fun_name = strf "_%s_cmdliner" (munge toolname) in + let fun_def = Cmdliner_data.bash_generic_completion fun_name in + strf +{| +%s +if ! declare -F %s > /dev/null; then + _completion_loader %s +fi +complete -F %s %s +|} fun_def fun_name fun_name fun_name toolname +end + +module Zsh = struct + let name = "zsh" + let sharedir = "zsh/site-functions" + let generic_script_name = "_cmdliner_generic" + let generic_completion = + Cmdliner_data.zsh_generic_completion "_cmdliner_generic" + + let tool_script_name ~toolname = "_" ^ toolname + let tool_completion ~toolname ~standalone = + if not standalone then + strf +{|#compdef %s +autoload _cmdliner_generic +_cmdliner_generic +|} toolname + else + let munge s = String.map (function '-' -> '_' | c -> c) s in + let fun_name = strf "_%s_cmdliner" (munge toolname) in + let fun_def = Cmdliner_data.zsh_generic_completion fun_name in + strf +{|#compdef %s +%s +%s +|} toolname fun_def fun_name +end + +module Pwsh = struct + let name = "pwsh" + let sharedir = "powershell" + let generic_script_name = "cmdliner_generic_completion.ps1" + let generic_completion = + Cmdliner_data.pwsh_generic_completion "_cmdliner_generic" + + let tool_script_name ~toolname = strf "%s_completion.ps1" toolname + let tool_completion ~toolname ~standalone = + if not standalone then + strf +{|Register-ArgumentCompleter -Native -CommandName %s -ScriptBlock $Global:_cmdliner_generic +|} toolname + else + let munge s = String.map (function '-' -> '_' | c -> c) s in + let fun_name = strf "_%s_cmdliner" (munge toolname) in + let fun_def = Cmdliner_data.pwsh_generic_completion fun_name in + strf +{| +%s + +Register-ArgumentCompleter -Native -CommandName %s -ScriptBlock %s +|} fun_def toolname fun_name +end + +let shells : shell list = [(module Bash); (module Zsh); (module Pwsh)] + +let generic_completion (module Shell : SHELL) = + with_binary_stdout @@ fun () -> + print_string Shell.generic_completion; + Cmdliner.Cmd.Exit.ok + +let tool_completion (module Shell : SHELL) ~toolname ~standalone = + with_binary_stdout @@ fun () -> + print_string (Shell.tool_completion ~toolname ~standalone); + Cmdliner.Cmd.Exit.ok + +(* Install commands *) + +let install_generic_completion ~dry_run ~update_opam_install shells sharedir = + with_binary_stdout @@ fun () -> + let install ~dry_run sharedir acc (module Shell : SHELL) = + let rel_path = Filename.concat Shell.sharedir Shell.generic_script_name in + let dest = Filename.concat sharedir Shell.sharedir in + let path = Filename.concat sharedir rel_path in + mkdir ~dry_run dest; + write_file ~dry_run path Shell.generic_completion; + (path, rel_path) :: acc + in + try + let moves = List.fold_left (install ~dry_run sharedir) [] shells in + maybe_update_opam_install_file ~update_opam_install "share_root" moves; + Cmdliner.Cmd.Exit.ok + with Failure e -> prerr_endline e; Cmdliner.Cmd.Exit.some_error + +let install_tool_completion + ~dry_run ~update_opam_install ~shells ~toolnames ~sharedir + ~standalone_completion:standalone + = + with_binary_stdout @@ fun () -> + let install ~dry_run ~toolnames sharedir acc (module Shell : SHELL) = + let write acc toolname = + let rel_path = + Filename.concat Shell.sharedir (Shell.tool_script_name ~toolname) + in + let path = Filename.concat sharedir rel_path in + write_file ~dry_run path (Shell.tool_completion ~toolname ~standalone); + (path, rel_path) :: acc + in + mkdir ~dry_run (Filename.concat sharedir Shell.sharedir); + List.fold_left write acc toolnames + in + let moves = List.fold_left (install ~dry_run ~toolnames sharedir) [] shells in + try + maybe_update_opam_install_file ~update_opam_install "share_root" moves; + Cmdliner.Cmd.Exit.ok + with Failure e -> prerr_endline e; Cmdliner.Cmd.Exit.some_error + +let install_tool_manpages ~dry_run ~update_opam_install ~tools ~mandir = + (* Note this correctly handles manpages sections but at the moment + all manpages for tool and commands are in section 1. *) + let rec get_mans tool = + let tool, name = split_toolname tool in + get_tool_manpages tool ~name |> error_to_failure + in + try + let mans = List.sort compare (List.concat (List.map get_mans tools)) in + let rec install ~dry_run ~last_sec acc = function + | (sec, basename, man) :: mans -> + let secdir = strf "man%d" sec in + let rel_path = Filename.concat secdir (strf "%s.%d" basename sec) in + let path = Filename.concat mandir rel_path in + if last_sec <> sec then mkdir ~dry_run (Filename.concat mandir secdir); + write_file ~dry_run path man; + install ~dry_run ~last_sec:sec ((path, rel_path) :: acc) mans + | [] -> acc + in + let moves = install ~dry_run ~last_sec:(-1) [] mans in + maybe_update_opam_install_file ~update_opam_install "man" moves; + Cmdliner.Cmd.Exit.ok + with Failure e -> prerr_endline e; Cmdliner.Cmd.Exit.some_error + +let install_tool_support + ~dry_run ~update_opam_install tools shells ~prefix ~sharedir ~mandir + ~standalone_completion + = + let sharedir = match sharedir with + | None -> Filename.concat prefix "share" | Some sharedir -> sharedir + in + let mandir = match mandir with + | None -> Filename.concat sharedir "man" | Some mandir -> mandir + in + let rc = install_tool_manpages ~dry_run ~update_opam_install ~tools ~mandir in + if rc <> Cmdliner.Cmd.Exit.ok then rc else + let toolnames = List.map snd (List.map split_toolname tools) in + install_tool_completion + ~dry_run ~update_opam_install ~shells ~toolnames ~sharedir + ~standalone_completion + +(* Tool command listing command *) + +let tool_commands tool = match get_tool_commands tool with +| Ok subs -> List.iter print_endline subs; Cmdliner.Cmd.Exit.ok +| Error e -> prerr_endline e; Cmdliner.Cmd.Exit.some_error + +(* Command line interface *) + +open Cmdliner +open Cmdliner.Term.Syntax + +let dry_run = + let doc = "Do not install, output paths that would be written." in + Arg.(value & flag & info ["dry-run"] ~doc) + +(* Since the program uses functions like Filename.basename we need to + make sure the given filepaths have the right separator. This may + not be the case e.g. in package manager build instructions. *) + +let path_to_platform_path s = + if Sys.win32 + then String.map (function '/' -> '\\' | c -> c) s + else String.map (function '\\' -> '/' | c -> c) s + +let platform_dirpath = + let parser s = Ok (path_to_platform_path s) in + Arg.Conv.of_conv ~parser Arg.dirpath + +let platform_filepath = + let parser s = Ok (path_to_platform_path s) in + Arg.Conv.of_conv ~parser Arg.filepath + +let standalone_completion = + let doc = + "Generate standalone completion scripts. These scripts do \ + not depend on the generic cmdliner completion scripts. For some \ + shells this may result in slower completion." + in + Arg.(value & flag & info ["standalone-completion"] ~doc) + +let update_opam_install = + let doc = + "Update or create an opam $(b,.install) file $(docv) with install moves \ + from the installed files to the corresponding opam install sections. \ + Also performed if $(b,--dry-run) is specified." + in + Arg.(value & opt (some platform_filepath) None & + info ["update-opam-install"] ~doc ~docv:"PKG.install") + +let prefix = + let doc = "$(docv) is the install prefix. For example $(b,/usr/local)." in + Arg.(required & pos ~rev:true 0 (some platform_dirpath) None & + info [] ~doc ~docv:"PREFIX") + +let sharedir_doc = "$(docv) is the $(b,share) directory to install to." +let sharedir_docv = "SHAREDIR" +let sharedir_posn ~rev n = + Arg.(required & pos ~rev n (some platform_dirpath) None & + info [] ~doc:sharedir_doc ~docv:sharedir_docv) + +let sharedir_pos0 = sharedir_posn ~rev:false 0 +let sharedir_poslast = sharedir_posn ~rev:true 0 +let sharedir_opt = + let absent = "$(i,PREFIX)$(b,/share)" in + Arg.(value & opt (some platform_dirpath) None & + info ["sharedir"] ~doc:sharedir_doc ~docv:sharedir_docv ~absent) + +let mandir_doc = "$(docv) is the root $(b,man) directory to install to." +let mandir_docv = "MANDIR" +let mandir_poslast = + Arg.(required & pos ~rev:true 0 (some platform_dirpath) None & + info [] ~doc:mandir_doc ~docv:mandir_docv) + +let mandir_opt = + let absent = "$(i,SHAREDIR)$(b,/man)" in + Arg.(value & opt (some platform_dirpath) None & + info ["mandir"] ~doc:mandir_doc ~docv:mandir_docv ~absent) + +let shell_assoc = List.map (fun ((module S : SHELL) as s) -> S.name, s) shells +let shells_doc = Arg.doc_alts_enum shell_assoc +let shell_conv = Arg.enum ~docv:"SHELL" shell_assoc +let shell_doc = strf "$(docv) the shell to support, must be %s." shells_doc +let shells_opt = + let doc = shell_doc ^ " Repeatable." in + let absent = "All supported shells" in + Arg.(value & opt_all shell_conv shells & info ["s"; "shell"] ~absent ~doc) + +let shell_posn n = + Arg.(required & pos n (some shell_conv) None & info [] ~doc:shell_doc) + +let shell_pos0 = shell_posn 0 +let shell_pos1 = shell_posn 1 + +let toolname_posn n = + let doc = "$(docv) is the name of the tool to complete." in + Arg.(required & pos n (some platform_filepath) None & + info [] ~doc ~docv:"TOOLNAME") + +let toolname_pos0 = toolname_posn 0 +let toolname_pos1 = toolname_posn 1 +let toolnames_posleft = + let doc = "$(docv) is the name of the tool to complete. Repeatable." in + Arg.(non_empty & pos_left ~rev:true 0 string [] & + info [] ~doc ~docv:"TOOLNAME") + +let tools_posleft = + let doc = + "$(i,TOOLEXEC) is the tool executable. Searched in the $(b,PATH) unless \ + an explicit file path is specified. $(i,NAME) is the tool name, if \ + unspecified derived from $(i,TOOLEXEC) by taking the basename and \ + stripping any $(b,.exe) extension. Repeatable." + in + let docv = "TOOLEXEC[:NAME]" in + Arg.(non_empty & pos_left ~rev:true 0 platform_filepath [] & + info [] ~doc ~docv) + +let generic_completion_cmd = + let doc = "Output generic completion scripts" in + let man = + [ `S Manpage.s_description; + `P "$(cmd) outputs the generic cmdliner completion script for a given \ + shell. Examples:"; + `Pre "$(cmd) $(b,zsh)"; `Noblank; + `Pre "$(b,eval) $(b,\\$\\()$(cmd) $(b,zsh\\))"; + `P "The script needs to be loaded in a shell for tool specific \ + scripts output by the command $(b,tool-completion) to work. See \ + command $(b,install generic-completion) to install them."; + ] + in + Cmd.make (Cmd.info "generic-completion" ~doc ~man) @@ + let+ shell = shell_pos0 in + generic_completion shell + +let tool_commands_cmd = + let doc = "Output all subcommands of a cmdliner tool" in + let man = + [ `S Manpage.s_description; + `P "$(cmd) outputs all the subcommands of a given cmdliner based \ + tool, one per line. Examples:"; + `Pre "$(cmd) $(b,./mytool)"; `Noblank; + `Pre "$(cmd) $(b,cmdliner)"; + ] + in + Cmd.make (Cmd.info "tool-commands" ~doc ~man) @@ + let+ tool = + let doc = + "$(docv) is the tool executable. Searched in the $(b,PATH) unless \ + an explicit file path is specified." + in + Arg.(required & pos 0 (some platform_filepath) None & + info [] ~doc ~docv:"TOOLEXEC") + in + tool_commands tool + +let tool_completion_cmd = + let doc = "Output tool completion scripts" in + let man = + [ `S Manpage.s_description; + `P "$(cmd) outputs the tool specific completion script of a given shell. \ + Example:"; + `Pre "$(cmd) $(b,zsh mytool)"; + `P "Note that tool specific completion script need the corresponding \ + generic completion script output by $(b,generic-completion) to be \ + loaded in the shell. To install these scripts see command \ + $(b,install tool-completion)."; + ] + in + Cmd.make (Cmd.info "tool-completion" ~doc ~man) @@ + let+ shell = shell_pos0 and+ toolname = toolname_pos1 + and+ standalone = standalone_completion in + tool_completion shell ~toolname ~standalone + +let install_generic_completion_cmd = + let doc = "Install generic completion scripts" in + let man = [ + `S Manpage.s_description; + `P "$(cmd) installs the generic completion script of given shells in \ + a $(b,share) directory according to specific shell conventions. \ + Directories are created if needed. \ + Use option $(b,--dry-run) to see which paths would be written. \ + Examples:"; + `Pre "$(cmd) $(b,/usr/local/share) # All supported shells"; `Noblank; + `Pre "$(cmd) $(b,--shell zsh /usr/local/share)"; + `P "To inspect the actual scripts use the command \ + $(b,generic-completion)."; + ] + in + Cmd.make (Cmd.info "generic-completion" ~doc ~man) @@ + (* No let punning in < 4.13 *) + let+ dry_run = dry_run and+ shells = shells_opt + and+ update_opam_install = update_opam_install + and+ sharedir_pos0 = sharedir_pos0 in + install_generic_completion ~dry_run ~update_opam_install shells sharedir_pos0 + +let install_tool_completion_cmd = + let doc = "Install tool completion scripts" in + let man = [ + `S Manpage.s_description; + `P "$(cmd) installs tool completion script of given tools and shells in \ + a $(b,share) directory according to specific shell conventions. \ + Directories are created if needed. \ + Use option $(b,--dry-run) to see which paths would be written. \ + Example:"; + `Pre "$(cmd) $(b,mytool) $(b,/usr/local/share) # All supported shells"; + `Noblank; + `Pre "$(cmd) $(b,--shell zsh mytool /usr/local/share)"; + `P "Note that the command $(b,install tool-support) also installs \ + completions like this command does. To inspect the actual scripts \ + use the command $(b,tool-completion)."; + ] + in + Cmd.make (Cmd.info "tool-completion" ~doc ~man) @@ + (* No let punning in < 4.13 *) + let+ dry_run = dry_run and+ shells = shells_opt + and+ update_opam_install = update_opam_install + and+ toolnames = toolnames_posleft and+ sharedir = sharedir_poslast + and+ standalone_completion = standalone_completion in + install_tool_completion + ~dry_run ~update_opam_install ~shells ~toolnames ~sharedir + ~standalone_completion + +let install_tool_manpages_cmd = + let doc = "Install tool and subcommand manpages" in + let man = [ + `S Manpage.s_description; + `P "$(cmd) installs the manpages of the tool and its commands \ + according in directories of a $(b,man) directory. Directories are \ + created if needed. \ + Use option $(b,--dry-run) to see which paths would be written. \ + Example:"; + `Pre "$(cmd) $(b,./mytool) $(b,/usr/local/share/man)"; + `P "Note that the command $(b,install tool-support) also installs manpages \ + like this command does." + ] + in + Cmd.make (Cmd.info "tool-manpages" ~doc ~man) @@ + let+ dry_run = dry_run and+ update_opam_install = update_opam_install + and+ tools = tools_posleft and+ mandir = mandir_poslast in + install_tool_manpages ~dry_run ~update_opam_install ~tools ~mandir + +let install_tool_support_cmd = + let doc = "Install both tool completion and manpages" in + let man = [ + `S Manpage.s_description; + `P "$(cmd) combines commands $(b,install tool-completion) and \ + $(b,install tool-manpages) to install all tool support files \ + in a given $(i,PREFIX) which is assumed to follow the Filesystem \ + Hierarchy Standard. + Use options $(b,--sharedir) and/or $(b,--mandir) if that is + not the case (e.g. in $(b,opam) as of writing). + Use option $(b,--dry-run) to see which paths would be written. \ + Example:"; + `Pre "$(cmd) $(b,./mytool /usr/local)"; `Noblank; + `Pre "$(cmd) $(b,--update-opam-install=mypkg.install) \\\\ \n\ + \ $(b,_build/mytool _build/prefix)"; + ] + in + Cmd.make (Cmd.info "tool-support" ~doc ~man) @@ + let+ dry_run = dry_run and+ update_opam_install = update_opam_install + and+ shells = shells_opt and+ tools = tools_posleft + and+ sharedir = sharedir_opt and+ mandir = mandir_opt and+ prefix = prefix + and+ standalone_completion = standalone_completion in + install_tool_support + ~dry_run ~update_opam_install tools shells ~prefix ~sharedir ~mandir + ~standalone_completion + +let install_cmd = + let doc = "Install support files for cmdliner tools" in + let man = + [ `S Manpage.s_description; + `P "$(cmd) subcommands install cmdliner support files. \ + See the library documentation or invoke \ + subcommands with $(b,--help) for more details."; ] + in + Cmd.group (Cmd.info "install" ~doc ~man) @@ + [install_generic_completion_cmd; install_tool_completion_cmd; + install_tool_manpages_cmd; install_tool_support_cmd] + +let cmd = + let doc = "Helper tool for cmdliner based tools" in + let default = Term.(ret (const (`Help (`Pager, None)))) in + let man = + [ `S Manpage.s_description; + `P "$(tool) is a helper for tools using the cmdliner command line \ + interface library. It helps with installing command line \ + completion scripts and manpages. See the library documentation or \ + invoke subcommands with $(b,--help) for more details."; ] + in + Cmd.group (Cmd.info "cmdliner" ~version:"%%VERSION%%" ~doc ~man) ~default @@ + [generic_completion_cmd; tool_commands_cmd; tool_completion_cmd; install_cmd] + +let main () = Cmd.eval' cmd +let () = if !Sys.interactive then () else exit (main ()) From 660365e15e5e12c08430fcf10ec6ec6bb7d159b9 Mon Sep 17 00:00:00 2001 From: Brian Ward Date: Mon, 16 Mar 2026 10:45:33 -0400 Subject: [PATCH 02/12] vendored cmdliner: patch legacy_prefixes to be unconditionally true --- src/core/cmdliner/cmdliner_trie.ml | 7 +------ src/core/cmdliner/patches/legacy_prefixes.patch | 13 +++++++++++++ 2 files changed, 14 insertions(+), 6 deletions(-) create mode 100644 src/core/cmdliner/patches/legacy_prefixes.patch diff --git a/src/core/cmdliner/cmdliner_trie.ml b/src/core/cmdliner/cmdliner_trie.ml index 4b520ff4fd0..965dfabc602 100644 --- a/src/core/cmdliner/cmdliner_trie.ml +++ b/src/core/cmdliner/cmdliner_trie.ml @@ -83,9 +83,4 @@ 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 -let legacy_prefixes ~env = match env "CMDLINER_LEGACY_PREFIXES" with -| None -> false -| Some s -> - match String.lowercase_ascii s with - | "true" | "yes" | "y" | "1" -> true - | _ -> false +let legacy_prefixes ~env = true diff --git a/src/core/cmdliner/patches/legacy_prefixes.patch b/src/core/cmdliner/patches/legacy_prefixes.patch new file mode 100644 index 00000000000..7ebc8106020 --- /dev/null +++ b/src/core/cmdliner/patches/legacy_prefixes.patch @@ -0,0 +1,13 @@ +--- a/src/core/cmdliner/cmdliner_trie.ml ++++ b/src/core/cmdliner/cmdliner_trie.ml +@@ -83,9 +83,4 @@ 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 + +-let legacy_prefixes ~env = match env "CMDLINER_LEGACY_PREFIXES" with +-| None -> false +-| Some s -> +- match String.lowercase_ascii s with +- | "true" | "yes" | "y" | "1" -> true +- | _ -> false ++let legacy_prefixes ~env = true From f0c7d83f88440baf237726871eb87f9ccc4ccb02 Mon Sep 17 00:00:00 2001 From: Brian Ward Date: Fri, 30 Jan 2026 14:03:39 -0500 Subject: [PATCH 03/12] Update reftests for new usage formatting --- tests/reftests/action-disk.test | 5 ++--- tests/reftests/admin-migrate-extrafiles.test | 8 +++---- tests/reftests/cli-versioning.test | 23 ++++++++++++++------ tests/reftests/depext-only.test | 3 +-- tests/reftests/pin-legacy.test | 5 ++--- tests/reftests/pin.test | 6 ++--- tests/reftests/show.test | 9 +++----- tests/reftests/tree.test | 4 ++-- tests/reftests/var-option.test | 12 +++++----- 9 files changed, 39 insertions(+), 36 deletions(-) diff --git a/tests/reftests/action-disk.test b/tests/reftests/action-disk.test index acd00130160..319526962b9 100644 --- a/tests/reftests/action-disk.test +++ b/tests/reftests/action-disk.test @@ -2247,9 +2247,8 @@ SYSTEM LOCK ${BASEDIR}/OPAM/config.lock (none => none) ### :III: Switch creation ### :III:1: empty ### opam switch create empty-switch --mpety -opam: unknown option '--mpety', did you mean either '-m' or '--empty'? -Usage: opam switch [OPTION]… [COMMAND] [ARG]… -Try 'opam switch --help' or 'opam --help' for more information. +Usage: opam switch [--help] [OPTION]… [COMMAND] [ARG]… +opam: unknown option '--mpety'. Did you mean either '-m' or '--empty'? # Return code 2 # ### :III:2: with package ### opam switch create package-switch --package main-repo | grep -v '^- ./$' | sed-cmd rsync tar cp touch mkdir | sed-hash $MD5 md5 | sed-hash $XSMD5 xs-hash diff --git a/tests/reftests/admin-migrate-extrafiles.test b/tests/reftests/admin-migrate-extrafiles.test index e81d0665e70..091831e0692 100644 --- a/tests/reftests/admin-migrate-extrafiles.test +++ b/tests/reftests/admin-migrate-extrafiles.test @@ -65,14 +65,14 @@ extra-files: [["foo"] ["bar"]] opam-version: "2.0" ### : required arguments ### opam admin migrate-extrafiles +Usage: opam admin migrate-extrafiles [--help] [--hash=HASH_ALGO] + [--packages=PACKAGES] [OPTION]… DIR URL opam admin: required arguments DIR, URL are missing -Usage: opam admin migrate-extrafiles [--hash=HASH_ALGO] [--packages=PACKAGES] [OPTION]… DIR URL -Try 'opam admin migrate-extrafiles --help' or 'opam admin --help' for more information. # Return code 2 # ### opam admin migrate-extrafiles ./migrated +Usage: opam admin migrate-extrafiles [--help] [--hash=HASH_ALGO] + [--packages=PACKAGES] [OPTION]… DIR URL opam admin: required argument URL is missing -Usage: opam admin migrate-extrafiles [--hash=HASH_ALGO] [--packages=PACKAGES] [OPTION]… DIR URL -Try 'opam admin migrate-extrafiles --help' or 'opam admin --help' for more information. # Return code 2 # ### #opam admin migrate-extrafiles https://an.url/prefix ./migrated ### : migrate all diff --git a/tests/reftests/cli-versioning.test b/tests/reftests/cli-versioning.test index 8f2d039824a..82e384cb29f 100644 --- a/tests/reftests/cli-versioning.test +++ b/tests/reftests/cli-versioning.test @@ -11,7 +11,9 @@ flags: compiler ### opam option depext=false Set to 'false' the field depext in global configuration ### opam switch install cli-versioning --empty | "${OPAMMAJORVERSION}" -> "CURRENTMAJOR" -opam: install was removed in version 2.1 of the opam CLI, but version CURRENTMAJOR has been requested. Use create instead or set OPAMCLI environment variable to 2.0. +opam: install was removed in version 2.1 of the opam CLI, but version CURRENTMAJOR has + been requested. Use create instead or set OPAMCLI environment variable + to 2.0. # Return code 2 # ### OPAMCLI=2.0 opam switch install cli-versioning --empty [WARNING] OPAMNODEPEXTS was ignored because CLI 2.0 was requested and it was introduced in 2.1. @@ -24,7 +26,8 @@ The following actions would be performed: === install 1 package - install baz 2 ### OPAMCLI=2.0 opam install baz --assume-depexts -opam: --assume-depexts was added in version 2.1 of the opam CLI, but version 2.0 has been requested, which is older. +opam: --assume-depexts was added in version 2.1 of the opam CLI, but version + 2.0 has been requested, which is older. # Return code 2 # ### opam config set cli version [WARNING] set was deprecated in version 2.1 of the opam CLI. Use opam var instead or set OPAMCLI environment variable to 2.0. @@ -54,7 +57,8 @@ No solution found, exiting No solution found, exiting # Return code 20 # ### OPAMCLI=2.0 opam install baz.2 --update-invariant -opam: --update-invariant was added in version 2.1 of the opam CLI, but version 2.0 has been requested, which is older. +opam: --update-invariant was added in version 2.1 of the opam CLI, but + version 2.0 has been requested, which is older. # Return code 2 # ### opam install baz.2 --update-invariant The following actions would be performed: @@ -66,27 +70,32 @@ The following actions would be performed: === install 1 package - install baz 2 ### opam install baz.2 --unlock-base | "${OPAMMAJORVERSION}" -> "CURRENTMAJOR" -opam: --unlock-base was removed in version 2.1 of the opam CLI, but version CURRENTMAJOR has been requested. Use --update-invariant instead or set OPAMCLI environment variable to 2.0. +opam: --unlock-base was removed in version 2.1 of the opam CLI, but version + CURRENTMAJOR has been requested. Use --update-invariant instead or set OPAMCLI + environment variable to 2.0. # Return code 2 # ### # opam option uses mk_command_ret ### opam option foo [ERROR] No option named 'foo' found. Use 'opam option [--global]' to list them # Return code 2 # ### OPAMCLI=2.0 opam option foo -opam: option was added in version 2.1 of the opam CLI, but version 2.0 has been requested, which is older. +opam: option was added in version 2.1 of the opam CLI, but version 2.0 has + been requested, which is older. # Return code 2 # ### opam option foo --global [ERROR] Field or section foo not found # Return code 5 # ### OPAMCLI=2.0 opam option foo --global -opam: --global was added in version 2.1 of the opam CLI, but version 2.0 has been requested, which is older. +opam: --global was added in version 2.1 of the opam CLI, but version 2.0 has + been requested, which is older. # Return code 2 # ### # opam lock uses mk_command ### opam lock foo [ERROR] No package matching foo # Return code 5 # ### OPAMCLI=2.0 opam lock foo -opam: lock was added in version 2.1 of the opam CLI, but version 2.0 has been requested, which is older. +opam: lock was added in version 2.1 of the opam CLI, but version 2.0 has been + requested, which is older. # Return code 2 # ### # Check for build test env ### # Note: you must have an installed opam with cli version enabled to pass these tests diff --git a/tests/reftests/depext-only.test b/tests/reftests/depext-only.test index 0eebd9adf11..d9d651024d2 100644 --- a/tests/reftests/depext-only.test +++ b/tests/reftests/depext-only.test @@ -98,9 +98,8 @@ The following system packages will first need to be installed: + echo "sys-foo" - sys-foo ### opam install foo --depext-only --no-depexts +Usage: opam install [--help] [OPTION]… [PACKAGES]… opam: --depext-only and --no-depexts can't be used together -Usage: opam install [OPTION]… [PACKAGES]… -Try 'opam install --help' or 'opam --help' for more information. # Return code 2 # ### opam option depext=false Set to 'false' the field depext in global configuration diff --git a/tests/reftests/pin-legacy.test b/tests/reftests/pin-legacy.test index 32be6166adb..21552cde7e0 100644 --- a/tests/reftests/pin-legacy.test +++ b/tests/reftests/pin-legacy.test @@ -226,9 +226,8 @@ bar.dev rsync file://${BASEDIR}/bar foo.1 local definition qux.dev rsync file://${BASEDIR}/qux ### opam pin remove --all foo -opam: opamMain.exe: Too many arguments. - Usage: opamMain.exe pin [OPTION]... remove PACKAGES...|TARGET - +opam: opamMain.exe: Too many arguments. Usage: opamMain.exe pin [OPTION]... + remove PACKAGES...|TARGET # Return code 2 # ### opam pin remove --all Ok, qux is no longer pinned to file://${BASEDIR}/qux (version dev) diff --git a/tests/reftests/pin.test b/tests/reftests/pin.test index 8d67743e9b1..f5f427dd4a8 100644 --- a/tests/reftests/pin.test +++ b/tests/reftests/pin.test @@ -302,9 +302,9 @@ The following actions will be performed: -> installed nip.1 Done. ### opam pin add nip2 --kind version -opam: Ambiguous argument "nip2", if it is the pinning target, you must specify a package name first -Usage: opam pin [OPTION]… [COMMAND] [ARG]… -Try 'opam pin --help' or 'opam --help' for more information. +Usage: opam pin [--help] [OPTION]… [COMMAND] [ARG]… +opam: Ambiguous argument "nip2", if it is the pinning target, you must + specify a package name first # Return code 2 # ### opam pin add nip2 ./nip2 --kind version Fatal error: Invalid character '/' in package version "./nip2" diff --git a/tests/reftests/show.test b/tests/reftests/show.test index 69080872993..f539e4e4e7e 100644 --- a/tests/reftests/show.test +++ b/tests/reftests/show.test @@ -452,19 +452,16 @@ version: "4" 4 ### : Check the error message in case of an invalid character ### opam show a&b +Usage: opam show [--help] [OPTION]… [PACKAGES]… opam: PACKAGES… arguments: Invalid character '&' in package name "a&b" -Usage: opam show [OPTION]… [PACKAGES]… -Try 'opam show --help' or 'opam --help' for more information. # Return code 2 # ### opam show bépo +Usage: opam show [--help] [OPTION]… [PACKAGES]… opam: PACKAGES… arguments: Invalid character '\195' in package name "b\195\169po" -Usage: opam show [OPTION]… [PACKAGES]… -Try 'opam show --help' or 'opam --help' for more information. # Return code 2 # ### opam show a.bépo +Usage: opam show [--help] [OPTION]… [PACKAGES]… opam: PACKAGES… arguments: Invalid character '\195' in package version "b\195\169po" -Usage: opam show [OPTION]… [PACKAGES]… -Try 'opam show --help' or 'opam --help' for more information. # Return code 2 # diff --git a/tests/reftests/tree.test b/tests/reftests/tree.test index 41811acb7ec..ab89a208864 100644 --- a/tests/reftests/tree.test +++ b/tests/reftests/tree.test @@ -392,9 +392,9 @@ e.1 ### : --no-switch : ### :::::::::::::::: ### opam tree --no-switch | '…' -> '...' | '`' -> "'" +Usage: opam tree [--help] [--recursive] [--subpath=PATH] [OPTION]... + [PACKAGES]... opam: --no-switch can't be used without specifying a package or a path -Usage: opam tree [--recursive] [--subpath=PATH] [OPTION]... [PACKAGES]... -Try 'opam tree --help' or 'opam --help' for more information. # Return code 2 # ### opam tree f h --no-switch The following actions are simulated: diff --git a/tests/reftests/var-option.test b/tests/reftests/var-option.test index eec8001904b..30829e8ac82 100644 --- a/tests/reftests/var-option.test +++ b/tests/reftests/var-option.test @@ -187,9 +187,9 @@ i-got-the-variables:etc ${BASEDIR}/OPAM/var-option/etc/i-got-the-variables # Etc i-got-the-variables:build ${BASEDIR}/OPAM/var-option/.opam-switch/build/i-got-the-variables.2.4.6 # Directory where the package was built i-got-the-variables:dev false # True if this is a development package ### opam var i-got-the-variables:version=1 | '…' -> '...' | '`' -> "'" +Usage: opam var [--help] [--global] [--package=PACKAGE] [OPTION]... + [VAR[=[VALUE]]] opam: variable setting needs a scope, use '--global' or '--switch ' -Usage: opam var [--global] [--package=PACKAGE] [OPTION]... [VAR[=[VALUE]]] -Try 'opam var --help' or 'opam --help' for more information. # Return code 2 # ### opam var i-got-the-variables:version=1 --switch var-option [ERROR] Package variables are read-only and cannot be updated using `opam var --global` @@ -207,9 +207,9 @@ Try 'opam var --help' or 'opam --help' for more information. [ERROR] Self variables (`_:`) are not valid here # Return code 2 # ### opam var _:version=1 | '…' -> '...' | '`' -> "'" +Usage: opam var [--help] [--global] [--package=PACKAGE] [OPTION]... + [VAR[=[VALUE]]] opam: variable setting needs a scope, use '--global' or '--switch ' -Usage: opam var [--global] [--package=PACKAGE] [OPTION]... [VAR[=[VALUE]]] -Try 'opam var --help' or 'opam --help' for more information. # Return code 2 # ### opam var _:version=1 --switch var-option [ERROR] Self variables (`_:`) are not valid here @@ -788,9 +788,9 @@ true ### opam option depext --global true ### opam var arch="somearch" | '…' -> '...' | '`' -> "'" +Usage: opam var [--help] [--global] [--package=PACKAGE] [OPTION]... + [VAR[=[VALUE]]] opam: variable setting needs a scope, use '--global' or '--switch ' -Usage: opam var [--global] [--package=PACKAGE] [OPTION]... [VAR[=[VALUE]]] -Try 'opam var --help' or 'opam --help' for more information. # Return code 2 # ### opam var arch="somearch" --global Added '[arch "\"somearch\"" "Set through 'opam var'"]' to field global-variables in global configuration From 68dcec3c62c2212cc1e99f6f197b7f83b11f8fd0 Mon Sep 17 00:00:00 2001 From: Brian Ward Date: Fri, 30 Jan 2026 16:51:21 -0500 Subject: [PATCH 04/12] Basic subcommand completions --- src/client/opamArgTools.ml | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/src/client/opamArgTools.ml b/src/client/opamArgTools.ml index cbf6627fbc7..f4ec024285d 100644 --- a/src/client/opamArgTools.ml +++ b/src/client/opamArgTools.ml @@ -710,15 +710,13 @@ type 'a default = [> `default of string] as 'a let mk_subcommands_with_default ~cli commands = let enum_with_default_valrem sl = - let parse, print = - let base = Arg.enum sl in - (Arg.conv_parser base, Arg.conv_printer base) - in - let parse s = - match parse s with + let base = Arg.enum sl in + let parser = Arg.Conv.parser base in + let parser s = + match parser s with | Ok x -> Ok (x) | _ -> Ok (Valid (`default s)) in - Arg.conv (parse, print) + Arg.Conv.of_conv ~parser base in mk_subcommands_aux ~cli enum_with_default_valrem commands From 6a21febf42835908f7ea10d3a51b3b8cf9d4a3f8 Mon Sep 17 00:00:00 2001 From: Brian Ward Date: Mon, 2 Feb 2026 10:27:28 -0500 Subject: [PATCH 05/12] Basic completion for atom_or_dir --- src/client/opamArg.ml | 79 ++++++++++++++++++++++++++++++++++++++----- 1 file changed, 70 insertions(+), 9 deletions(-) diff --git a/src/client/opamArg.ml b/src/client/opamArg.ml index 86531d5a821..fa78a891f89 100644 --- a/src/client/opamArg.ml +++ b/src/client/opamArg.ml @@ -641,6 +641,55 @@ let apply_global_options cli o = with | Sys_error _ | Not_found -> () +(** part of the global_options term, but by separating it out we can have other + completions depend on it for contextual information *) +let switch_flag = + let complete _ ~token = + OpamGlobalState.with_ `Lock_none @@ fun gt -> + let gt = OpamGlobalState.fix_switch_list gt in + let switches = OpamFile.Config.installed_switches gt.config |> List.sort OpamSwitch.compare in + let directives = List.filter_map + (fun sw -> + let sw_name = OpamSwitch.to_string sw in + if OpamCompat.String.starts_with sw_name ~prefix:token then + Some (Arg.Completion.string sw_name) + else + None) + switches + in + Ok directives + in + let switch = Arg.Conv.of_conv ~completion:(Arg.Completion.make complete) + Arg.string + in + mk_opt ~cli:(cli2_0, `Default) cli_original ~section:global_option_section ["switch"] + "SWITCH" "Use $(docv) as the current compiler switch. \ + This is equivalent to setting $(b,\\$OPAMSWITCH) to $(i,SWITCH)." + (Arg.some switch) None + +let complete_with_switch f = + let global_options_for_completion opt_switch = + create_global_options false false None [] true None opt_switch + [] [] + false + None None false + None None true true None true + false false + false None + in + let complete ctx ~token = + let opt_switch = Option.default None ctx in + let options = global_options_for_completion opt_switch in + apply_global_options (OpamCLIVersion.default, `Default) options; + OpamGlobalState.with_ `Lock_none @@ fun gt -> + OpamRepositoryState.with_ `Lock_none gt @@ fun rt -> + let st = + OpamSwitchState.load `Lock_none gt rt (OpamStateConfig.get_switch ()) + in + f st ~token + in + Arg.Completion.make ~context:switch_flag complete + (** Build options *) type build_options = { @@ -895,7 +944,7 @@ let atom_or_local = Arg.conv' (parse, print) let atom_or_dir = - let parse str = match Arg.conv_parser atom_or_local str with + let parser str = match Arg.conv_parser atom_or_local str with | Ok (`Filename _) -> Error (Printf.sprintf "Not a valid package specification or existing directory: %s" @@ -903,11 +952,28 @@ let atom_or_dir = | Ok (`Atom _ | `Dirname _ as atom_or_dir) -> Ok (atom_or_dir) | Error (`Msg e) -> Error e in - let print ppf + let pp ppf :> [ `Atom of OpamTypes.atom | `Dirname of OpamTypes.dirname ] -> unit = Arg.conv_printer atom_or_local ppf in - Arg.conv' (parse, print) + let completion = complete_with_switch (fun st ~token -> + let matching = OpamPackage.Set.filter + (fun pkg -> + OpamCompat.String.starts_with + ~prefix:token + (OpamPackage.to_string pkg)) + st.installed + in + let directives = OpamPackage.Set.to_list_map + (fun pkg -> + Arg.Completion.value + ~doc:"package" + (`Atom (OpamPackage.name pkg, None))) + matching + in + Ok (Arg.Completion.dirs :: directives)) + in + Arg.Conv.make ~docv:"ATOM" ~parser ~completion ~pp () let dep_formula = let module OpamParser = OpamParser.FullPos in @@ -1297,11 +1363,6 @@ let global_options cli = select the 2.0 CLI, set the $(b,OPAMCLI) environment variable to \ $(i,2.0) instead of using this parameter." Arg.string (OpamCLIVersion.to_string OpamCLIVersion.current) in - let switch = - mk_opt ~cli cli_original ~section ["switch"] - "SWITCH" "Use $(docv) as the current compiler switch. \ - This is equivalent to setting $(b,\\$OPAMSWITCH) to $(i,SWITCH)." - Arg.(some string) None in let yes = mk_vflag_all ~cli ~section [ cli_original, true, ["y";"yes"], @@ -1420,7 +1481,7 @@ let global_options cli = equivalent to setting $(b,IGNOREPINDEPENDS=true)." in Term.(const create_global_options - $git_version $debug $debug_level $verbose $quiet $color $switch + $git_version $debug $debug_level $verbose $quiet $color $switch_flag $yes $confirm_level $strict $root $external_solver $use_internal_solver $cudf_file $solver_preferences $best_effort From d283a0fb02981f62bdcc4aaeac6edcdf9211ec0e Mon Sep 17 00:00:00 2001 From: Brian Ward Date: Mon, 2 Feb 2026 12:25:42 -0500 Subject: [PATCH 06/12] Completions for packages, switches --- src/client/opamArg.ml | 80 ++++++++++++++++++++++--------------- src/client/opamArg.mli | 25 ++++++++++-- src/client/opamArgTools.ml | 34 ++++++++++++---- src/client/opamArgTools.mli | 14 ++++++- src/client/opamCommands.ml | 9 ++++- 5 files changed, 114 insertions(+), 48 deletions(-) diff --git a/src/client/opamArg.ml b/src/client/opamArg.ml index fa78a891f89..ddf4ca1b9ab 100644 --- a/src/client/opamArg.ml +++ b/src/client/opamArg.ml @@ -641,10 +641,7 @@ let apply_global_options cli o = with | Sys_error _ | Not_found -> () -(** part of the global_options term, but by separating it out we can have other - completions depend on it for contextual information *) -let switch_flag = - let complete _ ~token = +let complete_switch _ ~token = OpamGlobalState.with_ `Lock_none @@ fun gt -> let gt = OpamGlobalState.fix_switch_list gt in let switches = OpamFile.Config.installed_switches gt.config |> List.sort OpamSwitch.compare in @@ -658,8 +655,12 @@ let switch_flag = switches in Ok directives - in - let switch = Arg.Conv.of_conv ~completion:(Arg.Completion.make complete) + + +(** part of the global_options term, but by separating it out we can have other + completions depend on it for contextual information *) +let switch_flag = + let switch = Arg.Conv.of_conv ~completion:(Arg.Completion.make complete_switch) Arg.string in mk_opt ~cli:(cli2_0, `Default) cli_original ~section:global_option_section ["switch"] @@ -667,6 +668,8 @@ let switch_flag = This is equivalent to setting $(b,\\$OPAMSWITCH) to $(i,SWITCH)." (Arg.some switch) None +(** Helpers for completions *) + let complete_with_switch f = let global_options_for_completion opt_switch = create_global_options false false None [] true None opt_switch @@ -690,6 +693,26 @@ let complete_with_switch f = in Arg.Completion.make ~context:switch_flag complete +let complete_packages ?(which=`Installed ) ?(extras=[]) () = + complete_with_switch @@ fun st ~token -> + let packages = + match which with + | `Installed -> st.installed + | `All -> OpamPackage.Set.union st.packages st.installed + in + let packages = OpamPackage.names_of_packages packages in + let directives = List.filter_map + (fun pkg -> + let name = OpamPackage.Name.to_string pkg in + if OpamCompat.String.starts_with ~prefix:token name then + Some (Arg.Completion.string name) + else + None + ) + (OpamPackage.Name.Set.to_seq packages |> List.of_seq) + in + Ok (extras @ directives) + (** Build options *) type build_options = { @@ -817,9 +840,10 @@ let existing_filename_or_dash = Arg.conv' (parse, print) let dirname = - let parse str = Ok (OpamFilename.Dir.of_string str) in - let print ppf dir = pr_str ppf (escape_path (OpamFilename.prettify_dir dir)) in - Arg.conv' (parse, print) + let completion = Arg.Completion.complete_dirs in + let parser str = Ok (OpamFilename.Dir.of_string str) in + let pp ppf dir = pr_str ppf (escape_path (OpamFilename.prettify_dir dir)) in + Arg.Conv.make ~docv:"DIR" ~completion ~parser ~pp () let existing_filename_dirname_or_dash = let parse str = @@ -847,12 +871,13 @@ let subpath_conv = Arg.conv' (parse, print) let package_name = - let parse str = + let parser str = try Ok (OpamPackage.Name.of_string str) with Failure msg -> Error msg in - let print ppf pkg = pr_str ppf (OpamPackage.Name.to_string pkg) in - Arg.conv' (parse, print) + let pp ppf pkg = pr_str ppf (OpamPackage.Name.to_string pkg) in + let completion = complete_packages ~which:`All () in + Arg.Conv.make ~docv:"PACKAGE" ~completion ~pp ~parser () let package_version = let parse str = @@ -920,7 +945,7 @@ let atom = Arg.conv' (parse, print) let atom_or_local = - let parse str = + let parser str = if OpamFilename.is_rel_seg str || OpamCompat.String.exists OpamFilename.is_dir_sep str then @@ -936,12 +961,13 @@ let atom_or_local = | Ok at -> Ok (`Atom at) | Error (`Msg e) -> Error e in - let print ppf = function + let pp ppf = function | `Filename f -> pr_str ppf (OpamFilename.to_string f) | `Dirname d -> pr_str ppf (OpamFilename.Dir.to_string d) | `Atom a -> Arg.conv_printer atom ppf a in - Arg.conv' (parse, print) + let completion = complete_packages ~which:`All ~extras:[Arg.Completion.dirs; Arg.Completion.files] () in + Arg.Conv.make ~completion ~docv:"PACKAGE" ~parser ~pp () let atom_or_dir = let parser str = match Arg.conv_parser atom_or_local str with @@ -956,23 +982,7 @@ let atom_or_dir = :> [ `Atom of OpamTypes.atom | `Dirname of OpamTypes.dirname ] -> unit = Arg.conv_printer atom_or_local ppf in - let completion = complete_with_switch (fun st ~token -> - let matching = OpamPackage.Set.filter - (fun pkg -> - OpamCompat.String.starts_with - ~prefix:token - (OpamPackage.to_string pkg)) - st.installed - in - let directives = OpamPackage.Set.to_list_map - (fun pkg -> - Arg.Completion.value - ~doc:"package" - (`Atom (OpamPackage.name pkg, None))) - matching - in - Ok (Arg.Completion.dirs :: directives)) - in + let completion = complete_packages ~extras:[Arg.Completion.dirs] () in Arg.Conv.make ~docv:"ATOM" ~parser ~completion ~pp () let dep_formula = @@ -1275,11 +1285,15 @@ let repo_kind_flag ?section cli validity = (string_of_enum main_kinds)) let jobs_flag ?section cli validity = + let jobs_conv = Arg.Conv.of_conv + ~completion:(Arg.Completion.make (fun _ ~token:_ -> Ok (List.map Arg.Completion.value [1;2;3;4;5;6;7;8]))) + positive_integer + in mk_opt ~cli validity ?section ["j";"jobs"] "JOBS" "Set the maximal number of concurrent jobs to use. The default value is \ calculated from the number of cores. You can also set it using the \ $(b,\\$OPAMJOBS) environment variable." - Arg.(some positive_integer) None + Arg.(some jobs_conv) None let formula_flag ?section cli = mk_opt ~cli (cli_from ~experimental:true cli2_2) ?section ["formula"] "FORMULA" diff --git a/src/client/opamArg.mli b/src/client/opamArg.mli index b3619fe9f38..1a87612c0aa 100644 --- a/src/client/opamArg.mli +++ b/src/client/opamArg.mli @@ -316,10 +316,16 @@ type 'a subcommands = 'a subcommand list val mk_subcommands: cli:OpamCLIVersion.Sourced.t -> - 'a subcommands -> 'a option Term.t * string list Term.t + ?params_completions:('a option, string) Arg.Completion.func -> + 'a subcommands -> + 'a option Term.t * string list Term.t (** [subcommands cmds] are the terms [cmd] and [params]. [cmd] parses which sub-commands in [cmds] is selected and [params] parses the - remaining of the command-line parameters as a list of strings. *) + remaining of the command-line parameters as a list of strings. + + [params_completions] is used to complete parameters for the selected sub-command, + with the selected command as the context argument +*) type 'a default = [> `default of string] as 'a @@ -330,9 +336,16 @@ val enum_with_default: (string * 'a default) list -> 'a Arg.converter val mk_subcommands_with_default: cli:OpamCLIVersion.Sourced.t -> - 'a default subcommands -> 'a option Term.t * string list Term.t + ?params_completions:'a OpamArgTools.default_command_completer -> + 'a default subcommands -> + 'a option Term.t * string list Term.t (** Same as {!mk_subcommands} but use the default value if no - sub-command is selected. *) + sub-command is selected. + + The [params_completions] argument is called with [`default ""] for + the top-level completion, and with the command context when used for + parameters of sub-commands. +*) val bad_subcommand: cli:OpamCLIVersion.Sourced.t -> @@ -386,3 +399,7 @@ val help_sections: OpamCLIVersion.Sourced.t -> Manpage.block list val preinit_opam_env_variables: unit -> unit val init_opam_env_variabes: OpamCLIVersion.Sourced.t -> unit val scrubbed_environment_variables: string list + + +(** {2 Completion helpers} *) +val complete_switch: ('a, 'b) Arg.Completion.func diff --git a/src/client/opamArgTools.ml b/src/client/opamArgTools.ml index f4ec024285d..0b605cddfdd 100644 --- a/src/client/opamArgTools.ml +++ b/src/client/opamArgTools.ml @@ -677,7 +677,7 @@ let mk_subdoc ~cli ?(defaults=[]) ?(extra_defaults=[]) commands = `I (cmds, d) ) commands -let mk_subcommands_aux ~cli my_enum commands = +let mk_subcommands_aux ~cli ~params_completions my_enum commands = let commands = List.map (fun (v,n,c,a,d) -> contented_validity v c, n, a, d) commands in @@ -698,27 +698,47 @@ let mk_subcommands_aux ~cli my_enum commands = term_cli_check ~check Arg.(pos 0 (some & my_enum scommand) None & doc) in let params = + let completion = Arg.Completion.make ~context:command params_completions in + let params_conv = Arg.Conv.of_conv ~completion Arg.string in let doc = Arg.info ~doc:"Optional parameters." [] in - Arg.(value & pos_right 0 string [] & doc) + Arg.(value & pos_right 0 params_conv [] & doc) in command, params -let mk_subcommands ~cli commands = - mk_subcommands_aux ~cli Arg.enum commands +let mk_subcommands ~cli ?(params_completions= fun _ ~token:_ -> Ok []) commands = + mk_subcommands_aux ~cli ~params_completions Arg.enum commands type 'a default = [> `default of string] as 'a -let mk_subcommands_with_default ~cli commands = +type 'a default_command_completer = { + f:'b. ('a default option, 'b) Arg.Completion.func +} + +let mk_subcommands_with_default ~cli ?(params_completions= {f=fun _ ~token:_ -> Ok []}) commands = let enum_with_default_valrem sl = let base = Arg.enum sl in let parser = Arg.Conv.parser base in + let completion = + let Complete (_, enum_completer) = Arg.Completion.complete + (Arg.Conv.completion base) + in + let complete _ ~token = + let enum_values = + enum_completer None ~token |> Result.to_option |> Option.default [] + in + match params_completions.f (Some (Some (`default ""))) ~token with + | Error _ -> Ok enum_values + | Ok l -> Ok (enum_values @ l) + in + Arg.Completion.make complete + in let parser s = match parser s with | Ok x -> Ok (x) | _ -> Ok (Valid (`default s)) in - Arg.Conv.of_conv ~parser base + Arg.Conv.of_conv ~completion ~parser base in - mk_subcommands_aux ~cli enum_with_default_valrem commands + mk_subcommands_aux ~cli ~params_completions:params_completions.f enum_with_default_valrem commands let bad_subcommand ~cli subcommands (command, usersubcommand, userparams) = match usersubcommand with diff --git a/src/client/opamArgTools.mli b/src/client/opamArgTools.mli index 71d5ffd27df..c6f44fda9a7 100644 --- a/src/client/opamArgTools.mli +++ b/src/client/opamArgTools.mli @@ -77,13 +77,23 @@ type 'a subcommand = validity * string * 'a * string list * string type 'a subcommands = 'a subcommand list val mk_subcommands: - cli:OpamCLIVersion.Sourced.t -> 'a subcommands -> + cli:OpamCLIVersion.Sourced.t -> + ?params_completions:('a option, string) Arg.Completion.func -> + 'a subcommands -> 'a option Term.t * string list Term.t type 'a default = [> `default of string] as 'a +(* slightly unfortunate: typed completions require some higher-rank polymorphism + for the completion function here *) +type 'a default_command_completer = { + f:'b. ('a default option, 'b) Arg.Completion.func +} + val mk_subcommands_with_default: - cli:OpamCLIVersion.Sourced.t -> 'a default subcommands -> + cli:OpamCLIVersion.Sourced.t -> + ?params_completions:'a default_command_completer -> + 'a default subcommands -> 'a option Term.t * string list Term.t val bad_subcommand: diff --git a/src/client/opamCommands.ml b/src/client/opamCommands.ml index 301dc9aa4a7..ba01d8d96db 100644 --- a/src/client/opamCommands.ml +++ b/src/client/opamCommands.ml @@ -2814,8 +2814,13 @@ let switch cli = @ [`S Manpage.s_options] @ OpamArg.man_build_option_section in - - let command, params = mk_subcommands_with_default ~cli commands in + let params_completions = {OpamArgTools.f= + fun command_opt ~token -> + match Option.default None command_opt with + | Some (`set | `remove | `reinstall | `link | `install | `default _) | None -> + OpamArg.complete_switch None ~token + | _ -> Ok []} in + let command, params = mk_subcommands_with_default ~params_completions ~cli commands in let no_switch = mk_flag ~cli cli_original ["no-switch"] "Don't automatically select newly installed switches." in From 892b419eaaa9922226b9161fcf81debe063c2bac Mon Sep 17 00:00:00 2001 From: Brian Ward Date: Mon, 2 Feb 2026 16:10:14 -0500 Subject: [PATCH 07/12] completion for repos, switches, packages, more --- src/client/opamArg.ml | 96 +++++++++++++++++-------------------- src/client/opamArg.mli | 11 ++++- src/client/opamArgTools.ml | 40 +++++++++++++--- src/client/opamArgTools.mli | 7 ++- src/client/opamCommands.ml | 59 +++++++++++++++++++---- 5 files changed, 143 insertions(+), 70 deletions(-) diff --git a/src/client/opamArg.ml b/src/client/opamArg.ml index ddf4ca1b9ab..93af0ed2423 100644 --- a/src/client/opamArg.ml +++ b/src/client/opamArg.ml @@ -641,63 +641,34 @@ let apply_global_options cli o = with | Sys_error _ | Not_found -> () -let complete_switch _ ~token = - OpamGlobalState.with_ `Lock_none @@ fun gt -> - let gt = OpamGlobalState.fix_switch_list gt in - let switches = OpamFile.Config.installed_switches gt.config |> List.sort OpamSwitch.compare in - let directives = List.filter_map - (fun sw -> - let sw_name = OpamSwitch.to_string sw in - if OpamCompat.String.starts_with sw_name ~prefix:token then - Some (Arg.Completion.string sw_name) - else - None) - switches - in - Ok directives - - -(** part of the global_options term, but by separating it out we can have other - completions depend on it for contextual information *) -let switch_flag = - let switch = Arg.Conv.of_conv ~completion:(Arg.Completion.make complete_switch) - Arg.string - in - mk_opt ~cli:(cli2_0, `Default) cli_original ~section:global_option_section ["switch"] - "SWITCH" "Use $(docv) as the current compiler switch. \ - This is equivalent to setting $(b,\\$OPAMSWITCH) to $(i,SWITCH)." - (Arg.some switch) None - (** Helpers for completions *) -let complete_with_switch f = - let global_options_for_completion opt_switch = - create_global_options false false None [] true None opt_switch - [] [] - false - None None false - None None true true None true - false false - false None - in - let complete ctx ~token = - let opt_switch = Option.default None ctx in - let options = global_options_for_completion opt_switch in - apply_global_options (OpamCLIVersion.default, `Default) options; - OpamGlobalState.with_ `Lock_none @@ fun gt -> - OpamRepositoryState.with_ `Lock_none gt @@ fun rt -> - let st = - OpamSwitchState.load `Lock_none gt rt (OpamStateConfig.get_switch ()) - in - f st ~token - in - Arg.Completion.make ~context:switch_flag complete +let global_options_for_completion opt_switch = + create_global_options false false None [] true None opt_switch + [] [] + false + None None false + None None true true None true + false false + false None + +let complete_with_switch f ctx ~token = + let opt_switch = Option.default None ctx in + let options = global_options_for_completion opt_switch in + apply_global_options (OpamCLIVersion.default, `Default) options; + OpamGlobalState.with_ `Lock_none @@ fun gt -> + OpamRepositoryState.with_ `Lock_none gt @@ fun rt -> + let st = + OpamSwitchState.load `Lock_none gt rt (OpamStateConfig.get_switch ()) + in + f st ~token let complete_packages ?(which=`Installed ) ?(extras=[]) () = complete_with_switch @@ fun st ~token -> let packages = match which with | `Installed -> st.installed + | `Pinned -> st.pinned | `All -> OpamPackage.Set.union st.packages st.installed in let packages = OpamPackage.names_of_packages packages in @@ -713,6 +684,27 @@ let complete_packages ?(which=`Installed ) ?(extras=[]) () = in Ok (extras @ directives) +let package_completion ?(which=`Installed ) ?(extras=[]) () = + Arg.Completion.make + ~context:switch_flag + (complete_packages ~which ~extras ()) + +let complete_repos _ ~token = + OpamGlobalState.with_ `Lock_none @@ fun gt -> + OpamRepositoryState.with_ `Lock_none gt @@ fun rt -> + let repos = rt.repositories in + let directives = List.filter_map + (fun repo -> + let name = OpamRepositoryName.to_string repo in + if OpamCompat.String.starts_with ~prefix:token name then + Some (Arg.Completion.string name) + else + None + ) + (OpamRepositoryName.Map.keys repos) + in + Ok directives + (** Build options *) type build_options = { @@ -876,7 +868,7 @@ let package_name = with Failure msg -> Error msg in let pp ppf pkg = pr_str ppf (OpamPackage.Name.to_string pkg) in - let completion = complete_packages ~which:`All () in + let completion = package_completion ~which:`All () in Arg.Conv.make ~docv:"PACKAGE" ~completion ~pp ~parser () let package_version = @@ -966,7 +958,7 @@ let atom_or_local = | `Dirname d -> pr_str ppf (OpamFilename.Dir.to_string d) | `Atom a -> Arg.conv_printer atom ppf a in - let completion = complete_packages ~which:`All ~extras:[Arg.Completion.dirs; Arg.Completion.files] () in + let completion = package_completion ~which:`All ~extras:[Arg.Completion.dirs; Arg.Completion.files] () in Arg.Conv.make ~completion ~docv:"PACKAGE" ~parser ~pp () let atom_or_dir = @@ -982,7 +974,7 @@ let atom_or_dir = :> [ `Atom of OpamTypes.atom | `Dirname of OpamTypes.dirname ] -> unit = Arg.conv_printer atom_or_local ppf in - let completion = complete_packages ~extras:[Arg.Completion.dirs] () in + let completion = package_completion ~extras:[Arg.Completion.dirs] () in Arg.Conv.make ~docv:"ATOM" ~parser ~completion ~pp () let dep_formula = diff --git a/src/client/opamArg.mli b/src/client/opamArg.mli index 1a87612c0aa..0dc48de03df 100644 --- a/src/client/opamArg.mli +++ b/src/client/opamArg.mli @@ -316,7 +316,7 @@ type 'a subcommands = 'a subcommand list val mk_subcommands: cli:OpamCLIVersion.Sourced.t -> - ?params_completions:('a option, string) Arg.Completion.func -> + ?params_completions:(string option * 'a option, string) Arg.Completion.func -> 'a subcommands -> 'a option Term.t * string list Term.t (** [subcommands cmds] are the terms [cmd] and [params]. [cmd] parses @@ -324,7 +324,7 @@ val mk_subcommands: remaining of the command-line parameters as a list of strings. [params_completions] is used to complete parameters for the selected sub-command, - with the selected command as the context argument + with the [--switch] argument and selected command as the context *) type 'a default = [> `default of string] as 'a @@ -402,4 +402,11 @@ val scrubbed_environment_variables: string list (** {2 Completion helpers} *) + val complete_switch: ('a, 'b) Arg.Completion.func +val complete_repos: ('a, 'b) Arg.Completion.func +val complete_packages: + ?which:[ `All | `Installed | `Pinned ] -> + ?extras:'a Arg.Completion.directive conjunction -> + unit -> + (string option, 'a) Arg.Completion.func diff --git a/src/client/opamArgTools.ml b/src/client/opamArgTools.ml index 0b605cddfdd..eaaf0d8e0d5 100644 --- a/src/client/opamArgTools.ml +++ b/src/client/opamArgTools.ml @@ -677,6 +677,33 @@ let mk_subdoc ~cli ?(defaults=[]) ?(extra_defaults=[]) commands = `I (cmds, d) ) commands +let complete_switch _ ~token = + OpamGlobalState.with_ `Lock_none @@ fun gt -> + let gt = OpamGlobalState.fix_switch_list gt in + let switches = OpamFile.Config.installed_switches gt.config |> List.sort OpamSwitch.compare in + let directives = List.filter_map + (fun sw -> + let sw_name = OpamSwitch.to_string sw in + if OpamCompat.String.starts_with sw_name ~prefix:token then + Some (Arg.Completion.string sw_name) + else + None) + switches + in + Ok directives + + +(** part of the global_options term, but by separating it out we can have other + completions depend on it for contextual information *) +let switch_flag = + let switch = Arg.Conv.of_conv ~completion:(Arg.Completion.make complete_switch) + Arg.string + in + mk_opt ~cli:(cli2_0, `Default) cli_original ~section:Manpage.s_common_options ["switch"] + "SWITCH" "Use $(docv) as the current compiler switch. \ + This is equivalent to setting $(b,\\$OPAMSWITCH) to $(i,SWITCH)." + (Arg.some switch) None + let mk_subcommands_aux ~cli ~params_completions my_enum commands = let commands = List.map (fun (v,n,c,a,d) -> contented_validity v c, n, a, d) commands @@ -698,7 +725,7 @@ let mk_subcommands_aux ~cli ~params_completions my_enum commands = term_cli_check ~check Arg.(pos 0 (some & my_enum scommand) None & doc) in let params = - let completion = Arg.Completion.make ~context:command params_completions in + let completion = Arg.Completion.make ~context:(Term.product switch_flag command) params_completions in let params_conv = Arg.Conv.of_conv ~completion Arg.string in let doc = Arg.info ~doc:"Optional parameters." [] in Arg.(value & pos_right 0 params_conv [] & doc) @@ -711,7 +738,7 @@ let mk_subcommands ~cli ?(params_completions= fun _ ~token:_ -> Ok []) commands type 'a default = [> `default of string] as 'a type 'a default_command_completer = { - f:'b. ('a default option, 'b) Arg.Completion.func + f:'b. (string option * 'a default option, 'b) Arg.Completion.func } let mk_subcommands_with_default ~cli ?(params_completions= {f=fun _ ~token:_ -> Ok []}) commands = @@ -722,15 +749,16 @@ let mk_subcommands_with_default ~cli ?(params_completions= {f=fun _ ~token:_ -> let Complete (_, enum_completer) = Arg.Completion.complete (Arg.Conv.completion base) in - let complete _ ~token = + let complete ctx ~token = + let opt_switch = Option.default None ctx in let enum_values = - enum_completer None ~token |> Result.to_option |> Option.default [] + enum_completer None ~token |> Result.value ~default:[] in - match params_completions.f (Some (Some (`default ""))) ~token with + match params_completions.f (Some (opt_switch, Some (`default ""))) ~token with | Error _ -> Ok enum_values | Ok l -> Ok (enum_values @ l) in - Arg.Completion.make complete + Arg.Completion.make ~context:switch_flag complete in let parser s = match parser s with diff --git a/src/client/opamArgTools.mli b/src/client/opamArgTools.mli index c6f44fda9a7..a717c51730f 100644 --- a/src/client/opamArgTools.mli +++ b/src/client/opamArgTools.mli @@ -78,7 +78,7 @@ type 'a subcommands = 'a subcommand list val mk_subcommands: cli:OpamCLIVersion.Sourced.t -> - ?params_completions:('a option, string) Arg.Completion.func -> + ?params_completions:(string option * 'a option, string) Arg.Completion.func -> 'a subcommands -> 'a option Term.t * string list Term.t @@ -87,7 +87,7 @@ type 'a default = [> `default of string] as 'a (* slightly unfortunate: typed completions require some higher-rank polymorphism for the completion function here *) type 'a default_command_completer = { - f:'b. ('a default option, 'b) Arg.Completion.func + f:'b. (string option * 'a default option, 'b) Arg.Completion.func } val mk_subcommands_with_default: @@ -96,6 +96,9 @@ val mk_subcommands_with_default: 'a default subcommands -> 'a option Term.t * string list Term.t +val complete_switch: ('a, 'b) Arg.Completion.func +val switch_flag: string option Term.t + val bad_subcommand: cli:OpamCLIVersion.Sourced.t -> 'a default subcommands -> (string * 'a option * string list) -> 'b Term.ret diff --git a/src/client/opamCommands.ml b/src/client/opamCommands.ml index ba01d8d96db..c7f4f635f53 100644 --- a/src/client/opamCommands.ml +++ b/src/client/opamCommands.ml @@ -1708,7 +1708,8 @@ let exec cli = `P "This is a shortcut, and equivalent to $(b,opam config exec)."; ] in let cmd = - Arg.(non_empty & pos_all string [] & info ~docv:"COMMAND [ARG]..." []) + let cmd_conv = Arg.(Conv.of_conv ~completion:Completion.complete_restart string) in + Arg.(non_empty & pos_all cmd_conv [] & info ~docv:"COMMAND [ARG]..." []) in let no_switch = mk_flag ~cli (cli_from cli2_2) ["no-switch"] @@ -2161,9 +2162,18 @@ let update cli = mk_flag ~cli cli_original ["u";"upgrade"] "Automatically run $(b,opam upgrade) after the update." in let name_list = + let completion = + let complete ctx ~token = + let repos = OpamArg.complete_repos ctx ~token |> Result.value ~default:[] in + OpamArg.complete_packages ~which:(`Pinned) ~extras:repos () ctx ~token + in + Arg.Completion.make ~context:OpamArgTools.switch_flag complete + in + let names_conv = + Arg.(Conv.of_conv ~completion string) in arg_list "NAMES" "List of repository or development package names to update." - Arg.string in + names_conv in let all = mk_flag ~cli cli_original ["a"; "all"] "Update all configured repositories, not only what is set in the current \ @@ -2340,7 +2350,17 @@ let repository cli = `S Manpage.s_options; ] in - let command, params = mk_subcommands ~cli commands in + let params_completions ctx ~token = + let _switch, command = Option.default (None, None) ctx in + match command with + | Some (`add | `set_url) -> + OpamArg.complete_repos None ~token |> Result.map + (List.cons Arg.Completion.dirs) + | Some (`remove | `priority | `set_repos) -> + OpamArg.complete_repos None ~token + | _ -> Ok [] + in + let command, params = mk_subcommands ~params_completions ~cli commands in let scope = let scope_info ?docv flags doc = Arg.info ~docs:scope_section ~doc ?docv flags @@ -2359,7 +2379,9 @@ let repository cli = ] in let switches = - Arg.opt Arg.(list string) [] + let switch_conv = Arg.(Conv.of_conv ~completion:(Completion.make OpamArg.complete_switch) (list string)) + in + Arg.opt switch_conv [] (scope_info ["on-switches"] ~docv:"SWITCHES" "Act on the selections of the given list of switches") in @@ -2815,10 +2837,18 @@ let switch cli = @ OpamArg.man_build_option_section in let params_completions = {OpamArgTools.f= - fun command_opt ~token -> - match Option.default None command_opt with - | Some (`set | `remove | `reinstall | `link | `install | `default _) | None -> + fun ctx ~token -> + let opt_switch, command = Option.default (None, None) ctx in + match command with + | Some (`set | `remove | `reinstall | `install | `default _) | None -> OpamArg.complete_switch None ~token + | Some (`link) -> + OpamArg.complete_switch None ~token |> + Result.map (List.cons Arg.Completion.dirs) + | Some (`export | `import) -> + Ok [Arg.Completion.files] + | Some (`set_invariant) -> + OpamArg.complete_packages () (Some opt_switch) ~token | _ -> Ok []} in let command, params = mk_subcommands_with_default ~params_completions ~cli commands in let no_switch = @@ -3338,7 +3368,20 @@ let pin ?(unpin_only=false) cli = Term.const (Some `remove), Arg.(value & pos_all string [] & Arg.info []) else - mk_subcommands_with_default ~cli commands in + let params_completions = {OpamArgTools.f= + fun ctx ~token -> + let opt_switch, command = Option.default (None, None) ctx in + match command with + | Some (`scan) -> + Ok [Arg.Completion.dirs] + | Some (`remove) -> + OpamArg.complete_packages ~which:(`Pinned) ~extras:[Arg.Completion.dirs] () + (Some opt_switch) ~token + | Some (`add | `default "") -> + OpamArg.complete_packages ~which:(`All) ~extras:[Arg.Completion.dirs] () + (Some opt_switch) ~token + | _ -> Ok []} in + mk_subcommands_with_default ~cli ~params_completions commands in let edit = mk_flag ~cli cli_original ["e";"edit"] "With $(i,opam pin add), edit the opam file as with `opam pin edit' \ From deb7cb7168e117934133d0d9bfb2290bcd9654cc Mon Sep 17 00:00:00 2001 From: Brian Ward Date: Tue, 3 Feb 2026 10:11:42 -0500 Subject: [PATCH 08/12] Clean up mk_subcommands --- src/client/opamArg.mli | 8 ++++---- src/client/opamArgTools.ml | 26 +++++++++++++++++--------- src/client/opamArgTools.mli | 13 +++++++++---- src/client/opamCommands.ml | 34 +++++++++++++++++++--------------- 4 files changed, 49 insertions(+), 32 deletions(-) diff --git a/src/client/opamArg.mli b/src/client/opamArg.mli index 0dc48de03df..f425f7153d8 100644 --- a/src/client/opamArg.mli +++ b/src/client/opamArg.mli @@ -316,14 +316,14 @@ type 'a subcommands = 'a subcommand list val mk_subcommands: cli:OpamCLIVersion.Sourced.t -> - ?params_completions:(string option * 'a option, string) Arg.Completion.func -> + ?complete_parameters: ('a, string) OpamArgTools.parameter_completer -> 'a subcommands -> 'a option Term.t * string list Term.t (** [subcommands cmds] are the terms [cmd] and [params]. [cmd] parses which sub-commands in [cmds] is selected and [params] parses the remaining of the command-line parameters as a list of strings. - [params_completions] is used to complete parameters for the selected sub-command, + [complete_parameters] is used to complete parameters for the selected sub-command, with the [--switch] argument and selected command as the context *) @@ -336,13 +336,13 @@ val enum_with_default: (string * 'a default) list -> 'a Arg.converter val mk_subcommands_with_default: cli:OpamCLIVersion.Sourced.t -> - ?params_completions:'a OpamArgTools.default_command_completer -> + ?complete_parameters:'a OpamArgTools.parameter_completer_default -> 'a default subcommands -> 'a option Term.t * string list Term.t (** Same as {!mk_subcommands} but use the default value if no sub-command is selected. - The [params_completions] argument is called with [`default ""] for + The [complete_parameters] argument is called with [`default ""] for the top-level completion, and with the command context when used for parameters of sub-commands. *) diff --git a/src/client/opamArgTools.ml b/src/client/opamArgTools.ml index eaaf0d8e0d5..8f345993dec 100644 --- a/src/client/opamArgTools.ml +++ b/src/client/opamArgTools.ml @@ -704,7 +704,10 @@ let switch_flag = This is equivalent to setting $(b,\\$OPAMSWITCH) to $(i,SWITCH)." (Arg.some switch) None -let mk_subcommands_aux ~cli ~params_completions my_enum commands = +type ('cmd, 'd) parameter_completer = + opt_switch:string option -> ('cmd, 'd) Arg.Completion.func + +let mk_subcommands_aux ~cli ~complete_parameters my_enum commands = let commands = List.map (fun (v,n,c,a,d) -> contented_validity v c, n, a, d) commands in @@ -725,23 +728,28 @@ let mk_subcommands_aux ~cli ~params_completions my_enum commands = term_cli_check ~check Arg.(pos 0 (some & my_enum scommand) None & doc) in let params = - let completion = Arg.Completion.make ~context:(Term.product switch_flag command) params_completions in + + let completion = + let completer ctx ~token = + let (opt_switch, cmd) = Option.default (None, None) ctx in + complete_parameters ~opt_switch cmd ~token in + Arg.Completion.make ~context:(Term.product switch_flag command) completer in let params_conv = Arg.Conv.of_conv ~completion Arg.string in let doc = Arg.info ~doc:"Optional parameters." [] in Arg.(value & pos_right 0 params_conv [] & doc) in command, params -let mk_subcommands ~cli ?(params_completions= fun _ ~token:_ -> Ok []) commands = - mk_subcommands_aux ~cli ~params_completions Arg.enum commands +let mk_subcommands ~cli ?(complete_parameters= fun ~opt_switch:_ _ ~token:_ -> Ok []) commands = + mk_subcommands_aux ~cli ~complete_parameters Arg.enum commands type 'a default = [> `default of string] as 'a -type 'a default_command_completer = { - f:'b. (string option * 'a default option, 'b) Arg.Completion.func +type 'cmd parameter_completer_default = { + f:'d. ('cmd default, 'd) parameter_completer } -let mk_subcommands_with_default ~cli ?(params_completions= {f=fun _ ~token:_ -> Ok []}) commands = +let mk_subcommands_with_default ~cli ?(complete_parameters= {f=fun ~opt_switch:_ _ ~token:_ -> Ok []}) commands = let enum_with_default_valrem sl = let base = Arg.enum sl in let parser = Arg.Conv.parser base in @@ -754,7 +762,7 @@ let mk_subcommands_with_default ~cli ?(params_completions= {f=fun _ ~token:_ -> let enum_values = enum_completer None ~token |> Result.value ~default:[] in - match params_completions.f (Some (opt_switch, Some (`default ""))) ~token with + match complete_parameters.f ~opt_switch (Some (`default "")) ~token with | Error _ -> Ok enum_values | Ok l -> Ok (enum_values @ l) in @@ -766,7 +774,7 @@ let mk_subcommands_with_default ~cli ?(params_completions= {f=fun _ ~token:_ -> | _ -> Ok (Valid (`default s)) in Arg.Conv.of_conv ~completion ~parser base in - mk_subcommands_aux ~cli ~params_completions:params_completions.f enum_with_default_valrem commands + mk_subcommands_aux ~cli ~complete_parameters:complete_parameters.f enum_with_default_valrem commands let bad_subcommand ~cli subcommands (command, usersubcommand, userparams) = match usersubcommand with diff --git a/src/client/opamArgTools.mli b/src/client/opamArgTools.mli index a717c51730f..3cac8c6bef4 100644 --- a/src/client/opamArgTools.mli +++ b/src/client/opamArgTools.mli @@ -76,9 +76,14 @@ val string_of_enum: (validity * string * 'a) list -> string type 'a subcommand = validity * string * 'a * string list * string type 'a subcommands = 'a subcommand list + +type ('cmd, 'd) parameter_completer = + opt_switch:string option -> + ('cmd, 'd) Arg.Completion.func + val mk_subcommands: cli:OpamCLIVersion.Sourced.t -> - ?params_completions:(string option * 'a option, string) Arg.Completion.func -> + ?complete_parameters: ('a, string) parameter_completer -> 'a subcommands -> 'a option Term.t * string list Term.t @@ -86,13 +91,13 @@ type 'a default = [> `default of string] as 'a (* slightly unfortunate: typed completions require some higher-rank polymorphism for the completion function here *) -type 'a default_command_completer = { - f:'b. (string option * 'a default option, 'b) Arg.Completion.func +type 'cmd parameter_completer_default = { + f:'d. ('cmd default, 'd) parameter_completer } val mk_subcommands_with_default: cli:OpamCLIVersion.Sourced.t -> - ?params_completions:'a default_command_completer -> + ?complete_parameters:'a parameter_completer_default -> 'a default subcommands -> 'a option Term.t * string list Term.t diff --git a/src/client/opamCommands.ml b/src/client/opamCommands.ml index c7f4f635f53..a1261d29800 100644 --- a/src/client/opamCommands.ml +++ b/src/client/opamCommands.ml @@ -1445,8 +1445,15 @@ let config cli = ] @ mk_subdoc ~cli commands @ [`S Manpage.s_options] in - - let command, params = mk_subcommands ~cli commands in + let complete_parameters ~opt_switch cmd ~token = + match cmd with + | Some (`list) -> + OpamArg.complete_packages () (Some opt_switch) ~token + | Some (`subst | `pef | `cudf) -> + Ok [Arg.Completion.files] + | _ -> Ok [] + in + let command, params = mk_subcommands ~complete_parameters ~cli commands in let open Common_config_flags in let config global_options @@ -2350,9 +2357,8 @@ let repository cli = `S Manpage.s_options; ] in - let params_completions ctx ~token = - let _switch, command = Option.default (None, None) ctx in - match command with + let complete_parameters ~opt_switch:_ cmd ~token = + match cmd with | Some (`add | `set_url) -> OpamArg.complete_repos None ~token |> Result.map (List.cons Arg.Completion.dirs) @@ -2360,7 +2366,7 @@ let repository cli = OpamArg.complete_repos None ~token | _ -> Ok [] in - let command, params = mk_subcommands ~params_completions ~cli commands in + let command, params = mk_subcommands ~complete_parameters ~cli commands in let scope = let scope_info ?docv flags doc = Arg.info ~docs:scope_section ~doc ?docv flags @@ -2836,9 +2842,8 @@ let switch cli = @ [`S Manpage.s_options] @ OpamArg.man_build_option_section in - let params_completions = {OpamArgTools.f= - fun ctx ~token -> - let opt_switch, command = Option.default (None, None) ctx in + let complete_parameters = {OpamArgTools.f= + fun ~opt_switch command ~token -> match command with | Some (`set | `remove | `reinstall | `install | `default _) | None -> OpamArg.complete_switch None ~token @@ -2850,7 +2855,7 @@ let switch cli = | Some (`set_invariant) -> OpamArg.complete_packages () (Some opt_switch) ~token | _ -> Ok []} in - let command, params = mk_subcommands_with_default ~params_completions ~cli commands in + let command, params = mk_subcommands_with_default ~complete_parameters ~cli commands in let no_switch = mk_flag ~cli cli_original ["no-switch"] "Don't automatically select newly installed switches." in @@ -3368,10 +3373,9 @@ let pin ?(unpin_only=false) cli = Term.const (Some `remove), Arg.(value & pos_all string [] & Arg.info []) else - let params_completions = {OpamArgTools.f= - fun ctx ~token -> - let opt_switch, command = Option.default (None, None) ctx in - match command with + let complete_parameters = {OpamArgTools.f= + fun ~opt_switch cmd ~token -> + match cmd with | Some (`scan) -> Ok [Arg.Completion.dirs] | Some (`remove) -> @@ -3381,7 +3385,7 @@ let pin ?(unpin_only=false) cli = OpamArg.complete_packages ~which:(`All) ~extras:[Arg.Completion.dirs] () (Some opt_switch) ~token | _ -> Ok []} in - mk_subcommands_with_default ~cli ~params_completions commands in + mk_subcommands_with_default ~cli ~complete_parameters commands in let edit = mk_flag ~cli cli_original ["e";"edit"] "With $(i,opam pin add), edit the opam file as with `opam pin edit' \ From 6a127d61e0233b78d6cd4ed4bf350f668d722f1c Mon Sep 17 00:00:00 2001 From: Brian Ward Date: Tue, 3 Feb 2026 10:55:48 -0500 Subject: [PATCH 09/12] More misc completions, believe I'm beyond parity with existing --- src/client/opamArg.ml | 76 ++++++++++++++++++++++++++++--------- src/client/opamArg.mli | 8 +++- src/client/opamArgTools.ml | 9 ++--- src/client/opamArgTools.mli | 2 +- src/client/opamCommands.ml | 14 ++++--- 5 files changed, 78 insertions(+), 31 deletions(-) diff --git a/src/client/opamArg.ml b/src/client/opamArg.ml index 93af0ed2423..b60d5cd718b 100644 --- a/src/client/opamArg.ml +++ b/src/client/opamArg.ml @@ -653,7 +653,7 @@ let global_options_for_completion opt_switch = false None let complete_with_switch f ctx ~token = - let opt_switch = Option.default None ctx in + let opt_switch = OpamStd.Option.default None ctx in let options = global_options_for_completion opt_switch in apply_global_options (OpamCLIVersion.default, `Default) options; OpamGlobalState.with_ `Lock_none @@ fun gt -> @@ -814,9 +814,9 @@ let url = Arg.conv' (parse, print) let filename = - let parse str = Ok (OpamFilename.of_string str) in - let print ppf filename = pr_str ppf (OpamFilename.to_string filename) in - Arg.conv' (parse, print) + let parser str = Ok (OpamFilename.of_string str) in + let pp ppf filename = pr_str ppf (OpamFilename.to_string filename) in + Arg.Conv.make ~completion:Arg.Completion.complete_files ~docv:"A file" ~parser ~pp () let existing_filename_or_dash = let parse str = @@ -879,6 +879,14 @@ let package_version = let print ppf ver = pr_str ppf (OpamPackage.Version.to_string ver) in Arg.conv' (parse, print) +let level_int = + Arg.(Conv.of_conv + ~completion:(Completion.make + (fun _ ~token:_ -> + Ok (List.map Completion.value + [1;2;3;4;5;6;7;8]))) + int) + let positive_integer : int Arg.conv = let parser = Arg.conv_parser Arg.int in let printer = Arg.conv_printer Arg.int in @@ -1112,6 +1120,18 @@ let opamlist_column = in Arg.conv' (parse, print) +let complete_opam_fields _ ~token = + let directives = + List.filter_map + (fun (_, name) -> + if OpamCompat.String.starts_with ~prefix:token name && not (String.contains name '<') then + Some (Arg.Completion.string name) + else + None) + OpamListCommand.field_names + in + Ok directives + let opamlist_columns = let field_re = (* max paren nesting 1, obviously *) @@ -1124,7 +1144,7 @@ let opamlist_columns = alt [char ','; stop]; ]) in - let parse str = + let parser str = try let rec aux pos = if pos = String.length str then [] else @@ -1142,7 +1162,7 @@ let opamlist_columns = with Not_found -> Error (Printf.sprintf "Invalid columns specification: '%s'." str) in - let print ppf cols = + let pp ppf cols = let rec aux = function | x::(_::_) as r -> Arg.conv_printer opamlist_column ppf x; @@ -1153,7 +1173,8 @@ let opamlist_columns = in aux cols in - Arg.conv' (parse, print) + let completion = Arg.Completion.make complete_opam_fields in + Arg.Conv.make ~docv:"COLUMN" ~completion ~parser ~pp () let hash_kinds = Arg.enum @@ -1278,7 +1299,7 @@ let repo_kind_flag ?section cli validity = let jobs_flag ?section cli validity = let jobs_conv = Arg.Conv.of_conv - ~completion:(Arg.Completion.make (fun _ ~token:_ -> Ok (List.map Arg.Completion.value [1;2;3;4;5;6;7;8]))) + ~completion:(Arg.Conv.completion level_int) positive_integer in mk_opt ~cli validity ?section ["j";"jobs"] "JOBS" @@ -1345,7 +1366,7 @@ let global_options cli = "Like $(b,--debug), but allows specifying the debug level ($(b,--debug) \ sets it to 1). Equivalent to setting $(b,\\$OPAMDEBUG) to a positive \ integer." - Arg.(some int) None in + Arg.(some level_int) None in let verbose = Arg.(value & flag_all & info ~docs:section ["v";"verbose"] ~doc: "Be more verbose. One $(b,-v) shows all package commands, repeat to \ @@ -1764,21 +1785,40 @@ let package_selection cli = Arg.(pair ~sep:':' string string) in let has_flag = + let flag_conv = + let parser s = + match pkg_flag_of_string s with + | Pkgflag_Unknown s -> + Error ("Invalid package flag "^s^", must be one of "^ + OpamStd.List.concat_map " " string_of_pkg_flag + all_package_flags) + | f -> Ok f + in + let pp fmt flag = + Format.pp_print_string fmt (string_of_pkg_flag flag) + in + let completion = + let completer _ ~token = + Ok (List.filter_map + (fun flag -> + let s = string_of_pkg_flag flag in + if OpamCompat.String.starts_with ~prefix:token s then + Some (Arg.Completion.string s) + else + None) + all_package_flags) + in + Arg.Completion.make completer + in + Arg.Conv.make ~docv:"FLAG" ~completion ~parser ~pp () + in mk_opt_all ~cli cli_original ["has-flag"] "FLAG" ~section ("Only include packages which have the given flag set. \ Package flags are one of: "^ (OpamStd.List.concat_map " " (Printf.sprintf "$(b,%s)" @* string_of_pkg_flag) all_package_flags)) - (Arg.conv' - ((fun s -> match pkg_flag_of_string s with - | Pkgflag_Unknown s -> - Error ("Invalid package flag "^s^", must be one of "^ - OpamStd.List.concat_map " " string_of_pkg_flag - all_package_flags) - | f -> Ok f), - (fun fmt flag -> - Format.pp_print_string fmt (string_of_pkg_flag flag)))) + flag_conv in let has_tag = mk_opt_all ~cli cli_original ["has-tag"] "TAG" ~section diff --git a/src/client/opamArg.mli b/src/client/opamArg.mli index f425f7153d8..b7c8932ff67 100644 --- a/src/client/opamArg.mli +++ b/src/client/opamArg.mli @@ -268,6 +268,9 @@ val dirname: dirname Arg.conv val existing_filename_dirname_or_dash: OpamFilename.generic_file option Arg.conv +(** Like Arg.int but the completion suggests 1..8 *) +val level_int: int Arg.conv + val positive_integer: int Arg.conv (** Package name converter *) @@ -403,8 +406,9 @@ val scrubbed_environment_variables: string list (** {2 Completion helpers} *) -val complete_switch: ('a, 'b) Arg.Completion.func -val complete_repos: ('a, 'b) Arg.Completion.func +val complete_opam_fields: ('ctx, 'a) Arg.Completion.func +val complete_switches: ('ctx, 'a) Arg.Completion.func +val complete_repos: ('cta, 'a) Arg.Completion.func val complete_packages: ?which:[ `All | `Installed | `Pinned ] -> ?extras:'a Arg.Completion.directive conjunction -> diff --git a/src/client/opamArgTools.ml b/src/client/opamArgTools.ml index 8f345993dec..dca74429699 100644 --- a/src/client/opamArgTools.ml +++ b/src/client/opamArgTools.ml @@ -677,7 +677,7 @@ let mk_subdoc ~cli ?(defaults=[]) ?(extra_defaults=[]) commands = `I (cmds, d) ) commands -let complete_switch _ ~token = +let complete_switches _ ~token = OpamGlobalState.with_ `Lock_none @@ fun gt -> let gt = OpamGlobalState.fix_switch_list gt in let switches = OpamFile.Config.installed_switches gt.config |> List.sort OpamSwitch.compare in @@ -696,7 +696,7 @@ let complete_switch _ ~token = (** part of the global_options term, but by separating it out we can have other completions depend on it for contextual information *) let switch_flag = - let switch = Arg.Conv.of_conv ~completion:(Arg.Completion.make complete_switch) + let switch = Arg.Conv.of_conv ~completion:(Arg.Completion.make complete_switches) Arg.string in mk_opt ~cli:(cli2_0, `Default) cli_original ~section:Manpage.s_common_options ["switch"] @@ -728,10 +728,9 @@ let mk_subcommands_aux ~cli ~complete_parameters my_enum commands = term_cli_check ~check Arg.(pos 0 (some & my_enum scommand) None & doc) in let params = - let completion = let completer ctx ~token = - let (opt_switch, cmd) = Option.default (None, None) ctx in + let (opt_switch, cmd) = OpamStd.Option.default (None, None) ctx in complete_parameters ~opt_switch cmd ~token in Arg.Completion.make ~context:(Term.product switch_flag command) completer in let params_conv = Arg.Conv.of_conv ~completion Arg.string in @@ -758,7 +757,7 @@ let mk_subcommands_with_default ~cli ?(complete_parameters= {f=fun ~opt_switch:_ (Arg.Conv.completion base) in let complete ctx ~token = - let opt_switch = Option.default None ctx in + let opt_switch = OpamStd.Option.default None ctx in let enum_values = enum_completer None ~token |> Result.value ~default:[] in diff --git a/src/client/opamArgTools.mli b/src/client/opamArgTools.mli index 3cac8c6bef4..48240b1bea7 100644 --- a/src/client/opamArgTools.mli +++ b/src/client/opamArgTools.mli @@ -101,7 +101,7 @@ val mk_subcommands_with_default: 'a default subcommands -> 'a option Term.t * string list Term.t -val complete_switch: ('a, 'b) Arg.Completion.func +val complete_switches: ('a, 'b) Arg.Completion.func val switch_flag: string option Term.t val bad_subcommand: diff --git a/src/client/opamCommands.ml b/src/client/opamCommands.ml index a1261d29800..d9aeedd911b 100644 --- a/src/client/opamCommands.ml +++ b/src/client/opamCommands.ml @@ -972,6 +972,10 @@ let show cli = $(i,deprecated) flag"); ] in let fields = + let fields_conv = + let completion = Arg.Completion.make complete_opam_fields in + Arg.(Conv.of_conv ~completion (list string)) + in mk_opt ~cli cli_original ["f";"field"] "FIELDS" (Printf.sprintf "Only display the values of these fields. Fields can be selected \ @@ -980,7 +984,7 @@ let show cli = field can be queried by combinig with $(b,--raw)" (OpamStd.List.concat_map ", " (Printf.sprintf "$(i,%s)" @* snd) OpamListCommand.field_names)) - Arg.(list string) [] + fields_conv [] in let show_empty = mk_flag ~cli cli_original ["empty-fields"] @@ -2385,7 +2389,7 @@ let repository cli = ] in let switches = - let switch_conv = Arg.(Conv.of_conv ~completion:(Completion.make OpamArg.complete_switch) (list string)) + let switch_conv = Arg.(Conv.of_conv ~completion:(Completion.make OpamArg.complete_switches) (list string)) in Arg.opt switch_conv [] (scope_info ["on-switches"] ~docv:"SWITCHES" @@ -2405,7 +2409,7 @@ let repository cli = order, therefore 1 is the highest priority. Negative ints can be used to \ select from the lowest priority, -1 being last. $(b,set-repos) can \ otherwise be used to explicitly set the repository list at once." - Arg.(int) 1 + level_int 1 in let repository global_options command kind short scope rank params () = apply_global_options cli global_options; @@ -2846,9 +2850,9 @@ let switch cli = fun ~opt_switch command ~token -> match command with | Some (`set | `remove | `reinstall | `install | `default _) | None -> - OpamArg.complete_switch None ~token + OpamArg.complete_switches None ~token | Some (`link) -> - OpamArg.complete_switch None ~token |> + OpamArg.complete_switches None ~token |> Result.map (List.cons Arg.Completion.dirs) | Some (`export | `import) -> Ok [Arg.Completion.files] From 2eed079e7075d7a37c87a314e59d52b9ff6ef50e Mon Sep 17 00:00:00 2001 From: Brian Ward Date: Tue, 3 Feb 2026 16:25:51 -0500 Subject: [PATCH 10/12] Clean up mk_subcommands_with_default inputs --- src/client/opamArgTools.ml | 18 ++++++++++++------ src/client/opamArgTools.mli | 14 ++++++++++---- src/client/opamCommands.ml | 16 +++++++--------- 3 files changed, 29 insertions(+), 19 deletions(-) diff --git a/src/client/opamArgTools.ml b/src/client/opamArgTools.ml index dca74429699..545f0691665 100644 --- a/src/client/opamArgTools.ml +++ b/src/client/opamArgTools.ml @@ -739,16 +739,22 @@ let mk_subcommands_aux ~cli ~complete_parameters my_enum commands = in command, params -let mk_subcommands ~cli ?(complete_parameters= fun ~opt_switch:_ _ ~token:_ -> Ok []) commands = +let default_subcommand_completer = + fun ~opt_switch:_ _ ~token:_ -> Ok [] + +let mk_subcommands ~cli ?(complete_parameters=default_subcommand_completer) commands = mk_subcommands_aux ~cli ~complete_parameters Arg.enum commands type 'a default = [> `default of string] as 'a type 'cmd parameter_completer_default = { - f:'d. ('cmd default, 'd) parameter_completer -} + complete_parameters:'d. ('cmd default, 'd) parameter_completer +} [@@unboxed] -let mk_subcommands_with_default ~cli ?(complete_parameters= {f=fun ~opt_switch:_ _ ~token:_ -> Ok []}) commands = +let mk_subcommands_with_default ~cli + ?complete_parameters:({complete_parameters}={complete_parameters=default_subcommand_completer}) + commands + = let enum_with_default_valrem sl = let base = Arg.enum sl in let parser = Arg.Conv.parser base in @@ -761,7 +767,7 @@ let mk_subcommands_with_default ~cli ?(complete_parameters= {f=fun ~opt_switch:_ let enum_values = enum_completer None ~token |> Result.value ~default:[] in - match complete_parameters.f ~opt_switch (Some (`default "")) ~token with + match complete_parameters ~opt_switch (Some (`default "")) ~token with | Error _ -> Ok enum_values | Ok l -> Ok (enum_values @ l) in @@ -773,7 +779,7 @@ let mk_subcommands_with_default ~cli ?(complete_parameters= {f=fun ~opt_switch:_ | _ -> Ok (Valid (`default s)) in Arg.Conv.of_conv ~completion ~parser base in - mk_subcommands_aux ~cli ~complete_parameters:complete_parameters.f enum_with_default_valrem commands + mk_subcommands_aux ~cli ~complete_parameters enum_with_default_valrem commands let bad_subcommand ~cli subcommands (command, usersubcommand, userparams) = match usersubcommand with diff --git a/src/client/opamArgTools.mli b/src/client/opamArgTools.mli index 48240b1bea7..c429d33745a 100644 --- a/src/client/opamArgTools.mli +++ b/src/client/opamArgTools.mli @@ -89,11 +89,17 @@ val mk_subcommands: type 'a default = [> `default of string] as 'a -(* slightly unfortunate: typed completions require some higher-rank polymorphism - for the completion function here *) +(** In [mk_subcommands_with_default], we use this completer twice: + - once, alongside the built-in enum completer, to provide suggestions for the first parameter, + which is either a subcommand name or the argument to the default subcommand. + - once to provide suggestions for the parameters of subcommands, as in [mk_subcommands]. + + Unfortunately, the type of the returned ['a directive]s differs between the two, so we need + higher-rank polymorphism to express this, which we smuggle in via this wrapper record. +*) type 'cmd parameter_completer_default = { - f:'d. ('cmd default, 'd) parameter_completer -} + complete_parameters:'d. ('cmd default, 'd) parameter_completer +} [@@unboxed] val mk_subcommands_with_default: cli:OpamCLIVersion.Sourced.t -> diff --git a/src/client/opamCommands.ml b/src/client/opamCommands.ml index d9aeedd911b..db614b1386e 100644 --- a/src/client/opamCommands.ml +++ b/src/client/opamCommands.ml @@ -2846,8 +2846,7 @@ let switch cli = @ [`S Manpage.s_options] @ OpamArg.man_build_option_section in - let complete_parameters = {OpamArgTools.f= - fun ~opt_switch command ~token -> + let complete_parameters ~opt_switch command ~token = match command with | Some (`set | `remove | `reinstall | `install | `default _) | None -> OpamArg.complete_switches None ~token @@ -2858,8 +2857,8 @@ let switch cli = Ok [Arg.Completion.files] | Some (`set_invariant) -> OpamArg.complete_packages () (Some opt_switch) ~token - | _ -> Ok []} in - let command, params = mk_subcommands_with_default ~complete_parameters ~cli commands in + | _ -> Ok [] in + let command, params = mk_subcommands_with_default ~complete_parameters:{complete_parameters} ~cli commands in let no_switch = mk_flag ~cli cli_original ["no-switch"] "Don't automatically select newly installed switches." in @@ -3377,19 +3376,18 @@ let pin ?(unpin_only=false) cli = Term.const (Some `remove), Arg.(value & pos_all string [] & Arg.info []) else - let complete_parameters = {OpamArgTools.f= - fun ~opt_switch cmd ~token -> + let complete_parameters ~opt_switch cmd ~token = match cmd with | Some (`scan) -> Ok [Arg.Completion.dirs] | Some (`remove) -> OpamArg.complete_packages ~which:(`Pinned) ~extras:[Arg.Completion.dirs] () (Some opt_switch) ~token - | Some (`add | `default "") -> + | Some (`add | `default _) -> OpamArg.complete_packages ~which:(`All) ~extras:[Arg.Completion.dirs] () (Some opt_switch) ~token - | _ -> Ok []} in - mk_subcommands_with_default ~cli ~complete_parameters commands in + | _ -> Ok [] in + mk_subcommands_with_default ~cli ~complete_parameters:{complete_parameters} commands in let edit = mk_flag ~cli cli_original ["e";"edit"] "With $(i,opam pin add), edit the opam file as with `opam pin edit' \ From 279de05c7c5265b2037a58ece3c6e72fe102db10 Mon Sep 17 00:00:00 2001 From: Brian Ward Date: Mon, 16 Mar 2026 11:15:25 -0400 Subject: [PATCH 11/12] Update bash, zsh completion to use cmdliner's scripts --- src/state/shellscripts/complete.sh | 233 --------------------------- src/state/shellscripts/complete.zsh | 237 ---------------------------- src/state/shellscripts/dune | 15 ++ 3 files changed, 15 insertions(+), 470 deletions(-) delete mode 100644 src/state/shellscripts/complete.sh delete mode 100644 src/state/shellscripts/complete.zsh create mode 100644 src/state/shellscripts/dune diff --git a/src/state/shellscripts/complete.sh b/src/state/shellscripts/complete.sh deleted file mode 100644 index a30575a7b16..00000000000 --- a/src/state/shellscripts/complete.sh +++ /dev/null @@ -1,233 +0,0 @@ -if [ -z "$BASH_VERSION" ]; then return 0; fi - -_opam_add() -{ - IFS=$'\n' _opam_reply+=("$@") -} - -_opam_add_f() -{ - local cmd - cmd=$1; shift - _opam_add "$($cmd "$@" 2>/dev/null)" -} - -_opam_flags() -{ - opam "$@" --help=groff 2>/dev/null | \ - sed -n \ - -e 's%\\-\|\\N'"'45'"'%-%g' \ - -e 's%, \\fB%\n\\fB%g' \ - -e '/^\\fB-/p' | \ - sed -e 's%^\\fB\(-[^\\]*\).*%\1%' -} - -_opam_commands() -{ - opam "$@" --help=groff 2>/dev/null | \ - sed -n \ - -e 's%\\-\|\\N'"'45'"'%-%g' \ - -e '/^\.SH COMMANDS$/,/^\.SH/ s%^\\fB\([^,= ]*\)\\fR.*%\1%p' - echo '--help' -} - -_opam_vars() -{ - opam var --safe 2>/dev/null | \ - sed -n \ - -e '/^PKG:/d' \ - -e 's%^\([^#= ][^ ]*\).*%\1%p' -} - -_opam_argtype() -{ - local cmd flag - cmd="$1"; shift - flag="$1"; shift - case "$flag" in - -*) - opam "$cmd" --help=groff 2>/dev/null | \ - sed -n \ - -e 's%\\-\|\\N'"'45'"'%-%g' \ - -e 's%.*\\fB'"$flag"'\\fR[= ]\\fI\([^, ]*\)\\fR.*%\1%p' - ;; - esac -} - -_opam() -{ - local IFS cmd subcmd cur prev compgen_opt - - COMPREPLY=() - cmd=${COMP_WORDS[1]} - subcmd=${COMP_WORDS[2]} - cur=${COMP_WORDS[COMP_CWORD]} - prev=${COMP_WORDS[COMP_CWORD-1]} - compgen_opt=() - _opam_reply=() - - if [ $COMP_CWORD -eq 1 ]; then - _opam_add_f opam help topics - COMPREPLY=( $(compgen -W "${_opam_reply[*]}" -- $cur) ) - unset _opam_reply - return 0 - fi - - case "$(_opam_argtype $cmd $prev)" in - LEVEL|JOBS|RANK) _opam_add 1 2 3 4 5 6 7 8 9;; - FILE|FILENAME) compgen_opt+=(-o filenames -f);; - DIR|ROOT) compgen_opt+=(-o filenames -d);; - MAKE|CMD) compgen_opt+=(-c);; - KIND) _opam_add http local git darcs hg;; - WHEN) _opam_add always never auto;; - SWITCH|SWITCHES) _opam_add_f opam switch list --safe -s;; - COLUMNS|FIELDS) - _opam_add name version package synopsis synopsis-or-target \ - description installed-version pin source-hash \ - opam-file all-installed-versions available-versions \ - all-versions repository installed-files vc-ref depexts;; - PACKAGE|PACKAGES|PKG|PATTERN|PATTERNS) - _opam_add_f opam list --safe -A -s;; - FLAG) _opam_add light-uninstall verbose plugin compiler conf;; - REPOS) _opam_add_f opam repository list --safe -s -a;; - SHELL) _opam_add bash sh csh zsh fish;; - TAGS) ;; - CRITERIA) ;; - STRING) ;; - URL) - compgen_opt+=(-o filenames -d) - _opam_add "https://" "http://" "file://" \ - "git://" "git+file://" "git+ssh://" "git+https://" \ - "hg+file://" "hg+ssh://" "hg+https://" \ - "darcs+file://" "darcs+ssh://" "darcs+https://";; - "") - case "$cmd" in - install|show|info|inst|ins|in|i|inf|sh) - _opam_add_f opam list --safe -a -s - if [ $COMP_CWORD -gt 2 ]; then - _opam_add_f _opam_flags "$cmd" - fi;; - reinstall|remove|uninstall|reinst|remov|uninst|unins) - _opam_add_f opam list --safe -i -s - if [ $COMP_CWORD -gt 2 ]; then - _opam_add_f _opam_flags "$cmd" - fi;; - upgrade|upg) - _opam_add_f opam list --safe -i -s - _opam_add_f _opam_flags "$cmd" - ;; - switch|sw) - case $COMP_CWORD in - 2) - _opam_add_f _opam_commands "$cmd" - _opam_add_f opam switch list --safe -s;; - 3) - case "$subcmd" in - create|install) - _opam_add_f opam switch list-available --safe -s -a;; - set|remove|reinstall) - _opam_add_f opam switch list --safe -s;; - import|export) - compgen_opt+=(-o filenames -f);; - *) - _opam_add_f _opam_flags "$cmd" - esac;; - *) - _opam_add_f _opam_flags "$cmd" - esac;; - config|conf|c) - case $COMP_CWORD in - 2) - _opam_add_f _opam_commands "$cmd";; - 3) - case "$subcmd" in - var) _opam_add_f _opam_vars;; - exec) compgen_opt+=(-c);; - *) _opam_add_f _opam_flags "$cmd" - esac;; - *) - _opam_add_f _opam_flags "$cmd" - esac;; - repository|remote|repos|repo) - case $COMP_CWORD in - 2) - _opam_add_f _opam_commands "$cmd";; - 3) - case "$subcmd" in - list) - _opam_add_f _opam_flags "$cmd";; - *) - _opam_add_f opam repository list --safe -a -s - esac;; - *) - _opam_add_f _opam_flags "$cmd" - case "$subcmd" in - set-url|add) compgen_opt+=(-o filenames -f);; - set-repos) _opam_add_f opam repository list --safe -a -s;; - esac;; - esac;; - update|upd) - _opam_add_f opam repository list --safe -s - _opam_add_f opam pin list --safe -s - _opam_add_f _opam_flags "$cmd" - ;; - source|so) - if [ $COMP_CWORD -eq 2 ]; then - _opam_add_f opam list --safe -A -s - else - _opam_add_f _opam_flags "$cmd" - fi;; - pin) - case $COMP_CWORD in - 2) - _opam_add_f _opam_commands "$cmd";; - 3) - case "$subcmd" in - add) - compgen_opt+=(-o filenames -d) - _opam_add_f opam list --safe -A -s;; - remove|edit) - _opam_add_f opam pin list --safe -s;; - *) - _opam_add_f _opam_flags "$cmd" - esac;; - *) - case "$subcmd" in - add) - compgen_opt+=(-o filenames -d);; - *) - _opam_add_f _opam_flags "$cmd" - esac - esac;; - unpin) - if [ $COMP_CWORD -eq 2 ]; then - _opam_add_f opam pin list --safe -s - else - _opam_add_f _opam_flags "$cmd" - fi;; - var|v) - if [ $COMP_CWORD -eq 2 ]; then _opam_add_f _opam_vars - else _opam_add_f _opam_flags "$cmd"; fi;; - exec|e) - if [ $COMP_CWORD -eq 2 ]; then compgen_opt+=(-c) - else _opam_add_f _opam_flags "$cmd"; fi;; - lint|build) - if [ $COMP_CWORD -eq 2 ]; then - compgen_opt+=(-f -X '!*opam' -o plusdirs) - else _opam_add_f _opam_flags "$cmd"; fi;; - admin) - if [ $COMP_CWORD -eq 2 ]; then - _opam_add_f _opam_commands "$cmd" - else _opam_add_f _opam_flags "$cmd" "$subcmd"; fi;; - *) - _opam_add_f _opam_commands "$cmd" - _opam_add_f _opam_flags "$cmd" - esac;; - esac - - COMPREPLY=($(compgen -W "${_opam_reply[*]}" "${compgen_opt[@]}" -- "$cur")) - unset _opam_reply - return 0 -} - -complete -F _opam opam diff --git a/src/state/shellscripts/complete.zsh b/src/state/shellscripts/complete.zsh deleted file mode 100644 index a59d9f56d12..00000000000 --- a/src/state/shellscripts/complete.zsh +++ /dev/null @@ -1,237 +0,0 @@ -#compdef opam - -if [ -z "$ZSH_VERSION" ]; then return 0; fi - -_opam_add() -{ - IFS=$'\n' _opam_reply+=("$@") -} - -_opam_add_f() -{ - local cmd - cmd=$1; shift - _opam_add "$($cmd "$@" 2>/dev/null)" -} - -_opam_flags() -{ - opam "$@" --help=groff 2>/dev/null | \ - sed -n \ - -e 's%\\-\|\\N'"'45'"'%-%g' \ - -e 's%, \\fB%\n\\fB%g' \ - -e '/^\\fB-/p' | \ - sed -e 's%^\\fB\(-[^\\]*\).*%\1%' -} - -_opam_commands() -{ - opam "$@" --help=groff 2>/dev/null | \ - sed -n \ - -e 's%\\-\|\\N'"'45'"'%-%g' \ - -e '/^\.SH COMMANDS$/,/^\.SH/ s%^\\fB\([^,= ]*\)\\fR.*%\1%p' - echo '--help' -} - -_opam_vars() -{ - opam var -safe 2>/dev/null | \ - sed -n \ - -e '/^PKG:/d' \ - -e 's%^\([^#= ][^ ]*\).*%\1%p' -} - -_opam_argtype() -{ - local cmd flag - cmd="$1"; shift - flag="$1"; shift - case "$flag" in - -*) - opam "$cmd" --help=groff 2>/dev/null | \ - sed -n \ - -e 's%\\-\|\\N'"'45'"'%-%g' \ - -e 's%.*\\fB'"$flag"'\\fR[= ]\\fI\([^, ]*\)\\fR.*%\1%p' - ;; - esac -} - -_opam() -{ - local IFS cmd subcmd cur prev compgen_opt - - COMPREPLY=() - cmd=${COMP_WORDS[1]} - subcmd=${COMP_WORDS[2]} - cur=${COMP_WORDS[COMP_CWORD]} - prev=${COMP_WORDS[COMP_CWORD-1]} - compgen_opt=() - _opam_reply=() - - if [ $COMP_CWORD -eq 1 ]; then - _opam_add_f opam help topics - COMPREPLY=( $(compgen -W "${_opam_reply[*]}" -- $cur) ) - unset _opam_reply - return 0 - fi - - case "$(_opam_argtype $cmd $prev)" in - LEVEL|JOBS|RANK) _opam_add 1 2 3 4 5 6 7 8 9;; - FILE|FILENAME) compgen_opt+=(-o filenames -f);; - DIR|ROOT) compgen_opt+=(-o filenames -d);; - MAKE|CMD) compgen_opt+=(-c);; - KIND) _opam_add http local git darcs hg;; - WHEN) _opam_add always never auto;; - SWITCH|SWITCHES) _opam_add_f opam switch list --safe -s;; - COLUMNS|FIELDS) - _opam_add name version package synopsis synopsis-or-target \ - description installed-version pin source-hash \ - opam-file all-installed-versions available-versions \ - all-versions repository installed-files vc-ref depexts;; - PACKAGE|PACKAGES|PKG|PATTERN|PATTERNS) - _opam_add_f opam list --safe -A -s;; - FLAG) _opam_add light-uninstall verbose plugin compiler conf;; - REPOS) _opam_add_f opam repository list --safe -s -a;; - SHELL) _opam_add bash sh csh zsh fish;; - TAGS) ;; - CRITERIA) ;; - STRING) ;; - URL) - compgen_opt+=(-o filenames -d) - _opam_add "https://" "http://" "file://" \ - "git://" "git+file://" "git+ssh://" "git+https://" \ - "hg+file://" "hg+ssh://" "hg+https://" \ - "darcs+file://" "darcs+ssh://" "darcs+https://";; - "") - case "$cmd" in - install|show|info|inst|ins|in|i|inf|sh) - _opam_add_f opam list --safe -a -s - if [ $COMP_CWORD -gt 2 ]; then - _opam_add_f _opam_flags "$cmd" - fi;; - reinstall|remove|uninstall|reinst|remov|uninst|unins) - _opam_add_f opam list --safe -i -s - if [ $COMP_CWORD -gt 2 ]; then - _opam_add_f _opam_flags "$cmd" - fi;; - upgrade|upg) - _opam_add_f opam list --safe -i -s - _opam_add_f _opam_flags "$cmd" - ;; - switch|sw) - case $COMP_CWORD in - 2) - _opam_add_f _opam_commands "$cmd" - _opam_add_f opam switch list --safe -s;; - 3) - case "$subcmd" in - create|install) - _opam_add_f opam switch list-available --safe -s -a;; - set|remove|reinstall) - _opam_add_f opam switch list --safe -s;; - import|export) - compgen_opt+=(-o filenames -f);; - *) - _opam_add_f _opam_flags "$cmd" - esac;; - *) - _opam_add_f _opam_flags "$cmd" - esac;; - config|conf|c) - case $COMP_CWORD in - 2) - _opam_add_f _opam_commands "$cmd";; - 3) - case "$subcmd" in - var) _opam_add_f _opam_vars;; - exec) compgen_opt+=(-c);; - *) _opam_add_f _opam_flags "$cmd" - esac;; - *) - _opam_add_f _opam_flags "$cmd" - esac;; - repository|remote|repos|repo) - case $COMP_CWORD in - 2) - _opam_add_f _opam_commands "$cmd";; - 3) - case "$subcmd" in - list) - _opam_add_f _opam_flags "$cmd";; - *) - _opam_add_f opam repository list --safe -a -s - esac;; - *) - _opam_add_f _opam_flags "$cmd" - case "$subcmd" in - set-url|add) compgen_opt+=(-o filenames -f);; - set-repos) _opam_add_f opam repository list --safe -a -s;; - esac;; - esac;; - update|upd) - _opam_add_f opam repository list --safe -s - _opam_add_f opam pin list --safe -s - _opam_add_f _opam_flags "$cmd" - ;; - source|so) - if [ $COMP_CWORD -eq 2 ]; then - _opam_add_f opam list --safe -A -s - else - _opam_add_f _opam_flags "$cmd" - fi;; - pin) - case $COMP_CWORD in - 2) - _opam_add_f _opam_commands "$cmd";; - 3) - case "$subcmd" in - add) - compgen_opt+=(-o filenames -d) - _opam_add_f opam list --safe -A -s;; - remove|edit) - _opam_add_f opam pin list --safe -s;; - *) - _opam_add_f _opam_flags "$cmd" - esac;; - *) - case "$subcmd" in - add) - compgen_opt+=(-o filenames -d);; - *) - _opam_add_f _opam_flags "$cmd" - esac - esac;; - unpin) - if [ $COMP_CWORD -eq 2 ]; then - _opam_add_f opam pin list --safe -s - else - _opam_add_f _opam_flags "$cmd" - fi;; - var|v) - if [ $COMP_CWORD -eq 2 ]; then _opam_add_f _opam_vars - else _opam_add_f _opam_flags "$cmd"; fi;; - exec|e) - if [ $COMP_CWORD -eq 2 ]; then compgen_opt+=(-c) - else _opam_add_f _opam_flags "$cmd"; fi;; - lint|build) - if [ $COMP_CWORD -eq 2 ]; then - compgen_opt+=(-f -X '!*opam' -o plusdirs) - else _opam_add_f _opam_flags "$cmd"; fi;; - admin) - if [ $COMP_CWORD -eq 2 ]; then - _opam_add_f _opam_commands "$cmd" - else _opam_add_f _opam_flags "$cmd" "$subcmd"; fi;; - *) - _opam_add_f _opam_commands "$cmd" - _opam_add_f _opam_flags "$cmd" - esac;; - esac - - COMPREPLY=($(compgen -W "${_opam_reply[*]}" "${compgen_opt[@]}" -- "$cur")) - unset _opam_reply - return 0 -} - -autoload bashcompinit -bashcompinit -complete -F _opam opam diff --git a/src/state/shellscripts/dune b/src/state/shellscripts/dune new file mode 100644 index 00000000000..11a361a2133 --- /dev/null +++ b/src/state/shellscripts/dune @@ -0,0 +1,15 @@ +(rule + (targets complete.sh) + (deps %{project_root}/src/core/cmdliner/tool/opamCmdliner_tool.exe) + (action + (with-stdout-to + %{targets} + (run %{deps} tool-completion --standalone-completion bash opam)))) + +(rule + (targets complete.zsh) + (deps %{project_root}/src/core/cmdliner/tool/opamCmdliner_tool.exe) + (action + (with-stdout-to + %{targets} + (run %{deps} tool-completion --standalone-completion zsh opam)))) From a729330bc93cd1764b53e7b8c7d37ec77bebf8d3 Mon Sep 17 00:00:00 2001 From: Brian Ward Date: Mon, 16 Mar 2026 11:33:20 -0400 Subject: [PATCH 12/12] Add completion script for powershell --- src/state/dune | 2 +- src/state/opamEnv.ml | 6 ++++-- src/state/opamScript.mli | 1 + src/state/shellscripts/dune | 8 ++++++++ tests/reftests/init-scripts.unix.test | 5 +++++ tests/reftests/init-scripts.win32.test | 5 +++++ 6 files changed, 24 insertions(+), 3 deletions(-) diff --git a/src/state/dune b/src/state/dune index 3f4338b003b..b8ceda22953 100644 --- a/src/state/dune +++ b/src/state/dune @@ -13,7 +13,7 @@ (rule (targets opamScript.ml) - (deps ../../shell/crunch.ml (glob_files shellscripts/*.*sh)) + (deps ../../shell/crunch.ml (glob_files shellscripts/*.*sh) (glob_files shellscripts/*.ps1)) (action (with-stdout-to %{targets} (run ocaml %{deps})))) ; Embedded Cygwin mechanism (done in the configure script on Windows if requested) diff --git a/src/state/opamEnv.ml b/src/state/opamEnv.ml index 42bb8cd0ba6..4dc84dc97b2 100644 --- a/src/state/opamEnv.ml +++ b/src/state/opamEnv.ml @@ -933,7 +933,8 @@ let shells_list = [ SH_sh; SH_zsh; SH_csh; SH_fish; SH_pwsh Powershell; SH_cmd ] let complete_file = function | SH_sh | SH_bash -> Some "complete.sh" | SH_zsh -> Some "complete.zsh" - | SH_csh | SH_fish | SH_pwsh _ | SH_cmd -> None + | SH_pwsh _ -> Some "complete.ps1" + | SH_csh | SH_fish | SH_cmd -> None let env_hook_file = function | SH_sh | SH_bash -> Some "env_hook.sh" @@ -960,8 +961,9 @@ let init_file = function let complete_script = function | SH_sh | SH_bash -> Some OpamScript.complete | SH_zsh -> Some OpamScript.complete_zsh + | SH_pwsh _ -> Some OpamScript.complete_ps1 | SH_csh | SH_fish -> None - | SH_pwsh _ | SH_cmd -> None + | SH_cmd -> None let env_hook_script_base = function | SH_sh | SH_bash -> Some OpamScript.env_hook diff --git a/src/state/opamScript.mli b/src/state/opamScript.mli index 8bfe74d0e3e..30084834466 100644 --- a/src/state/opamScript.mli +++ b/src/state/opamScript.mli @@ -13,6 +13,7 @@ val complete : string val complete_zsh : string +val complete_ps1 : string val prompt : string val bwrap : string val sandbox_exec : string diff --git a/src/state/shellscripts/dune b/src/state/shellscripts/dune index 11a361a2133..87cab1d6d80 100644 --- a/src/state/shellscripts/dune +++ b/src/state/shellscripts/dune @@ -13,3 +13,11 @@ (with-stdout-to %{targets} (run %{deps} tool-completion --standalone-completion zsh opam)))) + +(rule + (targets complete.ps1) + (deps %{project_root}/src/core/cmdliner/tool/opamCmdliner_tool.exe) + (action + (with-stdout-to + %{targets} + (run %{deps} tool-completion --standalone-completion pwsh opam)))) diff --git a/tests/reftests/init-scripts.unix.test b/tests/reftests/init-scripts.unix.test index 15ba2acf2a8..c36b9914133 100644 --- a/tests/reftests/init-scripts.unix.test +++ b/tests/reftests/init-scripts.unix.test @@ -8,6 +8,7 @@ No configuration file found, using built-in defaults. ### # we need the switch for variables file ### opam switch create fake --empty --root root ### ls root/opam-init | unordered +complete.ps1 complete.sh complete.zsh env_hook.csh @@ -58,6 +59,10 @@ if ( -f '${BASEDIR}/root/opam-init/variables.csh' ) source '${BASEDIR}/root/opam ### cat root/opam-init/init.cmd if exist "${BASEDIR}/root/opam-init/variables.cmd" call "${BASEDIR}/root/opam-init/variables.cmd" >NUL 2>NUL ### cat root/opam-init/init.ps1 +if ([Environment]::UserInteractive) { + if Test-Path "${BASEDIR}/root/opam-init/complete.ps1" { . "${BASEDIR}/root/opam-init/complete.ps1" *> $null } +} + if Test-Path "${BASEDIR}/root/opam-init/variables.ps1" { . "${BASEDIR}/root/opam-init/variables.ps1" *> $null } ### : Variables scripts : ### cat root/opam-init/variables.sh | grep -v man | grep -v MANPATH diff --git a/tests/reftests/init-scripts.win32.test b/tests/reftests/init-scripts.win32.test index b87b340a8f1..499a998abbe 100644 --- a/tests/reftests/init-scripts.win32.test +++ b/tests/reftests/init-scripts.win32.test @@ -8,6 +8,7 @@ No configuration file found, using built-in defaults. ### # we need the switch for variables file ### opam switch create fake --empty --root root ### ls root/opam-init | unordered +complete.ps1 complete.sh complete.zsh env_hook.csh @@ -57,6 +58,10 @@ if ( -f '${BASEDIR}/root/opam-init/variables.csh' ) source '${BASEDIR}/root/opam ### cat root/opam-init/init.cmd if exist "${BASEDIR}/root/opam-init/variables.cmd" call "${BASEDIR}/root/opam-init/variables.cmd" >NUL 2>NUL ### cat root/opam-init/init.ps1 +if ([Environment]::UserInteractive) { + if Test-Path "${BASEDIR}/root/opam-init/complete.ps1" { . "${BASEDIR}/root/opam-init/complete.ps1" *> $null } +} + if Test-Path "${BASEDIR}/root/opam-init/variables.ps1" { . "${BASEDIR}/root/opam-init/variables.ps1" *> $null } ### : Variables scripts : ### cat root/opam-init/variables.sh | grep -v man | grep -v MANPATH