From a5ff0e8b5a35569fb710d51d735fa05baa027117 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sun, 8 Nov 2020 14:03:42 -0800 Subject: [PATCH 01/25] Add a function to make command aliases Signed-off-by: Rudi Grinberg --- src/cmdliner_manpage.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/cmdliner_manpage.ml b/src/cmdliner_manpage.ml index 2dbd1f6..b407219 100644 --- a/src/cmdliner_manpage.ml +++ b/src/cmdliner_manpage.ml @@ -23,6 +23,7 @@ let s_name = "NAME" let s_synopsis = "SYNOPSIS" let s_description = "DESCRIPTION" let s_commands = "COMMANDS" +let s_command_aliases = "COMMAND ALIASES" let s_arguments = "ARGUMENTS" let s_options = "OPTIONS" let s_common_options = "COMMON OPTIONS" @@ -45,7 +46,7 @@ let s_see_also = "SEE ALSO" let s_created = "" let order = [| s_name; s_synopsis; s_description; s_created; s_commands; - s_arguments; s_options; s_common_options; s_exit_status; + s_command_aliases; s_arguments; s_options; s_common_options; s_exit_status; s_environment; s_files; s_examples; s_bugs; s_authors; s_see_also; |] let order_synopsis = 1 From e52080a580fc91850e46c308a193d40a8dd03180 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Wed, 2 Dec 2020 01:53:41 -0800 Subject: [PATCH 02/25] Fix warnings in darcs exmaple Signed-off-by: Rudi Grinberg --- test/darcs_ex.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/darcs_ex.ml b/test/darcs_ex.ml index a7fd519..3421126 100644 --- a/test/darcs_ex.ml +++ b/test/darcs_ex.ml @@ -23,7 +23,7 @@ let record copts name email all ask_deps files = Printf.printf pr_copts copts (opt_str_str name) (opt_str_str email) all ask_deps (String.concat ", " files) -let help copts man_format cmds topic = match topic with +let help _copts man_format cmds topic = match topic with | None -> `Help (`Pager, None) (* help about the program. *) | Some topic -> let topics = "topics" :: "patterns" :: "environment" :: cmds in @@ -32,7 +32,7 @@ let help copts man_format cmds topic = match topic with | `Error e -> `Error (false, e) | `Ok t when t = "topics" -> List.iter print_endline topics; `Ok () | `Ok t when List.mem t cmds -> `Help (man_format, Some t) - | `Ok t -> + | `Ok _ -> let page = (topic, 7, "", "", ""), [`S topic; `P "Say something";] in `Ok (Cmdliner.Manpage.print man_format Format.std_formatter page) From 28268d6af35ad5957d330ba4c6e557bb0f595436 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sun, 8 Nov 2020 14:06:45 -0800 Subject: [PATCH 03/25] Add tests for darcs_ex to avoid regressions when eval_choice is implemented with groups Signed-off-by: Rudi Grinberg --- dune-project | 6 +- test/darcs.t | 190 +++++++++++++++++++++++++++++++++++++++++++++++++++ test/dune | 11 ++- 3 files changed, 204 insertions(+), 3 deletions(-) create mode 100644 test/darcs.t diff --git a/dune-project b/dune-project index f4beddd..66f1b4b 100644 --- a/dune-project +++ b/dune-project @@ -1,2 +1,4 @@ -(lang dune 1.4) -(name cmdliner) \ No newline at end of file +(lang dune 2.7) +(name cmdliner) + +(cram enable) diff --git a/test/darcs.t b/test/darcs.t new file mode 100644 index 0000000..d6fb813 --- /dev/null +++ b/test/darcs.t @@ -0,0 +1,190 @@ + $ ./darcs_ex.exe --invalid opt + darcs: unknown option `--invalid'. + Usage: darcs COMMAND ... + Try `darcs --help' for more information. + [1] + + $ ./darcs_ex.exe initialize --invalid + darcs: unknown option `--invalid'. + Usage: darcs initialize [OPTION]... + Try `darcs initialize --help' or `darcs --help' for more information. + [1] + + $ ./darcs_ex.exe initialize --help + NAME + darcs-initialize - make the current directory a repository + + SYNOPSIS + darcs initialize [OPTION]... + + DESCRIPTION + Turns the current directory into a Darcs repository. Any existing + files and subdirectories become ... + + OPTIONS + --repodir=DIR (absent=.) + Run the program in repository directory DIR. + + COMMON OPTIONS + These options are common to all commands. + + --debug + Give only debug output. + + --help[=FMT] (default=auto) + Show this help in format FMT. The value FMT must be one of `auto', + `pager', `groff' or `plain'. With `auto', the format is `pager` or + `plain' whenever the TERM env var is `dumb' or undefined. + + --prehook=VAL + Specify command to run before this darcs command. + + -q, --quiet + Suppress informational output. + + -v, --verbose + Give verbose output. + + --version + Show version information. + + MORE HELP + Use `darcs COMMAND --help' for help on a single command. + Use `darcs help patterns' for help on patch matching. + Use `darcs help environment' for help on environment variables. + + EXIT STATUS + initialize exits with the following status: + + 0 on success. + + 124 on command line parsing errors. + + 125 on unexpected internal errors (bugs). + + BUGS + Check bug reports at http://bugs.example.org. + + + $ TERM=dumb ./darcs_ex.exe + DARCS(1) Darcs Manual DARCS(1) + + + + NNAAMMEE + darcs - a revision control system + + SSYYNNOOPPSSIISS + ddaarrccss _C_O_M_M_A_N_D ... + + CCOOMMMMAANNDDSS + hheellpp + display help about darcs and darcs commands + + iinniittiiaalliizzee + make the current directory a repository + + rreeccoorrdd + create a patch from unrecorded changes + + CCOOMMMMOONN OOPPTTIIOONNSS + These options are common to all commands. + + ----ddeebbuugg + Give only debug output. + + ----hheellpp[=_F_M_T] (default=auto) + Show this help in format _F_M_T. The value _F_M_T must be one of `auto', + `pager', `groff' or `plain'. With `auto', the format is `pager` or + `plain' whenever the TTEERRMM env var is `dumb' or undefined. + + ----pprreehhooookk=_V_A_L + Specify command to run before this ddaarrccss command. + + --qq, ----qquuiieett + Suppress informational output. + + --vv, ----vveerrbboossee + Give verbose output. + + ----vveerrssiioonn + Show version information. + + MMOORREE HHEELLPP + Use `ddaarrccss _C_O_M_M_A_N_D --help' for help on a single command. + Use `ddaarrccss help patterns' for help on patch matching. + Use `ddaarrccss help environment' for help on environment variables. + + EEXXIITT SSTTAATTUUSS + ddaarrccss exits with the following status: + + 0 on success. + + 124 on command line parsing errors. + + 125 on unexpected internal errors (bugs). + + BBUUGGSS + Check bug reports at http://bugs.example.org. + + + + Darcs 11VERSION11 DARCS(1) + + $ ./darcs_ex.exe --help + NAME + darcs - a revision control system + + SYNOPSIS + darcs COMMAND ... + + COMMANDS + help + display help about darcs and darcs commands + + initialize + make the current directory a repository + + record + create a patch from unrecorded changes + + COMMON OPTIONS + These options are common to all commands. + + --debug + Give only debug output. + + --help[=FMT] (default=auto) + Show this help in format FMT. The value FMT must be one of `auto', + `pager', `groff' or `plain'. With `auto', the format is `pager` or + `plain' whenever the TERM env var is `dumb' or undefined. + + --prehook=VAL + Specify command to run before this darcs command. + + -q, --quiet + Suppress informational output. + + -v, --verbose + Give verbose output. + + --version + Show version information. + + MORE HELP + Use `darcs COMMAND --help' for help on a single command. + Use `darcs help patterns' for help on patch matching. + Use `darcs help environment' for help on environment variables. + + EXIT STATUS + darcs exits with the following status: + + 0 on success. + + 124 on command line parsing errors. + + 125 on unexpected internal errors (bugs). + + BUGS + Check bug reports at http://bugs.example.org. + diff --git a/test/dune b/test/dune index 012c36a..c9cb0c8 100644 --- a/test/dune +++ b/test/dune @@ -8,5 +8,14 @@ test_pos_req test_opt_req test_term_dups - test_with_used_args) + test_with_used_args + darcs_ex) (libraries cmdliner)) + +(cram + (applies_to groups) + (deps ./groups.exe)) + +(cram + (applies_to darcs) + (deps ./darcs_ex.exe)) From 8e3e88d8413e680519f8b903cd91c0cd5debfabd Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sun, 8 Nov 2020 18:32:32 -0800 Subject: [PATCH 04/25] prototype nested commands Signed-off-by: Rudi Grinberg --- src/cmdliner.ml | 58 ++++++++++++++++++++++++++++++++++++++++++++++++ src/cmdliner.mli | 15 +++++++++++++ 2 files changed, 73 insertions(+) diff --git a/src/cmdliner.ml b/src/cmdliner.ml index 40afd52..09f810f 100644 --- a/src/cmdliner.ml +++ b/src/cmdliner.ml @@ -265,6 +265,64 @@ module Term = struct let ei, res = term_eval ~catch ei f args in do_result help_ppf err_ppf ei res + module Group = struct + type 'a node = + | Term of 'a Cmdliner_term.t + | Group of 'a t list + + and 'a t = 'a node * info + + let term_add_args (al, f) info = + Cmdliner_info.term_add_args info al + + let rec add_args (node, info) = + match node with + | Term (al, f) -> (Term (al, f), term_add_args (al, f) info) + | Group subs -> (Group (List.map add_args subs), info) + + let (>>=) x f = + match x with + | Error e -> Error e + | Ok x -> f x + + let parse_arg_cmd = function + | [] -> Error `No_args + | cmd :: args -> + if String.length cmd >= 1 && cmd.[0] = '-' then + Error `No_args + else + Ok (cmd, args) + + let cmd_name (_, info) = Cmdliner_info.term_name info + + let one_of choices args = + parse_arg_cmd args >>= fun (cmd, args) -> + match List.find (fun t -> cmd_name t = cmd) choices with + | exception Not_found -> Error (`Invalid_command (cmd, choices)) + | choice -> Ok (choice, args) + + let rec choose_term choices args = + one_of choices args >>= fun ((t, info), args) -> + match t with + | Term t -> Ok ((t, info), args) + | Group subs -> choose_term subs args + + let eval + ?help:(help_ppf = Format.std_formatter) + ?err:(err_ppf = Format.err_formatter) + ?(catch = true) ?(env = env_default) ?(argv = Sys.argv) main choices = + let choices_f = List.map add_args choices in + let main_f = (term_add_args (fst main) (snd main)), fst main in + let main = fst main_f in + match choose_term choices_f (remove_exec argv) with + | Error `No_args -> assert false + | Error (`Invalid_command _) -> `Error `Exn + | Ok (((_, f), info), args) -> + let ei = Cmdliner_info.eval ~term:info ~main ~choices:[] ~env in + let ei, res = term_eval ~catch ei f args in + do_result help_ppf err_ppf ei res + end + let eval_peek_opts ?(version_opt = false) ?(env = env_default) ?(argv = Sys.argv) ((args, f) : 'a t) = diff --git a/src/cmdliner.mli b/src/cmdliner.mli index a993e83..e53c816 100644 --- a/src/cmdliner.mli +++ b/src/cmdliner.mli @@ -382,6 +382,21 @@ module Term : sig is unspecified the "main" term [t] is evaluated. [i] defines the name and man page of the program. *) + module Group : sig + type 'a term + + type 'a node = + | Term of 'a term + | Group of 'a t list + + and 'a t = 'a node * info + + val eval : + ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> + ?env:(string -> string option) -> ?argv:string array -> + 'a term * info -> 'a t list -> 'a result + end with type 'a term := 'a t + val eval_peek_opts : ?version_opt:bool -> ?env:(string -> string option) -> ?argv:string array -> 'a t -> 'a option * 'a result From d9808f17c659d54faaeba6383792603e2daf5936 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sun, 8 Nov 2020 18:32:50 -0800 Subject: [PATCH 05/25] add test for nested commands Signed-off-by: Rudi Grinberg --- test/dune | 1 + test/groups.ml | 40 ++++++++++++++++++++++++++++++++++++++++ test/groups.t | 34 ++++++++++++++++++++++++++++++++++ 3 files changed, 75 insertions(+) create mode 100644 test/groups.ml create mode 100644 test/groups.t diff --git a/test/dune b/test/dune index c9cb0c8..b07f242 100644 --- a/test/dune +++ b/test/dune @@ -9,6 +9,7 @@ test_opt_req test_term_dups test_with_used_args + groups darcs_ex) (libraries cmdliner)) diff --git a/test/groups.ml b/test/groups.ml new file mode 100644 index 0000000..563d403 --- /dev/null +++ b/test/groups.ml @@ -0,0 +1,40 @@ +open Cmdliner + +let things = + let thing = + let doc = "thing to operate on" in + let nfo = Arg.info ~doc [] in + Arg.(required & pos 0 (some string) None & nfo ) in + let show = + let show thing = + Printf.printf "showing %s\n" thing in + Term.(const show $ thing) + in + let list = + let list () = print_endline "listing things" in + Term.(const list $ (const ())) + in + let term : _ Term.Group.t list = + [ Term show, Term.info "show" + ; Term list, Term.info "list" + ] + in + (Term.Group.Group term), Term.info "things" + +let default_cmd = + let term = + let run () = + print_endline "default cmd"; + `Ok () + in + Term.(ret (const run $ (const ()))) + in + term, Term.info "groups" ~version:"%%VERSION%%" + +let cmds : _ Term.Group.t list = + let _term (t, info) = Term.Group.Term t, info in + [ things + ] + +let () = + Term.(exit @@ Term.Group.eval default_cmd cmds) diff --git a/test/groups.t b/test/groups.t new file mode 100644 index 0000000..18ba2d4 --- /dev/null +++ b/test/groups.t @@ -0,0 +1,34 @@ + $ ./groups.exe things list + listing things + + $ ./groups.exe things + Fatal error: exception File "src/cmdliner.ml", line 318, characters 24-30: Assertion failed + [2] + + $ ./groups.exe things show foo + showing foo + + $ ./groups.exe things list --help + NAME + groups + + SYNOPSIS + groups [OPTION]... + + OPTIONS + --help[=FMT] (default=auto) + Show this help in format FMT. The value FMT must be one of `auto', + `pager', `groff' or `plain'. With `auto', the format is `pager` or + `plain' whenever the TERM env var is `dumb' or undefined. + + --version + Show version information. + + + $ ./groups.exe things --help + Fatal error: exception File "src/cmdliner.ml", line 318, characters 24-30: Assertion failed + [2] + + $ ./groups.exe --help + Fatal error: exception File "src/cmdliner.ml", line 318, characters 24-30: Assertion failed + [2] From d0d031b17e4e445070718de6f345b4bf6beeb2ca Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 9 Nov 2020 18:47:06 -0800 Subject: [PATCH 06/25] enrich cmdliner_info term with group info Signed-off-by: Rudi Grinberg --- src/cmdliner.ml | 14 +++++++++----- src/cmdliner_info.ml | 25 ++++++++++++++++++++++++- src/cmdliner_info.mli | 15 ++++++++++++--- 3 files changed, 45 insertions(+), 9 deletions(-) diff --git a/src/cmdliner.ml b/src/cmdliner.ml index 09f810f..d963fbd 100644 --- a/src/cmdliner.ml +++ b/src/cmdliner.ml @@ -216,7 +216,7 @@ module Term = struct ?err:(err_ppf = Format.err_formatter) ?(catch = true) ?(env = env_default) ?(argv = Sys.argv) ((al, f), ti) = let term = Cmdliner_info.term_add_args ti al in - let ei = Cmdliner_info.eval ~term ~main:term ~choices:[] ~env in + let ei = Cmdliner_info.eval ~env (Simple term) in let args = remove_exec argv in let ei, res = term_eval ~catch ei f args in do_result help_ppf err_ppf ei res @@ -257,11 +257,14 @@ module Term = struct let main = fst main_f in match choose_term main_f choices_f (remove_exec argv) with | Error err -> - let ei = Cmdliner_info.eval ~term:main ~main ~choices ~env in + let ei = Cmdliner_info.eval ~env + (Sub_command { path = [main] ; sibling_terms = choices}) + in Cmdliner_msg.pp_err_usage err_ppf ei ~err_lines:false ~err; `Error `Parse | Ok ((chosen, f), args) -> - let ei = Cmdliner_info.eval ~term:chosen ~main ~choices ~env in + let ei = Cmdliner_info.eval ~env + (Sub_command { path = [main; chosen]; sibling_terms = choices }) in let ei, res = term_eval ~catch ei f args in do_result help_ppf err_ppf ei res @@ -318,7 +321,8 @@ module Term = struct | Error `No_args -> assert false | Error (`Invalid_command _) -> `Error `Exn | Ok (((_, f), info), args) -> - let ei = Cmdliner_info.eval ~term:info ~main ~choices:[] ~env in + let ei = Cmdliner_info.eval ~env + (Sub_command { path = [main ; info] ; sibling_terms = []}) in let ei, res = term_eval ~catch ei f args in do_result help_ppf err_ppf ei res end @@ -328,7 +332,7 @@ module Term = struct ((args, f) : 'a t) = let version = if version_opt then Some "dummy" else None in let term = Cmdliner_info.term ~args ?version "dummy" in - let ei = Cmdliner_info.eval ~term ~main:term ~choices:[] ~env in + let ei = Cmdliner_info.eval ~env (Simple term) in (term_eval_peek_opts ei f (remove_exec argv) :> 'a option * 'a result) (* Exits *) diff --git a/src/cmdliner_info.ml b/src/cmdliner_info.ml index 418dd4d..8e38d82 100644 --- a/src/cmdliner_info.ml +++ b/src/cmdliner_info.ml @@ -191,21 +191,43 @@ let term_args t = t.term_args let term_add_args t args = { t with term_args = Args.union args t.term_args } +type eval_kind = +| Simple of term +| Main of { term : term ; choices : term list } +| Sub_command of { path : term list ; sibling_terms : term list } + (* Eval info *) type eval = (* information about the evaluation context. *) { term : term; (* term being evaluated. *) main : term; (* main term. *) + path : term list; choices : term list; (* all term choices. *) env : string -> string option } (* environment variable lookup. *) -let eval ~term ~main ~choices ~env = { term; main; choices; env } +let eval ~env kind = + let (main, term, path, choices) = + match kind with + | Simple term -> (term, term, [term], []) + | Main { term ; choices } -> (term, term, [term], choices) + | Sub_command { path ; sibling_terms } -> + let (main, term) = + match path with + | main :: rest -> + (main, List.fold_left (fun _ last -> last) main rest) + | [] -> assert false + in + (main, term, path, sibling_terms) + in + { term; main; choices; env; path } let eval_term e = e.term let eval_main e = e.main +let eval_term_path e = e.path let eval_choices e = e.choices let eval_env_var e v = e.env v let eval_kind ei = + (* subgroup *) if ei.choices = [] then `Simple else if (ei.term.term_info.term_name == ei.main.term_info.term_name) then `Multiple_main else `Multiple_sub @@ -213,6 +235,7 @@ let eval_kind ei = let eval_with_term ei term = { ei with term } let eval_has_choice e cmd = + (* handle subgroup *) let is_cmd t = t.term_info.term_name = cmd in List.exists is_cmd e.choices diff --git a/src/cmdliner_info.mli b/src/cmdliner_info.mli index 7fa60cb..38f1e06 100644 --- a/src/cmdliner_info.mli +++ b/src/cmdliner_info.mli @@ -111,12 +111,21 @@ val term_add_args : term -> args -> term type eval -val eval : - term:term -> main:term -> choices:term list -> - env:(string -> string option) -> eval +type eval_kind = +| Simple of term +| Main of { term : term ; choices : term list } +| Sub_command of { path : term list ; sibling_terms : term list } +val eval : env:(string -> string option) -> eval_kind -> eval + +val eval_term_path : eval -> term list + +(** Equivalent to [List.last (eval_term_full e)] *) val eval_term : eval -> term + +(** Equivalent to [List.hd (eval_term_full e)] *) val eval_main : eval -> term + val eval_choices : eval -> term list val eval_env_var : eval -> string -> string option val eval_kind : eval -> [> `Multiple_main | `Multiple_sub | `Simple ] From 2bed1739ffffff3e65437654c19f30ddb3cad720 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 9 Nov 2020 18:47:28 -0800 Subject: [PATCH 07/25] add help for main subcommand Signed-off-by: Rudi Grinberg --- src/cmdliner.ml | 29 ++++++++++++++++++++--------- test/groups.t | 21 +++++++++++++++++---- 2 files changed, 37 insertions(+), 13 deletions(-) diff --git a/src/cmdliner.ml b/src/cmdliner.ml index d963fbd..7ef5e81 100644 --- a/src/cmdliner.ml +++ b/src/cmdliner.ml @@ -283,8 +283,8 @@ module Term = struct | Term (al, f) -> (Term (al, f), term_add_args (al, f) info) | Group subs -> (Group (List.map add_args subs), info) - let (>>=) x f = - match x with + let (>>=) res f = + match res with | Error e -> Error e | Ok x -> f x @@ -298,26 +298,37 @@ module Term = struct let cmd_name (_, info) = Cmdliner_info.term_name info - let one_of choices args = - parse_arg_cmd args >>= fun (cmd, args) -> + let one_of (cmd, args) choices = match List.find (fun t -> cmd_name t = cmd) choices with | exception Not_found -> Error (`Invalid_command (cmd, choices)) | choice -> Ok (choice, args) - let rec choose_term choices args = - one_of choices args >>= fun ((t, info), args) -> + let try_one_of choices args = + parse_arg_cmd args >>= fun (cmd, args) -> one_of (cmd, args) choices + + let rec try_choose_term choices args = + try_one_of choices args >>= choose_term + + and choose_term ((t, info), args) = match t with | Term t -> Ok ((t, info), args) - | Group subs -> choose_term subs args + | Group subs -> try_choose_term subs args + + let choose_term main choices args = + match parse_arg_cmd args with + | Error `No_args -> Ok (main, args) + | Ok (cmd, args) -> one_of (cmd, args) choices >>= choose_term let eval ?help:(help_ppf = Format.std_formatter) ?err:(err_ppf = Format.err_formatter) ?(catch = true) ?(env = env_default) ?(argv = Sys.argv) main choices = let choices_f = List.map add_args choices in - let main_f = (term_add_args (fst main) (snd main)), fst main in + let to_term_f ((al, f), ti) = Cmdliner_info.term_add_args ti al, f in + let main_args = fst main in + let main_f = to_term_f main in let main = fst main_f in - match choose_term choices_f (remove_exec argv) with + match choose_term (main_args, (fst main_f)) choices_f (remove_exec argv) with | Error `No_args -> assert false | Error (`Invalid_command _) -> `Error `Exn | Ok (((_, f), info), args) -> diff --git a/test/groups.t b/test/groups.t index 18ba2d4..2b288f3 100644 --- a/test/groups.t +++ b/test/groups.t @@ -2,7 +2,7 @@ listing things $ ./groups.exe things - Fatal error: exception File "src/cmdliner.ml", line 318, characters 24-30: Assertion failed + Fatal error: exception File "src/cmdliner.ml", line 334, characters 24-30: Assertion failed [2] $ ./groups.exe things show foo @@ -26,9 +26,22 @@ $ ./groups.exe things --help - Fatal error: exception File "src/cmdliner.ml", line 318, characters 24-30: Assertion failed + Fatal error: exception File "src/cmdliner.ml", line 334, characters 24-30: Assertion failed [2] $ ./groups.exe --help - Fatal error: exception File "src/cmdliner.ml", line 318, characters 24-30: Assertion failed - [2] + NAME + groups + + SYNOPSIS + groups [OPTION]... + + OPTIONS + --help[=FMT] (default=auto) + Show this help in format FMT. The value FMT must be one of `auto', + `pager', `groff' or `plain'. With `auto', the format is `pager` or + `plain' whenever the TERM env var is `dumb' or undefined. + + --version + Show version information. + From 7f6c514d2213b2768776c077746b148f9ed2d915 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 9 Nov 2020 19:57:27 -0800 Subject: [PATCH 08/25] pass path & choices Signed-off-by: Rudi Grinberg --- src/cmdliner.ml | 35 +++++++++++++++++++---------------- test/groups.t | 14 +++++++++----- 2 files changed, 28 insertions(+), 21 deletions(-) diff --git a/src/cmdliner.ml b/src/cmdliner.ml index 7ef5e81..b3bdbd9 100644 --- a/src/cmdliner.ml +++ b/src/cmdliner.ml @@ -298,26 +298,28 @@ module Term = struct let cmd_name (_, info) = Cmdliner_info.term_name info - let one_of (cmd, args) choices = + let one_of (cmd, choices, path, args) = match List.find (fun t -> cmd_name t = cmd) choices with - | exception Not_found -> Error (`Invalid_command (cmd, choices)) - | choice -> Ok (choice, args) + | exception Not_found -> Error (`Invalid_command (cmd, path, choices)) + | (choice, info) -> Ok ((choice, info), choices, info :: path, args) - let try_one_of choices args = - parse_arg_cmd args >>= fun (cmd, args) -> one_of (cmd, args) choices + let try_one_of choices path args = + match parse_arg_cmd args with + | Ok (cmd, args) -> one_of (cmd, choices, path, args) + | Error `No_args -> Error (`No_args (path, choices)) - let rec try_choose_term choices args = - try_one_of choices args >>= choose_term + let rec try_choose_term choices path args = + try_one_of choices path args >>= choose_term - and choose_term ((t, info), args) = + and choose_term ((t, info), choices, path, args) = match t with - | Term t -> Ok ((t, info), args) - | Group subs -> try_choose_term subs args + | Term t -> Ok ((t, info), choices, path, args) + | Group subs -> try_choose_term subs path args let choose_term main choices args = match parse_arg_cmd args with - | Error `No_args -> Ok (main, args) - | Ok (cmd, args) -> one_of (cmd, args) choices >>= choose_term + | Error `No_args -> Ok (main, choices, [], args) + | Ok (cmd, args) -> one_of (cmd, choices, [snd main], args) >>= choose_term let eval ?help:(help_ppf = Format.std_formatter) @@ -327,13 +329,14 @@ module Term = struct let to_term_f ((al, f), ti) = Cmdliner_info.term_add_args ti al, f in let main_args = fst main in let main_f = to_term_f main in - let main = fst main_f in + (* let main = fst main_f in *) match choose_term (main_args, (fst main_f)) choices_f (remove_exec argv) with - | Error `No_args -> assert false + | Error (`No_args (path, choices)) -> assert false | Error (`Invalid_command _) -> `Error `Exn - | Ok (((_, f), info), args) -> + | Ok (((_, f), info), sibling_terms, path, args) -> + let sibling_terms = List.map snd sibling_terms in let ei = Cmdliner_info.eval ~env - (Sub_command { path = [main ; info] ; sibling_terms = []}) in + (Sub_command { path = List.rev (info :: path) ; sibling_terms }) in let ei, res = term_eval ~catch ei f args in do_result help_ppf err_ppf ei res end diff --git a/test/groups.t b/test/groups.t index 2b288f3..ed48672 100644 --- a/test/groups.t +++ b/test/groups.t @@ -2,7 +2,7 @@ listing things $ ./groups.exe things - Fatal error: exception File "src/cmdliner.ml", line 334, characters 24-30: Assertion failed + Fatal error: exception File "src/cmdliner.ml", line 336, characters 42-48: Assertion failed [2] $ ./groups.exe things show foo @@ -10,10 +10,10 @@ $ ./groups.exe things list --help NAME - groups + groups-list SYNOPSIS - groups [OPTION]... + groups list [OPTION]... OPTIONS --help[=FMT] (default=auto) @@ -26,7 +26,7 @@ $ ./groups.exe things --help - Fatal error: exception File "src/cmdliner.ml", line 334, characters 24-30: Assertion failed + Fatal error: exception File "src/cmdliner.ml", line 336, characters 42-48: Assertion failed [2] $ ./groups.exe --help @@ -34,7 +34,11 @@ groups SYNOPSIS - groups [OPTION]... + groups COMMAND ... + + COMMANDS + things + OPTIONS --help[=FMT] (default=auto) From a718d574d4e7421b84c95fec70ec7935ec484a6f Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 9 Nov 2020 21:33:48 -0800 Subject: [PATCH 09/25] better error handling Signed-off-by: Rudi Grinberg --- src/cmdliner.ml | 19 ++++++++++++++----- src/cmdliner_docgen.ml | 8 +++++--- src/cmdliner_info.ml | 17 +++++++++-------- src/cmdliner_info.mli | 10 +++++++--- test/darcs.t | 8 ++++---- test/groups.ml | 9 +++++---- test/groups.t | 18 ++++++++++++------ 7 files changed, 56 insertions(+), 33 deletions(-) diff --git a/src/cmdliner.ml b/src/cmdliner.ml index b3bdbd9..1c0478e 100644 --- a/src/cmdliner.ml +++ b/src/cmdliner.ml @@ -258,13 +258,15 @@ module Term = struct match choose_term main_f choices_f (remove_exec argv) with | Error err -> let ei = Cmdliner_info.eval ~env - (Sub_command { path = [main] ; sibling_terms = choices}) + (Sub_command { term = main ; path = [main] ; main + ; sibling_terms = choices}) in Cmdliner_msg.pp_err_usage err_ppf ei ~err_lines:false ~err; `Error `Parse | Ok ((chosen, f), args) -> let ei = Cmdliner_info.eval ~env - (Sub_command { path = [main; chosen]; sibling_terms = choices }) in + (Sub_command { term = chosen ; path = [main; chosen] ; main; + sibling_terms = choices }) in let ei, res = term_eval ~catch ei f args in do_result help_ppf err_ppf ei res @@ -329,14 +331,21 @@ module Term = struct let to_term_f ((al, f), ti) = Cmdliner_info.term_add_args ti al, f in let main_args = fst main in let main_f = to_term_f main in - (* let main = fst main_f in *) + let main = fst main_f in match choose_term (main_args, (fst main_f)) choices_f (remove_exec argv) with - | Error (`No_args (path, choices)) -> assert false + | Error (`No_args (path, choices)) -> + let sibling_terms = List.map snd choices in + let ei = Cmdliner_info.eval ~env + (Sub_command { term = main ; path ; main ; sibling_terms}) + in + Cmdliner_msg.pp_err_usage err_ppf ei ~err_lines:false + ~err:"this command has subcommands"; + `Error `Parse | Error (`Invalid_command _) -> `Error `Exn | Ok (((_, f), info), sibling_terms, path, args) -> let sibling_terms = List.map snd sibling_terms in let ei = Cmdliner_info.eval ~env - (Sub_command { path = List.rev (info :: path) ; sibling_terms }) in + (Sub_command { main ; term = info ; path ; sibling_terms }) in let ei, res = term_eval ~catch ei f args in do_result help_ppf err_ppf ei res end diff --git a/src/cmdliner_docgen.ml b/src/cmdliner_docgen.ml index e41aa60..3bad7e8 100644 --- a/src/cmdliner_docgen.ml +++ b/src/cmdliner_docgen.ml @@ -61,9 +61,11 @@ let term_info_subst ei = function let invocation ?(sep = ' ') ei = match Cmdliner_info.eval_kind ei with | `Simple | `Multiple_main -> term_name (Cmdliner_info.eval_main ei) | `Multiple_sub -> - strf "%s%c%s" - Cmdliner_info.(term_name @@ eval_main ei) sep - Cmdliner_info.(term_name @@ eval_term ei) + let sep = String.make 1 sep in + Cmdliner_info.eval_parents_invocation_order ei + |> List.map Cmdliner_info.term_name + |> String.concat sep + |> strf "%s" let plain_invocation ei = invocation ei let invocation ?sep ei = esc @@ invocation ?sep ei diff --git a/src/cmdliner_info.ml b/src/cmdliner_info.ml index 8e38d82..d806115 100644 --- a/src/cmdliner_info.ml +++ b/src/cmdliner_info.ml @@ -194,7 +194,12 @@ let term_add_args t args = type eval_kind = | Simple of term | Main of { term : term ; choices : term list } -| Sub_command of { path : term list ; sibling_terms : term list } +| Sub_command of { term : term; + (** is [term] is from a group, [path] are the ancestors + direct with the direct parent *) + path : term list; + main : term; + sibling_terms : term list } (* Eval info *) @@ -210,13 +215,7 @@ let eval ~env kind = match kind with | Simple term -> (term, term, [term], []) | Main { term ; choices } -> (term, term, [term], choices) - | Sub_command { path ; sibling_terms } -> - let (main, term) = - match path with - | main :: rest -> - (main, List.fold_left (fun _ last -> last) main rest) - | [] -> assert false - in + | Sub_command { main ; term ; path ; sibling_terms } -> (main, term, path, sibling_terms) in { term; main; choices; env; path } @@ -232,6 +231,8 @@ let eval_kind ei = if (ei.term.term_info.term_name == ei.main.term_info.term_name) then `Multiple_main else `Multiple_sub +let eval_parents_invocation_order ei = List.rev ei.path + let eval_with_term ei term = { ei with term } let eval_has_choice e cmd = diff --git a/src/cmdliner_info.mli b/src/cmdliner_info.mli index 38f1e06..f6621fd 100644 --- a/src/cmdliner_info.mli +++ b/src/cmdliner_info.mli @@ -114,12 +114,15 @@ type eval type eval_kind = | Simple of term | Main of { term : term ; choices : term list } -| Sub_command of { path : term list ; sibling_terms : term list } +| Sub_command of { term : term; + (** is [term] is from a group, [path] are the ancestors + direct with the direct parent *) + path : term list; + main : term; + sibling_terms : term list } val eval : env:(string -> string option) -> eval_kind -> eval -val eval_term_path : eval -> term list - (** Equivalent to [List.last (eval_term_full e)] *) val eval_term : eval -> term @@ -131,6 +134,7 @@ val eval_env_var : eval -> string -> string option val eval_kind : eval -> [> `Multiple_main | `Multiple_sub | `Simple ] val eval_with_term : eval -> term -> eval val eval_has_choice : eval -> string -> bool +val eval_parents_invocation_order : eval -> term list (*--------------------------------------------------------------------------- Copyright (c) 2011 Daniel C. Bünzli diff --git a/test/darcs.t b/test/darcs.t index d6fb813..3f20abe 100644 --- a/test/darcs.t +++ b/test/darcs.t @@ -6,16 +6,16 @@ $ ./darcs_ex.exe initialize --invalid darcs: unknown option `--invalid'. - Usage: darcs initialize [OPTION]... - Try `darcs initialize --help' or `darcs --help' for more information. + Usage: initialize darcs [OPTION]... + Try `initialize darcs --help' or `darcs --help' for more information. [1] $ ./darcs_ex.exe initialize --help NAME - darcs-initialize - make the current directory a repository + initialize-darcs - make the current directory a repository SYNOPSIS - darcs initialize [OPTION]... + initialize darcs [OPTION]... DESCRIPTION Turns the current directory into a Darcs repository. Any existing diff --git a/test/groups.ml b/test/groups.ml index 563d403..6aac1ad 100644 --- a/test/groups.ml +++ b/test/groups.ml @@ -1,6 +1,6 @@ open Cmdliner -let things = +let gen_group name = let thing = let doc = "thing to operate on" in let nfo = Arg.info ~doc [] in @@ -11,7 +11,7 @@ let things = Term.(const show $ thing) in let list = - let list () = print_endline "listing things" in + let list () = Printf.printf "listing %s\n" name in Term.(const list $ (const ())) in let term : _ Term.Group.t list = @@ -19,7 +19,7 @@ let things = ; Term list, Term.info "list" ] in - (Term.Group.Group term), Term.info "things" + (Term.Group.Group term), Term.info name let default_cmd = let term = @@ -33,7 +33,8 @@ let default_cmd = let cmds : _ Term.Group.t list = let _term (t, info) = Term.Group.Term t, info in - [ things + [ gen_group "things" + ; gen_group "widgets" ] let () = diff --git a/test/groups.t b/test/groups.t index ed48672..8747012 100644 --- a/test/groups.t +++ b/test/groups.t @@ -2,18 +2,20 @@ listing things $ ./groups.exe things - Fatal error: exception File "src/cmdliner.ml", line 336, characters 42-48: Assertion failed - [2] + groups: this command has subcommands + Usage: groups COMMAND ... + Try `groups --help' for more information. + [124] $ ./groups.exe things show foo showing foo $ ./groups.exe things list --help NAME - groups-list + groups-things-list SYNOPSIS - groups list [OPTION]... + groups things list [OPTION]... OPTIONS --help[=FMT] (default=auto) @@ -26,8 +28,10 @@ $ ./groups.exe things --help - Fatal error: exception File "src/cmdliner.ml", line 336, characters 42-48: Assertion failed - [2] + groups: this command has subcommands + Usage: groups COMMAND ... + Try `groups --help' for more information. + [124] $ ./groups.exe --help NAME @@ -39,6 +43,8 @@ COMMANDS things + widgets + OPTIONS --help[=FMT] (default=auto) From 3cbe62c74e067c3da8c0d45d800ba0a6801a483d Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 9 Nov 2020 21:36:40 -0800 Subject: [PATCH 10/25] more error handling Signed-off-by: Rudi Grinberg --- src/cmdliner.ml | 9 ++++++++- test/groups.t | 12 ++++++++++++ 2 files changed, 20 insertions(+), 1 deletion(-) diff --git a/src/cmdliner.ml b/src/cmdliner.ml index 1c0478e..27e0863 100644 --- a/src/cmdliner.ml +++ b/src/cmdliner.ml @@ -341,7 +341,14 @@ module Term = struct Cmdliner_msg.pp_err_usage err_ppf ei ~err_lines:false ~err:"this command has subcommands"; `Error `Parse - | Error (`Invalid_command _) -> `Error `Exn + | Error (`Invalid_command (maybe, path, _choices)) -> + let err = Cmdliner_base.err_unknown ~kind:"command" maybe ~hints:[] in + let sibling_terms = List.map snd choices in + let ei = Cmdliner_info.eval ~env + (Sub_command { term = main ; path ; main ; sibling_terms}) + in + Cmdliner_msg.pp_err_usage err_ppf ei ~err_lines:false ~err; + `Error `Parse | Ok (((_, f), info), sibling_terms, path, args) -> let sibling_terms = List.map snd sibling_terms in let ei = Cmdliner_info.eval ~env diff --git a/test/groups.t b/test/groups.t index 8747012..559cf8b 100644 --- a/test/groups.t +++ b/test/groups.t @@ -55,3 +55,15 @@ --version Show version information. + + $ ./groups.exe foobar + groups: unknown command `foobar'. + Usage: groups COMMAND ... + Try `groups --help' for more information. + [124] + + $ ./groups.exe widgets baz + groups: unknown command `baz'. + Usage: groups COMMAND ... + Try `groups --help' for more information. + [124] From 63534f8aba47f7632720745856bd6ad62285ca59 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 9 Nov 2020 21:45:40 -0800 Subject: [PATCH 11/25] better help when no subcommand selected Signed-off-by: Rudi Grinberg --- src/cmdliner.ml | 9 ++++----- test/groups.t | 50 +++++++++++++++++++++++++++++++++++++++++-------- 2 files changed, 46 insertions(+), 13 deletions(-) diff --git a/src/cmdliner.ml b/src/cmdliner.ml index 27e0863..c5a2ea7 100644 --- a/src/cmdliner.ml +++ b/src/cmdliner.ml @@ -336,11 +336,10 @@ module Term = struct | Error (`No_args (path, choices)) -> let sibling_terms = List.map snd choices in let ei = Cmdliner_info.eval ~env - (Sub_command { term = main ; path ; main ; sibling_terms}) - in - Cmdliner_msg.pp_err_usage err_ppf ei ~err_lines:false - ~err:"this command has subcommands"; - `Error `Parse + (Sub_command { term = main ; path ; main ; sibling_terms}) in + let _, _, ei = add_stdopts ei in + Cmdliner_docgen.pp_man ~errs:err_ppf `Auto help_ppf ei; + `Help | Error (`Invalid_command (maybe, path, _choices)) -> let err = Cmdliner_base.err_unknown ~kind:"command" maybe ~hints:[] in let sibling_terms = List.map snd choices in diff --git a/test/groups.t b/test/groups.t index 559cf8b..659fd02 100644 --- a/test/groups.t +++ b/test/groups.t @@ -2,10 +2,27 @@ listing things $ ./groups.exe things - groups: this command has subcommands - Usage: groups COMMAND ... - Try `groups --help' for more information. - [124] + NAME + groups + + SYNOPSIS + groups COMMAND ... + + COMMANDS + list + + show + + + OPTIONS + --help[=FMT] (default=auto) + Show this help in format FMT. The value FMT must be one of `auto', + `pager', `groff' or `plain'. With `auto', the format is `pager` or + `plain' whenever the TERM env var is `dumb' or undefined. + + --version + Show version information. + $ ./groups.exe things show foo showing foo @@ -28,10 +45,27 @@ $ ./groups.exe things --help - groups: this command has subcommands - Usage: groups COMMAND ... - Try `groups --help' for more information. - [124] + NAME + groups + + SYNOPSIS + groups COMMAND ... + + COMMANDS + list + + show + + + OPTIONS + --help[=FMT] (default=auto) + Show this help in format FMT. The value FMT must be one of `auto', + `pager', `groff' or `plain'. With `auto', the format is `pager` or + `plain' whenever the TERM env var is `dumb' or undefined. + + --version + Show version information. + $ ./groups.exe --help NAME From a1a38198c9b10f1985345afdabe2114607b50fad Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 30 Nov 2020 17:34:05 -0800 Subject: [PATCH 12/25] Handle prefixes Signed-off-by: Rudi Grinberg --- src/cmdliner.ml | 38 ++++++++++++++++++++++++++++++++------ test/groups.ml | 1 + test/groups.t | 13 +++++++++++++ 3 files changed, 46 insertions(+), 6 deletions(-) diff --git a/src/cmdliner.ml b/src/cmdliner.ml index c5a2ea7..52332f0 100644 --- a/src/cmdliner.ml +++ b/src/cmdliner.ml @@ -300,10 +300,28 @@ module Term = struct let cmd_name (_, info) = Cmdliner_info.term_name info - let one_of (cmd, choices, path, args) = - match List.find (fun t -> cmd_name t = cmd) choices with - | exception Not_found -> Error (`Invalid_command (cmd, path, choices)) - | (choice, info) -> Ok ((choice, info), choices, info :: path, args) + let one_of (cmd, (choices : _ t list), path, args) = + let index = + let add acc c = + let name = cmd_name c in + match Cmdliner_trie.add acc name c with + | `New t -> t + | `Replaced (c', _) -> + let flip (x, y) = (y, x) in + invalid_arg (err_multi_cmd_def name (flip c) (flip c')) + in + List.fold_left add Cmdliner_trie.empty choices + in + match Cmdliner_trie.find index cmd with + | `Ok (choice, info) -> Ok ((choice, info), choices, info :: path, args) + | `Not_found -> + let all = Cmdliner_trie.ambiguities index "" in + let hints = Cmdliner_suggest.value cmd all in + Error (`Invalid_command (cmd, path, choices, hints)) + | `Ambiguous -> + let ambs = Cmdliner_trie.ambiguities index cmd in + let ambs = List.sort compare ambs in + Error (`Ambiguous (cmd, path, ambs)) let try_one_of choices path args = match parse_arg_cmd args with @@ -340,8 +358,16 @@ module Term = struct let _, _, ei = add_stdopts ei in Cmdliner_docgen.pp_man ~errs:err_ppf `Auto help_ppf ei; `Help - | Error (`Invalid_command (maybe, path, _choices)) -> - let err = Cmdliner_base.err_unknown ~kind:"command" maybe ~hints:[] in + | Error (`Invalid_command (maybe, path, choices, hints)) -> + let err = Cmdliner_base.err_unknown ~kind:"command" maybe ~hints in + let sibling_terms = List.map snd choices in + let ei = Cmdliner_info.eval ~env + (Sub_command { term = main ; path ; main ; sibling_terms}) + in + Cmdliner_msg.pp_err_usage err_ppf ei ~err_lines:false ~err; + `Error `Parse + | Error (`Ambiguous (cmd, path, ambs)) -> + let err = (Cmdliner_base.err_ambiguous ~kind:"command" cmd ~ambs) in let sibling_terms = List.map snd choices in let ei = Cmdliner_info.eval ~env (Sub_command { term = main ; path ; main ; sibling_terms}) diff --git a/test/groups.ml b/test/groups.ml index 6aac1ad..fabe16e 100644 --- a/test/groups.ml +++ b/test/groups.ml @@ -35,6 +35,7 @@ let cmds : _ Term.Group.t list = let _term (t, info) = Term.Group.Term t, info in [ gen_group "things" ; gen_group "widgets" + ; gen_group "widg" ] let () = diff --git a/test/groups.t b/test/groups.t index 659fd02..e5927cc 100644 --- a/test/groups.t +++ b/test/groups.t @@ -77,6 +77,8 @@ COMMANDS things + widg + widgets @@ -101,3 +103,14 @@ Usage: groups COMMAND ... Try `groups --help' for more information. [124] + +Prefixes + + $ ./groups.exe th show foo + showing foo + + $ ./groups.exe wid show foo + groups: command `wid' ambiguous and could be either `widg' or `widgets' + Usage: groups COMMAND ... + Try `groups --help' for more information. + [124] From 53bd9d38d84f4e63999d97b81b5b9c7634a4c2eb Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 1 Dec 2020 15:52:11 -0800 Subject: [PATCH 13/25] No subcommand specified is an error Signed-off-by: Rudi Grinberg --- src/cmdliner.ml | 10 ++++++--- src/cmdliner_base.ml | 4 ++++ src/cmdliner_base.mli | 1 + test/groups.t | 50 +++++++------------------------------------ 4 files changed, 20 insertions(+), 45 deletions(-) diff --git a/src/cmdliner.ml b/src/cmdliner.ml index 52332f0..2391127 100644 --- a/src/cmdliner.ml +++ b/src/cmdliner.ml @@ -352,12 +352,16 @@ module Term = struct let main = fst main_f in match choose_term (main_args, (fst main_f)) choices_f (remove_exec argv) with | Error (`No_args (path, choices)) -> + let err = + let name = List.map Cmdliner_info.term_name path in + Cmdliner_base.err_no_sub_command name + in let sibling_terms = List.map snd choices in let ei = Cmdliner_info.eval ~env (Sub_command { term = main ; path ; main ; sibling_terms}) in let _, _, ei = add_stdopts ei in - Cmdliner_docgen.pp_man ~errs:err_ppf `Auto help_ppf ei; - `Help + Cmdliner_msg.pp_err_usage err_ppf ei ~err_lines:false ~err; + `Error `Parse | Error (`Invalid_command (maybe, path, choices, hints)) -> let err = Cmdliner_base.err_unknown ~kind:"command" maybe ~hints in let sibling_terms = List.map snd choices in @@ -367,7 +371,7 @@ module Term = struct Cmdliner_msg.pp_err_usage err_ppf ei ~err_lines:false ~err; `Error `Parse | Error (`Ambiguous (cmd, path, ambs)) -> - let err = (Cmdliner_base.err_ambiguous ~kind:"command" cmd ~ambs) in + let err = Cmdliner_base.err_ambiguous ~kind:"command" cmd ~ambs in let sibling_terms = List.map snd choices in let ei = Cmdliner_info.eval ~env (Sub_command { term = main ; path ; main ; sibling_terms}) diff --git a/src/cmdliner_base.ml b/src/cmdliner_base.ml index 24ad20c..3367116 100644 --- a/src/cmdliner_base.ml +++ b/src/cmdliner_base.ml @@ -83,6 +83,10 @@ let err_unknown ?(hints = []) ~kind v = let hints = match hints with [] -> "." | hs -> did_you_mean (alts_str hs) in strf "unknown %s %s%s" kind (quote v) hints +let err_no_sub_command cmd_path = + strf "%s is a command group and requires a command argument." + (String.concat " " cmd_path) + 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) diff --git a/src/cmdliner_base.mli b/src/cmdliner_base.mli index 5c54ee0..c2bccc4 100644 --- a/src/cmdliner_base.mli +++ b/src/cmdliner_base.mli @@ -20,6 +20,7 @@ val err_ambiguous : kind:string -> string -> ambs:string list -> string val err_unknown : ?hints:string list -> kind:string -> string -> string val err_multi_def : kind:string -> string -> ('b -> string) -> 'b -> 'b -> string + val err_no_sub_command : string list -> string (** {1:conv Textual OCaml value converters} *) diff --git a/test/groups.t b/test/groups.t index e5927cc..64dde8f 100644 --- a/test/groups.t +++ b/test/groups.t @@ -2,27 +2,10 @@ listing things $ ./groups.exe things - NAME - groups - - SYNOPSIS - groups COMMAND ... - - COMMANDS - list - - show - - - OPTIONS - --help[=FMT] (default=auto) - Show this help in format FMT. The value FMT must be one of `auto', - `pager', `groff' or `plain'. With `auto', the format is `pager` or - `plain' whenever the TERM env var is `dumb' or undefined. - - --version - Show version information. - + groups: things groups is a command group and requires a command argument. + Usage: groups COMMAND ... + Try `groups --help' for more information. + [124] $ ./groups.exe things show foo showing foo @@ -45,27 +28,10 @@ $ ./groups.exe things --help - NAME - groups - - SYNOPSIS - groups COMMAND ... - - COMMANDS - list - - show - - - OPTIONS - --help[=FMT] (default=auto) - Show this help in format FMT. The value FMT must be one of `auto', - `pager', `groff' or `plain'. With `auto', the format is `pager` or - `plain' whenever the TERM env var is `dumb' or undefined. - - --version - Show version information. - + groups: things groups is a command group and requires a command argument. + Usage: groups COMMAND ... + Try `groups --help' for more information. + [124] $ ./groups.exe --help NAME From be75ba0819f4735881b6a65bfa36d5023e4b845c Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 1 Dec 2020 16:29:06 -0800 Subject: [PATCH 14/25] Use full term list for error message Signed-off-by: Rudi Grinberg --- src/cmdliner_info.ml | 2 ++ src/cmdliner_info.mli | 5 +---- src/cmdliner_msg.ml | 3 ++- test/darcs.t | 8 ++++---- test/groups.t | 14 ++++++++------ 5 files changed, 17 insertions(+), 15 deletions(-) diff --git a/src/cmdliner_info.ml b/src/cmdliner_info.ml index d806115..18590cf 100644 --- a/src/cmdliner_info.ml +++ b/src/cmdliner_info.ml @@ -219,6 +219,8 @@ let eval ~env kind = (main, term, path, sibling_terms) in { term; main; choices; env; path } + +let eval_terms e = e.path let eval_term e = e.term let eval_main e = e.main let eval_term_path e = e.path diff --git a/src/cmdliner_info.mli b/src/cmdliner_info.mli index f6621fd..a29be93 100644 --- a/src/cmdliner_info.mli +++ b/src/cmdliner_info.mli @@ -123,12 +123,9 @@ type eval_kind = val eval : env:(string -> string option) -> eval_kind -> eval -(** Equivalent to [List.last (eval_term_full e)] *) +val eval_terms : eval -> term list val eval_term : eval -> term - -(** Equivalent to [List.hd (eval_term_full e)] *) val eval_main : eval -> term - val eval_choices : eval -> term list val eval_env_var : eval -> string -> string option val eval_kind : eval -> [> `Multiple_main | `Multiple_sub | `Simple ] diff --git a/src/cmdliner_msg.ml b/src/cmdliner_msg.ml index e26599b..5c67a50 100644 --- a/src/cmdliner_msg.ml +++ b/src/cmdliner_msg.ml @@ -68,7 +68,8 @@ let err_arg_missing a = (* Other messages *) -let exec_name ei = Cmdliner_info.(term_name @@ eval_main ei) +let exec_name ei = + Cmdliner_info.(String.concat " " (List.map term_name (eval_terms ei))) let pp_version ppf ei = match Cmdliner_info.(term_version @@ eval_main ei) with | None -> assert false diff --git a/test/darcs.t b/test/darcs.t index 3f20abe..293d7f0 100644 --- a/test/darcs.t +++ b/test/darcs.t @@ -1,13 +1,13 @@ $ ./darcs_ex.exe --invalid opt - darcs: unknown option `--invalid'. + darcs darcs: unknown option `--invalid'. Usage: darcs COMMAND ... - Try `darcs --help' for more information. + Try `darcs darcs --help' for more information. [1] $ ./darcs_ex.exe initialize --invalid - darcs: unknown option `--invalid'. + darcs initialize: unknown option `--invalid'. Usage: initialize darcs [OPTION]... - Try `initialize darcs --help' or `darcs --help' for more information. + Try `initialize darcs --help' or `darcs initialize --help' for more information. [1] $ ./darcs_ex.exe initialize --help diff --git a/test/groups.t b/test/groups.t index 64dde8f..6cb6004 100644 --- a/test/groups.t +++ b/test/groups.t @@ -2,9 +2,10 @@ listing things $ ./groups.exe things - groups: things groups is a command group and requires a command argument. + things groups: things groups is a command group and requires a command + argument. Usage: groups COMMAND ... - Try `groups --help' for more information. + Try `things groups --help' for more information. [124] $ ./groups.exe things show foo @@ -28,9 +29,10 @@ $ ./groups.exe things --help - groups: things groups is a command group and requires a command argument. + things groups: things groups is a command group and requires a command + argument. Usage: groups COMMAND ... - Try `groups --help' for more information. + Try `things groups --help' for more information. [124] $ ./groups.exe --help @@ -65,9 +67,9 @@ [124] $ ./groups.exe widgets baz - groups: unknown command `baz'. + widgets groups: unknown command `baz'. Usage: groups COMMAND ... - Try `groups --help' for more information. + Try `widgets groups --help' for more information. [124] Prefixes From dd64e4a3cf1ca388bdeb33e0a5c3f7bff8475f8a Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 1 Dec 2020 16:39:44 -0800 Subject: [PATCH 15/25] Document command groups Signed-off-by: Rudi Grinberg --- src/cmdliner.mli | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/cmdliner.mli b/src/cmdliner.mli index e53c816..678b9ca 100644 --- a/src/cmdliner.mli +++ b/src/cmdliner.mli @@ -388,13 +388,23 @@ module Term : sig type 'a node = | Term of 'a term | Group of 'a t list + (** The type for an individual command or a command group. + {ul + {- [Term], individual command term.} + {- [Group], a list of command terms in the same group.}} *) and 'a t = 'a node * info + (** An individual command or a command group annotated with an [info] *) val eval : ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> ?env:(string -> string option) -> ?argv:string array -> 'a term * info -> 'a t list -> 'a result + (** [eval help err catch argv (t, i) choices] is like {!eval_choice} + except that it will search for term inside the command group [choices] + + If a command group is selected without a sub command, the program will + exit with an error message. *) end with type 'a term := 'a t val eval_peek_opts : From e29c474f648dff6961f3d5e0df39d6ac072c4289 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Wed, 2 Dec 2020 02:22:01 -0800 Subject: [PATCH 16/25] Fix reversed term order Signed-off-by: Rudi Grinberg --- src/cmdliner.ml | 13 ++++++++++++- src/cmdliner_docgen.ml | 2 +- test/darcs.t | 8 ++++---- test/groups.t | 12 ++++++------ 4 files changed, 23 insertions(+), 12 deletions(-) diff --git a/src/cmdliner.ml b/src/cmdliner.ml index 2391127..b8862dd 100644 --- a/src/cmdliner.ml +++ b/src/cmdliner.ml @@ -339,7 +339,18 @@ module Term = struct let choose_term main choices args = match parse_arg_cmd args with | Error `No_args -> Ok (main, choices, [], args) - | Ok (cmd, args) -> one_of (cmd, choices, [snd main], args) >>= choose_term + | Ok (cmd, args) -> + match one_of (cmd, choices, [snd main], args) >>= choose_term with + | Ok (t, choices, path, args) -> Ok (t, choices, List.rev path, args) + | Error e -> + Error ( + match e with + | `Invalid_command (cmd, path, choices, hint) -> + `Invalid_command (cmd, List.rev path, choices, hint) + | `Ambiguous (cmd, path, ambs) -> + `Ambiguous (cmd, List.rev path, ambs) + | `No_args (path, choices) -> + `No_args (List.rev path, choices)) let eval ?help:(help_ppf = Format.std_formatter) diff --git a/src/cmdliner_docgen.ml b/src/cmdliner_docgen.ml index 3bad7e8..a2bc4a6 100644 --- a/src/cmdliner_docgen.ml +++ b/src/cmdliner_docgen.ml @@ -62,7 +62,7 @@ let invocation ?(sep = ' ') ei = match Cmdliner_info.eval_kind ei with | `Simple | `Multiple_main -> term_name (Cmdliner_info.eval_main ei) | `Multiple_sub -> let sep = String.make 1 sep in - Cmdliner_info.eval_parents_invocation_order ei + Cmdliner_info.eval_terms ei |> List.map Cmdliner_info.term_name |> String.concat sep |> strf "%s" diff --git a/test/darcs.t b/test/darcs.t index 293d7f0..67223c8 100644 --- a/test/darcs.t +++ b/test/darcs.t @@ -6,16 +6,16 @@ $ ./darcs_ex.exe initialize --invalid darcs initialize: unknown option `--invalid'. - Usage: initialize darcs [OPTION]... - Try `initialize darcs --help' or `darcs initialize --help' for more information. + Usage: darcs initialize [OPTION]... + Try `darcs initialize --help' or `darcs initialize --help' for more information. [1] $ ./darcs_ex.exe initialize --help NAME - initialize-darcs - make the current directory a repository + darcs-initialize - make the current directory a repository SYNOPSIS - initialize darcs [OPTION]... + darcs initialize [OPTION]... DESCRIPTION Turns the current directory into a Darcs repository. Any existing diff --git a/test/groups.t b/test/groups.t index 6cb6004..a3eacbd 100644 --- a/test/groups.t +++ b/test/groups.t @@ -2,10 +2,10 @@ listing things $ ./groups.exe things - things groups: things groups is a command group and requires a command + groups things: groups things is a command group and requires a command argument. Usage: groups COMMAND ... - Try `things groups --help' for more information. + Try `groups things --help' for more information. [124] $ ./groups.exe things show foo @@ -29,10 +29,10 @@ $ ./groups.exe things --help - things groups: things groups is a command group and requires a command + groups things: groups things is a command group and requires a command argument. Usage: groups COMMAND ... - Try `things groups --help' for more information. + Try `groups things --help' for more information. [124] $ ./groups.exe --help @@ -67,9 +67,9 @@ [124] $ ./groups.exe widgets baz - widgets groups: unknown command `baz'. + groups widgets: unknown command `baz'. Usage: groups COMMAND ... - Try `widgets groups --help' for more information. + Try `groups widgets --help' for more information. [124] Prefixes From b47b44b61491dc3db2300f355908537afcde6cde Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Wed, 2 Dec 2020 02:29:04 -0800 Subject: [PATCH 17/25] tweak error Signed-off-by: Rudi Grinberg --- src/cmdliner.ml | 5 +---- src/cmdliner_base.ml | 5 ++--- src/cmdliner_base.mli | 2 +- test/groups.t | 6 ++---- 4 files changed, 6 insertions(+), 12 deletions(-) diff --git a/src/cmdliner.ml b/src/cmdliner.ml index b8862dd..fb17704 100644 --- a/src/cmdliner.ml +++ b/src/cmdliner.ml @@ -363,10 +363,7 @@ module Term = struct let main = fst main_f in match choose_term (main_args, (fst main_f)) choices_f (remove_exec argv) with | Error (`No_args (path, choices)) -> - let err = - let name = List.map Cmdliner_info.term_name path in - Cmdliner_base.err_no_sub_command name - in + let err = Cmdliner_base.err_no_sub_command in let sibling_terms = List.map snd choices in let ei = Cmdliner_info.eval ~env (Sub_command { term = main ; path ; main ; sibling_terms}) in diff --git a/src/cmdliner_base.ml b/src/cmdliner_base.ml index 3367116..fe0957b 100644 --- a/src/cmdliner_base.ml +++ b/src/cmdliner_base.ml @@ -83,9 +83,8 @@ let err_unknown ?(hints = []) ~kind v = let hints = match hints with [] -> "." | hs -> did_you_mean (alts_str hs) in strf "unknown %s %s%s" kind (quote v) hints -let err_no_sub_command cmd_path = - strf "%s is a command group and requires a command argument." - (String.concat " " cmd_path) +let err_no_sub_command = + "is a command group and requires a command argument." 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) diff --git a/src/cmdliner_base.mli b/src/cmdliner_base.mli index c2bccc4..3587c7b 100644 --- a/src/cmdliner_base.mli +++ b/src/cmdliner_base.mli @@ -20,7 +20,7 @@ val err_ambiguous : kind:string -> string -> ambs:string list -> string val err_unknown : ?hints:string list -> kind:string -> string -> string val err_multi_def : kind:string -> string -> ('b -> string) -> 'b -> 'b -> string - val err_no_sub_command : string list -> string + val err_no_sub_command : string (** {1:conv Textual OCaml value converters} *) diff --git a/test/groups.t b/test/groups.t index a3eacbd..486da26 100644 --- a/test/groups.t +++ b/test/groups.t @@ -2,8 +2,7 @@ listing things $ ./groups.exe things - groups things: groups things is a command group and requires a command - argument. + groups things: is a command group and requires a command argument. Usage: groups COMMAND ... Try `groups things --help' for more information. [124] @@ -29,8 +28,7 @@ $ ./groups.exe things --help - groups things: groups things is a command group and requires a command - argument. + groups things: is a command group and requires a command argument. Usage: groups COMMAND ... Try `groups things --help' for more information. [124] From 1552b34283e2691f7cdc9ce497d913960b79903a Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Wed, 2 Dec 2020 02:41:27 -0800 Subject: [PATCH 18/25] fix eval_choice pass path correctly Signed-off-by: Rudi Grinberg --- src/cmdliner.ml | 10 +++++----- test/darcs.t | 4 ++-- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/cmdliner.ml b/src/cmdliner.ml index fb17704..fdb9c3b 100644 --- a/src/cmdliner.ml +++ b/src/cmdliner.ml @@ -222,9 +222,9 @@ module Term = struct do_result help_ppf err_ppf ei res let choose_term main choices = function - | [] -> Ok (main, []) + | [] -> Ok (main, [], [fst main]) | maybe :: args' as args -> - if String.length maybe > 1 && maybe.[0] = '-' then Ok (main, args) else + if String.length maybe > 1 && maybe.[0] = '-' then Ok (main, args, [fst main]) else let index = let add acc (choice, _ as c) = let name = Cmdliner_info.term_name choice in @@ -235,7 +235,7 @@ module Term = struct List.fold_left add Cmdliner_trie.empty choices in match Cmdliner_trie.find index maybe with - | `Ok choice -> Ok (choice, args') + | `Ok choice -> Ok (choice, args', [fst main ; fst choice]) | `Not_found -> let all = Cmdliner_trie.ambiguities index "" in let hints = Cmdliner_suggest.value maybe all in @@ -263,9 +263,9 @@ module Term = struct in Cmdliner_msg.pp_err_usage err_ppf ei ~err_lines:false ~err; `Error `Parse - | Ok ((chosen, f), args) -> + | Ok ((chosen, f), args, path) -> let ei = Cmdliner_info.eval ~env - (Sub_command { term = chosen ; path = [main; chosen] ; main; + (Sub_command { term = chosen ; path ; main; sibling_terms = choices }) in let ei, res = term_eval ~catch ei f args in do_result help_ppf err_ppf ei res diff --git a/test/darcs.t b/test/darcs.t index 67223c8..8286bdd 100644 --- a/test/darcs.t +++ b/test/darcs.t @@ -1,7 +1,7 @@ $ ./darcs_ex.exe --invalid opt - darcs darcs: unknown option `--invalid'. + darcs: unknown option `--invalid'. Usage: darcs COMMAND ... - Try `darcs darcs --help' for more information. + Try `darcs --help' for more information. [1] $ ./darcs_ex.exe initialize --invalid From ea8a842edc156709bdcef928cf7553cb8f0ec3d0 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Wed, 2 Dec 2020 02:53:52 -0800 Subject: [PATCH 19/25] simplify all the silly term handling Signed-off-by: Rudi Grinberg --- src/cmdliner.ml | 15 ++------------- src/cmdliner_docgen.ml | 4 ++-- src/cmdliner_info.ml | 3 +-- src/cmdliner_info.mli | 3 +-- src/cmdliner_msg.ml | 12 +++++++++--- test/darcs.t | 2 +- 6 files changed, 16 insertions(+), 23 deletions(-) diff --git a/src/cmdliner.ml b/src/cmdliner.ml index fdb9c3b..baa38a9 100644 --- a/src/cmdliner.ml +++ b/src/cmdliner.ml @@ -235,7 +235,7 @@ module Term = struct List.fold_left add Cmdliner_trie.empty choices in match Cmdliner_trie.find index maybe with - | `Ok choice -> Ok (choice, args', [fst main ; fst choice]) + | `Ok choice -> Ok (choice, args', [fst choice ; fst main]) | `Not_found -> let all = Cmdliner_trie.ambiguities index "" in let hints = Cmdliner_suggest.value maybe all in @@ -339,18 +339,7 @@ module Term = struct let choose_term main choices args = match parse_arg_cmd args with | Error `No_args -> Ok (main, choices, [], args) - | Ok (cmd, args) -> - match one_of (cmd, choices, [snd main], args) >>= choose_term with - | Ok (t, choices, path, args) -> Ok (t, choices, List.rev path, args) - | Error e -> - Error ( - match e with - | `Invalid_command (cmd, path, choices, hint) -> - `Invalid_command (cmd, List.rev path, choices, hint) - | `Ambiguous (cmd, path, ambs) -> - `Ambiguous (cmd, List.rev path, ambs) - | `No_args (path, choices) -> - `No_args (List.rev path, choices)) + | Ok (cmd, args) -> one_of (cmd, choices, [snd main], args) >>= choose_term let eval ?help:(help_ppf = Format.std_formatter) diff --git a/src/cmdliner_docgen.ml b/src/cmdliner_docgen.ml index a2bc4a6..88bebea 100644 --- a/src/cmdliner_docgen.ml +++ b/src/cmdliner_docgen.ml @@ -62,8 +62,8 @@ let invocation ?(sep = ' ') ei = match Cmdliner_info.eval_kind ei with | `Simple | `Multiple_main -> term_name (Cmdliner_info.eval_main ei) | `Multiple_sub -> let sep = String.make 1 sep in - Cmdliner_info.eval_terms ei - |> List.map Cmdliner_info.term_name + Cmdliner_info.eval_terms_rev ei + |> List.rev_map Cmdliner_info.term_name |> String.concat sep |> strf "%s" diff --git a/src/cmdliner_info.ml b/src/cmdliner_info.ml index 18590cf..4a953ae 100644 --- a/src/cmdliner_info.ml +++ b/src/cmdliner_info.ml @@ -220,7 +220,6 @@ let eval ~env kind = in { term; main; choices; env; path } -let eval_terms e = e.path let eval_term e = e.term let eval_main e = e.main let eval_term_path e = e.path @@ -233,7 +232,7 @@ let eval_kind ei = if (ei.term.term_info.term_name == ei.main.term_info.term_name) then `Multiple_main else `Multiple_sub -let eval_parents_invocation_order ei = List.rev ei.path +let eval_terms_rev ei = ei.path let eval_with_term ei term = { ei with term } diff --git a/src/cmdliner_info.mli b/src/cmdliner_info.mli index a29be93..a469ff1 100644 --- a/src/cmdliner_info.mli +++ b/src/cmdliner_info.mli @@ -123,7 +123,6 @@ type eval_kind = val eval : env:(string -> string option) -> eval_kind -> eval -val eval_terms : eval -> term list val eval_term : eval -> term val eval_main : eval -> term val eval_choices : eval -> term list @@ -131,7 +130,7 @@ val eval_env_var : eval -> string -> string option val eval_kind : eval -> [> `Multiple_main | `Multiple_sub | `Simple ] val eval_with_term : eval -> term -> eval val eval_has_choice : eval -> string -> bool -val eval_parents_invocation_order : eval -> term list +val eval_terms_rev : eval -> term list (*--------------------------------------------------------------------------- Copyright (c) 2011 Daniel C. Bünzli diff --git a/src/cmdliner_msg.ml b/src/cmdliner_msg.ml index 5c67a50..2074686 100644 --- a/src/cmdliner_msg.ml +++ b/src/cmdliner_msg.ml @@ -68,8 +68,9 @@ let err_arg_missing a = (* Other messages *) -let exec_name ei = - Cmdliner_info.(String.concat " " (List.map term_name (eval_terms ei))) +let exec_name_terms terms = + String.concat " " (List.rev_map Cmdliner_info.term_name terms) +let exec_name ei = exec_name_terms (Cmdliner_info.eval_terms_rev ei) let pp_version ppf ei = match Cmdliner_info.(term_version @@ eval_main ei) with | None -> assert false @@ -80,8 +81,13 @@ let pp_try_help ppf ei = match Cmdliner_info.eval_kind ei with pp ppf "@[<2>Try `%s --help' for more information.@]" (exec_name ei) | `Multiple_sub -> let exec_cmd = Cmdliner_docgen.plain_invocation ei in + let parent = + Cmdliner_info.eval_terms_rev ei + |> List.tl + |> exec_name_terms + in pp ppf "@[<2>Try `%s --help' or `%s --help' for more information.@]" - exec_cmd (exec_name ei) + exec_cmd parent let pp_err ppf ei ~err = pp ppf "%s: @[%a@]@." (exec_name ei) pp_lines err diff --git a/test/darcs.t b/test/darcs.t index 8286bdd..958fbbb 100644 --- a/test/darcs.t +++ b/test/darcs.t @@ -7,7 +7,7 @@ $ ./darcs_ex.exe initialize --invalid darcs initialize: unknown option `--invalid'. Usage: darcs initialize [OPTION]... - Try `darcs initialize --help' or `darcs initialize --help' for more information. + Try `darcs initialize --help' or `darcs --help' for more information. [1] $ ./darcs_ex.exe initialize --help From 3a4937f72bd9074148584c735b33efe53438ada2 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Wed, 2 Dec 2020 02:59:04 -0800 Subject: [PATCH 20/25] implement eval_choice on top of group Signed-off-by: Rudi Grinberg --- src/cmdliner.ml | 29 ++++------------------------- test/darcs.t | 4 ++-- 2 files changed, 6 insertions(+), 27 deletions(-) diff --git a/src/cmdliner.ml b/src/cmdliner.ml index baa38a9..1de2270 100644 --- a/src/cmdliner.ml +++ b/src/cmdliner.ml @@ -245,31 +245,6 @@ module Term = struct let ambs = List.sort compare ambs in Error (Cmdliner_base.err_ambiguous ~kind:"command" maybe ~ambs) - let eval_choice - ?help:(help_ppf = Format.std_formatter) - ?err:(err_ppf = Format.err_formatter) - ?(catch = true) ?(env = env_default) ?(argv = Sys.argv) - main choices = - let to_term_f ((al, f), ti) = Cmdliner_info.term_add_args ti al, f in - let choices_f = List.rev_map to_term_f choices in - let main_f = to_term_f main in - let choices = List.rev_map fst choices_f in - let main = fst main_f in - match choose_term main_f choices_f (remove_exec argv) with - | Error err -> - let ei = Cmdliner_info.eval ~env - (Sub_command { term = main ; path = [main] ; main - ; sibling_terms = choices}) - in - Cmdliner_msg.pp_err_usage err_ppf ei ~err_lines:false ~err; - `Error `Parse - | Ok ((chosen, f), args, path) -> - let ei = Cmdliner_info.eval ~env - (Sub_command { term = chosen ; path ; main; - sibling_terms = choices }) in - let ei, res = term_eval ~catch ei f args in - do_result help_ppf err_ppf ei res - module Group = struct type 'a node = | Term of 'a Cmdliner_term.t @@ -383,6 +358,10 @@ module Term = struct do_result help_ppf err_ppf ei res end + let eval_choice ?help ?err ?catch ?env ?argv main choices = + let choices = List.map (fun (c, nfo) -> Group.Term c, nfo) choices in + Group.eval ?help ?err ?catch ?env ?argv main choices + let eval_peek_opts ?(version_opt = false) ?(env = env_default) ?(argv = Sys.argv) ((args, f) : 'a t) = diff --git a/test/darcs.t b/test/darcs.t index 958fbbb..7cf89a6 100644 --- a/test/darcs.t +++ b/test/darcs.t @@ -1,7 +1,7 @@ $ ./darcs_ex.exe --invalid opt - darcs: unknown option `--invalid'. + : unknown option `--invalid'. Usage: darcs COMMAND ... - Try `darcs --help' for more information. + Try ` --help' for more information. [1] $ ./darcs_ex.exe initialize --invalid From 0b58b1ea4d2a0250a2f8d541b9b7b66e1ef05c94 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Wed, 2 Dec 2020 03:00:30 -0800 Subject: [PATCH 21/25] Fix omission of main in path Signed-off-by: Rudi Grinberg --- src/cmdliner.ml | 5 +++-- test/darcs.t | 4 ++-- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/cmdliner.ml b/src/cmdliner.ml index 1de2270..e7b02f4 100644 --- a/src/cmdliner.ml +++ b/src/cmdliner.ml @@ -312,9 +312,10 @@ module Term = struct | Group subs -> try_choose_term subs path args let choose_term main choices args = + let path = [snd main] in match parse_arg_cmd args with - | Error `No_args -> Ok (main, choices, [], args) - | Ok (cmd, args) -> one_of (cmd, choices, [snd main], args) >>= choose_term + | Error `No_args -> Ok (main, choices, path, args) + | Ok (cmd, args) -> one_of (cmd, choices, path, args) >>= choose_term let eval ?help:(help_ppf = Format.std_formatter) diff --git a/test/darcs.t b/test/darcs.t index 7cf89a6..958fbbb 100644 --- a/test/darcs.t +++ b/test/darcs.t @@ -1,7 +1,7 @@ $ ./darcs_ex.exe --invalid opt - : unknown option `--invalid'. + darcs: unknown option `--invalid'. Usage: darcs COMMAND ... - Try ` --help' for more information. + Try `darcs --help' for more information. [1] $ ./darcs_ex.exe initialize --invalid From 2faab8668c4bb65eb30794d25d891d61e71a5bf7 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Wed, 3 Feb 2021 06:53:32 -0800 Subject: [PATCH 22/25] default cmd test Signed-off-by: Rudi Grinberg --- test/groups.t | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/test/groups.t b/test/groups.t index 486da26..e53fb1d 100644 --- a/test/groups.t +++ b/test/groups.t @@ -80,3 +80,8 @@ Prefixes Usage: groups COMMAND ... Try `groups --help' for more information. [124] + +Default cmd + + $ ./groups.exe + default cmd From d31764554dc5942a769c73444369b2c3afb34ce8 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Wed, 3 Feb 2021 08:52:40 -0800 Subject: [PATCH 23/25] fix displaying help Signed-off-by: Rudi Grinberg --- src/cmdliner.ml | 16 +++++++++++++--- src/cmdliner_docgen.ml | 3 +++ src/cmdliner_info.ml | 7 ++++++- src/cmdliner_info.mli | 2 +- src/cmdliner_msg.ml | 1 + test/chorus.ml | 2 +- test/groups.t | 42 ++++++++++++++++++++++++++++++++++++------ 7 files changed, 61 insertions(+), 12 deletions(-) diff --git a/src/cmdliner.ml b/src/cmdliner.ml index e7b02f4..0375dab 100644 --- a/src/cmdliner.ml +++ b/src/cmdliner.ml @@ -332,9 +332,19 @@ module Term = struct let sibling_terms = List.map snd choices in let ei = Cmdliner_info.eval ~env (Sub_command { term = main ; path ; main ; sibling_terms}) in - let _, _, ei = add_stdopts ei in - Cmdliner_msg.pp_err_usage err_ppf ei ~err_lines:false ~err; - `Error `Parse + let help, version, ei = add_stdopts ei in + let term_args = Cmdliner_info.(term_args @@ eval_term ei) in + let args = remove_exec argv in + begin match Cmdliner_cline.create ~peek_opts:true term_args args with + | Ok cl + | Error (_, cl) -> + begin match try_eval_stdopts ~catch:true ei cl help version with + | Some e -> do_result help_ppf err_ppf ei e + | None -> + Cmdliner_msg.pp_err_usage err_ppf ei ~err_lines:false ~err; + `Error `Parse + end + end | Error (`Invalid_command (maybe, path, choices, hints)) -> let err = Cmdliner_base.err_unknown ~kind:"command" maybe ~hints in let sibling_terms = List.map snd choices in diff --git a/src/cmdliner_docgen.ml b/src/cmdliner_docgen.ml index 88bebea..9010389 100644 --- a/src/cmdliner_docgen.ml +++ b/src/cmdliner_docgen.ml @@ -60,6 +60,7 @@ let term_info_subst ei = function let invocation ?(sep = ' ') ei = match Cmdliner_info.eval_kind ei with | `Simple | `Multiple_main -> term_name (Cmdliner_info.eval_main ei) +| `Multiple_group | `Multiple_sub -> let sep = String.make 1 sep in Cmdliner_info.eval_terms_rev ei @@ -83,6 +84,7 @@ let synopsis_pos_arg a = let synopsis ei = match Cmdliner_info.eval_kind ei with | `Multiple_main -> strf "$(b,%s) $(i,COMMAND) ..." @@ invocation ei +| `Multiple_group | `Simple | `Multiple_sub -> let rev_cli_order (a0, _) (a1, _) = Cmdliner_info.rev_arg_pos_cli_order a0 a1 @@ -99,6 +101,7 @@ let synopsis ei = match Cmdliner_info.eval_kind ei with let cmd_docs ei = match Cmdliner_info.eval_kind ei with | `Simple | `Multiple_sub -> [] +| `Multiple_group | `Multiple_main -> let add_cmd acc t = let cmd = strf "$(b,%s)" @@ term_name t in diff --git a/src/cmdliner_info.ml b/src/cmdliner_info.ml index 4a953ae..2b5a970 100644 --- a/src/cmdliner_info.ml +++ b/src/cmdliner_info.ml @@ -230,7 +230,12 @@ let eval_kind ei = (* subgroup *) if ei.choices = [] then `Simple else if (ei.term.term_info.term_name == ei.main.term_info.term_name) - then `Multiple_main else `Multiple_sub + then + match ei.path with + | [] -> assert false + | [_] -> `Multiple_main + | _ :: _ :: _ -> `Multiple_group + else `Multiple_sub let eval_terms_rev ei = ei.path diff --git a/src/cmdliner_info.mli b/src/cmdliner_info.mli index a469ff1..2a3d717 100644 --- a/src/cmdliner_info.mli +++ b/src/cmdliner_info.mli @@ -127,7 +127,7 @@ val eval_term : eval -> term val eval_main : eval -> term val eval_choices : eval -> term list val eval_env_var : eval -> string -> string option -val eval_kind : eval -> [> `Multiple_main | `Multiple_sub | `Simple ] +val eval_kind : eval -> [> `Multiple_main | `Multiple_group | `Multiple_sub | `Simple ] val eval_with_term : eval -> term -> eval val eval_has_choice : eval -> string -> bool val eval_terms_rev : eval -> term list diff --git a/src/cmdliner_msg.ml b/src/cmdliner_msg.ml index 2074686..98dbce8 100644 --- a/src/cmdliner_msg.ml +++ b/src/cmdliner_msg.ml @@ -79,6 +79,7 @@ let pp_version ppf ei = match Cmdliner_info.(term_version @@ eval_main ei) with let pp_try_help ppf ei = match Cmdliner_info.eval_kind ei with | `Simple | `Multiple_main -> pp ppf "@[<2>Try `%s --help' for more information.@]" (exec_name ei) +| `Multiple_group | `Multiple_sub -> let exec_cmd = Cmdliner_docgen.plain_invocation ei in let parent = diff --git a/test/chorus.ml b/test/chorus.ml index 5cf4c20..0e2cf2b 100644 --- a/test/chorus.ml +++ b/test/chorus.ml @@ -2,7 +2,7 @@ (* Implementation of the command *) -let chorus count msg = for i = 1 to count do print_endline msg done +let chorus count msg = for _ = 1 to count do print_endline msg done (* Command line interface *) diff --git a/test/groups.t b/test/groups.t index e53fb1d..a53cb33 100644 --- a/test/groups.t +++ b/test/groups.t @@ -3,8 +3,8 @@ $ ./groups.exe things groups things: is a command group and requires a command argument. - Usage: groups COMMAND ... - Try `groups things --help' for more information. + Usage: groups things [OPTION]... + Try `groups things --help' or `groups --help' for more information. [124] $ ./groups.exe things show foo @@ -28,9 +28,32 @@ $ ./groups.exe things --help + NAME + groups-things + + SYNOPSIS + groups things [OPTION]... + + COMMANDS + list + + show + + + OPTIONS + --help[=FMT] (default=auto) + Show this help in format FMT. The value FMT must be one of `auto', + `pager', `groff' or `plain'. With `auto', the format is `pager` or + `plain' whenever the TERM env var is `dumb' or undefined. + + --version + Show version information. + + + $ ./groups.exe things --invalid-arg groups things: is a command group and requires a command argument. - Usage: groups COMMAND ... - Try `groups things --help' for more information. + Usage: groups things [OPTION]... + Try `groups things --help' or `groups --help' for more information. [124] $ ./groups.exe --help @@ -66,8 +89,8 @@ $ ./groups.exe widgets baz groups widgets: unknown command `baz'. - Usage: groups COMMAND ... - Try `groups widgets --help' for more information. + Usage: groups widgets [OPTION]... + Try `groups widgets --help' or `groups --help' for more information. [124] Prefixes @@ -85,3 +108,10 @@ Default cmd $ ./groups.exe default cmd + +Version + + $ ./groups.exe things --version + %%VERSION%% + $ ./groups.exe things list --version + %%VERSION%% From 2a2d70edda2cec5fd5d9473ae9af47e76a90f5ca Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Wed, 3 Mar 2021 01:07:19 -0800 Subject: [PATCH 24/25] documentation testing Signed-off-by: Rudi Grinberg --- test/groups.ml | 16 ++++++++++++++-- test/groups.t | 14 +++++++++++--- 2 files changed, 25 insertions(+), 5 deletions(-) diff --git a/test/groups.ml b/test/groups.ml index fabe16e..74db6a9 100644 --- a/test/groups.ml +++ b/test/groups.ml @@ -19,7 +19,13 @@ let gen_group name = ; Term list, Term.info "list" ] in - (Term.Group.Group term), Term.info name + let man = + [ `S "DESCRIPTION" + ; `P (Printf.sprintf "description of %S" name) + ] + in + let doc = Printf.sprintf "doc for %S" name in + (Term.Group.Group term), Term.info ~doc ~man name let default_cmd = let term = @@ -29,7 +35,13 @@ let default_cmd = in Term.(ret (const run $ (const ()))) in - term, Term.info "groups" ~version:"%%VERSION%%" + let doc = "default term doc" in + let man = + [ `S "DESCRIPTION" + ; `P "description of default term" + ] + in + term, Term.info "groups" ~version:"%%VERSION%%" ~doc ~man let cmds : _ Term.Group.t list = let _term (t, info) = Term.Group.Term t, info in diff --git a/test/groups.t b/test/groups.t index a53cb33..e85efd6 100644 --- a/test/groups.t +++ b/test/groups.t @@ -29,11 +29,14 @@ $ ./groups.exe things --help NAME - groups-things + groups-things - default term doc SYNOPSIS groups things [OPTION]... + DESCRIPTION + description of default term + COMMANDS list @@ -58,18 +61,23 @@ $ ./groups.exe --help NAME - groups + groups - default term doc SYNOPSIS groups COMMAND ... + DESCRIPTION + description of default term + COMMANDS things + doc for "things" widg + doc for "widg" widgets - + doc for "widgets" OPTIONS --help[=FMT] (default=auto) From b4f565634f63a67387c941a311236b2ae6d1aef2 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Wed, 3 Mar 2021 12:17:17 -0800 Subject: [PATCH 25/25] fix manpage for sub terms Signed-off-by: Rudi Grinberg --- src/cmdliner.ml | 13 ++++++------- src/cmdliner_info.ml | 8 +++----- src/cmdliner_info.mli | 5 +---- test/groups.t | 10 ++-------- 4 files changed, 12 insertions(+), 24 deletions(-) diff --git a/src/cmdliner.ml b/src/cmdliner.ml index 0375dab..a5995bb 100644 --- a/src/cmdliner.ml +++ b/src/cmdliner.ml @@ -331,7 +331,7 @@ module Term = struct let err = Cmdliner_base.err_no_sub_command in let sibling_terms = List.map snd choices in let ei = Cmdliner_info.eval ~env - (Sub_command { term = main ; path ; main ; sibling_terms}) in + (Sub_command { path ; main ; sibling_terms}) in let help, version, ei = add_stdopts ei in let term_args = Cmdliner_info.(term_args @@ eval_term ei) in let args = remove_exec argv in @@ -348,23 +348,22 @@ module Term = struct | Error (`Invalid_command (maybe, path, choices, hints)) -> let err = Cmdliner_base.err_unknown ~kind:"command" maybe ~hints in let sibling_terms = List.map snd choices in - let ei = Cmdliner_info.eval ~env - (Sub_command { term = main ; path ; main ; sibling_terms}) + let ei = + Cmdliner_info.eval ~env (Sub_command { path ; main ; sibling_terms}) in Cmdliner_msg.pp_err_usage err_ppf ei ~err_lines:false ~err; `Error `Parse | Error (`Ambiguous (cmd, path, ambs)) -> let err = Cmdliner_base.err_ambiguous ~kind:"command" cmd ~ambs in let sibling_terms = List.map snd choices in - let ei = Cmdliner_info.eval ~env - (Sub_command { term = main ; path ; main ; sibling_terms}) - in + let ei = + Cmdliner_info.eval ~env (Sub_command { path ; main ; sibling_terms}) in Cmdliner_msg.pp_err_usage err_ppf ei ~err_lines:false ~err; `Error `Parse | Ok (((_, f), info), sibling_terms, path, args) -> let sibling_terms = List.map snd sibling_terms in let ei = Cmdliner_info.eval ~env - (Sub_command { main ; term = info ; path ; sibling_terms }) in + (Sub_command { main ; path ; sibling_terms }) in let ei, res = term_eval ~catch ei f args in do_result help_ppf err_ppf ei res end diff --git a/src/cmdliner_info.ml b/src/cmdliner_info.ml index 2b5a970..df141db 100644 --- a/src/cmdliner_info.ml +++ b/src/cmdliner_info.ml @@ -194,10 +194,7 @@ let term_add_args t args = type eval_kind = | Simple of term | Main of { term : term ; choices : term list } -| Sub_command of { term : term; - (** is [term] is from a group, [path] are the ancestors - direct with the direct parent *) - path : term list; +| Sub_command of { path : term list; main : term; sibling_terms : term list } @@ -215,7 +212,8 @@ let eval ~env kind = match kind with | Simple term -> (term, term, [term], []) | Main { term ; choices } -> (term, term, [term], choices) - | Sub_command { main ; term ; path ; sibling_terms } -> + | Sub_command { main ; path ; sibling_terms } -> + let term = List.hd path in (main, term, path, sibling_terms) in { term; main; choices; env; path } diff --git a/src/cmdliner_info.mli b/src/cmdliner_info.mli index 2a3d717..9d0474c 100644 --- a/src/cmdliner_info.mli +++ b/src/cmdliner_info.mli @@ -114,10 +114,7 @@ type eval type eval_kind = | Simple of term | Main of { term : term ; choices : term list } -| Sub_command of { term : term; - (** is [term] is from a group, [path] are the ancestors - direct with the direct parent *) - path : term list; +| Sub_command of { path : term list; main : term; sibling_terms : term list } diff --git a/test/groups.t b/test/groups.t index e85efd6..8f99846 100644 --- a/test/groups.t +++ b/test/groups.t @@ -29,19 +29,13 @@ $ ./groups.exe things --help NAME - groups-things - default term doc + groups-things - doc for "things" SYNOPSIS groups things [OPTION]... DESCRIPTION - description of default term - - COMMANDS - list - - show - + description of "things" OPTIONS --help[=FMT] (default=auto)