ocaml/ocamldoc/odoc_args.ml

(***********************************************************************)
(*                                                                     *)
(*                             OCamldoc                                *)
(*                                                                     *)
(*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
(*                                                                     *)
(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the Q Public License version 1.0.               *)
(*                                                                     *)
(***********************************************************************)

(** Command-line arguments. *)

module M = Odoc_messages

let current_generator = ref (None : Odoc_gen.generator option)

let get_html_generator () =
  match !current_generator with
    None -> (module Odoc_html.Generator : Odoc_html.Html_generator)
  | Some (Odoc_gen.Html m) -> m
  | Some _ -> failwith (M.current_generator_is_not "html")
;;

let get_latex_generator () =
  match !current_generator with
    None -> (module Odoc_latex.Generator : Odoc_latex.Latex_generator)
  | Some (Odoc_gen.Latex m) -> m
  | Some _ -> failwith (M.current_generator_is_not "latex")
;;

let get_texi_generator () =
  match !current_generator with
    None -> (module Odoc_texi.Generator : Odoc_texi.Texi_generator)
  | Some (Odoc_gen.Texi m) -> m
  | Some _ -> failwith (M.current_generator_is_not "texi")
;;

let get_man_generator () =
  match !current_generator with
    None -> (module Odoc_man.Generator : Odoc_man.Man_generator)
  | Some (Odoc_gen.Man m) -> m
  | Some _ -> failwith (M.current_generator_is_not "man")
;;

let get_dot_generator () =
  match !current_generator with
    None -> (module Odoc_dot.Generator : Odoc_dot.Dot_generator)
  | Some (Odoc_gen.Dot m) -> m
  | Some _ -> failwith (M.current_generator_is_not "dot")
;;

let get_base_generator () =
  match !current_generator with
    None -> (module Odoc_gen.Base_generator : Odoc_gen.Base)
  | Some (Odoc_gen.Base m) -> m
  | Some _ -> failwith (M.current_generator_is_not "base")
;;

let extend_html_generator f =
  let current = get_html_generator () in
  let module Current = (val current : Odoc_html.Html_generator) in
  let module F = (val f : Odoc_gen.Html_functor) in
  let module M = F(Current) in
  current_generator := Some (Odoc_gen.Html (module M : Odoc_html.Html_generator))
;;

let extend_latex_generator f =
  let current = get_latex_generator () in
  let module Current = (val current : Odoc_latex.Latex_generator) in
  let module F = (val f : Odoc_gen.Latex_functor) in
  let module M = F(Current) in
  current_generator := Some(Odoc_gen.Latex (module M : Odoc_latex.Latex_generator))
;;

let extend_texi_generator f =
  let current = get_texi_generator () in
  let module Current = (val current : Odoc_texi.Texi_generator) in
  let module F = (val f : Odoc_gen.Texi_functor) in
  let module M = F(Current) in
  current_generator := Some(Odoc_gen.Texi (module M : Odoc_texi.Texi_generator))
;;

let extend_man_generator f =
  let current = get_man_generator () in
  let module Current = (val current : Odoc_man.Man_generator) in
  let module F = (val f : Odoc_gen.Man_functor) in
  let module M = F(Current) in
  current_generator := Some(Odoc_gen.Man (module M : Odoc_man.Man_generator))
;;

let extend_dot_generator f =
  let current = get_dot_generator () in
  let module Current = (val current : Odoc_dot.Dot_generator) in
  let module F = (val f : Odoc_gen.Dot_functor) in
  let module M = F(Current) in
  current_generator := Some (Odoc_gen.Dot (module M : Odoc_dot.Dot_generator))
;;

let extend_base_generator f =
  let current = get_base_generator () in
  let module Current = (val current : Odoc_gen.Base) in
  let module F = (val f : Odoc_gen.Base_functor) in
  let module M = F(Current) in
  current_generator := Some (Odoc_gen.Base (module M : Odoc_gen.Base))
;;

(** Analysis of a string defining options. Return the list of
   options according to the list giving associations between
   [(character, _)] and a list of options. *)
let analyse_option_string l s =
  List.fold_left
    (fun acc -> fun ((c,_), v) ->
      if String.contains s c then
        acc @ v
      else
        acc)
    []
    l

(** Analysis of a string defining the merge options to be used.
   Returns the list of options specified.*)
let analyse_merge_options s =
  let l = [
    (M.merge_description, [Odoc_types.Merge_description]) ;
    (M.merge_author, [Odoc_types.Merge_author]) ;
    (M.merge_version, [Odoc_types.Merge_version]) ;
    (M.merge_see, [Odoc_types.Merge_see]) ;
    (M.merge_since, [Odoc_types.Merge_since]) ;
    (M.merge_before, [Odoc_types.Merge_before]) ;
    (M.merge_deprecated, [Odoc_types.Merge_deprecated]) ;
    (M.merge_param, [Odoc_types.Merge_param]) ;
    (M.merge_raised_exception, [Odoc_types.Merge_raised_exception]) ;
    (M.merge_return_value, [Odoc_types.Merge_return_value]) ;
    (M.merge_custom, [Odoc_types.Merge_custom]) ;
    (M.merge_all, Odoc_types.all_merge_options)
  ]
  in
  analyse_option_string l s


let f_latex_title s =
  try
    let pos = String.index s ',' in
    let n = int_of_string (String.sub s 0 pos) in
    let len = String.length s in
    let command = String.sub s (pos + 1) (len - pos - 1) in
    Odoc_latex.latex_titles := List.remove_assoc n !Odoc_latex.latex_titles ;
    Odoc_latex.latex_titles := (n, command) :: !Odoc_latex.latex_titles
  with
    Not_found
  | Invalid_argument _ ->
      incr Odoc_global.errors ;
      prerr_endline (M.wrong_format s)

let add_hidden_modules s =
  let l = Str.split (Str.regexp ",") s in
  List.iter
    (fun n ->
      let name = Str.global_replace (Str.regexp "[ \n\r\t]+") "" n in
      match name with
        "" -> ()
      | _ ->
          match name.[0] with
            'A'..'Z' -> Odoc_global.hidden_modules := name :: !Odoc_global.hidden_modules
          | _ ->
              incr Odoc_global.errors;
              prerr_endline (M.not_a_module_name name)
    )
    l

let set_generator (g : Odoc_gen.generator) = current_generator := Some g

(** The default option list *)
let default_options = [
  "-version", Arg.Unit (fun () -> print_string M.message_version ; print_newline () ; exit 0) , M.option_version ;
  "-vnum", Arg.Unit (fun () -> print_string M.config_version ;
                               print_newline () ; exit 0) , M.option_version ;
  "-v", Arg.Unit (fun () -> Odoc_global.verbose := true), M.verbose_mode ;
  "-I", Arg.String (fun s ->
       Odoc_global.include_dirs :=
         (Misc.expand_directory Config.standard_library s) :: !Odoc_global.include_dirs),
    M.include_dirs ;
  "-pp", Arg.String (fun s -> Odoc_global.preprocessor := Some s), M.preprocess ;
  "-ppx", Arg.String (fun s -> Odoc_global.ppx := s :: !Odoc_global.ppx), M.ppx ;
  "-impl", Arg.String (fun s ->
       Odoc_global.files := !Odoc_global.files @ [Odoc_global.Impl_file s]),
    M.option_impl ;
    "-intf", Arg.String (fun s ->
       Odoc_global.files := !Odoc_global.files @ [Odoc_global.Intf_file s]),
    M.option_intf ;
  "-text", Arg.String (fun s ->
       Odoc_global.files := !Odoc_global.files @ [Odoc_global.Text_file s]),
    M.option_text ;
  "-rectypes", Arg.Set Odoc_global.recursive_types, M.rectypes ;
  "-nolabels", Arg.Unit (fun () -> Odoc_global.classic := true), M.nolabels ;
  "-warn-error", Arg.Set Odoc_global.warn_error, M.werr ;
  "-hide-warnings", Arg.Clear Odoc_config.print_warnings, M.hide_warnings ;
  "-o", Arg.String (fun s -> Odoc_global.out_file := s), M.out_file ;
  "-d", Arg.String (fun s -> Odoc_global.target_dir := s), M.target_dir ;
  "-sort", Arg.Unit (fun () -> Odoc_global.sort_modules := true), M.sort_modules ;
  "-no-stop", Arg.Set Odoc_global.no_stop, M.no_stop ;
  "-no-custom-tags", Arg.Set Odoc_global.no_custom_tags, M.no_custom_tags ;
  "-stars", Arg.Set Odoc_global.remove_stars, M.remove_stars ;
  "-inv-merge-ml-mli", Arg.Set Odoc_global.inverse_merge_ml_mli, M.inverse_merge_ml_mli ;
  "-no-module-constraint-filter", Arg.Clear Odoc_global.filter_with_module_constraints,
  M.no_filter_with_module_constraints ;

  "-keep-code", Arg.Set Odoc_global.keep_code, M.keep_code^"\n" ;

  "-dump", Arg.String (fun s -> Odoc_global.dump := Some s), M.dump ;
  "-load", Arg.String (fun s -> Odoc_global.load := !Odoc_global.load @ [s]), M.load^"\n" ;

  "-t", Arg.String (fun s -> Odoc_global.title := Some s), M.option_title ;
  "-intro", Arg.String (fun s -> Odoc_global.intro_file := Some s), M.option_intro ;
  "-hide", Arg.String add_hidden_modules, M.hide_modules ;
  "-m", Arg.String (fun s -> Odoc_global.merge_options := !Odoc_global.merge_options @ (analyse_merge_options s)),
  M.merge_options ^
  "\n\n *** choosing a generator ***\n";

(* generators *)
  "-html", Arg.Unit (fun () -> set_generator
       (Odoc_gen.Html (module Odoc_html.Generator : Odoc_html.Html_generator))),
    M.generate_html ;
  "-latex", Arg.Unit (fun () -> set_generator
       (Odoc_gen.Latex (module Odoc_latex.Generator : Odoc_latex.Latex_generator))),
    M.generate_latex ;
  "-texi", Arg.Unit (fun () -> set_generator
       (Odoc_gen.Texi (module Odoc_texi.Generator : Odoc_texi.Texi_generator))),
    M.generate_texinfo ;
  "-man", Arg.Unit (fun () -> set_generator
       (Odoc_gen.Man (module Odoc_man.Generator : Odoc_man.Man_generator))),
    M.generate_man ;
  "-dot", Arg.Unit (fun () -> set_generator
       (Odoc_gen.Dot (module Odoc_dot.Generator : Odoc_dot.Dot_generator))),
    M.generate_dot ;
  "-customdir", Arg.Unit (fun () -> Printf.printf "%s\n" Odoc_config.custom_generators_path; exit 0),
  M.display_custom_generators_dir ;
  "-i", Arg.String (fun s -> ()), M.add_load_dir ;
  "-g", Arg.String (fun s -> ()), M.load_file ^
  "\n\n *** HTML options ***\n";

(* html only options *)
  "-all-params", Arg.Set Odoc_html.with_parameter_list, M.with_parameter_list ;
  "-css-style", Arg.String (fun s -> Odoc_html.css_style := Some s), M.css_style ;
  "-index-only", Arg.Set Odoc_html.index_only, M.index_only ;
  "-colorize-code", Arg.Set Odoc_html.colorize_code, M.colorize_code ;
  "-short-functors", Arg.Set Odoc_html.html_short_functors, M.html_short_functors ;
  "-charset", Arg.Set_string Odoc_html.charset, (M.charset !Odoc_html.charset)^
  "\n\n *** LaTeX options ***\n";

(* latex only options *)
  "-noheader", Arg.Unit (fun () -> Odoc_global.with_header := false), M.no_header ;
  "-notrailer", Arg.Unit (fun () -> Odoc_global.with_trailer := false), M.no_trailer ;
  "-sepfiles", Arg.Set Odoc_latex.separate_files, M.separate_files ;
  "-latextitle", Arg.String f_latex_title, M.latex_title Odoc_latex.latex_titles ;
  "-latex-value-prefix",
    Arg.String (fun s -> Odoc_latex.latex_value_prefix := s), M.latex_value_prefix ;
  "-latex-type-prefix",
    Arg.String (fun s -> Odoc_latex.latex_type_prefix := s), M.latex_type_prefix ;
  "-latex-exception-prefix",
    Arg.String (fun s -> Odoc_latex.latex_exception_prefix := s), M.latex_exception_prefix ;
  "-latex-attribute-prefix",
    Arg.String (fun s -> Odoc_latex.latex_attribute_prefix := s), M.latex_attribute_prefix ;
  "-latex-method-prefix",
    Arg.String (fun s -> Odoc_latex.latex_method_prefix := s), M.latex_method_prefix ;
  "-latex-module-prefix",
    Arg.String (fun s -> Odoc_latex.latex_module_prefix := s), M.latex_module_prefix ;
  "-latex-module-type-prefix",
    Arg.String (fun s -> Odoc_latex.latex_module_type_prefix := s), M.latex_module_type_prefix ;
  "-latex-class-prefix",
    Arg.String (fun s -> Odoc_latex.latex_class_prefix := s), M.latex_class_prefix ;
  "-latex-class-type-prefix",
    Arg.String (fun s -> Odoc_latex.latex_class_type_prefix := s), M.latex_class_type_prefix ;
  "-notoc", Arg.Unit (fun () -> Odoc_global.with_toc := false), M.no_toc ^
  "\n\n *** texinfo options ***\n";

(* texi only options *)
  "-noindex", Arg.Clear Odoc_global.with_index, M.no_index ;
  "-esc8", Arg.Set Odoc_texi.esc_8bits, M.esc_8bits ;
  "-info-section", Arg.String ((:=) Odoc_texi.info_section), M.info_section ;
  "-info-entry", Arg.String (fun s -> Odoc_texi.info_entry := !Odoc_texi.info_entry @ [ s ]),
  M.info_entry ^
  "\n\n *** dot options ***\n";

(* dot only options *)
  "-dot-colors", Arg.String (fun s -> Odoc_dot.dot_colors := Str.split (Str.regexp_string ",") s), M.dot_colors ;
  "-dot-include-all", Arg.Set Odoc_dot.dot_include_all, M.dot_include_all ;
  "-dot-types", Arg.Set Odoc_dot.dot_types, M.dot_types ;
  "-dot-reduce", Arg.Set Odoc_dot.dot_reduce, M.dot_reduce^
  "\n\n *** man pages options ***\n";

(* man only options *)
  "-man-mini", Arg.Set Odoc_man.man_mini, M.man_mini ;
  "-man-suffix", Arg.String (fun s -> Odoc_man.man_suffix := s), M.man_suffix ;
  "-man-section", Arg.String (fun s -> Odoc_man.man_section := s), M.man_section ;

]

let options = ref default_options

let modified_options () =
  !options != default_options

let append_last_doc suffix =
  match List.rev !options with
  | (key, spec, doc) :: tl ->
      options := List.rev ((key, spec, doc ^ suffix) :: tl)
  | [] -> ()

(** The help option list, overriding the default ones from the Arg module *)
let help_options = ref []
let help_action () =
  let msg =
    Arg.usage_string
      (!options @ !help_options)
      (M.usage ^ M.options_are) in
  print_string msg
let () =
  help_options := [
    "-help", Arg.Unit help_action, M.help ;
    "--help", Arg.Unit help_action, M.help
]

let add_option o =
  if not (modified_options ()) then
    append_last_doc "\n *** custom generator options ***\n";
  let (s,_,_) = o in
  let rec iter = function
      [] -> [o]
    | (s2,f,m) :: q ->
        if s = s2 then
          o :: q
        else
          (s2,f,m) :: (iter q)
  in
  options := iter !options

let parse () =
  let anonymous f =
    let sf =
      if Filename.check_suffix f "ml" then
        Odoc_global.Impl_file f
      else
        if Filename.check_suffix f "mli" then
          Odoc_global.Intf_file f
        else
          if Filename.check_suffix f "txt" then
            Odoc_global.Text_file f
          else
            failwith (Odoc_messages.unknown_extension f)
    in
    Odoc_global.files := !Odoc_global.files @ [sf]
  in
  if modified_options () then append_last_doc "\n";
  let options = !options @ !help_options in
  let _ = Arg.parse options
      anonymous
      (M.usage^M.options_are)
  in
  (* we sort the hidden modules by name, to be sure that for example,
     A.B is before A, so we will match against A.B before A in
     Odoc_name.hide_modules.*)
  Odoc_global.hidden_modules :=
    List.sort (fun a -> fun b -> - (compare a b)) !Odoc_global.hidden_modules