parallel flattened queue for recursive --help resolution

Replace recursive depth-first help_resolve with BFS queue + fork-based
parallelism (up to num_cores workers). Workers marshal results back via
pipes; discovered subcommands are enqueued for the next wave.

Also fix usage positional extraction to match "USAGE" without colon
(Go/Cobra style), and skip empty-result check to consider positionals.
This commit is contained in:
atagen 2026-03-22 23:06:02 +11:00
parent 3cc278b144
commit d0cc80109e
2 changed files with 102 additions and 38 deletions

View file

@ -230,32 +230,93 @@ let cmd_manpage_dir dir =
) command_sections
let help_resolve ?(timeout=10_000) cmd rest name =
let resolve_one go rest name depth =
let text = match run_cmd (cmd :: rest @ ["--help"]) timeout with
| Some _ as r -> r
| None -> run_cmd (cmd :: rest @ ["-h"]) timeout in
match text with
| None -> None
| Some text ->
(match parse_help text with
| Error _ -> None
| Ok r when r.entries = [] && r.subcommands = [] -> None
| Ok r when depth >= 5 -> Some (generate_extern name r)
| Ok r ->
let main = generate_extern name { r with subcommands = [] } in
let subs = List.map (fun (sc : subcommand) ->
let sub_name = name ^ " " ^ sc.name in
match go (rest @ [sc.name]) sub_name (depth + 1) with
| Some s -> "\n" ^ s
| None ->
Printf.sprintf "\nexport extern \"%s\" [ # %s\n]\n"
(escape_nu sub_name) (escape_nu sc.desc)
) r.subcommands in
Some (String.concat "" (main :: subs)))
in
let fix = ref (fun _ _ _ -> None) in
fix := (fun rest name depth -> resolve_one !fix rest name depth);
!fix rest name 0
let max_jobs = num_cores () in
let queue = Queue.create () in
Queue.push (rest, name, 0, "") queue;
let results = ref [] in
(* pending: (pid, rd, rest, name, depth, desc) *)
let pending = ref [] in
let collect rd p_rest p_name p_depth p_desc =
let ic = Unix.in_channel_of_descr rd in
let[@warning "-8"] result : (string * (string * string) list) option =
try Marshal.from_channel ic with _ -> None in
close_in ic;
match result with
| None ->
if p_desc <> "" then
results := Printf.sprintf "export extern \"%s\" [ # %s\n]\n"
(escape_nu p_name) (escape_nu p_desc) :: !results
| Some (code, subs) ->
results := code :: !results;
if p_depth < 5 then
List.iter (fun (sc_name, sc_desc) ->
Queue.push
(p_rest @ [sc_name], p_name ^ " " ^ sc_name,
p_depth + 1, sc_desc) queue
) subs in
let reap () =
pending := List.filter (fun (pid, rd, p_rest, p_name, p_depth, p_desc) ->
match Unix.waitpid [Unix.WNOHANG] pid with
| (0, _) -> true
| _ -> collect rd p_rest p_name p_depth p_desc; false
| exception Unix.Unix_error (Unix.ECHILD, _, _) ->
collect rd p_rest p_name p_depth p_desc; false
) !pending in
let wait_slot () =
while List.length !pending >= max_jobs do
reap ();
if List.length !pending >= max_jobs then
(try ignore (Unix.wait ()) with Unix.Unix_error _ -> ());
reap ()
done in
while not (Queue.is_empty queue) || !pending <> [] do
while not (Queue.is_empty queue) do
let (q_rest, q_name, q_depth, q_desc) = Queue.pop queue in
wait_slot ();
let (rd, wr) = Unix.pipe () in
let pid = Unix.fork () in
if pid = 0 then begin
Unix.close rd;
List.iter (fun (_, prd, _, _, _, _) ->
try Unix.close prd with _ -> ()) !pending;
let result =
let text = match run_cmd (cmd :: q_rest @ ["--help"]) timeout with
| Some _ as r -> r
| None -> run_cmd (cmd :: q_rest @ ["-h"]) timeout in
match text with
| None -> None
| Some text ->
(match parse_help text with
| Error _ -> None
| Ok r when r.entries = [] && r.subcommands = [] && r.positionals = [] -> None
| Ok r ->
let at_limit = q_depth >= 5 in
let code = generate_extern q_name
(if at_limit then r else { r with subcommands = [] }) in
let subs = if at_limit then []
else List.map (fun (sc : subcommand) -> (sc.name, sc.desc))
r.subcommands in
Some (code, subs)) in
let oc = Unix.out_channel_of_descr wr in
Marshal.to_channel oc (result : (string * (string * string) list) option) [];
close_out oc;
exit 0
end else begin
Unix.close wr;
pending := (pid, rd, q_rest, q_name, q_depth, q_desc) :: !pending
end
done;
if !pending <> [] then begin
reap ();
if !pending <> [] && Queue.is_empty queue then begin
(try ignore (Unix.wait ()) with Unix.Unix_error _ -> ());
reap ()
end
end
done;
match !results with
| [] -> None
| rs -> Some (String.concat "\n" (List.rev rs))
let cmd_help args =
let iterative, cmd_args = match args with

View file

@ -415,18 +415,21 @@ let extract_usage_positionals text =
else
let t = String.trim lines_arr.(i) in
let tlen = String.length t in
if tlen >= 6 then
let prefix = String.lowercase_ascii (String.sub t 0 6) in
if prefix = "usage:" then begin
let after = String.sub t 6 (tlen - 6) |> String.trim in
if String.length after > 0 then Some after
else if i + 1 < len then
(* Clap style: USAGE:\n cmd [OPTIONS] PATTERN *)
let next = String.trim lines_arr.(i + 1) in
if String.length next > 0 then Some next else None
else None
end else go (i + 1)
else go (i + 1)
let lc = String.lowercase_ascii t in
if tlen >= 6 && String.sub lc 0 6 = "usage:" then begin
let after = String.sub t 6 (tlen - 6) |> String.trim in
if String.length after > 0 then Some after
else if i + 1 < len then
(* Clap style: USAGE:\n cmd [OPTIONS] PATTERN *)
let next = String.trim lines_arr.(i + 1) in
if String.length next > 0 then Some next else None
else None
end else if lc = "usage" then begin
if i + 1 < len then
let next = String.trim lines_arr.(i + 1) in
if String.length next > 0 then Some next else None
else None
end else go (i + 1)
in
go 0
in