Note:

You are viewing a development version of the library. Goto the latest version.

let pp_print_help ~ctxt hext hsty fmt () =

  (* Print with a precise length *)
  let pp_print_justified sz fmt str =
    let ns =
      String.make sz ' '
    in
      String.blit str 0 ns 0 (String.length str);
      pp_print_string fmt ns
  in

  (* Print definition for the output style *)
  let pp_print_output_def sz fmt (term, def) =
    pp_print_string fmt "  ";
    pp_print_justified sz fmt term;
    pp_print_string fmt "  ";
    pp_open_box fmt 0;
    pp_print_string_spaced fmt def;
    pp_close_box fmt ();
    pp_print_newline fmt ()
  in

  let pp_print_specs spec_help fmt specs =

    let help_specs =
      List.rev_append
        (List.rev_map
           (fun (cli, t, hlp) ->
              let arg, hlp =
                match OASISString.nsplit hlp ' ' with
                  | hd :: tl ->
                      hd, (String.concat " " tl)
                  | [] ->
                      """"
              in
              let arg =
                match t with
                  | Arg.Symbol (lst, _) ->
                      "{"^(String.concat "|" lst)^"}"
                  | _ ->
                      arg
              in
              let term =
                if arg <> "" then
                  cli^" "^arg
                else
                  cli
              in
                term, hlp)
           specs)
        (if spec_help then
           ["-help|--help", s_ "Display this list of options"]
         else
           [])
    in

    let sz =
      List.fold_left
        (fun acc (s, _) -> max (String.length s) acc)
        0
        help_specs
    in

    let pp_print_spec fmt (term, hlp) =
      match hsty with
        | Markdown ->
            pp_print_def fmt
              ("`"^term^"`")
              [pp_print_string_spaced, hlp]
        | Output ->
            pp_print_output_def
              sz fmt (term, hlp)
    in

      pp_print_list pp_print_spec "" fmt help_specs;
      if hsty = Output then
        pp_print_newline fmt ()
  in

  let pp_print_scmds fmt () =
    let scmds =
      List.rev_map
        (fun scmd -> scmd.scmd_name, `Builtin scmd)
        (CLISubCommand.list_builtin ~deprecated:false ())
    in
    let plugin_scmds =
      if not ctxt.OASISContext.ignore_plugins then
        List.rev_map
          (fun plugin -> plugin.PluginLoader.name, `Plugin plugin)
          (CLISubCommand.list_plugin ~deprecated:false ())
      else
        []
    in
    let all_scmds =
      List.sort
        (fun (nm1, _) (nm2, _) -> String.compare nm1 nm2)
        (List.rev_append scmds plugin_scmds)
    in
    let sz =
      (* Compute max size of the name. *)
      List.fold_left
        (fun sz (nm, c) ->
           max sz (String.length nm))
        0 all_scmds
    in
    let plugin_synopsis plg =
      match plg.PluginLoader.synopsis with
        | Some e -> e
        | None -> "No synopsis"
    in
    let plugin_markdown_data plg =
      let lst =
        match plg.PluginLoader.version with
          | Some v -> ["Version: "^v]
          | None -> []
      in
        (plugin_synopsis plg) ::
        ("Findlib: "^plg.PluginLoader.findlib_name) ::
        lst
    in
    let plugin_output_data plg =
      let findlib_name = plg.PluginLoader.findlib_name in
      let synopsis = plugin_synopsis plg in
      match plg.PluginLoader.version with
        | Some ver_str ->
            Printf.sprintf "%s (%s v%s)" synopsis findlib_name ver_str
        | None ->
            Printf.sprintf "%s (%s)" synopsis findlib_name
    in
      pp_print_para fmt (s_ "Available subcommands:");
      List.iter
        (fun (name, e) ->
           match hsty, e with
             | Markdown`Builtin scmd  ->
                 pp_print_def fmt ("`"^name^"`")
                   [pp_print_string_spaced, scmd.scmd_synopsis]
             | Markdown`Plugin plg ->
                 pp_print_def fmt ("`"^name^"`")
                   (List.map
                      (fun s -> pp_print_string_spaced, s)
                      (plugin_markdown_data plg))
             | Output`Builtin scmd ->
                 pp_print_output_def
                   sz fmt (name, scmd.scmd_synopsis)
             | Output`Plugin plg ->
                 pp_print_output_def
                   sz fmt
                   (name, plugin_output_data plg))
        all_scmds;
      if hsty = Output then
        pp_print_newline fmt ()
  in

  let pp_print_scmd fmt ~global_options ?origin scmd =
    let (scmd_specs, _), _  = scmd.scmd_run () in
    if not scmd.scmd_deprecated then
      pp_print_title fmt 2
        (Printf.sprintf (f_ "Subcommand %s") scmd.scmd_name)
    else
      pp_print_title fmt 2
        (Printf.sprintf (f_ "Subcommand %s (deprecated)") scmd.scmd_name);

    begin
      match origin with
        | Some (`Plugin plg) ->
            fprintf fmt
              "@[<v>__Version__: %s<br/>@,__Findlib__: %s<br/>@]"
              (match plg.PluginLoader.version with
                 | Some ver_str -> ver_str
                 | None -> "undefined")
              plg.PluginLoader.findlib_name;
        | Some `Builtin | None ->
            ()
    end;

    pp_print_string fmt scmd.scmd_help;
    pp_print_endblock
      ~check_last_char:scmd.scmd_help
      fmt ();

    fprintf fmt
      (f_ "Usage: oasis [global-options*] %s %s")
      scmd.scmd_name (s_ scmd.scmd_usage);
    pp_print_endblock fmt ();

    if global_options then
      begin
        pp_print_para fmt (s_ "Global options: ");

        pp_print_specs true fmt (fst (fspecs ()))
      end;

    if scmd_specs <> [] then
      begin
        pp_print_para fmt (s_ "Options: ");

        pp_print_specs false fmt scmd_specs
      end
  in

    (* Write general introduction. *)
    begin
      match hext with
        | NoSubCommand | AllSubCommand ->
            begin
              pp_print_string fmt usage_msg;
              pp_print_endblock fmt ();

              pp_print_string fmt CLIData.main_mkd;
              pp_print_endblock
                ~check_last_char:CLIData.main_mkd
                fmt ();

              pp_print_specs true fmt (fst (fspecs ()));

              pp_print_scmds fmt ();
            end

        | SubCommand _ ->
            ()
    end;

    (* Write body, focusing on specific command selected. *)
    begin
      match hext with
        | NoSubCommand ->
            ()

        | SubCommand nm ->
            pp_print_scmd fmt ~global_options:true (CLISubCommand.find nm)

        | AllSubCommand ->
            let scmds =
              List.rev_map
                (fun scmd -> scmd, `Builtin)
                (CLISubCommand.list_builtin ~deprecated:false ())
            in
            let plugin_scmds =
              if not ctxt.OASISContext.ignore_plugins then
                List.rev_map
                  (fun plugin ->
                     CLISubCommand.find plugin.PluginLoader.name,
                     `Plugin plugin)
                  (CLISubCommand.list_plugin ~deprecated:false ())
              else
                []
            in
            List.iter
              (fun (scmd, origin) ->
                 pp_print_scmd fmt ~global_options:false ~origin scmd)
              (List.sort
                 (fun (scmd1, _) (scmd2, _) ->
                    String.compare scmd1.scmd_name scmd2.scmd_name)
                 (List.rev_append plugin_scmds scmds))
    end