From c42d21191772dd8c92783ede94fb66b241da97a3 Mon Sep 17 00:00:00 2001
From: Jules Aguillon <jules@j3s.fr>
Date: Thu, 13 Apr 2023 11:45:22 +0200
Subject: [PATCH] Add --help=commands

This adds `--help=commands`, which prints the list of all the
sub-commands accepted by the executable.
This list can be used to quickly navigate between the different
manpages and can be parsed.

The output on test/darcs_ex is:

    darcs
    darcs initialize
    darcs record
    darcs help

Unlike other help formats, it outputs to stdout and use a strict format
that can be parsed: newline-separated list.

This is an argument to the `--help` option instead of a new option
because it can also be used by humans.
It is not exposed in the library.
---
 src/cmdliner_arg.ml  | 31 ++++++++++++++++++++-----------
 src/cmdliner_arg.mli |  4 +++-
 src/cmdliner_eval.ml |  9 ++++++---
 src/cmdliner_msg.ml  | 13 +++++++++++++
 src/cmdliner_msg.mli |  3 +++
 5 files changed, 45 insertions(+), 15 deletions(-)

diff --git a/src/cmdliner_arg.ml b/src/cmdliner_arg.ml
index 56d1fb6..612e8d9 100644
--- a/src/cmdliner_arg.ml
+++ b/src/cmdliner_arg.ml
@@ -317,26 +317,35 @@ let man_fmts =
   ["auto", `Auto; "pager", `Pager; "groff", `Groff; "plain", `Plain]
 
 let man_fmt_docv = "FMT"
-let man_fmts_enum = Cmdliner_base.enum man_fmts
-let man_fmts_alts = doc_alts_enum man_fmts
-let man_fmts_doc kind =
-  strf "Show %s in format $(docv). The value $(docv) must be %s. \
-        With $(b,auto), the format is $(b,pager) or $(b,plain) whenever \
-        the $(b,TERM) env var is $(b,dumb) or undefined."
-    kind man_fmts_alts
+
+let mk_man_format man_fmts doc_kind =
+  let man_fmts_enum = Cmdliner_base.enum man_fmts in
+  let man_fmts_alts = doc_alts_enum man_fmts in
+  let man_fmts_doc =
+    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. With $(b,commands), \
+       outputs the list of commands, separated by newlines."
+      doc_kind man_fmts_alts
+  in
+  (man_fmts_enum, man_fmts_doc)
 
 let man_format =
-  let doc = man_fmts_doc "output" in
+  let arg, doc = mk_man_format man_fmts "output" in
   let docv = man_fmt_docv in
-  value & opt man_fmts_enum `Pager & info ["man-format"] ~docv ~doc
+  value & opt arg `Pager & info ["man-format"] ~docv ~doc
 
 let stdopt_version ~docs =
   value & flag & info ["version"] ~docs ~doc:"Show version information."
 
+type help_format = [ `Commands | Cmdliner_manpage.format ]
+
 let stdopt_help ~docs =
-  let doc = man_fmts_doc "this help" in
+  let help_fmts = man_fmts @ [ "commands", `Commands ] in
+  let arg, doc = mk_man_format help_fmts "this help" in
   let docv = man_fmt_docv in
-  value & opt ~vopt:(Some `Auto) (some man_fmts_enum) None &
+  value & opt ~vopt:(Some `Auto) (some arg) None &
   info ["help"] ~docv ~docs ~doc
 
 (* Predefined converters. *)
diff --git a/src/cmdliner_arg.mli b/src/cmdliner_arg.mli
index e3faa2f..dabdef1 100644
--- a/src/cmdliner_arg.mli
+++ b/src/cmdliner_arg.mli
@@ -62,9 +62,11 @@ val last : 'a list t -> 'a Cmdliner_term.t
 
 (** {1 Predefined arguments} *)
 
+type help_format = [ `Commands | Cmdliner_manpage.format ]
+
 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
+val stdopt_help : docs:string -> help_format option Cmdliner_term.t
 
 (** {1 Converters} *)
 
diff --git a/src/cmdliner_eval.ml b/src/cmdliner_eval.ml
index c3747bf..061509d 100644
--- a/src/cmdliner_eval.ml
+++ b/src/cmdliner_eval.ml
@@ -29,7 +29,7 @@ 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
+       | `Std_help of Cmdliner_arg.help_format | `Std_version ]) result
 
 let run_parser ~catch ei cl f = try (f ei cl :> 'a eval_result) with
 | exn when catch ->
@@ -73,12 +73,15 @@ let do_help help_ppf err_ppf ei fmt cmd =
   in
   Cmdliner_docgen.pp_man ~errs:err_ppf fmt help_ppf ei
 
-let do_result help_ppf err_ppf ei = function
+(** [std_ppf] is used for machine output. *)
+let do_result help_ppf ?(std_ppf = Format.std_formatter) err_ppf ei = function
 | Ok v -> Ok (`Ok v)
 | Error res ->
     match res with
-    | `Std_help fmt ->
+    | `Std_help (#Cmdliner_manpage.format as fmt) ->
         Cmdliner_docgen.pp_man ~errs:err_ppf fmt help_ppf ei; Ok `Help
+    | `Std_help `Commands ->
+        Cmdliner_msg.pp_commands std_ppf ei; Ok `Help
     | `Std_version ->
         Cmdliner_msg.pp_version help_ppf ei; Ok `Version
     | `Parse err ->
diff --git a/src/cmdliner_msg.ml b/src/cmdliner_msg.ml
index a61c815..602e76d 100644
--- a/src/cmdliner_msg.ml
+++ b/src/cmdliner_msg.ml
@@ -96,6 +96,19 @@ let pp_err_usage ppf ei ~err_lines ~err =
     (exec_name ei) pp_err err (Cmdliner_docgen.pp_plain_synopsis ~errs:ppf) ei
     pp_try_help ei
 
+let pp_commands ppf ei =
+  let open Cmdliner_info in
+  let rec find_sub_commands path cmd =
+    let path = Cmd.name cmd :: path in
+    List.rev path :: List.concat_map (find_sub_commands path) (Cmd.children cmd)
+  in
+  let pp_segs =
+    let pp_sep ppf () = pp ppf " " in
+    Format.(pp_print_list ~pp_sep pp_print_string)
+  in
+  find_sub_commands [] (Eval.main ei)
+  |> List.iter (pp ppf "%a@." pp_segs)
+
 let pp_backtrace ppf ei e bt =
   let bt = Printexc.raw_backtrace_to_string bt in
   let bt =
diff --git a/src/cmdliner_msg.mli b/src/cmdliner_msg.mli
index 125e175..893719b 100644
--- a/src/cmdliner_msg.mli
+++ b/src/cmdliner_msg.mli
@@ -35,6 +35,9 @@ 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
 
+(** The output of [--help=commands]. *)
+val pp_commands : Format.formatter -> Cmdliner_info.Eval.t -> unit
+
 val pp_backtrace :
   Format.formatter ->
   Cmdliner_info.Eval.t -> exn -> Printexc.raw_backtrace -> unit