path: root/src/cmdliner_docgen.ml

(*---------------------------------------------------------------------------
   Copyright (c) 2011 The cmdliner programmers. All rights reserved.
   Distributed under the ISC license, see terms at the end of the file.
  ---------------------------------------------------------------------------*)

let rev_compare n0 n1 = compare n1 n0
let strf = Printf.sprintf

let order_args a0 a1 =
  match Cmdliner_info.Arg.is_opt a0, Cmdliner_info.Arg.is_opt a1 with
  | true, true -> (* optional by name *)
      let key names =
        let k = List.hd (List.sort rev_compare names) in
        let k = String.lowercase_ascii k in
        if k.[1] = '-' then String.sub k 1 (String.length k - 1) else k
      in
      compare
        (key @@ Cmdliner_info.Arg.opt_names a0)
        (key @@ Cmdliner_info.Arg.opt_names a1)
  | false, false -> (* positional by variable *)
      compare
        (String.lowercase_ascii @@ Cmdliner_info.Arg.docv a0)
        (String.lowercase_ascii @@ Cmdliner_info.Arg.docv a1)
  | true, false -> -1 (* positional first *)
  | false, true -> 1  (* optional after *)

let esc = Cmdliner_manpage.escape
let cmd_name t = esc @@ Cmdliner_info.Cmd.name t

let sorted_items_to_blocks ~boilerplate:b items =
  (* Items are sorted by section and then rev. sorted by appearance.
     We gather them by section in correct order in a `Block and prefix
     them with optional boilerplate *)
  let boilerplate = match b with None -> (fun _ -> None) | Some b -> b in
  let mk_block sec acc = match boilerplate sec with
  | None -> (sec, `Blocks acc)
  | Some b -> (sec, `Blocks (b :: acc))
  in
  let rec loop secs sec acc = function
  | (sec', it) :: its when sec' = sec -> loop secs sec (it :: acc) its
  | (sec', it) :: its -> loop (mk_block sec acc :: secs) sec' [it] its
  | [] -> (mk_block sec acc) :: secs
  in
  match items with
  | [] -> []
  | (sec, it) :: its -> loop [] sec [it] its

(* Doc string variables substitutions. *)

let env_info_subst ~subst e = function
| "env" -> Some (strf "$(b,%s)" @@ esc (Cmdliner_info.Env.info_var e))
| id -> subst id

let exit_info_subst ~subst e = function
| "status" -> Some (strf "%d" (fst @@ Cmdliner_info.Exit.info_codes e))
| "status_max" -> Some (strf "%d" (snd @@ Cmdliner_info.Exit.info_codes e))
| id -> subst id

let arg_info_subst ~subst a = function
| "docv" ->
    Some (strf "$(i,%s)" @@ esc (Cmdliner_info.Arg.docv a))
| "opt" when Cmdliner_info.Arg.is_opt a ->
    Some (strf "$(b,%s)" @@ esc (Cmdliner_info.Arg.opt_name_sample a))
| "env" as id ->
    begin match Cmdliner_info.Arg.env a with
    | Some e -> env_info_subst ~subst e id
    | None -> subst id
    end
| id -> subst id

let cmd_info_subst ei = function
| "tname" -> Some (strf "$(b,%s)" @@ cmd_name (Cmdliner_info.Eval.cmd ei))
| "mname" -> Some (strf "$(b,%s)" @@ cmd_name (Cmdliner_info.Eval.main ei))
| _ -> None

(* Command docs *)

let invocation ?(sep = " ") ?(parents = []) cmd =
  let names = List.rev_map Cmdliner_info.Cmd.name (cmd :: parents) in
  esc @@ String.concat sep names

let synopsis_pos_arg a =
  let v = match Cmdliner_info.Arg.docv a with "" -> "ARG" | v -> v in
  let v = strf "$(i,%s)" (esc v) in
  let v = (if Cmdliner_info.Arg.is_req a then strf "%s" else strf "[%s]") v in
  match Cmdliner_info.Arg.(pos_len @@ pos_kind a) with
  | None -> v ^ "…"
  | Some 1 -> v
  | Some n ->
      let rec loop n acc = if n <= 0 then acc else loop (n - 1) (v :: acc) in
      String.concat " " (loop n [])

let synopsis_opt_arg a n =
  let var = match Cmdliner_info.Arg.docv a with "" -> "VAL" | v -> v in
  match Cmdliner_info.Arg.opt_kind a with
  | Cmdliner_info.Arg.Flag -> strf "$(b,%s)" (esc n)
  | Cmdliner_info.Arg.Opt ->
        if String.length n > 2
        then strf "$(b,%s)=$(i,%s)" (esc n) (esc var)
        else strf "$(b,%s) $(i,%s)" (esc n) (esc var)
  | Cmdliner_info.Arg.Opt_vopt _ ->
      if String.length n > 2
      then strf "$(b,%s)[=$(i,%s)]" (esc n) (esc var)
      else strf "$(b,%s) [$(i,%s)]" (esc n) (esc var)

let deprecated cmd = match Cmdliner_info.Cmd.deprecated cmd with
| None -> "" | Some _ -> "(Deprecated) "

let synopsis ?parents cmd = match Cmdliner_info.Cmd.children cmd with
| [] ->
    let rev_cli_order (a0, _) (a1, _) =
      Cmdliner_info.Arg.rev_pos_cli_order a0 a1
    in
    let args = Cmdliner_info.Cmd.args cmd in
    let oargs, pargs = Cmdliner_info.Arg.(Set.partition is_opt args) in
    let oargs =
      (* Keep only those that are listed in the s_options section and
         that are not [--version] or [--help]. * *)
      let keep a =
          let drop_names n = n = "--help" || n = "--version" in
          Cmdliner_info.Arg.docs a = Cmdliner_manpage.s_options &&
          not (List.exists drop_names (Cmdliner_info.Arg.opt_names a))
      in
      let oargs = Cmdliner_info.Arg.Set.(elements (filter keep oargs)) in
      let count = List.length oargs in
      let any_option = "[$(i,OPTION)]…" in
      if count = 0 || count > 3 then any_option else
      let syn a =
        strf "[%s]" (synopsis_opt_arg a (Cmdliner_info.Arg.opt_name_sample a))
      in
      let oargs = List.sort order_args oargs in
      let oargs = String.concat " " (List.map syn oargs) in
      String.concat " " [oargs; any_option]
    in
    let pargs =
      let pargs = Cmdliner_info.Arg.Set.elements pargs in
      if pargs = [] then "" else
      let pargs = List.map (fun a -> a, synopsis_pos_arg a) pargs in
      let pargs = List.sort rev_cli_order pargs in
      String.concat " " ("" (* add a space *) :: List.rev_map snd pargs)
    in
    strf "%s$(b,%s) %s%s"
      (deprecated cmd) (invocation ?parents cmd) oargs pargs
| _cmds ->
    let subcmd = match Cmdliner_info.Cmd.has_args cmd with
    | false -> "$(i,COMMAND)" | true -> "[$(i,COMMAND)]"
    in
    strf "%s$(b,%s) %s …" (deprecated cmd) (invocation ?parents cmd) subcmd

let cmd_docs ei = match Cmdliner_info.(Cmd.children (Eval.cmd ei)) with
| [] -> []
| cmds ->
    let add_cmd acc cmd =
      let syn = synopsis cmd in
      (Cmdliner_info.Cmd.docs cmd, `I (syn, Cmdliner_info.Cmd.doc cmd)) :: acc
    in
    let by_sec_by_rev_name (s0, `I (c0, _)) (s1, `I (c1, _)) =
      let c = compare s0 s1 in
      if c <> 0 then c else compare c1 c0 (* N.B. reverse *)
    in
    let cmds = List.fold_left add_cmd [] cmds in
    let cmds = List.sort by_sec_by_rev_name cmds in
    let cmds = (cmds :> (string * Cmdliner_manpage.block) list) in
    sorted_items_to_blocks ~boilerplate:None cmds

(* Argument docs *)

let arg_man_item_label a =
  let s = match Cmdliner_info.Arg.is_pos a with
  | true -> strf "$(i,%s)" (esc @@ Cmdliner_info.Arg.docv a)
  | false ->
      let names = List.sort compare (Cmdliner_info.Arg.opt_names a) in
      String.concat ", " (List.rev_map (synopsis_opt_arg a) names)
  in
  match Cmdliner_info.Arg.deprecated a with
  | None -> s | Some _ -> "(Deprecated) " ^ s

let arg_to_man_item ~errs ~subst ~buf a =
  let subst = arg_info_subst ~subst a in
  let or_env ~value a = match Cmdliner_info.Arg.env a with
  | None -> ""
  | Some e ->
      let value = if value then " or" else "absent " in
      strf "%s $(b,%s) env" value (esc @@ Cmdliner_info.Env.info_var e)
  in
  let absent = match Cmdliner_info.Arg.absent a with
  | Cmdliner_info.Arg.Err -> "required"
  | Cmdliner_info.Arg.Doc "" -> strf "%s" (or_env ~value:false a)
  | Cmdliner_info.Arg.Doc s ->
      let s = Cmdliner_manpage.subst_vars ~errs ~subst buf s in
      strf "absent=%s%s" s (or_env ~value:true a)
  | Cmdliner_info.Arg.Val v ->
      match Lazy.force v with
      | "" -> strf "%s" (or_env ~value:false a)
      | v -> strf "absent=$(b,%s)%s" (esc v) (or_env ~value:true a)
  in
  let optvopt = match Cmdliner_info.Arg.opt_kind a with
  | Cmdliner_info.Arg.Opt_vopt v -> strf "default=$(b,%s)" (esc v)
  | _ -> ""
  in
  let argvdoc = match optvopt, absent with
  | "", "" -> ""
  | s, "" | "", s -> strf " (%s)" s
  | s, s' -> strf " (%s) (%s)" s s'
  in
  let doc = Cmdliner_info.Arg.doc a in
  let doc = Cmdliner_manpage.subst_vars ~errs ~subst buf doc in
  (Cmdliner_info.Arg.docs a, `I (arg_man_item_label a ^ argvdoc, doc))

let arg_docs ~errs ~subst ~buf ei =
  let by_sec_by_arg a0 a1 =
    let c = compare (Cmdliner_info.Arg.docs a0) (Cmdliner_info.Arg.docs a1) in
    if c <> 0 then c else
    let c =
      match Cmdliner_info.Arg.deprecated a0, Cmdliner_info.Arg.deprecated a1
      with
      | None, None | Some _, Some _ -> 0
      | None, Some _ -> -1 | Some _, None -> 1
    in
    if c <> 0 then c else order_args a0 a1
  in
  let keep_arg a acc =
    if not Cmdliner_info.Arg.(is_pos a && (docv a = "" || doc a = ""))
    then (a :: acc) else acc
  in
  let args = Cmdliner_info.Cmd.args @@ Cmdliner_info.Eval.cmd ei in
  let args = Cmdliner_info.Arg.Set.fold keep_arg args [] in
  let args = List.sort by_sec_by_arg args in
  let args = List.rev_map (arg_to_man_item ~errs ~subst ~buf) args in
  sorted_items_to_blocks ~boilerplate:None args

(* Exit statuses doc *)

let exit_boilerplate sec = match sec = Cmdliner_manpage.s_exit_status with
| false -> None
| true -> Some (Cmdliner_manpage.s_exit_status_intro)

let exit_docs ~errs ~subst ~buf ~has_sexit ei =
  let by_sec (s0, _) (s1, _) = compare s0 s1 in
  let add_exit_item acc e =
    let subst = exit_info_subst ~subst e in
    let min, max = Cmdliner_info.Exit.info_codes e in
    let doc = Cmdliner_info.Exit.info_doc e in
    let label = if min = max then strf "%d" min else strf "%d-%d" min max in
    let item = `I (label, Cmdliner_manpage.subst_vars ~errs ~subst buf doc) in
    (Cmdliner_info.Exit.info_docs e, item) :: acc
  in
  let exits = Cmdliner_info.Cmd.exits @@ Cmdliner_info.Eval.cmd ei in
  let exits = List.sort Cmdliner_info.Exit.info_order exits in
  let exits = List.fold_left add_exit_item [] exits in
  let exits = List.stable_sort by_sec (* sort by section *) exits in
  let boilerplate = if has_sexit then None else Some exit_boilerplate in
  sorted_items_to_blocks ~boilerplate exits

(* Environment doc *)

let env_boilerplate sec = match sec = Cmdliner_manpage.s_environment with
| false -> None
| true -> Some (Cmdliner_manpage.s_environment_intro)

let env_docs ~errs ~subst ~buf ~has_senv ei =
  let add_env_item ~subst (seen, envs as acc) e =
    if Cmdliner_info.Env.Set.mem e seen then acc else
    let seen = Cmdliner_info.Env.Set.add e seen in
    let var = strf "$(b,%s)" @@ esc (Cmdliner_info.Env.info_var e) in
    let var = match Cmdliner_info.Env.info_deprecated e with
    | None -> var | Some _ -> "(Deprecated) " ^ var in
    let doc = Cmdliner_info.Env.info_doc e in
    let doc = Cmdliner_manpage.subst_vars ~errs ~subst buf doc in
    let envs = (Cmdliner_info.Env.info_docs e, `I (var, doc)) :: envs in
    seen, envs
  in
  let add_arg_env a acc = match Cmdliner_info.Arg.env a with
  | None -> acc
  | Some e -> add_env_item ~subst:(arg_info_subst ~subst a) acc e
  in
  let add_env acc e = add_env_item ~subst:(env_info_subst ~subst e) acc e in
  let by_sec_by_rev_name (s0, `I (v0, _)) (s1, `I (v1, _)) =
    let c = compare s0 s1 in
    if c <> 0 then c else compare v1 v0 (* N.B. reverse *)
  in
  (* Arg envs before term envs is important here: if the same is mentioned
     both in an arg and in a term the substs of the arg are allowed. *)
  let args = Cmdliner_info.Cmd.args @@ Cmdliner_info.Eval.cmd ei in
  let tenvs = Cmdliner_info.Cmd.envs @@ Cmdliner_info.Eval.cmd ei in
  let init = Cmdliner_info.Env.Set.empty, [] in
  let acc = Cmdliner_info.Arg.Set.fold add_arg_env args init in
  let _, envs = List.fold_left add_env acc tenvs in
  let envs = List.sort by_sec_by_rev_name envs in
  let envs = (envs :> (string * Cmdliner_manpage.block) list) in
  let boilerplate = if has_senv then None else Some env_boilerplate in
  sorted_items_to_blocks ~boilerplate envs

(* xref doc *)

let xref_docs ~errs ei =
  let main = Cmdliner_info.Eval.main ei in
  let to_xref = function
  | `Main -> Cmdliner_info.Cmd.name main, 1
  | `Tool tool -> tool, 1
  | `Page (name, sec) -> name, sec
  | `Cmd c ->
      (* N.B. we are handling only the first subcommand level here *)
      let cmds = Cmdliner_info.Cmd.children main in
      let mname = Cmdliner_info.Cmd.name main in
      let is_cmd cmd = Cmdliner_info.Cmd.name cmd = c in
      if List.exists is_cmd cmds then strf "%s-%s" mname c, 1 else
      (Format.fprintf errs "xref %s: no such command name@." c; "doc-err", 0)
  in
  let xref_str (name, sec) = strf "%s(%d)" (esc name) sec in
  let xrefs = Cmdliner_info.Cmd.man_xrefs @@ Cmdliner_info.Eval.cmd ei in
  let xrefs = match main == Cmdliner_info.Eval.cmd ei with
  | true -> List.filter (fun x -> x <> `Main) xrefs  (* filter out default *)
  | false -> xrefs
  in
  let xrefs = List.fold_left (fun acc x -> to_xref x :: acc) [] xrefs in
  let xrefs = List.(rev_map xref_str (sort rev_compare xrefs)) in
  if xrefs = [] then [] else
  [Cmdliner_manpage.s_see_also, `P (String.concat ", " xrefs)]

(* Man page construction *)

let ensure_s_name ei sm =
  if Cmdliner_manpage.(smap_has_section sm ~sec:s_name) then sm else
  let cmd = Cmdliner_info.Eval.cmd ei in
  let parents = Cmdliner_info.Eval.parents ei in
  let tname = (deprecated cmd) ^ invocation ~sep:"-" ~parents cmd in
  let tdoc = Cmdliner_info.Cmd.doc cmd in
  let tagline = if tdoc = "" then "" else strf " - %s" tdoc in
  let tagline = `P (strf "%s%s" tname tagline) in
  Cmdliner_manpage.(smap_append_block sm ~sec:s_name tagline)

let ensure_s_synopsis ei sm =
  if Cmdliner_manpage.(smap_has_section sm ~sec:s_synopsis) then sm else
  let cmd = Cmdliner_info.Eval.cmd ei in
  let parents = Cmdliner_info.Eval.parents ei in
  let synopsis = `P (synopsis ~parents cmd) in
  Cmdliner_manpage.(smap_append_block sm ~sec:s_synopsis synopsis)

let insert_cmd_man_docs ~errs ei sm =
  let buf = Buffer.create 200 in
  let subst = cmd_info_subst ei in
  let ins sm (sec, b) = Cmdliner_manpage.smap_append_block sm ~sec b in
  let has_senv = Cmdliner_manpage.(smap_has_section sm ~sec:s_environment) in
  let has_sexit = Cmdliner_manpage.(smap_has_section sm ~sec:s_exit_status) in
  let sm = List.fold_left ins sm (cmd_docs ei) in
  let sm = List.fold_left ins sm (arg_docs ~errs ~subst ~buf ei) in
  let sm = List.fold_left ins sm (exit_docs ~errs ~subst ~buf ~has_sexit ei)in
  let sm = List.fold_left ins sm (env_docs ~errs ~subst ~buf ~has_senv ei) in
  let sm = List.fold_left ins sm (xref_docs ~errs ei) in
  sm

let text ~errs ei =
  let man = Cmdliner_info.Cmd.man @@ Cmdliner_info.Eval.cmd ei in
  let sm = Cmdliner_manpage.smap_of_blocks man in
  let sm = ensure_s_name ei sm in
  let sm = ensure_s_synopsis ei sm in
  let sm = insert_cmd_man_docs ei ~errs sm in
  Cmdliner_manpage.smap_to_blocks sm

let title ei =
  let main = Cmdliner_info.Eval.main ei in
  let exec = String.capitalize_ascii (Cmdliner_info.Cmd.name main) in
  let cmd = Cmdliner_info.Eval.cmd ei in
  let parents = Cmdliner_info.Eval.parents ei in
  let name = String.uppercase_ascii (invocation ~sep:"-" ~parents cmd) in
  let center_header = esc @@ strf "%s Manual" exec in
  let left_footer =
    let version = match Cmdliner_info.Cmd.version main with
    | None -> "" | Some v -> " " ^ v
    in
    esc @@ strf "%s%s" exec version
  in
  name, 1, "", left_footer, center_header

let man ~errs ei = title ei, text ~errs ei

let pp_man ~errs fmt ppf ei =
  Cmdliner_manpage.print
    ~errs ~subst:(cmd_info_subst ei) fmt ppf (man ~errs ei)

(* Plain synopsis for usage *)

let pp_plain_synopsis ~errs ppf ei =
  let buf = Buffer.create 100 in
  let subst = cmd_info_subst ei in
  let cmd = Cmdliner_info.Eval.cmd ei in
  let parents = Cmdliner_info.Eval.parents ei in
  let synopsis = synopsis ~parents cmd in
  let syn = Cmdliner_manpage.doc_to_plain ~errs ~subst buf synopsis in
  Format.fprintf ppf "@[%s@]" syn

(*---------------------------------------------------------------------------
   Copyright (c) 2011 The cmdliner programmers

   Permission to use, copy, modify, and/or distribute this software for any
   purpose with or without fee is hereby granted, provided that the above
   copyright notice and this permission notice appear in all copies.

   THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
   WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
   MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
   ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
   WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
   ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
   OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  ---------------------------------------------------------------------------*)