diff options
Diffstat (limited to 'ocaml-binary-annot/ocamldoc')
79 files changed, 26096 insertions, 0 deletions
diff --git a/ocaml-binary-annot/ocamldoc/.cvsignore b/ocaml-binary-annot/ocamldoc/.cvsignore new file mode 100644 index 0000000000..0372a09821 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/.cvsignore @@ -0,0 +1,17 @@ +ocamldoc +ocamldoc.opt +odoc_crc.ml +odoc_lexer.ml +odoc_ocamlhtml.ml +odoc_parser.ml +odoc_parser.mli +odoc_see_lexer.ml +odoc_text_lexer.ml +odoc_text_parser.ml +odoc_text_parser.mli +stdlib_man +*.output +test_stdlib +test_latex +test +*.a diff --git a/ocaml-binary-annot/ocamldoc/.depend b/ocaml-binary-annot/ocamldoc/.depend new file mode 100644 index 0000000000..6467d445b3 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/.depend @@ -0,0 +1,253 @@ +odoc.cmo: ../typing/typedtree.cmi odoc_messages.cmo odoc_info.cmi \ + odoc_global.cmi odoc_gen.cmi odoc_config.cmi odoc_args.cmi \ + odoc_analyse.cmi ../utils/misc.cmi ../utils/config.cmi \ + ../utils/clflags.cmi +odoc.cmx: ../typing/typedtree.cmx odoc_messages.cmx odoc_info.cmx \ + odoc_global.cmx odoc_gen.cmx odoc_config.cmx odoc_args.cmx \ + odoc_analyse.cmx ../utils/misc.cmx ../utils/config.cmx \ + ../utils/clflags.cmx +odoc_analyse.cmo: ../utils/warnings.cmi ../typing/typetexp.cmi \ + ../typing/types.cmi ../typing/typemod.cmi ../typing/typedtree.cmi \ + ../typing/typedecl.cmi ../typing/typecore.cmi ../typing/typeclass.cmi \ + ../bytecomp/translcore.cmi ../bytecomp/translclass.cmi \ + ../parsing/syntaxerr.cmi ../parsing/parse.cmi odoc_types.cmi \ + odoc_text.cmi odoc_sig.cmi odoc_module.cmo odoc_misc.cmi \ + odoc_messages.cmo odoc_merge.cmi odoc_global.cmi odoc_dep.cmo \ + odoc_cross.cmi odoc_comments.cmi odoc_class.cmo odoc_ast.cmi \ + ../utils/misc.cmi ../parsing/location.cmi ../parsing/lexer.cmi \ + ../typing/includemod.cmi ../typing/env.cmi ../typing/ctype.cmi \ + ../utils/config.cmi ../utils/clflags.cmi ../utils/ccomp.cmi \ + odoc_analyse.cmi +odoc_analyse.cmx: ../utils/warnings.cmx ../typing/typetexp.cmx \ + ../typing/types.cmx ../typing/typemod.cmx ../typing/typedtree.cmx \ + ../typing/typedecl.cmx ../typing/typecore.cmx ../typing/typeclass.cmx \ + ../bytecomp/translcore.cmx ../bytecomp/translclass.cmx \ + ../parsing/syntaxerr.cmx ../parsing/parse.cmx odoc_types.cmx \ + odoc_text.cmx odoc_sig.cmx odoc_module.cmx odoc_misc.cmx \ + odoc_messages.cmx odoc_merge.cmx odoc_global.cmx odoc_dep.cmx \ + odoc_cross.cmx odoc_comments.cmx odoc_class.cmx odoc_ast.cmx \ + ../utils/misc.cmx ../parsing/location.cmx ../parsing/lexer.cmx \ + ../typing/includemod.cmx ../typing/env.cmx ../typing/ctype.cmx \ + ../utils/config.cmx ../utils/clflags.cmx ../utils/ccomp.cmx \ + odoc_analyse.cmi +odoc_args.cmo: odoc_types.cmi odoc_texi.cmo odoc_messages.cmo odoc_man.cmo \ + odoc_latex.cmo odoc_html.cmo odoc_global.cmi odoc_gen.cmi odoc_dot.cmo \ + odoc_config.cmi ../utils/misc.cmi ../utils/config.cmi odoc_args.cmi +odoc_args.cmx: odoc_types.cmx odoc_texi.cmx odoc_messages.cmx odoc_man.cmx \ + odoc_latex.cmx odoc_html.cmx odoc_global.cmx odoc_gen.cmx odoc_dot.cmx \ + odoc_config.cmx ../utils/misc.cmx ../utils/config.cmx odoc_args.cmi +odoc_ast.cmo: ../typing/types.cmi ../typing/typedtree.cmi \ + ../typing/predef.cmi ../typing/path.cmi ../parsing/parsetree.cmi \ + odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_sig.cmi \ + odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_messages.cmo \ + odoc_global.cmi odoc_exception.cmo odoc_env.cmi odoc_class.cmo \ + ../utils/misc.cmi ../parsing/location.cmi ../typing/ident.cmi \ + ../parsing/asttypes.cmi odoc_ast.cmi +odoc_ast.cmx: ../typing/types.cmx ../typing/typedtree.cmx \ + ../typing/predef.cmx ../typing/path.cmx ../parsing/parsetree.cmi \ + odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_sig.cmx \ + odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_messages.cmx \ + odoc_global.cmx odoc_exception.cmx odoc_env.cmx odoc_class.cmx \ + ../utils/misc.cmx ../parsing/location.cmx ../typing/ident.cmx \ + ../parsing/asttypes.cmi odoc_ast.cmi +odoc_class.cmo: ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ + odoc_parameter.cmo odoc_name.cmi +odoc_class.cmx: ../typing/types.cmx odoc_value.cmx odoc_types.cmx \ + odoc_parameter.cmx odoc_name.cmx +odoc_comments.cmo: odoc_types.cmi odoc_text.cmi odoc_see_lexer.cmo \ + odoc_parser.cmi odoc_misc.cmi odoc_messages.cmo odoc_merge.cmi \ + odoc_lexer.cmo odoc_global.cmi odoc_cross.cmi odoc_comments_global.cmi \ + odoc_comments.cmi +odoc_comments.cmx: odoc_types.cmx odoc_text.cmx odoc_see_lexer.cmx \ + odoc_parser.cmx odoc_misc.cmx odoc_messages.cmx odoc_merge.cmx \ + odoc_lexer.cmx odoc_global.cmx odoc_cross.cmx odoc_comments_global.cmx \ + odoc_comments.cmi +odoc_comments_global.cmo: odoc_comments_global.cmi +odoc_comments_global.cmx: odoc_comments_global.cmi +odoc_config.cmo: ../utils/config.cmi odoc_config.cmi +odoc_config.cmx: ../utils/config.cmx odoc_config.cmi +odoc_control.cmo: +odoc_control.cmx: +odoc_cross.cmo: odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_search.cmi \ + odoc_scan.cmo odoc_parameter.cmo odoc_name.cmi odoc_module.cmo \ + odoc_misc.cmi odoc_messages.cmo odoc_global.cmi odoc_exception.cmo \ + odoc_class.cmo odoc_cross.cmi +odoc_cross.cmx: odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_search.cmx \ + odoc_scan.cmx odoc_parameter.cmx odoc_name.cmx odoc_module.cmx \ + odoc_misc.cmx odoc_messages.cmx odoc_global.cmx odoc_exception.cmx \ + odoc_class.cmx odoc_cross.cmi +odoc_dag2html.cmo: odoc_info.cmi odoc_dag2html.cmi +odoc_dag2html.cmx: odoc_info.cmx odoc_dag2html.cmi +odoc_dep.cmo: ../parsing/parsetree.cmi odoc_type.cmo odoc_print.cmi \ + odoc_module.cmo ../tools/depend.cmi +odoc_dep.cmx: ../parsing/parsetree.cmi odoc_type.cmx odoc_print.cmx \ + odoc_module.cmx ../tools/depend.cmx +odoc_dot.cmo: odoc_messages.cmo odoc_info.cmi +odoc_dot.cmx: odoc_messages.cmx odoc_info.cmx +odoc_env.cmo: ../typing/types.cmi ../typing/printtyp.cmi ../typing/predef.cmi \ + ../typing/path.cmi odoc_name.cmi ../typing/btype.cmi odoc_env.cmi +odoc_env.cmx: ../typing/types.cmx ../typing/printtyp.cmx ../typing/predef.cmx \ + ../typing/path.cmx odoc_name.cmx ../typing/btype.cmx odoc_env.cmi +odoc_exception.cmo: ../typing/types.cmi odoc_types.cmi odoc_name.cmi +odoc_exception.cmx: ../typing/types.cmx odoc_types.cmx odoc_name.cmx +odoc_gen.cmo: odoc_texi.cmo odoc_module.cmo odoc_man.cmo odoc_latex.cmo \ + odoc_html.cmo odoc_dot.cmo odoc_gen.cmi +odoc_gen.cmx: odoc_texi.cmx odoc_module.cmx odoc_man.cmx odoc_latex.cmx \ + odoc_html.cmx odoc_dot.cmx odoc_gen.cmi +odoc_global.cmo: odoc_types.cmi odoc_messages.cmo odoc_config.cmi \ + ../utils/clflags.cmi odoc_global.cmi +odoc_global.cmx: odoc_types.cmx odoc_messages.cmx odoc_config.cmx \ + ../utils/clflags.cmx odoc_global.cmi +odoc_html.cmo: odoc_text.cmi odoc_ocamlhtml.cmo odoc_messages.cmo \ + odoc_info.cmi odoc_global.cmi odoc_dag2html.cmi ../parsing/asttypes.cmi +odoc_html.cmx: odoc_text.cmx odoc_ocamlhtml.cmx odoc_messages.cmx \ + odoc_info.cmx odoc_global.cmx odoc_dag2html.cmx ../parsing/asttypes.cmi +odoc_info.cmo: ../typing/printtyp.cmi odoc_value.cmo odoc_types.cmi \ + odoc_type.cmo odoc_text.cmi odoc_str.cmi odoc_search.cmi odoc_scan.cmo \ + odoc_print.cmi odoc_parameter.cmo odoc_name.cmi odoc_module.cmo \ + odoc_misc.cmi odoc_global.cmi odoc_exception.cmo odoc_dep.cmo \ + odoc_config.cmi odoc_comments.cmi odoc_class.cmo odoc_analyse.cmi \ + odoc_info.cmi +odoc_info.cmx: ../typing/printtyp.cmx odoc_value.cmx odoc_types.cmx \ + odoc_type.cmx odoc_text.cmx odoc_str.cmx odoc_search.cmx odoc_scan.cmx \ + odoc_print.cmx odoc_parameter.cmx odoc_name.cmx odoc_module.cmx \ + odoc_misc.cmx odoc_global.cmx odoc_exception.cmx odoc_dep.cmx \ + odoc_config.cmx odoc_comments.cmx odoc_class.cmx odoc_analyse.cmx \ + odoc_info.cmi +odoc_inherit.cmo: +odoc_inherit.cmx: +odoc_latex.cmo: odoc_to_text.cmo odoc_messages.cmo odoc_latex_style.cmo \ + odoc_info.cmi ../parsing/asttypes.cmi +odoc_latex.cmx: odoc_to_text.cmx odoc_messages.cmx odoc_latex_style.cmx \ + odoc_info.cmx ../parsing/asttypes.cmi +odoc_latex_style.cmo: +odoc_latex_style.cmx: +odoc_lexer.cmo: odoc_parser.cmi odoc_messages.cmo odoc_global.cmi \ + odoc_comments_global.cmi +odoc_lexer.cmx: odoc_parser.cmx odoc_messages.cmx odoc_global.cmx \ + odoc_comments_global.cmx +odoc_man.cmo: odoc_str.cmi odoc_print.cmi odoc_misc.cmi odoc_messages.cmo \ + odoc_info.cmi ../parsing/asttypes.cmi +odoc_man.cmx: odoc_str.cmx odoc_print.cmx odoc_misc.cmx odoc_messages.cmx \ + odoc_info.cmx ../parsing/asttypes.cmi +odoc_merge.cmo: odoc_value.cmo odoc_types.cmi odoc_type.cmo \ + odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_messages.cmo \ + odoc_global.cmi odoc_exception.cmo odoc_class.cmo odoc_merge.cmi +odoc_merge.cmx: odoc_value.cmx odoc_types.cmx odoc_type.cmx \ + odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_messages.cmx \ + odoc_global.cmx odoc_exception.cmx odoc_class.cmx odoc_merge.cmi +odoc_messages.cmo: ../utils/config.cmi +odoc_messages.cmx: ../utils/config.cmx +odoc_misc.cmo: ../typing/types.cmi ../typing/predef.cmi ../typing/path.cmi \ + odoc_types.cmi odoc_messages.cmo ../parsing/longident.cmi \ + ../typing/ctype.cmi ../typing/btype.cmi odoc_misc.cmi +odoc_misc.cmx: ../typing/types.cmx ../typing/predef.cmx ../typing/path.cmx \ + odoc_types.cmx odoc_messages.cmx ../parsing/longident.cmx \ + ../typing/ctype.cmx ../typing/btype.cmx odoc_misc.cmi +odoc_module.cmo: ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ + odoc_type.cmo odoc_name.cmi odoc_exception.cmo odoc_class.cmo +odoc_module.cmx: ../typing/types.cmx odoc_value.cmx odoc_types.cmx \ + odoc_type.cmx odoc_name.cmx odoc_exception.cmx odoc_class.cmx +odoc_name.cmo: ../typing/path.cmi odoc_misc.cmi ../typing/ident.cmi \ + odoc_name.cmi +odoc_name.cmx: ../typing/path.cmx odoc_misc.cmx ../typing/ident.cmx \ + odoc_name.cmi +odoc_ocamlhtml.cmo: +odoc_ocamlhtml.cmx: +odoc_parameter.cmo: ../typing/types.cmi odoc_types.cmi +odoc_parameter.cmx: ../typing/types.cmx odoc_types.cmx +odoc_parser.cmo: odoc_types.cmi odoc_comments_global.cmi odoc_parser.cmi +odoc_parser.cmx: odoc_types.cmx odoc_comments_global.cmx odoc_parser.cmi +odoc_print.cmo: ../typing/types.cmi ../typing/printtyp.cmi odoc_print.cmi +odoc_print.cmx: ../typing/types.cmx ../typing/printtyp.cmx odoc_print.cmi +odoc_scan.cmo: odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_module.cmo \ + odoc_exception.cmo odoc_class.cmo +odoc_scan.cmx: odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_module.cmx \ + odoc_exception.cmx odoc_class.cmx +odoc_search.cmo: odoc_value.cmo odoc_types.cmi odoc_type.cmo \ + odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_exception.cmo \ + odoc_class.cmo odoc_search.cmi +odoc_search.cmx: odoc_value.cmx odoc_types.cmx odoc_type.cmx \ + odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_exception.cmx \ + odoc_class.cmx odoc_search.cmi +odoc_see_lexer.cmo: odoc_parser.cmi +odoc_see_lexer.cmx: odoc_parser.cmx +odoc_sig.cmo: ../typing/types.cmi ../typing/typedtree.cmi ../typing/path.cmi \ + ../parsing/parsetree.cmi odoc_value.cmo odoc_types.cmi odoc_type.cmo \ + odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_misc.cmi \ + odoc_messages.cmo odoc_merge.cmi odoc_global.cmi odoc_exception.cmo \ + odoc_env.cmi odoc_class.cmo ../utils/misc.cmi ../parsing/location.cmi \ + ../typing/btype.cmi ../parsing/asttypes.cmi odoc_sig.cmi +odoc_sig.cmx: ../typing/types.cmx ../typing/typedtree.cmx ../typing/path.cmx \ + ../parsing/parsetree.cmi odoc_value.cmx odoc_types.cmx odoc_type.cmx \ + odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_misc.cmx \ + odoc_messages.cmx odoc_merge.cmx odoc_global.cmx odoc_exception.cmx \ + odoc_env.cmx odoc_class.cmx ../utils/misc.cmx ../parsing/location.cmx \ + ../typing/btype.cmx ../parsing/asttypes.cmi odoc_sig.cmi +odoc_str.cmo: ../typing/types.cmi ../typing/printtyp.cmi odoc_value.cmo \ + odoc_type.cmo odoc_print.cmi odoc_name.cmi odoc_misc.cmi \ + odoc_messages.cmo odoc_exception.cmo odoc_class.cmo \ + ../parsing/asttypes.cmi odoc_str.cmi +odoc_str.cmx: ../typing/types.cmx ../typing/printtyp.cmx odoc_value.cmx \ + odoc_type.cmx odoc_print.cmx odoc_name.cmx odoc_misc.cmx \ + odoc_messages.cmx odoc_exception.cmx odoc_class.cmx \ + ../parsing/asttypes.cmi odoc_str.cmi +odoc_test.cmo: odoc_info.cmi odoc_gen.cmi odoc_args.cmi +odoc_test.cmx: odoc_info.cmx odoc_gen.cmx odoc_args.cmx +odoc_texi.cmo: odoc_to_text.cmo odoc_messages.cmo odoc_info.cmi \ + ../parsing/asttypes.cmi +odoc_texi.cmx: odoc_to_text.cmx odoc_messages.cmx odoc_info.cmx \ + ../parsing/asttypes.cmi +odoc_text.cmo: odoc_types.cmi odoc_text_parser.cmi odoc_text_lexer.cmo \ + odoc_text.cmi +odoc_text.cmx: odoc_types.cmx odoc_text_parser.cmx odoc_text_lexer.cmx \ + odoc_text.cmi +odoc_text_lexer.cmo: odoc_text_parser.cmi odoc_misc.cmi +odoc_text_lexer.cmx: odoc_text_parser.cmx odoc_misc.cmx +odoc_text_parser.cmo: odoc_types.cmi odoc_misc.cmi odoc_text_parser.cmi +odoc_text_parser.cmx: odoc_types.cmx odoc_misc.cmx odoc_text_parser.cmi +odoc_to_text.cmo: odoc_module.cmo odoc_messages.cmo odoc_info.cmi +odoc_to_text.cmx: odoc_module.cmx odoc_messages.cmx odoc_info.cmx +odoc_type.cmo: ../typing/types.cmi odoc_types.cmi odoc_name.cmi \ + ../parsing/asttypes.cmi +odoc_type.cmx: ../typing/types.cmx odoc_types.cmx odoc_name.cmx \ + ../parsing/asttypes.cmi +odoc_types.cmo: odoc_messages.cmo odoc_types.cmi +odoc_types.cmx: odoc_messages.cmx odoc_types.cmi +odoc_value.cmo: ../typing/types.cmi ../typing/printtyp.cmi odoc_types.cmi \ + odoc_parameter.cmo odoc_name.cmi +odoc_value.cmx: ../typing/types.cmx ../typing/printtyp.cmx odoc_types.cmx \ + odoc_parameter.cmx odoc_name.cmx +t.cmo: +t.cmx: +odoc_analyse.cmi: odoc_module.cmo odoc_global.cmi +odoc_args.cmi: odoc_gen.cmi +odoc_ast.cmi: ../typing/types.cmi ../typing/typedtree.cmi ../typing/path.cmi \ + ../parsing/parsetree.cmi odoc_sig.cmi odoc_name.cmi odoc_module.cmo +odoc_comments.cmi: odoc_types.cmi odoc_module.cmo +odoc_comments_global.cmi: +odoc_config.cmi: +odoc_cross.cmi: odoc_types.cmi odoc_module.cmo +odoc_dag2html.cmi: odoc_info.cmi +odoc_env.cmi: ../typing/types.cmi odoc_name.cmi +odoc_gen.cmi: odoc_texi.cmo odoc_module.cmo odoc_man.cmo odoc_latex.cmo \ + odoc_html.cmo odoc_dot.cmo +odoc_global.cmi: odoc_types.cmi +odoc_info.cmi: ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ + odoc_type.cmo odoc_search.cmi odoc_parameter.cmo odoc_module.cmo \ + odoc_global.cmi odoc_exception.cmo odoc_class.cmo +odoc_merge.cmi: odoc_types.cmi odoc_module.cmo +odoc_misc.cmi: ../typing/types.cmi odoc_types.cmi ../parsing/longident.cmi +odoc_name.cmi: ../typing/path.cmi ../parsing/longident.cmi \ + ../typing/ident.cmi +odoc_parser.cmi: odoc_types.cmi +odoc_print.cmi: ../typing/types.cmi +odoc_search.cmi: odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_module.cmo \ + odoc_exception.cmo odoc_class.cmo +odoc_sig.cmi: ../typing/types.cmi ../parsing/parsetree.cmi odoc_types.cmi \ + odoc_type.cmo odoc_name.cmi odoc_module.cmo odoc_env.cmi odoc_class.cmo +odoc_str.cmi: ../typing/types.cmi odoc_value.cmo odoc_type.cmo \ + odoc_exception.cmo odoc_class.cmo +odoc_text.cmi: odoc_types.cmi +odoc_text_parser.cmi: odoc_types.cmi +odoc_types.cmi: diff --git a/ocaml-binary-annot/ocamldoc/Changes.txt b/ocaml-binary-annot/ocamldoc/Changes.txt new file mode 100644 index 0000000000..3707d265bd --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/Changes.txt @@ -0,0 +1,209 @@ +TODO: + - need to fix display of type parameters for inherited classes/class types + - need to add an environment while generating to print correct links: + file foo.mli: + type u + module type M = sig type u end + module N : sig include M val f: u -> unit end + Here, in html for example, f in displayed being of type Foo.u instead of Foo.M.u + - latex: types variant polymorphes dépassent de la page quand ils sont trop longs + - utilisation nouvelles infos de Xavier: "début de rec", etc. + - xml generator + +===== +Release > 3.11.0: +- option -g also for native code version (loading custom generators) + +===== +Release 3.09.3: +- mod: PR#4017 new option -short-functors to use a short form to display + functors in html generator +- fix: PR#4016 (using modtype constraint to filter module elements displayed in doc) +- fix: PR#4066 (missing crossref in text from intro files) +- fix: PR#4007 (error in merging of top dependencies of modules) +- fix: PR#3981 (-dot-colors has no effect) +- mod: name resolution in cross-referencing: {!name} if name is not + found, then it is searched in the parent module/class, and in the parent + of the parent, and so on until it is found. + +===== +Release 3.09.1: + - fix: remove .TP for generated man pages, use .sp instead + (.TP caused a lot of odd margins) + - fix: html generator now output DOCTYPE and character encoding information. + - add: m_text_only field in Module.t_module, to separate real modules + from text files handled as modules. + - fix: display only text for "text modules" + - extensible {foo } syntax + - user can give .txt files on the command line, containing ocamldoc formatted + text, to be able to include bigger texts out of source files + - -o option is now used by the html generator to indicate the prefix + of generated index files (to avoid conflict when a Index module exists + on case-insensitive file systems). + +===== +Release 3.08.4: + - some improvements in html display + - better error messages for misplaced variant constructors comments + - some fixes in man page generation (escaping characters) + +===== +Release 3.08.2: + - fix: error "Lexing: empty token" (PR#3173) + +===== +Release 3.08.1: + - add: new -intf and -impl options supported (PR#3036) + - fix: display of class parameters in HTML and LaTeX (PR#2994) + - fix: display of link to class page in html (PR#2994) + +===== +Release 3.08.0: + - fix: method parameters names in signature are now retrieved correctly + (fix of Odoc_value.parameter_list_from_arrows to handle Tpoly for methods) + - ajout à la doc de Module_list et Index_list (utilisé dans le html seulement) + - ajout à la doc: fichier de l'option -intro utilisé pour l'index en html + - fix: create a Module_with instead of a Module_alias when we encounter + module A : Foo in a signature + - latex: style latex pour indenter dans les module kind et les class kind + - latex: il manque la génération des paramètres de classe + - parse des {!modules: } et {!indexlist} + - gestion des Module_list et Index_list + - no need to Dynlink.add_available_units any more + - generate html from module_kind rather than from module_type + + same for classes and class types + - add the kind to module parameters (the way the parameter was build in the parsetree) + - fix: the generated ocamldoc.sty is more robust for paragraphs in + ocamldocdescription environment + - fix: when generating separated files in latex, generate them in + the same directory than the main file, (the one specified by -o) + - mod: one section per to module in latex output + improve latex output + - mod: odoc_latex: use buffers instead of string concatenation + - add: new ocamldoc man page, thanks to Samuel Mimram + - fix: useless parenthesis around agruments of arguments of a type constructor in + type definitions, and aournd arguments of exceptions in exception definitions. + - fix: blank lines in verbatim, latex, code pre, code and ele ref modes + are now accepted + - fix: html generator: included module names were displayed with their simple + name rather than their fully qualified name + - fix: use a formatter from a buffer rather Format.str_formatter in + Odoc_mist.sting_of_module_type, to avoid too much blanks + - new module odoc_print, will work when Format.pp_print_flush is fixed + - odoc_html: use buffers instead of string concatenation + - odoc_man: use buffers instead of string concatenation + - odoc_cross.ml: use hash tables modified on the fly to resolve + (module | module type | exception) name aliases + - odoc_html: replace some calls to Str. by specific functions on strings + - odoc_cross.ml: use a Map to associate a complete name to + the known elements with this name, instead of searching each time + through the whole list of modules -> a gain of more than 90% in speed + for cross-referencing (Odoc_cross.associate) + - fix: Odoc_name.cut printed a '(' instead of a '.' + - add: new option -customdir + - add: new option -i (to add a path to the directory where + to look for custom generators) + - add: add odoc_config.ml{,i} + - add: keep_code in Odoc_info.Args interface + - add: m_code_intf and m_code fields for modules, fit when the + Odoc_args.keep_code option is set, and fit for all modules, not + only toplevel ones + - fix: bug preventing to get the code in a .mli + - fix: missing spaces after carriage return in types (Odoc_misc.string_of_type_expr) + - fixes: some bugs in the text parser + ( ]} meaning end of code and somehting else instead of end of precode) + - add: in Odoc_info: text_of_string, text_string_of_text, info_of_string + - fix: better output of titles in html (use more the style) + - add: -intro option to use a file content as ocamldoc comment to use as + introduction for LaTeX document and HTML index page + - add: the HTML generator generates the code of the module if available + - add: field m_code for modules, to keep the code of top modules + - fix: display "include Foo" instead of "include module Foo" in Latex, Man, Texi + - fix: not display comments associated to include directives + - fix: bad display of type parameters for class and class types + +====== + +Release 3.05 : + - added link tags in html header to reference sections and subsections + in each page (for browser which handle those tags) + - no titles nor lists in first sentence of text in indexes and latex titles + - only one table for the titles in HTML output + - fix of bad comment association for types in .ml files + - dumps now contain a magic number, checked when dumps are loaded + - new option -o to use with texi, latex and dot generators + - new .code CSS class used + - better output for classes and modules, with their type + - added texinfo generator, by Olivier Andrieu + - removed iso generator, which became the odoc_check custom generator + - link syntax {{:url}text} added to the manual + - (** comments in code is colorized in ocaml code html pages + - new class .code in style + - new generator : -dot . Output dot code to display + modules or types dependencies. + - new option -inv-merge-ml-mli to inverse the priority of + .ml and .mli when merging + - option -werr becomes -warn-error + - possibility to define and reference section labels + Exemple: + (** {2:mysectionlabel My title bla bla bla} *) + in module Foo + + This section is referenced with {!Foo.mysectionlabel} in + a comment. + +Pre-release 4 : + - new option -werr to treat ocamldoc warnings as errors + - new option -hide to remove some modules from complete names, + (e.g., print ref instead of Pervasives.ref) + - HTML doc in classic style only contain indexes to existing element kinds + (i.e. there is no class index if the doc does not contain any class.) + - First description sentence now stops at the first period followed by a blank, + or at the first blank line. + - update of user manual + - check report generator added (options -iso and -iso-{val|ty|cl|ex|mod}) + - Odoc_info.Scan.scanner base class added + - support for custom tags (@xxx with xxx not a predefined tag), see manual + - new classes info in Odoc_html, Odoc_to_text, Odoc_latex, and Odoc_man, which + contains the functions for printing info structures + - replacement of modules Odoc_html.Text and Odoc_latex.Text by + classes Odoc_html.text and Odoc_latex.text to allow the redefinition + of their methods in custom generators + - bug fix : a shortcut list can be pu after a blank line + - improved display of variant constructors, record fields and + their comments in classic HTML + - blank lines in comments become <p> in HTML instead of <br> + - bug fix : there can be blanks between the last item + and the ending } of a list + - new option -latextitles + - number of errors encountered is displayed + - if at least one error occurs, exit code is not 0 + - more precise error messages + - bug fix : \n and other blanks are accepted after, for example, {i + +Pre-release 3 : + - option -stars + - complete paths of executables in the generated Makefile + - names of executables changed to ocamldoc and ocamldoc.opt + - better LaTeX output + - option -sepfiles for LaTeX + - ocamldoc.sty used by the generated LaTeX + - ocamldoc.hva added to use Hevea on the generated LaTeX + - user manual updated + - {[ ]} marks to put pre-formatted code on more than one line + - {!Toto.tutu} to add cross references between elements + - some bug fixes + +Rep-release 2 : +- generator of texinfo files : odoc_texi.cma +- use of CSS in generated html +- new option -css-style to provide a different style sheet +- improved html +- added more precise titles in generated html pages +- no more links to unknown elements +- added indexes +- simple html : added <LINK ...> in <HEAD> : compliant + browsers should display quick access to modules and indexes in + their navigation bar (for example, mozilla 0.9.5 is compliant) +- '{bone}' doesn't work any more ; a space is required as in '{b one}'. + Same for {e, {i, and some others marks. Check the manual +- bug fixes diff --git a/ocaml-binary-annot/ocamldoc/Makefile b/ocaml-binary-annot/ocamldoc/Makefile new file mode 100644 index 0000000000..b352aab63d --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/Makefile @@ -0,0 +1,371 @@ +#(***********************************************************************) +#(* 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. *) +#(* *) +#(***********************************************************************) + +# $Id$ + +include ../config/Makefile + +# Various commands and dir +########################## +CAMLRUN=../boot/ocamlrun +OCAMLC = ../ocamlcomp.sh +OCAMLOPT = ../ocamlcompopt.sh +OCAMLDEP = $(CAMLRUN) ../tools/ocamldep +OCAMLLEX = $(CAMLRUN) ../boot/ocamllex +OCAMLYACC= ../boot/ocamlyacc +OCAMLLIB = $(LIBDIR) +OCAMLBIN = $(BINDIR) + +OCAMLPP=-pp './remove_DEBUG' + +# For installation +############## +MKDIR=mkdir -p +CP=cp -f +OCAMLDOC=ocamldoc +OCAMLDOC_RUN=./ocamldoc.opt #sh ./runocamldoc $(SUPPORTS_SHARED_LIBRARIES) +OCAMLDOC_OPT=$(OCAMLDOC).opt +OCAMLDOC_LIBCMA=odoc_info.cma +OCAMLDOC_LIBCMI=odoc_info.cmi +OCAMLDOC_LIBCMXA=odoc_info.cmxa +OCAMLDOC_LIBA=odoc_info.a +INSTALL_LIBDIR=$(OCAMLLIB)/ocamldoc +INSTALL_CUSTOMDIR=$(INSTALL_LIBDIR)/custom +INSTALL_BINDIR=$(OCAMLBIN) +INSTALL_MANODIR=$(MANDIR)/man3 + +INSTALL_MLIS=odoc_info.mli +INSTALL_CMIS=$(INSTALL_MLIS:.mli=.cmi) + +ODOC_TEST=odoc_test.cmo + +GENERATORS_CMOS= \ + generators/odoc_todo.cmo \ + generators/odoc_literate.cmo +GENERATORS_CMXS=$(GENERATORS_CMOS:.cmo=.cmxs) + + +# Compilation +############# +OCAMLSRCDIR=.. +INCLUDES_DEP=-I $(OCAMLSRCDIR)/parsing \ + -I $(OCAMLSRCDIR)/utils \ + -I $(OCAMLSRCDIR)/typing \ + -I $(OCAMLSRCDIR)/driver \ + -I $(OCAMLSRCDIR)/bytecomp \ + -I $(OCAMLSRCDIR)/tools \ + -I $(OCAMLSRCDIR)/toplevel/ + +INCLUDES_NODEP= -I $(OCAMLSRCDIR)/stdlib \ + -I $(OCAMLSRCDIR)/otherlibs/str \ + -I $(OCAMLSRCDIR)/otherlibs/dynlink \ + -I $(OCAMLSRCDIR)/otherlibs/unix \ + -I $(OCAMLSRCDIR)/otherlibs/num \ + -I $(OCAMLSRCDIR)/otherlibs/graph + +INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP) + +COMPFLAGS=$(INCLUDES) -warn-error A +LINKFLAGS=$(INCLUDES) -nostdlib + +CMOFILES= odoc_config.cmo \ + odoc_messages.cmo\ + odoc_global.cmo\ + odoc_types.cmo\ + odoc_misc.cmo\ + odoc_text_parser.cmo\ + odoc_text_lexer.cmo\ + odoc_text.cmo\ + odoc_name.cmo\ + odoc_parameter.cmo\ + odoc_value.cmo\ + odoc_type.cmo\ + odoc_exception.cmo\ + odoc_class.cmo\ + odoc_module.cmo\ + odoc_print.cmo \ + odoc_str.cmo\ + odoc_comments_global.cmo\ + odoc_parser.cmo\ + odoc_lexer.cmo\ + odoc_see_lexer.cmo\ + odoc_env.cmo\ + odoc_merge.cmo\ + odoc_sig.cmo\ + odoc_ast.cmo\ + odoc_control.cmo\ + odoc_inherit.cmo\ + odoc_search.cmo\ + odoc_scan.cmo\ + odoc_cross.cmo\ + odoc_comments.cmo\ + odoc_dep.cmo\ + odoc_analyse.cmo\ + odoc_info.cmo + + +CMXFILES= $(CMOFILES:.cmo=.cmx) +CMIFILES= $(CMOFILES:.cmo=.cmi) + +EXECMOFILES=$(CMOFILES) \ + odoc_dag2html.cmo \ + odoc_to_text.cmo \ + odoc_ocamlhtml.cmo \ + odoc_html.cmo \ + odoc_man.cmo \ + odoc_latex_style.cmo \ + odoc_latex.cmo \ + odoc_texi.cmo \ + odoc_dot.cmo \ + odoc_gen.cmo \ + odoc_args.cmo\ + odoc.cmo + +EXECMXFILES= $(EXECMOFILES:.cmo=.cmx) +EXECMIFILES= $(EXECMOFILES:.cmo=.cmi) + +LIBCMOFILES=$(CMOFILES) +LIBCMXFILES= $(LIBCMOFILES:.cmo=.cmx) +LIBCMIFILES= $(LIBCMOFILES:.cmo=.cmi) + +# Les cmo et cmx de la distrib OCAML +OCAMLCMOFILES=$(OCAMLSRCDIR)/parsing/printast.cmo \ + $(OCAMLSRCDIR)/typing/ident.cmo \ + $(OCAMLSRCDIR)/utils/tbl.cmo \ + $(OCAMLSRCDIR)/utils/misc.cmo \ + $(OCAMLSRCDIR)/utils/config.cmo \ + $(OCAMLSRCDIR)/utils/clflags.cmo \ + $(OCAMLSRCDIR)/utils/warnings.cmo \ + $(OCAMLSRCDIR)/utils/ccomp.cmo \ + $(OCAMLSRCDIR)/utils/consistbl.cmo \ + $(OCAMLSRCDIR)/parsing/linenum.cmo\ + $(OCAMLSRCDIR)/parsing/location.cmo\ + $(OCAMLSRCDIR)/parsing/longident.cmo \ + $(OCAMLSRCDIR)/parsing/syntaxerr.cmo \ + $(OCAMLSRCDIR)/parsing/parser.cmo \ + $(OCAMLSRCDIR)/parsing/lexer.cmo \ + $(OCAMLSRCDIR)/parsing/parse.cmo \ + $(OCAMLSRCDIR)/typing/types.cmo \ + $(OCAMLSRCDIR)/typing/path.cmo \ + $(OCAMLSRCDIR)/typing/btype.cmo \ + $(OCAMLSRCDIR)/typing/predef.cmo \ + $(OCAMLSRCDIR)/typing/datarepr.cmo \ + $(OCAMLSRCDIR)/typing/subst.cmo \ + $(OCAMLSRCDIR)/typing/env.cmo \ + $(OCAMLSRCDIR)/typing/ctype.cmo \ + $(OCAMLSRCDIR)/typing/primitive.cmo \ + $(OCAMLSRCDIR)/typing/oprint.cmo \ + $(OCAMLSRCDIR)/typing/printtyp.cmo \ + $(OCAMLSRCDIR)/typing/includecore.cmo \ + $(OCAMLSRCDIR)/typing/typetexp.cmo \ + $(OCAMLSRCDIR)/typing/typedtree.cmo \ + $(OCAMLSRCDIR)/typing/parmatch.cmo \ + $(OCAMLSRCDIR)/typing/stypes.cmo \ + $(OCAMLSRCDIR)/typing/typecore.cmo \ + $(OCAMLSRCDIR)/typing/includeclass.cmo \ + $(OCAMLSRCDIR)/typing/typedecl.cmo \ + $(OCAMLSRCDIR)/typing/typeclass.cmo \ + $(OCAMLSRCDIR)/typing/mtype.cmo \ + $(OCAMLSRCDIR)/typing/includemod.cmo \ + $(OCAMLSRCDIR)/typing/typemod.cmo \ + $(OCAMLSRCDIR)/bytecomp/lambda.cmo \ + $(OCAMLSRCDIR)/bytecomp/typeopt.cmo \ + $(OCAMLSRCDIR)/bytecomp/printlambda.cmo \ + $(OCAMLSRCDIR)/bytecomp/switch.cmo \ + $(OCAMLSRCDIR)/bytecomp/matching.cmo \ + $(OCAMLSRCDIR)/bytecomp/translobj.cmo \ + $(OCAMLSRCDIR)/bytecomp/translcore.cmo \ + $(OCAMLSRCDIR)/bytecomp/translclass.cmo \ + $(OCAMLSRCDIR)/tools/depend.cmo + +OCAMLCMXFILES=$(OCAMLCMOFILES:.cmo=.cmx) + +STDLIB_MLIS=../stdlib/*.mli \ + ../otherlibs/unix/unix.mli \ + ../otherlibs/str/str.mli \ + ../otherlibs/bigarray/bigarray.mli \ + ../otherlibs/num/num.mli + +all: exe lib generators + +exe: $(OCAMLDOC) +lib: $(OCAMLDOC_LIBCMA) $(OCAMLDOC_LIBCMI) $(ODOC_TEST) +generators: $(GENERATORS_CMOS) + +opt.opt: exeopt libopt generatorsopt + $(MAKE) manpages +exeopt: $(OCAMLDOC_OPT) +libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI) +generatorsopt: $(GENERATORS_CMXS) + +debug: + make OCAMLPP="" + +$(OCAMLDOC): $(EXECMOFILES) + $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) +$(OCAMLDOC_OPT): $(EXECMXFILES) + $(OCAMLOPT) -o $@ unix.cmxa str.cmxa dynlink.cmxa $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES) + +$(OCAMLDOC_LIBCMA): $(LIBCMOFILES) + $(OCAMLC) -a -o $@ $(LINKFLAGS) $(OCAMLCMOFILES) $(LIBCMOFILES) +$(OCAMLDOC_LIBCMXA): $(LIBCMXFILES) + $(OCAMLOPT) -a -o $@ $(LINKFLAGS) $(OCAMLCMXFILES) $(LIBCMXFILES) + +manpages: stdlib_man/Pervasives.3o + +dot: $(EXECMOFILES) + $(OCAMLDOC_RUN) -dot -dot-reduce -o ocamldoc.dot $(INCLUDES) \ + odoc*.ml + +# Parsers and lexers dependencies : +################################### +odoc_text_parser.ml: odoc_text_parser.mly +odoc_text_parser.mli: odoc_text_parser.mly + +odoc_parser.ml: odoc_parser.mly +odoc_parser.mli:odoc_parser.mly + +odoc_text_lexer.ml: odoc_text_lexer.mll + +odoc_lexer.ml:odoc_lexer.mll + +odoc_ocamlhtml.ml: odoc_ocamlhtml.mll + +odoc_see_lexer.ml: odoc_see_lexer.mll + + +# generic rules : +################# + +.SUFFIXES: .mll .mly .ml .mli .cmo .cmi .cmx .cmxs + +.ml.cmo: + $(OCAMLC) $(OCAMLPP) $(COMPFLAGS) -c $< + +.mli.cmi: + $(OCAMLC) $(OCAMLPP) $(COMPFLAGS) -c $< + +.ml.cmx: + $(OCAMLOPT) $(OCAMLPP) $(COMPFLAGS) -c $< + +.ml.cmxs: + $(OCAMLOPT) -shared -o $@ $(OCAMLPP) $(COMPFLAGS) $< + +.mll.ml: + $(OCAMLLEX) $< + +.mly.ml: + $(OCAMLYACC) -v $< + +.mly.mli: + $(OCAMLYACC) -v $< + +# Installation targets +###################### +install: dummy + if test -d $(INSTALL_BINDIR); then : ; else $(MKDIR) $(INSTALL_BINDIR); fi + if test -d $(INSTALL_LIBDIR); then : ; else $(MKDIR) $(INSTALL_LIBDIR); fi + if test -d $(INSTALL_CUSTOMDIR); then : ; else $(MKDIR) $(INSTALL_CUSTOMDIR); fi + $(CP) $(OCAMLDOC) $(INSTALL_BINDIR)/$(OCAMLDOC)$(EXE) + $(CP) ocamldoc.hva *.cmi $(OCAMLDOC_LIBCMA) $(INSTALL_LIBDIR) + $(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) $(INSTALL_LIBDIR) + if test -d $(INSTALL_MANODIR); then : ; else $(MKDIR) $(INSTALL_MANODIR); fi + if test -d stdlib_man; then $(CP) stdlib_man/* $(INSTALL_MANODIR); else : ; fi + +installopt: + if test -f $(OCAMLDOC_OPT) ; then $(MAKE) installopt_really ; fi + +installopt_really: + if test -d $(INSTALL_BINDIR); then : ; else $(MKDIR) $(INSTALL_BINDIR); fi + if test -d $(INSTALL_LIBDIR); then : ; else $(MKDIR) $(INSTALL_LIBDIR); fi + $(CP) $(OCAMLDOC_OPT) $(INSTALL_BINDIR)/$(OCAMLDOC_OPT)$(EXE) + $(CP) ocamldoc.hva $(OCAMLDOC_LIBA) $(OCAMLDOC_LIBCMXA) $(INSTALL_LIBDIR) + $(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) $(INSTALL_LIBDIR) + +# Testing : +########### +test: dummy + $(MKDIR) $@ + $(OCAMLDOC_RUN) -html -colorize-code -sort -d $@ $(INCLUDES) -dump $@/ocamldoc.odoc odoc*.ml odoc*.mli -v + $(MKDIR) $@-custom + $(OCAMLDOC_RUN) -colorize-code -sort -d $@-custom $(INCLUDES) \ + -g generators/odoc_literate.cmo -g generators/odoc_todo.cmo \ + -load $@/ocamldoc.odoc -v + +test_stdlib: dummy + $(MKDIR) $@ + $(OCAMLDOC_RUN) -html -colorize-code -sort -d $@ $(INCLUDES) -dump $@/stdlib.odoc -keep-code \ + ../stdlib/pervasives.ml ../stdlib/*.mli \ + ../otherlibs/unix/unix.mli \ + ../otherlibs/str/str.mli + +test_framed: dummy + $(MKDIR) $@ + $(OCAMLDOC_RUN) -g odoc_fhtml.cmo -sort -colorize-code -d $@ $(INCLUDES) odoc*.ml odoc*.mli + +test_latex: dummy + $(MKDIR) $@ + $(OCAMLDOC_RUN) -latex -sort -o $@/test.tex -d $@ $(INCLUDES) odoc*.ml odoc*.mli test2.txt ../stdlib/*.mli ../otherlibs/unix/unix.mli + +test_latex_simple: dummy + $(MKDIR) $@ + $(OCAMLDOC_RUN) -latex -sort -o $@/test.tex -d $@ $(INCLUDES) \ + -latextitle 6,subsection -latextitle 7,subsubection \ + ../stdlib/hashtbl.mli \ + ../stdlib/arg.mli \ + ../otherlibs/unix/unix.mli \ + ../stdlib/map.mli + +test_man: dummy + $(MKDIR) $@ + $(OCAMLDOC_RUN) -man -sort -d $@ $(INCLUDES) odoc*.ml odoc*.mli + +test_texi: dummy + $(MKDIR) $@ + $(OCAMLDOC_RUN) -texi -sort -d $@ $(INCLUDES) odoc*.ml odoc*.mli + +stdlib_man/Pervasives.3o: $(STDLIB_MLIS) + $(MKDIR) stdlib_man + $(OCAMLDOC_RUN) -man -d stdlib_man $(INCLUDES) \ + -t "OCaml library" -man-mini \ + $(STDLIB_MLIS) + +autotest_stdlib: dummy + $(MKDIR) $@ + $(OCAMLDOC_RUN) -g autotest/odoc_test.cmo\ + $(INCLUDES) -keep-code \ + ../stdlib/pervasives.ml ../stdlib/*.mli \ + ../otherlibs/unix/unix.mli \ + ../otherlibs/str/str.mli + +# backup, clean and depend : +############################ + +clean:: dummy + @rm -f *~ \#*\# + @rm -f $(OCAMLDOC) $(OCAMLDOC_OPT) *.cma *.cmxa *.cmo *.cmi *.cmx *.a *.o + @rm -f odoc_parser.output odoc_text_parser.output + @rm -f odoc_lexer.ml odoc_text_lexer.ml odoc_see_lexer.ml odoc_ocamlhtml.ml + @rm -f odoc_parser.ml odoc_parser.mli odoc_text_parser.ml odoc_text_parser.mli + @rm -rf stdlib_man + +depend:: + $(OCAMLYACC) odoc_text_parser.mly + $(OCAMLYACC) odoc_parser.mly + $(OCAMLLEX) odoc_text_lexer.mll + $(OCAMLLEX) odoc_lexer.mll + $(OCAMLLEX) odoc_ocamlhtml.mll + $(OCAMLLEX) odoc_see_lexer.mll + $(OCAMLDEP) $(INCLUDES_DEP) *.mll *.mly *.ml *.mli > .depend + +dummy: + +include .depend diff --git a/ocaml-binary-annot/ocamldoc/Makefile.nt b/ocaml-binary-annot/ocamldoc/Makefile.nt new file mode 100644 index 0000000000..387aec928c --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/Makefile.nt @@ -0,0 +1,272 @@ +#(***********************************************************************) +#(* 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. *) +#(* *) +#(***********************************************************************) + +# $Id$ + +include ../config/Makefile + +CAMLRUN =../boot/ocamlrun +OCAMLC = ../ocamlcomp.sh +OCAMLOPT = ../ocamlcompopt.sh +OCAMLLEX =$(CAMLRUN) ../boot/ocamllex +OCAMLYACC=../boot/ocamlyacc + +OCAMLLIB = $(LIBDIR) +OCAMLBIN = $(BINDIR) + +OCAMLPP=-pp "grep -v DEBUG" + +# For installation +############## +MKDIR=mkdir +CP=cp +OCAMLDOC=ocamldoc +OCAMLDOC_RUN=$(CAMLRUN) $(OCAMLDOC) +OCAMLDOC_OPT=$(OCAMLDOC).opt +OCAMLDOC_LIBCMA=odoc_info.cma +OCAMLDOC_LIBCMI=odoc_info.cmi +OCAMLDOC_LIBCMXA=odoc_info.cmxa +OCAMLDOC_LIBA=odoc_info.$(A) +INSTALL_LIBDIR=$(OCAMLLIB)/ocamldoc +INSTALL_CUSTOMDIR=$(INSTALL_LIBDIR)/custom +INSTALL_BINDIR=$(OCAMLBIN) + +INSTALL_MLIS=odoc_info.mli +INSTALL_CMIS=$(INSTALL_MLIS:.mli=.cmi) + +# Compilation +############# +OCAMLSRCDIR=.. +INCLUDES_DEP=-I $(OCAMLSRCDIR)/parsing \ + -I $(OCAMLSRCDIR)/utils \ + -I $(OCAMLSRCDIR)/typing \ + -I $(OCAMLSRCDIR)/driver \ + -I $(OCAMLSRCDIR)/bytecomp \ + -I $(OCAMLSRCDIR)/tools \ + -I $(OCAMLSRCDIR)/toplevel/ + +INCLUDES_NODEP= -I $(OCAMLSRCDIR)/stdlib \ + -I $(OCAMLSRCDIR)/otherlibs/str \ + -I $(OCAMLSRCDIR)/otherlibs/dynlink \ + -I $(OCAMLSRCDIR)/otherlibs/win32unix \ + -I $(OCAMLSRCDIR)/otherlibs/num \ + -I $(OCAMLSRCDIR)/otherlibs/win32graph + +INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP) + +COMPFLAGS=$(INCLUDES) +LINKFLAGS=$(INCLUDES) -nostdlib + +CMOFILES= odoc_config.cmo \ + odoc_global.cmo\ + odoc_messages.cmo\ + odoc_types.cmo\ + odoc_misc.cmo\ + odoc_text_parser.cmo\ + odoc_text_lexer.cmo\ + odoc_text.cmo\ + odoc_name.cmo\ + odoc_parameter.cmo\ + odoc_value.cmo\ + odoc_type.cmo\ + odoc_exception.cmo\ + odoc_class.cmo\ + odoc_module.cmo\ + odoc_print.cmo \ + odoc_str.cmo\ + odoc_args.cmo\ + odoc_comments_global.cmo\ + odoc_parser.cmo\ + odoc_lexer.cmo\ + odoc_see_lexer.cmo\ + odoc_env.cmo\ + odoc_merge.cmo\ + odoc_sig.cmo\ + odoc_ast.cmo\ + odoc_control.cmo\ + odoc_inherit.cmo\ + odoc_search.cmo\ + odoc_scan.cmo\ + odoc_cross.cmo\ + odoc_comments.cmo\ + odoc_dep.cmo\ + odoc_analyse.cmo\ + odoc_info.cmo + + +CMXFILES= $(CMOFILES:.cmo=.cmx) +CMIFILES= $(CMOFILES:.cmo=.cmi) + +EXECMOFILES=$(CMOFILES)\ + odoc_dag2html.cmo\ + odoc_to_text.cmo\ + odoc_ocamlhtml.cmo\ + odoc_html.cmo\ + odoc_man.cmo\ + odoc_latex_style.cmo \ + odoc_latex.cmo\ + odoc_texi.cmo\ + odoc_dot.cmo\ + odoc.cmo + + +EXECMXFILES= $(EXECMOFILES:.cmo=.cmx) +EXECMIFILES= $(EXECMOFILES:.cmo=.cmi) + +LIBCMOFILES=$(CMOFILES) +LIBCMXFILES= $(LIBCMOFILES:.cmo=.cmx) +LIBCMIFILES= $(LIBCMOFILES:.cmo=.cmi) + +# Les cmo et cmx de la distrib OCAML +OCAMLCMOFILES=$(OCAMLSRCDIR)/parsing/printast.cmo \ + $(OCAMLSRCDIR)/typing/ident.cmo \ + $(OCAMLSRCDIR)/utils/tbl.cmo \ + $(OCAMLSRCDIR)/utils/misc.cmo \ + $(OCAMLSRCDIR)/utils/config.cmo \ + $(OCAMLSRCDIR)/utils/clflags.cmo \ + $(OCAMLSRCDIR)/utils/warnings.cmo \ + $(OCAMLSRCDIR)/utils/ccomp.cmo \ + $(OCAMLSRCDIR)/utils/consistbl.cmo \ + $(OCAMLSRCDIR)/parsing/linenum.cmo\ + $(OCAMLSRCDIR)/parsing/location.cmo\ + $(OCAMLSRCDIR)/parsing/longident.cmo \ + $(OCAMLSRCDIR)/parsing/syntaxerr.cmo \ + $(OCAMLSRCDIR)/parsing/parser.cmo \ + $(OCAMLSRCDIR)/parsing/lexer.cmo \ + $(OCAMLSRCDIR)/parsing/parse.cmo \ + $(OCAMLSRCDIR)/typing/types.cmo \ + $(OCAMLSRCDIR)/typing/path.cmo \ + $(OCAMLSRCDIR)/typing/btype.cmo \ + $(OCAMLSRCDIR)/typing/predef.cmo \ + $(OCAMLSRCDIR)/typing/datarepr.cmo \ + $(OCAMLSRCDIR)/typing/subst.cmo \ + $(OCAMLSRCDIR)/typing/env.cmo \ + $(OCAMLSRCDIR)/typing/ctype.cmo \ + $(OCAMLSRCDIR)/typing/primitive.cmo \ + $(OCAMLSRCDIR)/typing/oprint.cmo \ + $(OCAMLSRCDIR)/typing/printtyp.cmo \ + $(OCAMLSRCDIR)/typing/includecore.cmo \ + $(OCAMLSRCDIR)/typing/typetexp.cmo \ + $(OCAMLSRCDIR)/typing/parmatch.cmo \ + $(OCAMLSRCDIR)/typing/typedtree.cmo \ + $(OCAMLSRCDIR)/typing/stypes.cmo \ + $(OCAMLSRCDIR)/typing/typecore.cmo \ + $(OCAMLSRCDIR)/typing/includeclass.cmo \ + $(OCAMLSRCDIR)/typing/typedecl.cmo \ + $(OCAMLSRCDIR)/typing/typeclass.cmo \ + $(OCAMLSRCDIR)/typing/mtype.cmo \ + $(OCAMLSRCDIR)/typing/includemod.cmo \ + $(OCAMLSRCDIR)/typing/typemod.cmo \ + $(OCAMLSRCDIR)/bytecomp/lambda.cmo \ + $(OCAMLSRCDIR)/bytecomp/typeopt.cmo \ + $(OCAMLSRCDIR)/bytecomp/printlambda.cmo \ + $(OCAMLSRCDIR)/bytecomp/switch.cmo \ + $(OCAMLSRCDIR)/bytecomp/matching.cmo \ + $(OCAMLSRCDIR)/bytecomp/translobj.cmo \ + $(OCAMLSRCDIR)/bytecomp/translcore.cmo \ + $(OCAMLSRCDIR)/bytecomp/translclass.cmo \ + $(OCAMLSRCDIR)/tools/depend.cmo + +OCAMLCMXFILES=$(OCAMLCMOFILES:.cmo=.cmx) + +all: exe lib +exe: $(OCAMLDOC) +lib: $(OCAMLDOC_LIBCMA) $(OCAMLDOC_LIBCMI) + +opt.opt: exeopt libopt +exeopt: $(OCAMLDOC_OPT) +libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI) +debug: + make OCAMLPP="" + +$(OCAMLDOC): $(EXECMOFILES) + $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) +$(OCAMLDOC_OPT): $(EXECMXFILES) + $(OCAMLOPT) -o $@ unix.cmxa str.cmxa dynlink.cmxa $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES) + +$(OCAMLDOC_LIBCMA): $(LIBCMOFILES) + $(OCAMLC) -a -o $@ $(LINKFLAGS) $(OCAMLCMOFILES) $(LIBCMOFILES) +$(OCAMLDOC_LIBCMXA): $(LIBCMXFILES) + $(OCAMLOPT) -a -o $@ $(LINKFLAGS) $(OCAMLCMXFILES) $(LIBCMXFILES) + +# generic rules : +################# + +.SUFFIXES: .mli .ml .cmi .cmo .cmx + +.mli.cmi: + $(OCAMLC) $(OCAMLPP) $(COMPFLAGS) -c $< + +.ml.cmo: + $(OCAMLC) $(OCAMLPP) $(COMPFLAGS) -c $< + +.ml.cmx: + $(OCAMLOPT) $(OCAMLPP) $(COMPFLAGS) -c $< + +odoc_text_parser.ml odoc_text_parser.mli: odoc_text_parser.mly + $(OCAMLYACC) odoc_text_parser.mly + +odoc_parser.ml odoc_parser.mli: odoc_parser.mly + $(OCAMLYACC) odoc_parser.mly + +odoc_text_lexer.ml: odoc_text_lexer.mll + $(OCAMLLEX) odoc_text_lexer.mll + +odoc_lexer.ml: odoc_lexer.mll + $(OCAMLLEX) odoc_lexer.mll + +odoc_ocamlhtml.ml: odoc_ocamlhtml.mll + $(OCAMLLEX) odoc_ocamlhtml.mll + +odoc_see_lexer.ml: odoc_see_lexer.mll + $(OCAMLLEX) odoc_see_lexer.mll + +# Installation targets +###################### +install: dummy + $(MKDIR) -p $(INSTALL_BINDIR) + $(MKDIR) -p $(INSTALL_LIBDIR) + $(CP) $(OCAMLDOC) $(INSTALL_BINDIR)/$(OCAMLDOC).exe + $(CP) ocamldoc.hva *.cmi $(OCAMLDOC_LIBCMA) $(INSTALL_LIBDIR) + $(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) $(INSTALL_LIBDIR) + +installopt: + if test -f $(OCAMLDOC_OPT); then $(MAKEREC) installopt_really; fi + +installopt_really: + $(MKDIR) -p $(INSTALL_BINDIR) + $(MKDIR) -p $(INSTALL_LIBDIR) + $(CP) $(OCAMLDOC_OPT) $(INSTALL_BINDIR)/$(OCAMLDOC_OPT).exe + $(CP) ocamldoc.hva $(OCAMLDOC_LIBA) $(OCAMLDOC_LIBCMXA) $(INSTALL_LIBDIR) + $(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) $(INSTALL_LIBDIR) + + +# backup, clean and depend : +############################ + +clean:: dummy + @rm -f *~ /#*/# + @rm -f $(OCAMLDOC) $(OCAMLDOC_OPT) *.cma *.cmxa *.cmo *.cmi *.cmx *.$(A) *.$(O) + @rm -f odoc_parser.output odoc_text_parser.output + @rm -f odoc_lexer.ml odoc_text_lexer.ml odoc_see_lexer.ml odoc_ocamlhtml.ml + @rm -f odoc_parser.ml odoc_parser.mli odoc_text_parser.ml odoc_text_parser.mli + +depend:: + rm -f .depend + $(OCAMLYACC) odoc_text_parser.mly + $(OCAMLYACC) odoc_parser.mly + $(OCAMLLEX) odoc_text_lexer.mll + $(OCAMLLEX) odoc_lexer.mll + $(OCAMLDEP) $(INCLUDES_DEP) *.mll *.mly *.ml *.mli > .depend + +dummy: + +include .depend diff --git a/ocaml-binary-annot/ocamldoc/generators/odoc_literate.ml b/ocaml-binary-annot/ocamldoc/generators/odoc_literate.ml new file mode 100644 index 0000000000..e79b4f1a21 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/generators/odoc_literate.ml @@ -0,0 +1,207 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id: odoc_literate.ml,v 1.1 2008/02/28 11:09:33 guesdon Exp $ *) + +open Odoc_info +module Naming = Odoc_html.Naming +open Odoc_info.Value +open Odoc_info.Module + +let p = Printf.bprintf +let bp = Printf.bprintf +let bs = Buffer.add_string + +module Html = + (val + ( + match !Odoc_args.current_generator with + None -> (module Odoc_html.Generator : Odoc_html.Html_generator) + | Some (Odoc_gen.Html m) -> m + | _ -> + failwith + "A non-html generator is already set. Cannot install the Todo-list html generator" + ) : Odoc_html.Html_generator) +;; + +module Generator = +struct +class html = + object (self) + inherit Html.html as html + + method private html_of_module_comment b text = + let br1, br2 = + match text with + [(Odoc_info.Title (n, l_opt, t))] -> false, false + | (Odoc_info.Title (n, l_opt, t)) :: _ -> false, true + | _ -> true, true + in + if br1 then p b "<br/>"; + self#html_of_text b text; + if br2 then p b "<br/><br/>\n" + + method private html_of_Title b n l_opt t = + let label1 = self#create_title_label (n, l_opt, t) in + p b "<a name=\"%s\"></a>\n" (Naming.label_target label1); + p b "<h%d>" n; + self#html_of_text b t; + p b "</h%d>" n + + val mutable code_id = 0 + method private code_block b code = + code_id <- code_id + 1; + Printf.bprintf b + "<span class=\"code_expand\" onclick=\"if(document.getElementById('code%d').style.display=='none') {document.getElementById('code%d').style.display='block';} else {document.getElementById('code%d').style.display='none';}\"><img src=\"expand_collapse.png\" alt=\"+/-\"/></span>" code_id code_id code_id; + Printf.bprintf b "<div id=\"code%d\" class=\"codeblock\">" code_id; + self#html_of_code b code; + Printf.bprintf b "</div>" + + (** Print html code for a value. *) + method private html_of_value b v = + Odoc_info.reset_type_names (); + self#html_of_info b v.val_info; + bs b "<pre>"; + bs b (self#keyword "val"); + bs b " "; + (* html mark *) + bp b "<a name=\"%s\"></a>" (Naming.value_target v); + bs b (self#escape (Name.simple v.val_name)); + bs b " : "; + self#html_of_type_expr b (Name.father v.val_name) v.val_type; + bs b "</pre>"; + ( + if !Odoc_html.with_parameter_list then + self#html_of_parameter_list b (Name.father v.val_name) v.val_parameters + else + self#html_of_described_parameter_list b (Name.father v.val_name) v.val_parameters + ); + ( + match v.val_code with + None -> () + | Some code -> + self#code_block b code + ) +(* + (** Print html code for a module. *) + method private html_of_module b ?(info=true) ?(complete=true) ?(with_link=true) m = + let (html_file, _) = Naming.html_files m.m_name in + let father = Name.father m.m_name in + bs b "<pre>"; + bs b ((self#keyword "module")^" "); + ( + if with_link then + bp b "<a href=\"%s\">%s</a>" html_file (Name.simple m.m_name) + else + bs b (Name.simple m.m_name) + ); +(* A remettre quand on compilera avec ocaml 3.10 + ( + match m.m_kind with + Module_functor _ when !Odoc_info.Args.html_short_functors -> + () + + | _ -> *) bs b ": "; + (* + ); + *) + self#html_of_module_kind b father ~modu: m m.m_kind; + bs b "</pre>"; + if info && complete then + self#html_of_info ~indent: false b m.m_info + +*) + initializer + default_style_options <- + ["a:visited {color : #416DFF; text-decoration : none; }" ; + "a:link {color : #416DFF; text-decoration : none;}" ; + "a:hover {color : Red; text-decoration : none; background-color: #5FFF88}" ; + "a:active {color : Red; text-decoration : underline; }" ; + ".keyword { font-weight : bold ; color : Red }" ; + ".keywordsign { color : #C04600 }" ; + ".superscript { font-size : 4 }" ; + ".subscript { font-size : 4 }" ; + ".comment { color : Green }" ; + ".constructor { color : Blue }" ; + ".type { color : #5C6585 }" ; + ".string { color : Maroon }" ; + ".warning { color : Red ; font-weight : bold }" ; + ".info { margin-top: 8px; }"; + ".param_info { margin-top: 4px; margin-left : 3em; margin-right : 3em }" ; + ".code { color : #465F91 ; }" ; + "h1 { font-size : 20pt ; text-align: center; }" ; + + "h2 { font-size : 20pt ; border: 1px solid #000000; "^ + "margin-top: 5px; margin-bottom: 2px;"^ + "text-align: center; background-color: #90BDFF ;"^ + "padding: 2px; }" ; + + "h3 { font-size : 20pt ; border: 1px solid #000000; "^ + "margin-top: 5px; margin-bottom: 2px;"^ + "text-align: center; background-color: #90DDFF ;"^ + "padding: 2px; }" ; + + "h4 { font-size : 20pt ; border: 1px solid #000000; "^ + "margin-top: 5px; margin-bottom: 2px;"^ + "text-align: center; background-color: #90EDFF ;"^ + "padding: 2px; }" ; + + "h5 { font-size : 20pt ; border: 1px solid #000000; "^ + "margin-top: 5px; margin-bottom: 2px;"^ + "text-align: center; background-color: #90FDFF ;"^ + "padding: 2px; }" ; + + "h6 { font-size : 20pt ; border: 1px solid #000000; "^ + "margin-top: 5px; margin-bottom: 2px;"^ + "text-align: center; background-color: #C0FFFF ; "^ + "padding: 2px; }" ; + + "div.h7 { font-size : 20pt ; border: 1px solid #000000; "^ + "margin-top: 5px; margin-bottom: 2px;"^ + "text-align: center; background-color: #E0FFFF ; "^ + "padding: 2px; }" ; + + "div.h8 { font-size : 20pt ; border: 1px solid #000000; "^ + "margin-top: 5px; margin-bottom: 2px;"^ + "text-align: center; background-color: #F0FFFF ; "^ + "padding: 2px; }" ; + + "div.h9 { font-size : 20pt ; border: 1px solid #000000; "^ + "margin-top: 5px; margin-bottom: 2px;"^ + "text-align: center; background-color: #FFFFFF ; "^ + "padding: 2px; }" ; + + ".typetable { border-style : hidden }" ; + ".indextable { border-style : hidden }" ; + ".paramstable { border-style : hidden ; padding: 5pt 5pt}" ; + "body { background-color : White }" ; + "tr { background-color : White }" ; + "td.typefieldcomment { background-color : #FFFFFF ; font-size: smaller ;}" ; + "pre { margin-bottom: 4px ; margin-left: 1em; "^ + "border-color: #27408b; border-style: solid; "^ + "border-width: 1px 1px 1px 3px; "^ + "padding: 4px; }" ; + "div.sig_block {margin-left: 2em}" ; + + "div.codeblock { "^ + "margin-left: 2em; margin-right: 1em; padding: 6px; "^ + "margin-bottom: 8px; display: none; "^ + "border-width: 1px 1px 1px 3px; border-style: solid; border-color: grey; }" ; + + "span.code_expand { color: blue; text-decoration: underline; cursor: pointer; "^ + "margin-left: 1em ; } "; + ]; + end +end + +let _ = Odoc_args.set_generator + (Odoc_gen.Html (module Generator : Odoc_html.Html_generator)) + ;; diff --git a/ocaml-binary-annot/ocamldoc/generators/odoc_todo.ml b/ocaml-binary-annot/ocamldoc/generators/odoc_todo.ml new file mode 100644 index 0000000000..23e6c8892d --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/generators/odoc_todo.ml @@ -0,0 +1,225 @@ +(***********************************************************************) +(* OCamldoc *) +(* *) +(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2010 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. *) +(* *) +(***********************************************************************) + +(* $Id: odoc_todo.ml 411 2004-08-03 13:08:20Z guesdon $ *) + +(** An OCamldoc generator to retrieve information in "todo" tags and + generate an html page with all todo items. *) + +open Odoc_info +module Naming = Odoc_html.Naming +open Odoc_info.Value +open Odoc_info.Module +open Odoc_info.Type +open Odoc_info.Exception +open Odoc_info.Class + +let p = Printf.bprintf + +module Html = + (val + ( + match !Odoc_args.current_generator with + None -> (module Odoc_html.Generator : Odoc_html.Html_generator) + | Some (Odoc_gen.Html m) -> m + | _ -> + failwith + "A non-html generator is already set. Cannot install the Todo-list html generator" + ) : Odoc_html.Html_generator) +;; + +module Generator = +struct + class scanner html = + object (self) + inherit Odoc_info.Scan.scanner + + val b = Buffer.create 256 + method buffer = b + + method private gen_if_tag name target info_opt = + match info_opt with + None -> () + | Some i -> + let l = + List.fold_left + (fun acc (t, text) -> + match t with + "todo" -> + begin + match text with + (Odoc_info.Code s) :: q -> + ( + try + let n = int_of_string s in + let head = + Odoc_info.Code (Printf.sprintf "[%d] " n) + in + (Some n, head::q) :: acc + with _ -> (None, text) :: acc + ) + | _ -> (None, text) :: acc + + end + | _ -> acc + ) + [] + i.i_custom + in + match l with + [] -> () + | _ -> + let l = List.sort + (fun a b -> + match a, b with + (None, _), _ -> -1 + | _, (None, _) -> 1 + | (Some n1, _), (Some n2, _) -> compare n1 n2 + ) + l + in + p b "<pre><a href=\"%s\">%s</a></pre><div class=\"info\">" + target name; + let col = function + None -> "#000000" + | Some 1 -> "#FF0000" + | Some 2 -> "#AA5555" + | Some 3 -> "#44BB00" + | Some n -> Printf.sprintf "#%2x0000" (0xAA - (n * 0x10)) + in + List.iter + (fun (n, e) -> + Printf.bprintf b "<span style=\"color: %s\">" (col n); + html#html_of_text b e; + p b "</span><br/>\n"; + ) + l; + p b "</div>" + + method scan_value v = + self#gen_if_tag + v.val_name + (Odoc_html.Naming.complete_value_target v) + v.val_info + + method scan_type t = + self#gen_if_tag + t.ty_name + (Odoc_html.Naming.complete_type_target t) + t.ty_info + + method scan_exception e = + self#gen_if_tag + e.ex_name + (Odoc_html.Naming.complete_exception_target e) + e.ex_info + + method scan_attribute a = + self#gen_if_tag + a.att_value.val_name + (Odoc_html.Naming.complete_attribute_target a) + a.att_value.val_info + + method scan_method m = + self#gen_if_tag + m.met_value.val_name + (Odoc_html.Naming.complete_method_target m) + m.met_value.val_info + + (** This method scan the elements of the given module. *) + method scan_module_elements m = + List.iter + (fun ele -> + match ele with + Odoc_module.Element_module m -> self#scan_module m + | Odoc_module.Element_module_type mt -> self#scan_module_type mt + | Odoc_module.Element_included_module im -> self#scan_included_module im + | Odoc_module.Element_class c -> self#scan_class c + | Odoc_module.Element_class_type ct -> self#scan_class_type ct + | Odoc_module.Element_value v -> self#scan_value v + | Odoc_module.Element_exception e -> self#scan_exception e + | Odoc_module.Element_type t -> self#scan_type t + | Odoc_module.Element_module_comment t -> self#scan_module_comment t + ) + (Odoc_module.module_elements ~trans: false m) + + method scan_included_module _ = () + + method scan_class_pre c = + self#gen_if_tag + c.cl_name + (fst (Odoc_html.Naming.html_files c.cl_name)) + c.cl_info; + true + + method scan_class_type_pre ct = + self#gen_if_tag + ct.clt_name + (fst (Odoc_html.Naming.html_files ct.clt_name)) + ct.clt_info; + true + + method scan_module_pre m = + self#gen_if_tag + m.m_name + (fst (Odoc_html.Naming.html_files m.m_name)) + m.m_info; + true + + method scan_module_type_pre mt = + self#gen_if_tag + mt.mt_name + (fst (Odoc_html.Naming.html_files mt.mt_name)) + mt.mt_info; + true + end + + class html : Html.html = + object (self) + inherit Html.html as html + + (** we have to hack a little because we cannot inherit from + scanner, since public method cannot be hidden and + our html class must respect the type of the default + html generator class *) + val mutable scanner = new scanner (new Html.html ) + + method generate modules = + (* prevent having the 'todo' tag signaled as not handled *) + tag_functions <- ("todo", (fun _ -> "")) :: tag_functions; + (* generate doc as usual *) + html#generate modules; + (* then retrieve the todo tags and generate the todo.html page *) + let title = + match !Odoc_info.Global.title with + None -> "" + | Some s -> s + in + let b = Buffer.create 512 in + p b "<html>"; + self#print_header b title ; + p b "<body><h1>%s</h1>" title; + scanner#scan_module_list modules; + Buffer.add_buffer b scanner#buffer; + let oc = open_out + (Filename.concat !Odoc_info.Global.target_dir "todo.html") + in + Buffer.output_buffer oc b; + close_out oc + + initializer + scanner <- new scanner self + end +end + +let _ = Odoc_args.set_generator + (Odoc_gen.Html (module Generator : Odoc_html.Html_generator)) + ;; diff --git a/ocaml-binary-annot/ocamldoc/ocamldoc.hva b/ocaml-binary-annot/ocamldoc/ocamldoc.hva new file mode 100644 index 0000000000..454cee9e7e --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/ocamldoc.hva @@ -0,0 +1,19 @@ +\usepackage{alltt} +\newenvironment{ocamldoccode}{\begin{alltt}}{\end{alltt}} +\newenvironment{ocamldocdescription}{\begin{quote}}{\end{quote}} +\newenvironment{ocamldoccomment}{\begin{quote}}{\end{quote}} +\newcommand\textbar{|} +\newcommand\textbackslash{\begin{rawhtml}\\end{rawhtml}} +\newcommand\textasciicircum{\^{}} +\newcommand\sharp{#} + +\let\ocamldocvspace\vspace +\newenvironment{ocamldocindent}{\list{}{}\item\relax}{\endlist} +\newenvironment{ocamldocsigend} + {\noindent\quad\texttt{sig}\ocamldocindent} + {\endocamldocindent\vskip -\lastskip + \noindent\quad\texttt{end}\medskip} +\newenvironment{ocamldocobjectend} + {\noindent\quad\texttt{object}\ocamldocindent} + {\endocamldocindent\vskip -\lastskip + \noindent\quad\texttt{end}\medskip} diff --git a/ocaml-binary-annot/ocamldoc/ocamldoc.sty b/ocaml-binary-annot/ocamldoc/ocamldoc.sty new file mode 100644 index 0000000000..6a8ef1e959 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/ocamldoc.sty @@ -0,0 +1,58 @@ +%% Support macros for LaTeX documentation generated by ocamldoc. +%% This file is in the public domain; do what you want with it. + +\NeedsTeXFormat{LaTeX2e} +\ProvidesPackage{ocamldoc} + [2001/12/04 v1.0 ocamldoc support] + +\newenvironment{ocamldoccode}{% + \bgroup + \leftskip\@totalleftmargin + \rightskip\z@skip + \parindent\z@ + \parfillskip\@flushglue + \parskip\z@skip + %\noindent + \@@par\smallskip + \@tempswafalse + \def\par{% + \if@tempswa + \leavevmode\null\@@par\penalty\interlinepenalty + \else + \@tempswatrue + \ifhmode\@@par\penalty\interlinepenalty\fi + \fi} + \obeylines + \verbatim@font + \let\org@prime~% + \@noligs + \let\org@dospecials\dospecials + \g@remfrom@specials{\\} + \g@remfrom@specials{\{} + \g@remfrom@specials{\}} + \let\do\@makeother + \dospecials + \let\dospecials\org@dospecials + \frenchspacing\@vobeyspaces + \everypar \expandafter{\the\everypar \unpenalty}} +{\egroup\par} + +\def\g@remfrom@specials#1{% + \def\@new@specials{} + \def\@remove##1{% + \ifx##1#1\else + \g@addto@macro\@new@specials{\do ##1}\fi} + \let\do\@remove\dospecials + \let\dospecials\@new@specials + } + +\newenvironment{ocamldocdescription} +{\list{}{\rightmargin0pt \topsep0pt}\raggedright\item\relax} +{\endlist\medskip} + +\newenvironment{ocamldoccomment} +{\list{}{\leftmargin 2\leftmargini \rightmargin0pt \topsep0pt}\raggedright\item\relax} +{\endlist} + +\let\ocamldocvspace\vspace +\endinput diff --git a/ocaml-binary-annot/ocamldoc/odoc.ml b/ocaml-binary-annot/ocamldoc/odoc.ml new file mode 100644 index 0000000000..54b84db93c --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc.ml @@ -0,0 +1,137 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Main module for bytecode. +@todo coucou le todo*) + +open Config +open Clflags +open Misc +open Format +open Typedtree + +module M = Odoc_messages + +let print_DEBUG s = print_string s ; print_newline () + +(* we check if we must load a module given on the command line *) +let arg_list = Array.to_list Sys.argv +let (plugins, paths) = + let rec iter (files, incs) = function + [] | _ :: [] -> (List.rev files, List.rev incs) + | "-g" :: file :: q when + ((Filename.check_suffix file "cmo") or + (Filename.check_suffix file "cma") or + (Filename.check_suffix file "cmxs")) -> + iter (file :: files, incs) q + | "-i" :: dir :: q -> + iter (files, dir :: incs) q + | _ :: q -> + iter (files, incs) q + in + iter ([], []) arg_list + +let _ = print_DEBUG "Fin analyse des arguments pour le dynamic load" + +(** Return the real name of the file to load, + searching it in the paths if it is + a simple name and not in the current directory. *) +let get_real_filename name = + if Filename.basename name <> name then + name + else + ( + let paths = Filename.current_dir_name :: paths @ [Odoc_config.custom_generators_path] in + try + let d = List.find + (fun d -> Sys.file_exists (Filename.concat d name)) + paths + in + Filename.concat d name + with + Not_found -> + failwith (M.file_not_found_in_paths paths name) + ) + +let load_plugin file = + let file = Dynlink.adapt_filename file in + Dynlink.allow_unsafe_modules true; + try + let real_file = get_real_filename file in + ignore(Dynlink.loadfile real_file) + with + Dynlink.Error e -> + prerr_endline (Odoc_messages.load_file_error file (Dynlink.error_message e)) ; + exit 1 + | Not_found -> + prerr_endline (Odoc_messages.load_file_error file "Not_found"); + exit 1 + | Sys_error s + | Failure s -> + prerr_endline (Odoc_messages.load_file_error file s); + exit 1 +;; +List.iter load_plugin plugins;; + +let () = print_DEBUG "Fin du chargement dynamique eventuel" + +let () = Odoc_args.parse () + + +let loaded_modules = + List.flatten + (List.map + (fun f -> + Odoc_info.verbose (Odoc_messages.loading f); + try + let l = Odoc_analyse.load_modules f in + Odoc_info.verbose Odoc_messages.ok; + l + with Failure s -> + prerr_endline s ; + incr Odoc_global.errors ; + [] + ) + !Odoc_global.load + ) + +let modules = Odoc_analyse.analyse_files ~init: loaded_modules !Odoc_global.files + +let _ = + match !Odoc_global.dump with + None -> () + | Some f -> + try Odoc_analyse.dump_modules f modules + with Failure s -> + prerr_endline s ; + incr Odoc_global.errors + + +let _ = + match !Odoc_args.current_generator with + None -> + () + | Some gen -> + let generator = Odoc_gen.get_minimal_generator gen in + Odoc_info.verbose Odoc_messages.generating_doc; + generator#generate modules; + Odoc_info.verbose Odoc_messages.ok + +let _ = + if !Odoc_global.errors > 0 then + ( + prerr_endline (Odoc_messages.errors_occured !Odoc_global.errors) ; + exit 1 + ) + else + exit 0 diff --git a/ocaml-binary-annot/ocamldoc/odoc_analyse.ml b/ocaml-binary-annot/ocamldoc/odoc_analyse.ml new file mode 100644 index 0000000000..2091dd3967 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_analyse.ml @@ -0,0 +1,539 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Analysis of source files. This module is strongly inspired from + driver/main.ml :-) *) + +let print_DEBUG s = print_string s ; print_newline () + +open Config +open Clflags +open Misc +open Format +open Typedtree + + +(** Initialize the search path. + The current directory is always searched first, + then the directories specified with the -I option (in command-line order), + then the standard library directory. *) +let init_path () = + load_path := + "" :: List.rev (Config.standard_library :: !Clflags.include_dirs); + Env.reset_cache () + +(** Return the initial environment in which compilation proceeds. *) +let initial_env () = + try + if !Clflags.nopervasives + then Env.initial + else Env.open_pers_signature "Pervasives" Env.initial + with Not_found -> + fatal_error "cannot open pervasives.cmi" + +(** Optionally preprocess a source file *) +let preprocess sourcefile = + match !Clflags.preprocessor with + None -> sourcefile + | Some pp -> + let tmpfile = Filename.temp_file "camlpp" "" in + let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in + if Ccomp.command comm <> 0 then begin + remove_file tmpfile; + Printf.eprintf "Preprocessing error\n"; + exit 2 + end; + tmpfile + +(** Remove the input file if this file was the result of a preprocessing.*) +let remove_preprocessed inputfile = + match !Clflags.preprocessor with + None -> () + | Some _ -> remove_file inputfile + +let remove_preprocessed_if_ast inputfile = + match !Clflags.preprocessor with + None -> () + | Some _ -> if inputfile <> !Location.input_name then remove_file inputfile + +exception Outdated_version + +(** Parse a file or get a dumped syntax tree in it *) +let parse_file inputfile parse_fun ast_magic = + let ic = open_in_bin inputfile in + let is_ast_file = + try + let buffer = String.create (String.length ast_magic) in + really_input ic buffer 0 (String.length ast_magic); + if buffer = ast_magic then true + else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then + raise Outdated_version + else false + with + Outdated_version -> + fatal_error "Ocaml and preprocessor have incompatible versions" + | _ -> false + in + let ast = + try + if is_ast_file then begin + Location.input_name := input_value ic; + input_value ic + end else begin + seek_in ic 0; + Location.input_name := inputfile; + let lexbuf = Lexing.from_channel ic in + Location.init lexbuf inputfile; + parse_fun lexbuf + end + with x -> close_in ic; raise x + in + close_in ic; + ast + +let (++) x f = f x + +(** Analysis of an implementation file. Returns (Some typedtree) if + no error occured, else None and an error message is printed.*) +let process_implementation_file ppf sourcefile = + init_path (); + let prefixname = Filename.chop_extension sourcefile in + let modulename = String.capitalize(Filename.basename prefixname) in + Env.set_unit_name modulename; + let inputfile = preprocess sourcefile in + let env = initial_env () in + try + let parsetree = parse_file inputfile Parse.implementation ast_impl_magic_number in + let typedtree = Typemod.type_implementation sourcefile prefixname modulename env parsetree in + (Some (parsetree, typedtree), inputfile) + with + e -> + match e with + Syntaxerr.Error err -> + fprintf Format.err_formatter "@[%a@]@." + Syntaxerr.report_error err; + None, inputfile + | Failure s -> + prerr_endline s; + incr Odoc_global.errors ; + None, inputfile + | e -> + raise e + +(** Analysis of an interface file. Returns (Some signature) if + no error occured, else None and an error message is printed.*) +let process_interface_file ppf sourcefile = + init_path (); + let prefixname = Filename.chop_extension sourcefile in + let modulename = String.capitalize(Filename.basename prefixname) in + Env.set_unit_name modulename; + let inputfile = preprocess sourcefile in + let ast = parse_file inputfile Parse.interface ast_intf_magic_number in + let sg = Typemod.transl_signature (initial_env()) ast in + Warnings.check_fatal (); + (ast, sg, inputfile) + +(** The module used to analyse the parsetree and signature of an implementation file.*) +module Ast_analyser = Odoc_ast.Analyser (Odoc_comments.Basic_info_retriever) + +(** The module used to analyse the parse tree and typed tree of an interface file.*) +module Sig_analyser = Odoc_sig.Analyser (Odoc_comments.Basic_info_retriever) + +(** Handle an error. This is a partial copy of the compiler + driver/error.ml file. We do this because there are + some differences between the possibly raised exceptions + in the bytecode (error.ml) and opt (opterros.ml) compilers + and we don't want to take care of this. Besises, these + differences only concern code generation (i believe).*) +let process_error exn = + let report ppf = function + | Lexer.Error(err, loc) -> + Location.print_error ppf loc; + Lexer.report_error ppf err + | Syntaxerr.Error err -> + Syntaxerr.report_error ppf err + | Env.Error err -> + Location.print_error_cur_file ppf; + Env.report_error ppf err + | Ctype.Tags(l, l') -> + Location.print_error_cur_file ppf; + fprintf ppf + "In this program,@ variant constructors@ `%s and `%s@ \ + have the same hash value." l l' + | Typecore.Error(loc, err) -> + Location.print_error ppf loc; Typecore.report_error ppf err + | Typetexp.Error(loc, err) -> + Location.print_error ppf loc; Typetexp.report_error ppf err + | Typedecl.Error(loc, err) -> + Location.print_error ppf loc; Typedecl.report_error ppf err + | Includemod.Error err -> + Location.print_error_cur_file ppf; + Includemod.report_error ppf err + | Typemod.Error(loc, err) -> + Location.print_error ppf loc; Typemod.report_error ppf err + | Translcore.Error(loc, err) -> + Location.print_error ppf loc; Translcore.report_error ppf err + | Sys_error msg -> + Location.print_error_cur_file ppf; + fprintf ppf "I/O error: %s" msg + | Typeclass.Error(loc, err) -> + Location.print_error ppf loc; Typeclass.report_error ppf err + | Translclass.Error(loc, err) -> + Location.print_error ppf loc; Translclass.report_error ppf err + | Warnings.Errors (n) -> + Location.print_error_cur_file ppf; + fprintf ppf "Error-enabled warnings (%d occurrences)" n + | x -> + fprintf ppf "@]"; + fprintf ppf + "Compilation error(%s). Use the OCaml compiler to get more details." + (Printexc.to_string x) + in + Format.fprintf Format.err_formatter "@[%a@]@." report exn + +(** Process the given file, according to its extension. Return the Module.t created, if any.*) +let process_file ppf sourcefile = + if !Odoc_global.verbose then + ( + let f = match sourcefile with + Odoc_global.Impl_file f + | Odoc_global.Intf_file f -> f + | Odoc_global.Text_file f -> f + in + print_string (Odoc_messages.analysing f) ; + print_newline (); + ); + match sourcefile with + Odoc_global.Impl_file file -> + ( + Location.input_name := file; + try + let (parsetree_typedtree_opt, input_file) = process_implementation_file ppf file in + match parsetree_typedtree_opt with + None -> + None + | Some (parsetree, typedtree) -> + let file_module = Ast_analyser.analyse_typed_tree file + !Location.input_name parsetree typedtree + in + file_module.Odoc_module.m_top_deps <- Odoc_dep.impl_dependencies parsetree ; + + if !Odoc_global.verbose then + ( + print_string Odoc_messages.ok; + print_newline () + ); + remove_preprocessed input_file; + Some file_module + with + | Sys_error s + | Failure s -> + prerr_endline s ; + incr Odoc_global.errors ; + None + | e -> + process_error e ; + incr Odoc_global.errors ; + None + ) + | Odoc_global.Intf_file file -> + ( + Location.input_name := file; + try + let (ast, signat, input_file) = process_interface_file ppf file in + let file_module = Sig_analyser.analyse_signature file + !Location.input_name ast signat + in + + file_module.Odoc_module.m_top_deps <- Odoc_dep.intf_dependencies ast ; + + if !Odoc_global.verbose then + ( + print_string Odoc_messages.ok; + print_newline () + ); + remove_preprocessed input_file; + Some file_module + with + | Sys_error s + | Failure s -> + prerr_endline s; + incr Odoc_global.errors ; + None + | e -> + process_error e ; + incr Odoc_global.errors ; + None + ) + | Odoc_global.Text_file file -> + Location.input_name := file; + try + let mod_name = + String.capitalize (Filename.basename (Filename.chop_extension file)) + in + let txt = + try Odoc_text.Texter.text_of_string (Odoc_misc.input_file_as_string file) + with Odoc_text.Text_syntax (l, c, s) -> + raise (Failure (Odoc_messages.text_parse_error l c s)) + in + let m = + { + Odoc_module.m_name = mod_name ; + Odoc_module.m_type = Types.Tmty_signature [] ; + Odoc_module.m_info = None ; + Odoc_module.m_is_interface = true ; + Odoc_module.m_file = file ; + Odoc_module.m_kind = Odoc_module.Module_struct + [Odoc_module.Element_module_comment txt] ; + Odoc_module.m_loc = + { Odoc_types.loc_impl = None ; + Odoc_types.loc_inter = Some (file, 0) } ; + Odoc_module.m_top_deps = [] ; + Odoc_module.m_code = None ; + Odoc_module.m_code_intf = None ; + Odoc_module.m_text_only = true ; + } + in + Some m + with + | Sys_error s + | Failure s -> + prerr_endline s; + incr Odoc_global.errors ; + None + | e -> + process_error e ; + incr Odoc_global.errors ; + None + +(** Remove the class elements between the stop special comments. *) +let rec remove_class_elements_between_stop keep eles = + match eles with + [] -> [] + | ele :: q -> + match ele with + Odoc_class.Class_comment [ Odoc_types.Raw "/*" ] -> + remove_class_elements_between_stop (not keep) q + | Odoc_class.Class_attribute _ + | Odoc_class.Class_method _ + | Odoc_class.Class_comment _ -> + if keep then + ele :: (remove_class_elements_between_stop keep q) + else + remove_class_elements_between_stop keep q + +(** Remove the class elements between the stop special comments in a class kind. *) +let rec remove_class_elements_between_stop_in_class_kind k = + match k with + Odoc_class.Class_structure (inher, l) -> + Odoc_class.Class_structure (inher, remove_class_elements_between_stop true l) + | Odoc_class.Class_apply _ -> k + | Odoc_class.Class_constr _ -> k + | Odoc_class.Class_constraint (k1, ctk) -> + Odoc_class.Class_constraint (remove_class_elements_between_stop_in_class_kind k1, + remove_class_elements_between_stop_in_class_type_kind ctk) + +(** Remove the class elements beetween the stop special comments in a class type kind. *) +and remove_class_elements_between_stop_in_class_type_kind tk = + match tk with + Odoc_class.Class_signature (inher, l) -> + Odoc_class.Class_signature (inher, remove_class_elements_between_stop true l) + | Odoc_class.Class_type _ -> tk + + +(** Remove the module elements between the stop special comments. *) +let rec remove_module_elements_between_stop keep eles = + let f = remove_module_elements_between_stop in + match eles with + [] -> [] + | ele :: q -> + match ele with + Odoc_module.Element_module_comment [ Odoc_types.Raw "/*" ] -> + f (not keep) q + | Odoc_module.Element_module_comment _ -> + if keep then + ele :: (f keep q) + else + f keep q + | Odoc_module.Element_module m -> + if keep then + ( + m.Odoc_module.m_kind <- remove_module_elements_between_stop_in_module_kind m.Odoc_module.m_kind ; + (Odoc_module.Element_module m) :: (f keep q) + ) + else + f keep q + | Odoc_module.Element_module_type mt -> + if keep then + ( + mt.Odoc_module.mt_kind <- Odoc_misc.apply_opt + remove_module_elements_between_stop_in_module_type_kind mt.Odoc_module.mt_kind ; + (Odoc_module.Element_module_type mt) :: (f keep q) + ) + else + f keep q + | Odoc_module.Element_included_module _ -> + if keep then + ele :: (f keep q) + else + f keep q + | Odoc_module.Element_class c -> + if keep then + ( + c.Odoc_class.cl_kind <- remove_class_elements_between_stop_in_class_kind c.Odoc_class.cl_kind ; + (Odoc_module.Element_class c) :: (f keep q) + ) + else + f keep q + | Odoc_module.Element_class_type ct -> + if keep then + ( + ct.Odoc_class.clt_kind <- remove_class_elements_between_stop_in_class_type_kind ct.Odoc_class.clt_kind ; + (Odoc_module.Element_class_type ct) :: (f keep q) + ) + else + f keep q + | Odoc_module.Element_value _ + | Odoc_module.Element_exception _ + | Odoc_module.Element_type _ -> + if keep then + ele :: (f keep q) + else + f keep q + + +(** Remove the module elements between the stop special comments, in the given module kind. *) +and remove_module_elements_between_stop_in_module_kind k = + match k with + | Odoc_module.Module_struct l -> Odoc_module.Module_struct (remove_module_elements_between_stop true l) + | Odoc_module.Module_alias _ -> k + | Odoc_module.Module_functor (params, k2) -> + Odoc_module.Module_functor (params, remove_module_elements_between_stop_in_module_kind k2) + | Odoc_module.Module_apply (k1, k2) -> + Odoc_module.Module_apply (remove_module_elements_between_stop_in_module_kind k1, + remove_module_elements_between_stop_in_module_kind k2) + | Odoc_module.Module_with (mtkind, s) -> + Odoc_module.Module_with (remove_module_elements_between_stop_in_module_type_kind mtkind, s) + | Odoc_module.Module_constraint (k2, mtkind) -> + Odoc_module.Module_constraint (remove_module_elements_between_stop_in_module_kind k2, + remove_module_elements_between_stop_in_module_type_kind mtkind) + | Odoc_module.Module_typeof _ -> k + | Odoc_module.Module_unpack _ -> k + +(** Remove the module elements between the stop special comment, in the given module type kind. *) +and remove_module_elements_between_stop_in_module_type_kind tk = + match tk with + | Odoc_module.Module_type_struct l -> Odoc_module.Module_type_struct (remove_module_elements_between_stop true l) + | Odoc_module.Module_type_functor (params, tk2) -> + Odoc_module.Module_type_functor (params, remove_module_elements_between_stop_in_module_type_kind tk2) + | Odoc_module.Module_type_alias _ -> tk + | Odoc_module.Module_type_with (tk2, s) -> + Odoc_module.Module_type_with (remove_module_elements_between_stop_in_module_type_kind tk2, s) + | Odoc_module.Module_type_typeof _ -> tk + +(** Remove elements between the stop special comment. *) +let remove_elements_between_stop module_list = + List.map + (fun m -> + m.Odoc_module.m_kind <- remove_module_elements_between_stop_in_module_kind m.Odoc_module.m_kind; + m + ) + module_list + +(** This function builds the modules from the given list of source files. *) +let analyse_files ?(init=[]) files = + let modules_pre = + init @ + (List.fold_left + (fun acc -> fun file -> + try + match process_file Format.err_formatter file with + None -> + acc + | Some m -> + acc @ [ m ] + with + Failure s -> + prerr_endline s ; + incr Odoc_global.errors ; + acc + ) + [] + files + ) + in + (* Remove elements between the stop special comments, if needed. *) + let modules = + if !Odoc_global.no_stop then + modules_pre + else + remove_elements_between_stop modules_pre + in + + + if !Odoc_global.verbose then + ( + print_string Odoc_messages.merging; + print_newline () + ); + let merged_modules = Odoc_merge.merge !Odoc_global.merge_options modules in + if !Odoc_global.verbose then + ( + print_string Odoc_messages.ok; + print_newline (); + ); + let modules_list = + (List.fold_left + (fun acc -> fun m -> acc @ (Odoc_module.module_all_submodules ~trans: false m)) + merged_modules + merged_modules + ) + in + if !Odoc_global.verbose then + ( + print_string Odoc_messages.cross_referencing; + print_newline () + ); + let _ = Odoc_cross.associate modules_list in + + if !Odoc_global.verbose then + ( + print_string Odoc_messages.ok; + print_newline (); + ); + + if !Odoc_global.sort_modules then + Sort.list (fun m1 -> fun m2 -> m1.Odoc_module.m_name < m2.Odoc_module.m_name) merged_modules + else + merged_modules + +let dump_modules file (modules : Odoc_module.t_module list) = + try + let chanout = open_out_bin file in + let dump = Odoc_types.make_dump modules in + output_value chanout dump; + close_out chanout + with + Sys_error s -> + raise (Failure s) + +let load_modules file = + try + let chanin = open_in_bin file in + let dump = input_value chanin in + close_in chanin ; + let (l : Odoc_module.t_module list) = Odoc_types.open_dump dump in + l + with + Sys_error s -> + raise (Failure s) diff --git a/ocaml-binary-annot/ocamldoc/odoc_analyse.mli b/ocaml-binary-annot/ocamldoc/odoc_analyse.mli new file mode 100644 index 0000000000..b927ad4a06 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_analyse.mli @@ -0,0 +1,31 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Analysis of source files. *) + +(** This function builds the top modules from the analysis of the + given list of source files. + @param init is the list of modules already known from a previous analysis. +*) +val analyse_files : + ?init: Odoc_module.t_module list -> + Odoc_global.source_file list -> + Odoc_module.t_module list + +(** Dump of a list of modules into a file. + @raise Failure if an error occurs.*) +val dump_modules : string -> Odoc_module.t_module list -> unit + +(** Load of a list of modules from a file. + @raise Failure if an error occurs.*) +val load_modules : string -> Odoc_module.t_module list diff --git a/ocaml-binary-annot/ocamldoc/odoc_args.ml b/ocaml-binary-annot/ocamldoc/odoc_args.ml new file mode 100644 index 0000000000..f3500f51d3 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_args.ml @@ -0,0 +1,245 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* cvsid $Id$ *) + +(** Command-line arguments. *) + +module M = Odoc_messages + +let current_generator = ref (None : Odoc_gen.generator option) + +(** 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_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 options = ref [ + "-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 ; + "-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 ^ + "\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 add_option o = + 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 + 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 diff --git a/ocaml-binary-annot/ocamldoc/odoc_args.mli b/ocaml-binary-annot/ocamldoc/odoc_args.mli new file mode 100644 index 0000000000..2f190ef756 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_args.mli @@ -0,0 +1,27 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Analysis of the command line arguments. *) + +(** The current module defining the generator to use. *) +val current_generator : Odoc_gen.generator option ref + +(** To set the documentation generator. *) +val set_generator : Odoc_gen.generator -> unit + +(** Add an option specification. *) +val add_option : string * Arg.spec * string -> unit + +(** Parse the args. + [byte] indicate if we are in bytecode mode (default is [true]).*) +val parse : unit -> unit diff --git a/ocaml-binary-annot/ocamldoc/odoc_ast.ml b/ocaml-binary-annot/ocamldoc/odoc_ast.ml new file mode 100644 index 0000000000..c497794184 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_ast.ml @@ -0,0 +1,1738 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Analysis of implementation files. *) +open Misc +open Asttypes +open Types +open Typedtree + +let print_DEBUG3 s = print_string s ; print_newline ();; +let print_DEBUG s = print_string s ; print_newline ();; + +type typedtree = (Typedtree.structure * Typedtree.module_coercion) + +module Name = Odoc_name +open Odoc_parameter +open Odoc_value +open Odoc_type +open Odoc_exception +open Odoc_class +open Odoc_module +open Odoc_types + +(** This variable contains the regular expression representing a blank.*) +let blank = "[ \010\013\009\012']" + +(** This variable contains the regular expression representing a blank but not a '\n'.*) +let simple_blank = "[ \013\009\012]" + +(** This module is used to search for structure items by name in a Typedtree.structure. + One function creates two hash tables, which can then be used to search for elements. + Class elements do not use tables. +*) +module Typedtree_search = + struct + type ele = + | M of string + | MT of string + | T of string + | C of string + | CT of string + | E of string + | ER of string + | P of string + | IM of string + + type tab = (ele, Typedtree.structure_item) Hashtbl.t + type tab_values = (Odoc_module.Name.t, Typedtree.pattern * Typedtree.expression) Hashtbl.t + + let iter_val_pattern = function + | Typedtree.Tpat_any -> None + | Typedtree.Tpat_var name -> Some (Name.from_ident name) + | Typedtree.Tpat_tuple _ -> None (* A VOIR quand on traitera les tuples *) + | _ -> None + + let add_to_hashes table table_values tt = + match tt with + | Typedtree.Tstr_module (ident, _) -> + Hashtbl.add table (M (Name.from_ident ident)) tt + | Typedtree.Tstr_recmodule mods -> + List.iter + (fun (ident,mod_expr) -> + Hashtbl.add table (M (Name.from_ident ident)) + (Typedtree.Tstr_module (ident,mod_expr)) + ) + mods + | Typedtree.Tstr_modtype (ident, _) -> + Hashtbl.add table (MT (Name.from_ident ident)) tt + | Typedtree.Tstr_exception (ident, _) -> + Hashtbl.add table (E (Name.from_ident ident)) tt + | Typedtree.Tstr_exn_rebind (ident, _) -> + Hashtbl.add table (ER (Name.from_ident ident)) tt + | Typedtree.Tstr_type ident_type_decl_list -> + List.iter + (fun (id, e) -> + Hashtbl.add table (T (Name.from_ident id)) + (Typedtree.Tstr_type [(id,e)])) + ident_type_decl_list + | Typedtree.Tstr_class info_list -> + List.iter + (fun ((id,_,_,_,_) as ci) -> + Hashtbl.add table (C (Name.from_ident id)) + (Typedtree.Tstr_class [ci])) + info_list + | Typedtree.Tstr_cltype info_list -> + List.iter + (fun ((id,_) as ci) -> + Hashtbl.add table + (CT (Name.from_ident id)) + (Typedtree.Tstr_cltype [ci])) + info_list + | Typedtree.Tstr_value (_, pat_exp_list) -> + List.iter + (fun (pat,exp) -> + match iter_val_pattern pat.Typedtree.pat_desc with + None -> () + | Some n -> Hashtbl.add table_values n (pat,exp) + ) + pat_exp_list + | Typedtree.Tstr_primitive (ident, _) -> + Hashtbl.add table (P (Name.from_ident ident)) tt + | Typedtree.Tstr_open _ -> () + | Typedtree.Tstr_include _ -> () + | Typedtree.Tstr_eval _ -> () + + let tables typedtree = + let t = Hashtbl.create 13 in + let t_values = Hashtbl.create 13 in + List.iter (add_to_hashes t t_values) typedtree; + (t, t_values) + + let search_module table name = + match Hashtbl.find table (M name) with + (Typedtree.Tstr_module (_, module_expr)) -> module_expr + | _ -> assert false + + let search_module_type table name = + match Hashtbl.find table (MT name) with + | (Typedtree.Tstr_modtype (_, module_type)) -> module_type + | _ -> assert false + + let search_exception table name = + match Hashtbl.find table (E name) with + | (Typedtree.Tstr_exception (_, excep_decl)) -> excep_decl + | _ -> assert false + + let search_exception_rebind table name = + match Hashtbl.find table (ER name) with + | (Typedtree.Tstr_exn_rebind (_, p)) -> p + | _ -> assert false + + let search_type_declaration table name = + match Hashtbl.find table (T name) with + | (Typedtree.Tstr_type [(_,decl)]) -> decl + | _ -> assert false + + let search_class_exp table name = + match Hashtbl.find table (C name) with + | (Typedtree.Tstr_class [(_,_,_,ce,_)]) -> + ( + try + let type_decl = search_type_declaration table name in + (ce, type_decl.Types.type_params) + with + Not_found -> + (ce, []) + ) + | _ -> assert false + + let search_class_type_declaration table name = + match Hashtbl.find table (CT name) with + | (Typedtree.Tstr_cltype [(_,cltype_decl)]) -> cltype_decl + | _ -> assert false + + let search_value table name = Hashtbl.find table name + + let search_primitive table name = + match Hashtbl.find table (P name) with + Tstr_primitive (ident, val_desc) -> val_desc.Types.val_type + | _ -> assert false + + let get_nth_inherit_class_expr cls n = + let rec iter cpt = function + | [] -> + raise Not_found + | Typedtree.Cf_inher (clexp, _, _) :: q -> + if n = cpt then clexp else iter (cpt+1) q + | _ :: q -> + iter cpt q + in + iter 0 cls.Typedtree.cl_field + + let search_attribute_type cls name = + let rec iter = function + | [] -> + raise Not_found + | Typedtree.Cf_val (_, ident, Some exp, _) :: q + when Name.from_ident ident = name -> + exp.Typedtree.exp_type + | _ :: q -> + iter q + in + iter cls.Typedtree.cl_field + + let class_sig_of_cltype_decl = + let rec iter = function + Types.Tcty_constr (_, _, cty) -> iter cty + | Types.Tcty_signature s -> s + | Types.Tcty_fun (_,_, cty) -> iter cty + in + fun ct_decl -> iter ct_decl.Types.clty_type + + let search_virtual_attribute_type table ctname name = + let ct_decl = search_class_type_declaration table ctname in + let cls_sig = class_sig_of_cltype_decl ct_decl in + let (_,_,texp) = Types.Vars.find name cls_sig.cty_vars in + texp + + let search_method_expression cls name = + let rec iter = function + | [] -> + raise Not_found + | Typedtree.Cf_meth (label, exp) :: q when label = name -> + exp + | _ :: q -> + iter q + in + iter cls.Typedtree.cl_field + end + +module Analyser = + functor (My_ir : Odoc_sig.Info_retriever) -> + + struct + module Sig = Odoc_sig.Analyser (My_ir) + + (** This variable is used to load a file as a string and retrieve characters from it.*) + let file = Sig.file + + (** The name of the analysed file. *) + let file_name = Sig.file_name + + (** This function takes two indexes (start and end) and return the string + corresponding to the indexes in the file global variable. The function + prepare_file must have been called to fill the file global variable.*) + let get_string_of_file = Sig.get_string_of_file + + (** This function loads the given file in the file global variable. + and sets file_name.*) + let prepare_file = Sig.prepare_file + + (** The function used to get the comments in a class. *) + let get_comments_in_class = Sig.get_comments_in_class + + (** The function used to get the comments in a module. *) + let get_comments_in_module = Sig.get_comments_in_module + + (** This function takes a parameter pattern and builds the + corresponding [parameter] structure. The f_desc function + is used to retrieve a parameter description, if any, from + a parameter name. + *) + let tt_param_info_from_pattern env f_desc pat = + let rec iter_pattern pat = + match pat.pat_desc with + Typedtree.Tpat_var ident -> + let name = Name.from_ident ident in + Simple_name { sn_name = name ; + sn_text = f_desc name ; + sn_type = Odoc_env.subst_type env pat.pat_type + } + + | Typedtree.Tpat_alias (pat, _) -> + iter_pattern pat + + | Typedtree.Tpat_tuple patlist -> + Tuple + (List.map iter_pattern patlist, + Odoc_env.subst_type env pat.pat_type) + + | Typedtree.Tpat_construct (cons_desc, _) when + (* we give a name to the parameter only if it unit *) + (match cons_desc.cstr_res.desc with + Tconstr (p, _, _) -> + Path.same p Predef.path_unit + | _ -> + false) + -> + (* a () argument, it never has description *) + Simple_name { sn_name = "()" ; + sn_text = None ; + sn_type = Odoc_env.subst_type env pat.pat_type + } + + | _ -> + (* implicit pattern matching -> anonymous parameter *) + Simple_name { sn_name = "()" ; + sn_text = None ; + sn_type = Odoc_env.subst_type env pat.pat_type + } + in + iter_pattern pat + + (** Analysis of the parameter of a function. Return a list of t_parameter created from + the (pattern, expression) structures encountered. *) + let rec tt_analyse_function_parameters env current_comment_opt pat_exp_list = + match pat_exp_list with + [] -> + (* This case means we have a 'function' without pattern, that's impossible *) + raise (Failure "tt_analyse_function_parameters: 'function' without pattern") + + | (pattern_param, exp) :: second_ele :: q -> + (* implicit pattern matching -> anonymous parameter and no more parameter *) + (* A VOIR : le label ? *) + let parameter = Odoc_parameter.Tuple ([], Odoc_env.subst_type env pattern_param.pat_type) in + [ parameter ] + + | (pattern_param, func_body) :: [] -> + let parameter = + tt_param_info_from_pattern + env + (Odoc_parameter.desc_from_info_opt current_comment_opt) + pattern_param + + in + (* For optional parameters with a default value, a special treatment is required *) + (* we look if the name of the parameter we just add is "*opt*", which means + that there is a let param_name = ... in ... just right now *) + let (p, next_exp) = + match parameter with + Simple_name { sn_name = "*opt*" } -> + ( + ( + match func_body.exp_desc with + Typedtree.Texp_let (_, ({pat_desc = Typedtree.Tpat_var id } , exp) :: _, func_body2) -> + let name = Name.from_ident id in + let new_param = Simple_name + { sn_name = name ; + sn_text = Odoc_parameter.desc_from_info_opt current_comment_opt name ; + sn_type = Odoc_env.subst_type env exp.exp_type + } + in + (new_param, func_body2) + | _ -> + print_DEBUG3 "Pas le bon filtre pour le parametre optionnel avec valeur par defaut."; + (parameter, func_body) + ) + ) + | _ -> + (parameter, func_body) + in + (* continue if the body is still a function *) + match next_exp.exp_desc with + Texp_function (pat_exp_list, _) -> + p :: (tt_analyse_function_parameters env current_comment_opt pat_exp_list) + | _ -> + (* something else ; no more parameter *) + [ p ] + + (** Analysis of a Tstr_value from the typedtree. Create and return a list of [t_value]. + @raise Failure if an error occurs.*) + let tt_analyse_value env current_module_name comment_opt loc pat_exp rec_flag = + let (pat, exp) = pat_exp in + match (pat.pat_desc, exp.exp_desc) with + (Typedtree.Tpat_var ident, Typedtree.Texp_function (pat_exp_list2, partial)) -> + (* a new function is defined *) + let name_pre = Name.from_ident ident in + let name = Name.parens_if_infix name_pre in + let complete_name = Name.concat current_module_name name in + (* create the value *) + let new_value = { + val_name = complete_name ; + val_info = comment_opt ; + val_type = Odoc_env.subst_type env pat.Typedtree.pat_type ; + val_recursive = rec_flag = Asttypes.Recursive ; + val_parameters = tt_analyse_function_parameters env comment_opt pat_exp_list2 ; + val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ; + val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ; + } + in + [ new_value ] + + | (Typedtree.Tpat_var ident, _) -> + (* a new value is defined *) + let name_pre = Name.from_ident ident in + let name = Name.parens_if_infix name_pre in + let complete_name = Name.concat current_module_name name in + let new_value = { + val_name = complete_name ; + val_info = comment_opt ; + val_type = Odoc_env.subst_type env pat.Typedtree.pat_type ; + val_recursive = rec_flag = Asttypes.Recursive ; + val_parameters = [] ; + val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ; + val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ; + } + in + [ new_value ] + + | (Typedtree.Tpat_tuple lpat, _) -> + (* new identifiers are defined *) + (* A VOIR : by now we don't accept to have global variables defined in tuples *) + [] + + | _ -> + (* something else, we don't care ? A VOIR *) + [] + + (** This function takes a Typedtree.class_expr and returns a string which can stand for the class name. + The name can be "object ... end" if the class expression is not an ident or a class constraint or a class apply. *) + let rec tt_name_of_class_expr clexp = +(* + ( + match clexp.Typedtree.cl_desc with + Tclass_ident _ -> prerr_endline "Tclass_ident" + | Tclass_structure _ -> prerr_endline "Tclass_structure" + | Tclass_fun _ -> prerr_endline "Tclass_fun" + | Tclass_apply _ -> prerr_endline "Tclass_apply" + | Tclass_let _ -> prerr_endline "Tclass_let" + | Tclass_constraint _ -> prerr_endline "Tclass_constraint" + ); +*) + match clexp.Typedtree.cl_desc with + Typedtree.Tclass_ident p -> Name.from_path p + | Typedtree.Tclass_constraint (class_expr, _, _, _) + | Typedtree.Tclass_apply (class_expr, _) -> tt_name_of_class_expr class_expr +(* + | Typedtree.Tclass_fun (_, _, class_expr, _) -> tt_name_of_class_expr class_expr + | Typedtree.Tclass_let (_,_,_, class_expr) -> tt_name_of_class_expr class_expr +*) + | _ -> Odoc_messages.object_end + + (** Analysis of a method expression to get the method parameters. + @param first indicates if we're analysing the method for + the first time ; in that case we must not keep the first parameter, + which is "self-*", the object itself. + *) + let rec tt_analyse_method_expression env current_method_name comment_opt ?(first=true) exp = + match exp.Typedtree.exp_desc with + Typedtree.Texp_function (pat_exp_list, _) -> + ( + match pat_exp_list with + [] -> + (* it is not a function since there are no parameters *) + (* we can't get here normally *) + raise (Failure (Odoc_messages.bad_tree^" "^(Odoc_messages.method_without_param current_method_name))) + | l -> + match l with + [] -> + (* cas impossible, on l'a filtré avant *) + assert false + | (pattern_param, exp) :: second_ele :: q -> + (* implicit pattern matching -> anonymous parameter *) + (* Note : We can't match this pattern if it is the first call to the function. *) + let new_param = Simple_name + { sn_name = "??" ; sn_text = None; + sn_type = Odoc_env.subst_type env pattern_param.Typedtree.pat_type } + in + [ new_param ] + + | (pattern_param, body) :: [] -> + (* if this is the first call to the function, this is the first parameter and we skip it *) + if not first then + ( + let parameter = + tt_param_info_from_pattern + env + (Odoc_parameter.desc_from_info_opt comment_opt) + pattern_param + in + (* For optional parameters with a default value, a special treatment is required. *) + (* We look if the name of the parameter we just add is "*opt*", which means + that there is a let param_name = ... in ... just right now. *) + let (current_param, next_exp) = + match parameter with + Simple_name { sn_name = "*opt*"} -> + ( + ( + match body.exp_desc with + Typedtree.Texp_let (_, ({pat_desc = Typedtree.Tpat_var id } , exp) :: _, body2) -> + let name = Name.from_ident id in + let new_param = Simple_name + { sn_name = name ; + sn_text = Odoc_parameter.desc_from_info_opt comment_opt name ; + sn_type = Odoc_env.subst_type env exp.Typedtree.exp_type ; + } + in + (new_param, body2) + | _ -> + print_DEBUG3 "Pas le bon filtre pour le parametre optionnel avec valeur par defaut."; + (parameter, body) + ) + ) + | _ -> + (* no *opt* parameter, we add the parameter then continue *) + (parameter, body) + in + current_param :: (tt_analyse_method_expression env current_method_name comment_opt ~first: false next_exp) + ) + else + tt_analyse_method_expression env current_method_name comment_opt ~first: false body + ) + | _ -> + (* no more parameter *) + [] + + (** Analysis of a [Parsetree.class_struture] and a [Typedtree.class_structure] to get a couple + (inherited classes, class elements). *) + let analyse_class_structure env current_class_name tt_class_sig last_pos pos_limit p_cls tt_cls table = + let rec iter acc_inher acc_fields last_pos = function + | [] -> + let s = get_string_of_file last_pos pos_limit in + let (_, ele_coms) = My_ir.all_special !file_name s in + let ele_comments = + List.fold_left + (fun acc -> fun sc -> + match sc.Odoc_types.i_desc with + None -> + acc + | Some t -> + acc @ [Class_comment t]) + [] + ele_coms + in + (acc_inher, acc_fields @ ele_comments) + + | (Parsetree.Pcf_inher (_, p_clexp, _)) :: q -> + let tt_clexp = + let n = List.length acc_inher in + try Typedtree_search.get_nth_inherit_class_expr tt_cls n + with Not_found -> + raise (Failure ( + Odoc_messages.inherit_classexp_not_found_in_typedtree n)) + in + let (info_opt, ele_comments) = + get_comments_in_class last_pos + p_clexp.Parsetree.pcl_loc.Location.loc_start.Lexing.pos_cnum + in + let text_opt = + match info_opt with None -> None + | Some i -> i.Odoc_types.i_desc in + let name = tt_name_of_class_expr tt_clexp in + let inher = + { + ic_name = Odoc_env.full_class_or_class_type_name env name ; + ic_class = None ; + ic_text = text_opt ; + } + in + iter (acc_inher @ [ inher ]) (acc_fields @ ele_comments) + p_clexp.Parsetree.pcl_loc.Location.loc_end.Lexing.pos_cnum + q + + | ((Parsetree.Pcf_val (label, mutable_flag, _, _, loc) | + Parsetree.Pcf_valvirt (label, mutable_flag, _, loc) ) as x) :: q -> + let virt = match x with Parsetree.Pcf_val _ -> false | _ -> true in + let complete_name = Name.concat current_class_name label in + let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in + let type_exp = + try + if virt then + Typedtree_search.search_virtual_attribute_type table + (Name.simple current_class_name) label + else + Typedtree_search.search_attribute_type tt_cls label + with Not_found -> + raise (Failure (Odoc_messages.attribute_not_found_in_typedtree complete_name)) + in + let att = + { + att_value = { val_name = complete_name ; + val_info = info_opt ; + val_type = Odoc_env.subst_type env type_exp ; + val_recursive = false ; + val_parameters = [] ; + val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ; + val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ; + } ; + att_mutable = mutable_flag = Asttypes.Mutable ; + att_virtual = virt ; + } + in + iter acc_inher (acc_fields @ ele_comments @ [ Class_attribute att ]) loc.Location.loc_end.Lexing.pos_cnum q + + | (Parsetree.Pcf_virt (label, private_flag, _, loc)) :: q -> + let complete_name = Name.concat current_class_name label in + let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in + let met_type = + try Odoc_sig.Signature_search.search_method_type label tt_class_sig + with Not_found -> raise (Failure (Odoc_messages.method_type_not_found current_class_name label)) + in + let real_type = + match met_type.Types.desc with + Tarrow (_, _, t, _) -> + t + | _ -> + (* ?!? : not an arrow type ! return the original type *) + met_type + in + let met = + { + met_value = { val_name = complete_name ; + val_info = info_opt ; + val_type = Odoc_env.subst_type env real_type ; + val_recursive = false ; + val_parameters = [] ; + val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ; + val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ; + } ; + met_private = private_flag = Asttypes.Private ; + met_virtual = true ; + } + in + (* update the parameter description *) + Odoc_value.update_value_parameters_text met.met_value; + + iter acc_inher (acc_fields @ ele_comments @ [ Class_method met ]) loc.Location.loc_end.Lexing.pos_cnum q + + | (Parsetree.Pcf_meth (label, private_flag, _, _, loc)) :: q -> + let complete_name = Name.concat current_class_name label in + let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in + let exp = + try Typedtree_search.search_method_expression tt_cls label + with Not_found -> raise (Failure (Odoc_messages.method_not_found_in_typedtree complete_name)) + in + let real_type = + match exp.exp_type.desc with + Tarrow (_, _, t,_) -> + t + | _ -> + (* ?!? : not an arrow type ! return the original type *) + exp.Typedtree.exp_type + in + let met = + { + met_value = { val_name = complete_name ; + val_info = info_opt ; + val_type = Odoc_env.subst_type env real_type ; + val_recursive = false ; + val_parameters = tt_analyse_method_expression env complete_name info_opt exp ; + val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ; + val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ; + } ; + met_private = private_flag = Asttypes.Private ; + met_virtual = false ; + } + in + (* update the parameter description *) + Odoc_value.update_value_parameters_text met.met_value; + + iter acc_inher (acc_fields @ ele_comments @ [ Class_method met ]) loc.Location.loc_end.Lexing.pos_cnum q + + | Parsetree.Pcf_cstr (_, _, loc) :: q -> + (* don't give a $*%@ ! *) + iter acc_inher acc_fields loc.Location.loc_end.Lexing.pos_cnum q + + | Parsetree.Pcf_let (_, _, loc) :: q -> + (* don't give a $*%@ ! *) + iter acc_inher acc_fields loc.Location.loc_end.Lexing.pos_cnum q + + | (Parsetree.Pcf_init exp) :: q -> + iter acc_inher acc_fields exp.Parsetree.pexp_loc.Location.loc_end.Lexing.pos_cnum q + in + iter [] [] last_pos (snd p_cls) + + (** Analysis of a [Parsetree.class_expr] and a [Typedtree.class_expr] to get a a couple (class parameters, class kind). *) + let rec analyse_class_kind env current_class_name comment_opt last_pos p_class_expr tt_class_exp table = + match (p_class_expr.Parsetree.pcl_desc, tt_class_exp.Typedtree.cl_desc) with + (Parsetree.Pcl_constr (lid, _), tt_class_exp_desc ) -> + let name = + match tt_class_exp_desc with + Typedtree.Tclass_ident p -> Name.from_path p + | _ -> + (* we try to get the name from the environment. *) + (* A VOIR : dommage qu'on n'ait pas un Tclass_ident :-( même quand on a class tutu = toto *) + Name.from_longident lid + in + (* On n'a pas ici les paramètres de type sous forme de Types.type_expr, + par contre on peut les trouver dans le class_type *) + let params = + match tt_class_exp.Typedtree.cl_type with + Types.Tcty_constr (p2, type_exp_list, cltyp) -> + (* cltyp is the class type for [type_exp_list] p *) + type_exp_list + | _ -> + [] + in + ([], + Class_constr + { + cco_name = Odoc_env.full_class_name env name ; + cco_class = None ; + cco_type_parameters = List.map (Odoc_env.subst_type env) params ; + } ) + + | (Parsetree.Pcl_structure p_class_structure, Typedtree.Tclass_structure tt_class_structure) -> + (* we need the class signature to get the type of methods in analyse_class_structure *) + let tt_class_sig = + match tt_class_exp.Typedtree.cl_type with + Types.Tcty_signature class_sig -> class_sig + | _ -> raise (Failure "analyse_class_kind: no class signature for a class structure.") + in + let (inherited_classes, class_elements) = analyse_class_structure + env + current_class_name + tt_class_sig + last_pos + p_class_expr.Parsetree.pcl_loc.Location.loc_end.Lexing.pos_cnum + p_class_structure + tt_class_structure + table + in + ([], + Class_structure (inherited_classes, class_elements) ) + + | (Parsetree.Pcl_fun (label, expression_opt, pattern, p_class_expr2), + Typedtree.Tclass_fun (pat, ident_exp_list, tt_class_expr2, partial)) -> + (* we check that this is not an optional parameter with + a default value. In this case, we look for the good parameter pattern *) + let (parameter, next_tt_class_exp) = + match pat.Typedtree.pat_desc with + Typedtree.Tpat_var ident when Name.from_ident ident = "*opt*" -> + ( + (* there must be a Tclass_let just after *) + match tt_class_expr2.Typedtree.cl_desc with + Typedtree.Tclass_let (_, ({pat_desc = Typedtree.Tpat_var id } , exp) :: _, _, tt_class_expr3) -> + let name = Name.from_ident id in + let new_param = Simple_name + { sn_name = name ; + sn_text = Odoc_parameter.desc_from_info_opt comment_opt name ; + sn_type = Odoc_env.subst_type env exp.exp_type + } + in + (new_param, tt_class_expr3) + | _ -> + (* strange case *) + (* we create the parameter and add it to the class *) + raise (Failure "analyse_class_kind: strange case") + ) + | _ -> + (* no optional parameter with default value, we create the parameter *) + let new_param = + tt_param_info_from_pattern + env + (Odoc_parameter.desc_from_info_opt comment_opt) + pat + in + (new_param, tt_class_expr2) + in + let (params, k) = analyse_class_kind + env current_class_name comment_opt last_pos p_class_expr2 + next_tt_class_exp table + in + (parameter :: params, k) + + | (Parsetree.Pcl_apply (p_class_expr2, _), Tclass_apply (tt_class_expr2, exp_opt_optional_list)) -> + let applied_name = + (* we want an ident, or else the class applied will appear in the form object ... end, + because if the class applied has no name, the code is kinda ugly, isn't it ? *) + match tt_class_expr2.Typedtree.cl_desc with + Typedtree.Tclass_ident p -> Name.from_path p (* A VOIR : obtenir le nom complet *) + | _ -> + (* A VOIR : dommage qu'on n'ait pas un Tclass_ident :-( même quand on a class tutu = toto *) + match p_class_expr2.Parsetree.pcl_desc with + Parsetree.Pcl_constr (lid, _) -> + (* we try to get the name from the environment. *) + Name.from_longident lid + | _ -> + Odoc_messages.object_end + in + let param_exps = List.fold_left + (fun acc -> fun (exp_opt, _) -> + match exp_opt with + None -> acc + | Some e -> acc @ [e]) + [] + exp_opt_optional_list + in + let param_types = List.map (fun e -> e.Typedtree.exp_type) param_exps in + let params_code = + List.map + (fun e -> get_string_of_file + e.exp_loc.Location.loc_start.Lexing.pos_cnum + e.exp_loc.Location.loc_end.Lexing.pos_cnum) + param_exps + in + ([], + Class_apply + { capp_name = Odoc_env.full_class_name env applied_name ; + capp_class = None ; + capp_params = param_types ; + capp_params_code = params_code ; + } ) + + | (Parsetree.Pcl_let (_, _, p_class_expr2), Typedtree.Tclass_let (_, _, _, tt_class_expr2)) -> + (* we don't care about these lets *) + analyse_class_kind + env current_class_name comment_opt last_pos p_class_expr2 + tt_class_expr2 table + + | (Parsetree.Pcl_constraint (p_class_expr2, p_class_type2), + Typedtree.Tclass_constraint (tt_class_expr2, _, _, _)) -> + let (l, class_kind) = analyse_class_kind + env current_class_name comment_opt last_pos p_class_expr2 + tt_class_expr2 table + in + (* A VOIR : analyse du class type ? on n'a pas toutes les infos. cf. Odoc_sig.analyse_class_type_kind *) + let class_type_kind = + (*Sig.analyse_class_type_kind + env + "" + p_class_type2.Parsetree.pcty_loc.Location.loc_start.Lexing.pos_cnum + p_class_type2 + tt_class_expr2.Typedtree.cl_type + *) + Class_type { cta_name = Odoc_messages.object_end ; + cta_class = None ; cta_type_parameters = [] } + in + (l, Class_constraint (class_kind, class_type_kind)) + + | _ -> + raise (Failure "analyse_class_kind: Parsetree and typedtree don't match.") + + (** Analysis of a [Parsetree.class_declaration] and a [Typedtree.class_expr] to return a [t_class].*) + let analyse_class env current_module_name comment_opt p_class_decl tt_type_params tt_class_exp table = + let name = p_class_decl.Parsetree.pci_name in + let complete_name = Name.concat current_module_name name in + let pos_start = p_class_decl.Parsetree.pci_expr.Parsetree.pcl_loc.Location.loc_start.Lexing.pos_cnum in + let type_parameters = tt_type_params in + let virt = p_class_decl.Parsetree.pci_virt = Asttypes.Virtual in + let cltype = Odoc_env.subst_class_type env tt_class_exp.Typedtree.cl_type in + let (parameters, kind) = analyse_class_kind + env + complete_name + comment_opt + pos_start + p_class_decl.Parsetree.pci_expr + tt_class_exp + table + in + let cl = + { + cl_name = complete_name ; + cl_info = comment_opt ; + cl_type = cltype ; + cl_virtual = virt ; + cl_type_parameters = type_parameters ; + cl_kind = kind ; + cl_parameters = parameters ; + cl_loc = { loc_impl = Some (!file_name, pos_start) ; loc_inter = None } ; + } + in + cl + + (** Get a name from a module expression, or "struct ... end" if the module expression + is not an ident of a constraint on an ident. *) + let rec tt_name_from_module_expr mod_expr = + match mod_expr.Typedtree.mod_desc with + Typedtree.Tmod_ident p -> Name.from_path p + | Typedtree.Tmod_constraint (m_exp, _, _) -> tt_name_from_module_expr m_exp + | Typedtree.Tmod_structure _ + | Typedtree.Tmod_functor _ + | Typedtree.Tmod_apply _ + | Typedtree.Tmod_unpack _ -> + Odoc_messages.struct_end + + (** Get the list of included modules in a module structure of a typed tree. *) + let tt_get_included_module_list tt_structure = + let f acc item = + match item with + Typedtree.Tstr_include (mod_expr, _) -> + acc @ [ + { (* A VOIR : chercher dans les modules et les module types, avec quel env ? *) + im_name = tt_name_from_module_expr mod_expr ; + im_module = None ; + im_info = None ; + } + ] + | _ -> + acc + in + List.fold_left f [] tt_structure + + (** This function takes a [module element list] of a module and replaces the "dummy" included modules with + the ones found in typed tree structure of the module. *) + let replace_dummy_included_modules module_elements included_modules = + let rec f = function + | ([], _) -> + [] + | ((Element_included_module im) :: q, (im_repl :: im_q)) -> + (Element_included_module { im_repl with im_info = im.im_info }) + :: (f (q, im_q)) + | ((Element_included_module im) :: q, []) -> + (Element_included_module im) :: q + | (ele :: q, l) -> + ele :: (f (q, l)) + in + f (module_elements, included_modules) + + (** This function removes the elements of the module which does not + belong to the given module type, if the module type is expanded + and the module has a "structure" kind. *) + let rec filter_module_with_module_type_constraint m mt = + match m.m_kind, mt with + Module_struct l, Types.Tmty_signature lsig -> + m.m_kind <- Module_struct (filter_module_elements_with_module_type_constraint l lsig); + m.m_type <- mt; + | _ -> () + + (** This function removes the elements of the module type which does not + belong to the given module type, if the module type is expanded + and the module type has a "structure" kind. *) + and filter_module_type_with_module_type_constraint mtyp mt = + match mtyp.mt_kind, mt with + Some Module_type_struct l, Types.Tmty_signature lsig -> + mtyp.mt_kind <- Some (Module_type_struct (filter_module_elements_with_module_type_constraint l lsig)); + mtyp.mt_type <- Some mt; + | _ -> () + + and filter_module_elements_with_module_type_constraint l lsig = + let pred ele = + let f = match ele with + Element_module m -> + (function + Types.Tsig_module (ident,t,_) -> + let n1 = Name.simple m.m_name + and n2 = Ident.name ident in + ( + match n1 = n2 with + true -> filter_module_with_module_type_constraint m t; true + | false -> false + ) + | _ -> false) + | Element_module_type mt -> + (function + Types.Tsig_modtype (ident,Types.Tmodtype_manifest t) -> + let n1 = Name.simple mt.mt_name + and n2 = Ident.name ident in + ( + match n1 = n2 with + true -> filter_module_type_with_module_type_constraint mt t; true + | false -> false + ) + | _ -> false) + | Element_value v -> + (function + Types.Tsig_value (ident,_) -> + let n1 = Name.simple v.val_name + and n2 = Ident.name ident in + n1 = n2 + | _ -> false) + | Element_type t -> + (function + Types.Tsig_type (ident,_,_) -> + (* A VOIR: il est possible que le détail du type soit caché *) + let n1 = Name.simple t.ty_name + and n2 = Ident.name ident in + n1 = n2 + | _ -> false) + | Element_exception e -> + (function + Types.Tsig_exception (ident,_) -> + let n1 = Name.simple e.ex_name + and n2 = Ident.name ident in + n1 = n2 + | _ -> false) + | Element_class c -> + (function + Types.Tsig_class (ident,_,_) -> + let n1 = Name.simple c.cl_name + and n2 = Ident.name ident in + n1 = n2 + | _ -> false) + | Element_class_type ct -> + (function + Types.Tsig_cltype (ident,_,_) -> + let n1 = Name.simple ct.clt_name + and n2 = Ident.name ident in + n1 = n2 + | _ -> false) + | Element_module_comment _ -> fun _ -> true + | Element_included_module _ -> fun _ -> true + in + List.exists f lsig + in + List.filter pred l + + (** Analysis of a parse tree structure with a typed tree, to return module elements.*) + let rec analyse_structure env current_module_name last_pos pos_limit parsetree typedtree = + print_DEBUG "Odoc_ast:analyse_struture"; + let (table, table_values) = Typedtree_search.tables typedtree in + let rec iter env last_pos = function + [] -> + let s = get_string_of_file last_pos pos_limit in + let (_, ele_coms) = My_ir.all_special !file_name s in + let ele_comments = + List.fold_left + (fun acc -> fun sc -> + match sc.Odoc_types.i_desc with + None -> + acc + | Some t -> + acc @ [Element_module_comment t]) + [] + ele_coms + in + ele_comments + | item :: q -> + let (comment_opt, ele_comments) = + get_comments_in_module last_pos item.Parsetree.pstr_loc.Location.loc_start.Lexing.pos_cnum + in + let pos_limit2 = + match q with + [] -> pos_limit + | item2 :: _ -> item2.Parsetree.pstr_loc.Location.loc_start.Lexing.pos_cnum + in + let (maybe_more, new_env, elements) = analyse_structure_item + env + current_module_name + item.Parsetree.pstr_loc + pos_limit2 + comment_opt + item.Parsetree.pstr_desc + typedtree + table + table_values + in + ele_comments @ elements @ (iter new_env (item.Parsetree.pstr_loc.Location.loc_end.Lexing.pos_cnum + maybe_more) q) + in + iter env last_pos parsetree + + (** Analysis of a parse tree structure item to obtain a new environment and a list of elements.*) + and analyse_structure_item env current_module_name loc pos_limit comment_opt parsetree_item_desc typedtree + table table_values = + print_DEBUG "Odoc_ast:analyse_struture_item"; + match parsetree_item_desc with + Parsetree.Pstr_eval _ -> + (* don't care *) + (0, env, []) + | Parsetree.Pstr_value (rec_flag, pat_exp_list) -> + (* of rec_flag * (pattern * expression) list *) + (* For each value, look for the value name, then look in the + typedtree for the corresponding information, + at last analyse this information to build the value *) + let rec iter_pat = function + | Parsetree.Ppat_any -> None + | Parsetree.Ppat_var name -> Some name + | Parsetree.Ppat_tuple _ -> None (* A VOIR quand on traitera les tuples *) + | Parsetree.Ppat_constraint (pat, _) -> iter_pat pat.Parsetree.ppat_desc + | _ -> None + in + let rec iter ?(first=false) last_pos acc_env acc p_e_list = + match p_e_list with + [] -> + (acc_env, acc) + | (pat, exp) :: q -> + let value_name_opt = iter_pat pat.Parsetree.ppat_desc in + let new_last_pos = exp.Parsetree.pexp_loc.Location.loc_end.Lexing.pos_cnum in + match value_name_opt with + None -> + iter new_last_pos acc_env acc q + | Some name -> + try + let pat_exp = Typedtree_search.search_value table_values name in + let (info_opt, ele_comments) = + (* we already have the optional comment for the first value. *) + if first then + (comment_opt, []) + else + get_comments_in_module + last_pos + pat.Parsetree.ppat_loc.Location.loc_start.Lexing.pos_cnum + in + let l_values = tt_analyse_value + env + current_module_name + info_opt + loc + pat_exp + rec_flag + in + let new_env = List.fold_left + (fun e -> fun v -> + Odoc_env.add_value e v.val_name + ) + acc_env + l_values + in + let l_ele = List.map (fun v -> Element_value v) l_values in + iter + new_last_pos + new_env + (acc @ ele_comments @ l_ele) + q + with + Not_found -> + iter new_last_pos acc_env acc q + in + let (new_env, l_ele) = iter ~first: true loc.Location.loc_start.Lexing.pos_cnum env [] pat_exp_list in + (0, new_env, l_ele) + + | Parsetree.Pstr_primitive (name_pre, val_desc) -> + (* of string * value_description *) + print_DEBUG ("Parsetree.Pstr_primitive ("^name_pre^", ["^(String.concat ", " val_desc.Parsetree.pval_prim)^"]"); + let typ = Typedtree_search.search_primitive table name_pre in + let name = Name.parens_if_infix name_pre in + let complete_name = Name.concat current_module_name name in + let new_value = { + val_name = complete_name ; + val_info = comment_opt ; + val_type = Odoc_env.subst_type env typ ; + val_recursive = false ; + val_parameters = [] ; + val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ; + val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ; + } + in + let new_env = Odoc_env.add_value env new_value.val_name in + (0, new_env, [Element_value new_value]) + + | Parsetree.Pstr_type name_typedecl_list -> + (* of (string * type_declaration) list *) + (* we start by extending the environment *) + let new_env = + List.fold_left + (fun acc_env -> fun (name, _) -> + let complete_name = Name.concat current_module_name name in + Odoc_env.add_type acc_env complete_name + ) + env + name_typedecl_list + in + let rec f ?(first=false) maybe_more_acc last_pos name_type_decl_list = + match name_type_decl_list with + [] -> (maybe_more_acc, []) + | (name, type_decl) :: q -> + let complete_name = Name.concat current_module_name name in + let loc_start = type_decl.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum in + let loc_end = type_decl.Parsetree.ptype_loc.Location.loc_end.Lexing.pos_cnum in + let pos_limit2 = + match q with + [] -> pos_limit + | (_, td) :: _ -> td.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum + in + let (maybe_more, name_comment_list) = + Sig.name_comment_from_type_kind + loc_end + pos_limit2 + type_decl.Parsetree.ptype_kind + in + let tt_type_decl = + try Typedtree_search.search_type_declaration table name + with Not_found -> raise (Failure (Odoc_messages.type_not_found_in_typedtree complete_name)) + in + let (com_opt, ele_comments) = (* the comment for the first type was already retrieved *) + if first then + (comment_opt , []) + else + get_comments_in_module last_pos loc_start + in + let kind = Sig.get_type_kind + new_env name_comment_list + tt_type_decl.Types.type_kind + in + let new_end = loc_end + maybe_more in + let t = + { + ty_name = complete_name ; + ty_info = com_opt ; + ty_parameters = + List.map2 + (fun p (co,cn,_) -> + (Odoc_env.subst_type new_env p, + co, cn) + ) + tt_type_decl.Types.type_params + tt_type_decl.Types.type_variance ; + ty_kind = kind ; + ty_private = tt_type_decl.Types.type_private; + ty_manifest = + (match tt_type_decl.Types.type_manifest with + None -> None + | Some t -> Some (Odoc_env.subst_type new_env t)); + ty_loc = { loc_impl = Some (!file_name, loc_start) ; loc_inter = None } ; + ty_code = + ( + if !Odoc_global.keep_code then + Some (get_string_of_file loc_start new_end) + else + None + ) ; + } + in + let (maybe_more2, info_after_opt) = + My_ir.just_after_special + !file_name + (get_string_of_file new_end pos_limit2) + in + t.ty_info <- Sig.merge_infos t.ty_info info_after_opt ; + let (maybe_more3, eles) = f (maybe_more + maybe_more2) (new_end + maybe_more2) q in + (maybe_more3, ele_comments @ ((Element_type t) :: eles)) + in + let (maybe_more, eles) = f ~first: true 0 loc.Location.loc_start.Lexing.pos_cnum name_typedecl_list in + (maybe_more, new_env, eles) + + | Parsetree.Pstr_exception (name, excep_decl) -> + (* a new exception is defined *) + let complete_name = Name.concat current_module_name name in + (* we get the exception declaration in the typed tree *) + let tt_excep_decl = + try Typedtree_search.search_exception table name + with Not_found -> + raise (Failure (Odoc_messages.exception_not_found_in_typedtree complete_name)) + in + let new_env = Odoc_env.add_exception env complete_name in + let loc_start = loc.Location.loc_start.Lexing.pos_cnum in + let loc_end = loc.Location.loc_end.Lexing.pos_cnum in + let new_ex = + { + ex_name = complete_name ; + ex_info = comment_opt ; + ex_args = List.map (Odoc_env.subst_type new_env) tt_excep_decl ; + ex_alias = None ; + ex_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ; + ex_code = + ( + if !Odoc_global.keep_code then + Some (get_string_of_file loc_start loc_end) + else + None + ) ; + } + in + (0, new_env, [ Element_exception new_ex ]) + + | Parsetree.Pstr_exn_rebind (name, _) -> + (* a new exception is defined *) + let complete_name = Name.concat current_module_name name in + (* we get the exception rebind in the typed tree *) + let tt_path = + try Typedtree_search.search_exception_rebind table name + with Not_found -> + raise (Failure (Odoc_messages.exception_not_found_in_typedtree complete_name)) + in + let new_env = Odoc_env.add_exception env complete_name in + let new_ex = + { + ex_name = complete_name ; + ex_info = comment_opt ; + ex_args = [] ; + ex_alias = Some { ea_name = (Odoc_env.full_exception_name env (Name.from_path tt_path)) ; + ea_ex = None ; } ; + ex_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ; + ex_code = None ; + } + in + (0, new_env, [ Element_exception new_ex ]) + + | Parsetree.Pstr_module (name, module_expr) -> + ( + (* of string * module_expr *) + try + let tt_module_expr = Typedtree_search.search_module table name in + let new_module_pre = analyse_module + env + current_module_name + name + comment_opt + module_expr + tt_module_expr + in + let code = + if !Odoc_global.keep_code then + let loc = module_expr.Parsetree.pmod_loc in + let st = loc.Location.loc_start.Lexing.pos_cnum in + let en = loc.Location.loc_end.Lexing.pos_cnum in + Some (get_string_of_file st en) + else + None + in + let new_module = + { new_module_pre with m_code = code } + in + let new_env = Odoc_env.add_module env new_module.m_name in + let new_env2 = + match new_module.m_type with + (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *) + Types.Tmty_signature s -> + Odoc_env.add_signature new_env new_module.m_name + ~rel: (Name.simple new_module.m_name) s + | _ -> + new_env + in + (0, new_env2, [ Element_module new_module ]) + with + Not_found -> + let complete_name = Name.concat current_module_name name in + raise (Failure (Odoc_messages.module_not_found_in_typedtree complete_name)) + ) + + | Parsetree.Pstr_recmodule mods -> + (* A VOIR ICI pb: pas de lien avec les module type + dans les contraintes sur les modules *) + let new_env = + List.fold_left + (fun acc_env (name, _, mod_exp) -> + let complete_name = Name.concat current_module_name name in + let e = Odoc_env.add_module acc_env complete_name in + let tt_mod_exp = + try Typedtree_search.search_module table name + with Not_found -> raise (Failure (Odoc_messages.module_not_found_in_typedtree complete_name)) + in + let new_module = analyse_module + e + current_module_name + name + None + mod_exp + tt_mod_exp + in + match new_module.m_type with + Types.Tmty_signature s -> + Odoc_env.add_signature e new_module.m_name + ~rel: (Name.simple new_module.m_name) s + | _ -> + e + ) + env + mods + in + let rec f ?(first=false) last_pos name_mod_exp_list = + match name_mod_exp_list with + [] -> [] + | (name, _, mod_exp) :: q -> + let complete_name = Name.concat current_module_name name in + let loc_start = mod_exp.Parsetree.pmod_loc.Location.loc_start.Lexing.pos_cnum in + let loc_end = mod_exp.Parsetree.pmod_loc.Location.loc_end.Lexing.pos_cnum in + let tt_mod_exp = + try Typedtree_search.search_module table name + with Not_found -> raise (Failure (Odoc_messages.module_not_found_in_typedtree complete_name)) + in + let (com_opt, ele_comments) = (* the comment for the first type was already retrieved *) + if first then + (comment_opt, []) + else + get_comments_in_module last_pos loc_start + in + let new_module = analyse_module + new_env + current_module_name + name + com_opt + mod_exp + tt_mod_exp + in + let eles = f loc_end q in + ele_comments @ ((Element_module new_module) :: eles) + in + let eles = f ~first: true loc.Location.loc_start.Lexing.pos_cnum mods in + (0, new_env, eles) + + | Parsetree.Pstr_modtype (name, modtype) -> + let complete_name = Name.concat current_module_name name in + let tt_module_type = + try Typedtree_search.search_module_type table name + with Not_found -> + raise (Failure (Odoc_messages.module_type_not_found_in_typedtree complete_name)) + in + let kind = Sig.analyse_module_type_kind env complete_name + modtype tt_module_type + in + let mt = + { + mt_name = complete_name ; + mt_info = comment_opt ; + mt_type = Some tt_module_type ; + mt_is_interface = false ; + mt_file = !file_name ; + mt_kind = Some kind ; + mt_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ; + } + in + let new_env = Odoc_env.add_module_type env mt.mt_name in + let new_env2 = + match tt_module_type with + (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on n'aurait pas la signature *) + Types.Tmty_signature s -> + Odoc_env.add_signature new_env mt.mt_name ~rel: (Name.simple mt.mt_name) s + | _ -> + new_env + in + (0, new_env2, [ Element_module_type mt ]) + + | Parsetree.Pstr_open longident -> + (* A VOIR : enrichir l'environnement quand open ? *) + let ele_comments = match comment_opt with + None -> [] + | Some i -> + match i.i_desc with + None -> [] + | Some t -> [Element_module_comment t] + in + (0, env, ele_comments) + + | Parsetree.Pstr_class class_decl_list -> + (* we start by extending the environment *) + let new_env = + List.fold_left + (fun acc_env -> fun class_decl -> + let complete_name = Name.concat current_module_name class_decl.Parsetree.pci_name in + Odoc_env.add_class acc_env complete_name + ) + env + class_decl_list + in + let rec f ?(first=false) last_pos class_decl_list = + match class_decl_list with + [] -> + [] + | class_decl :: q -> + let (tt_class_exp, tt_type_params) = + try Typedtree_search.search_class_exp table class_decl.Parsetree.pci_name + with Not_found -> + let complete_name = Name.concat current_module_name class_decl.Parsetree.pci_name in + raise (Failure (Odoc_messages.class_not_found_in_typedtree complete_name)) + in + let (com_opt, ele_comments) = + if first then + (comment_opt, []) + else + get_comments_in_module last_pos class_decl.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum + in + let last_pos2 = class_decl.Parsetree.pci_loc.Location.loc_end.Lexing.pos_cnum in + let new_class = analyse_class + new_env + current_module_name + com_opt + class_decl + tt_type_params + tt_class_exp + table + in + ele_comments @ ((Element_class new_class) :: (f last_pos2 q)) + in + (0, new_env, f ~first: true loc.Location.loc_start.Lexing.pos_cnum class_decl_list) + + | Parsetree.Pstr_class_type class_type_decl_list -> + (* we start by extending the environment *) + let new_env = + List.fold_left + (fun acc_env -> fun class_type_decl -> + let complete_name = Name.concat current_module_name class_type_decl.Parsetree.pci_name in + Odoc_env.add_class_type acc_env complete_name + ) + env + class_type_decl_list + in + let rec f ?(first=false) last_pos class_type_decl_list = + match class_type_decl_list with + [] -> + [] + | class_type_decl :: q -> + let name = class_type_decl.Parsetree.pci_name in + let complete_name = Name.concat current_module_name name in + let virt = class_type_decl.Parsetree.pci_virt = Asttypes.Virtual in + let tt_cltype_declaration = + try Typedtree_search.search_class_type_declaration table name + with Not_found -> + raise (Failure (Odoc_messages.class_type_not_found_in_typedtree complete_name)) + in + let type_params = tt_cltype_declaration.Types.clty_params in + let kind = Sig.analyse_class_type_kind + new_env + complete_name + class_type_decl.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum + class_type_decl.Parsetree.pci_expr + tt_cltype_declaration.Types.clty_type + in + let (com_opt, ele_comments) = + if first then + (comment_opt, []) + else + get_comments_in_module last_pos class_type_decl.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum + in + let last_pos2 = class_type_decl.Parsetree.pci_loc.Location.loc_end.Lexing.pos_cnum in + let new_ele = + Element_class_type + { + clt_name = complete_name ; + clt_info = com_opt ; + clt_type = Odoc_env.subst_class_type env tt_cltype_declaration.Types.clty_type ; + clt_type_parameters = List.map (Odoc_env.subst_type new_env) type_params ; + clt_virtual = virt ; + clt_kind = kind ; + clt_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; + loc_inter = None } ; + } + in + ele_comments @ (new_ele :: (f last_pos2 q)) + in + (0, new_env, f ~first: true loc.Location.loc_start.Lexing.pos_cnum class_type_decl_list) + + | Parsetree.Pstr_include module_expr -> + (* we add a dummy included module which will be replaced by a correct + one at the end of the module analysis, + to use the Path.t of the included modules in the typdtree. *) + let im = + { + im_name = "dummy" ; + im_module = None ; + im_info = comment_opt ; + } + in + (0, env, [ Element_included_module im ]) (* A VOIR : étendre l'environnement ? avec quoi ? *) + + (** Analysis of a [Parsetree.module_expr] and a name to return a [t_module].*) + and analyse_module env current_module_name module_name comment_opt p_module_expr tt_module_expr = + let complete_name = Name.concat current_module_name module_name in + let pos_start = p_module_expr.Parsetree.pmod_loc.Location.loc_start.Lexing.pos_cnum in + let pos_end = p_module_expr.Parsetree.pmod_loc.Location.loc_end.Lexing.pos_cnum in + let modtype = + (* A VOIR : Odoc_env.subst_module_type env ? *) + tt_module_expr.Typedtree.mod_type + in + let m_code_intf = + match p_module_expr.Parsetree.pmod_desc with + Parsetree.Pmod_constraint (_, pmodule_type) -> + let loc_start = pmodule_type.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in + let loc_end = pmodule_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in + Some (get_string_of_file loc_start loc_end) + | _ -> + None + in + let m_base = + { + m_name = complete_name ; + m_type = modtype ; + m_info = comment_opt ; + m_is_interface = false ; + m_file = !file_name ; + m_kind = Module_struct [] ; + m_loc = { loc_impl = Some (!file_name, pos_start) ; loc_inter = None } ; + m_top_deps = [] ; + m_code = None ; (* code is set by the caller, after the module is created *) + m_code_intf = m_code_intf ; + m_text_only = false ; + } + in + match (p_module_expr.Parsetree.pmod_desc, tt_module_expr.Typedtree.mod_desc) with + (Parsetree.Pmod_ident longident, Typedtree.Tmod_ident path) -> + let alias_name = Odoc_env.full_module_name env (Name.from_path path) in + { m_base with m_kind = Module_alias { ma_name = alias_name ; + ma_module = None ; } } + + | (Parsetree.Pmod_structure p_structure, Typedtree.Tmod_structure tt_structure) -> + let elements = analyse_structure env complete_name pos_start pos_end p_structure tt_structure in + (* we must complete the included modules *) + let included_modules_from_tt = tt_get_included_module_list tt_structure in + let elements2 = replace_dummy_included_modules elements included_modules_from_tt in + { m_base with m_kind = Module_struct elements2 } + + | (Parsetree.Pmod_functor (_, pmodule_type, p_module_expr2), + Typedtree.Tmod_functor (ident, mtyp, tt_module_expr2)) -> + let loc_start = pmodule_type.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in + let loc_end = pmodule_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in + let mp_type_code = get_string_of_file loc_start loc_end in + print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code); + let mp_name = Name.from_ident ident in + let mp_kind = Sig.analyse_module_type_kind env + current_module_name pmodule_type mtyp + in + let param = + { + mp_name = mp_name ; + mp_type = Odoc_env.subst_module_type env mtyp ; + mp_type_code = mp_type_code ; + mp_kind = mp_kind ; + } + in + let dummy_complete_name = (*Name.concat "__"*) param.mp_name in + (* TODO: A VOIR CE __ *) + let new_env = Odoc_env.add_module env dummy_complete_name in + let m_base2 = analyse_module + new_env + current_module_name + module_name + None + p_module_expr2 + tt_module_expr2 + in + let kind = m_base2.m_kind in + { m_base with m_kind = Module_functor (param, kind) } + + | (Parsetree.Pmod_apply (p_module_expr1, p_module_expr2), + Typedtree.Tmod_apply (tt_module_expr1, tt_module_expr2, _)) + | (Parsetree.Pmod_apply (p_module_expr1, p_module_expr2), + Typedtree.Tmod_constraint + ({ Typedtree.mod_desc = Typedtree.Tmod_apply (tt_module_expr1, tt_module_expr2, _)}, + _, _) + ) -> + let m1 = analyse_module + env + current_module_name + module_name + None + p_module_expr1 + tt_module_expr1 + in + let m2 = analyse_module + env + current_module_name + module_name + None + p_module_expr2 + tt_module_expr2 + in + { m_base with m_kind = Module_apply (m1.m_kind, m2.m_kind) } + + | (Parsetree.Pmod_constraint (p_module_expr2, p_modtype), + Typedtree.Tmod_constraint (tt_module_expr2, tt_modtype, _)) -> + print_DEBUG ("Odoc_ast: case Parsetree.Pmod_constraint + Typedtree.Tmod_constraint "^module_name); + let m_base2 = analyse_module + env + current_module_name + module_name + None + p_module_expr2 + tt_module_expr2 + in + let mtkind = Sig.analyse_module_type_kind env + (Name.concat current_module_name "??") + p_modtype tt_modtype + in + let tt_modtype = Odoc_env.subst_module_type env tt_modtype in + if !Odoc_global.filter_with_module_constraints then + filter_module_with_module_type_constraint m_base2 tt_modtype; + { + m_base with + m_type = tt_modtype ; + m_kind = Module_constraint (m_base2.m_kind, mtkind) ; + } + + | (Parsetree.Pmod_structure p_structure, + Typedtree.Tmod_constraint + ({ Typedtree.mod_desc = Typedtree.Tmod_structure tt_structure}, + tt_modtype, _) + ) -> + (* needed for recursive modules *) + + print_DEBUG ("Odoc_ast: case Parsetree.Pmod_structure + Typedtree.Tmod_constraint "^module_name); + let elements = analyse_structure env complete_name pos_start pos_end p_structure tt_structure in + (* we must complete the included modules *) + let included_modules_from_tt = tt_get_included_module_list tt_structure in + let elements2 = replace_dummy_included_modules elements included_modules_from_tt in + { m_base with + m_type = Odoc_env.subst_module_type env tt_modtype ; + m_kind = Module_struct elements2 ; + } + + | (Parsetree.Pmod_unpack (p_exp), + Typedtree.Tmod_unpack (t_exp, tt_modtype)) -> + print_DEBUG ("Odoc_ast: case Parsetree.Pmod_unpack + Typedtree.Tmod_unpack "^module_name); + let code = + let loc = p_module_expr.Parsetree.pmod_loc in + let loc_end = loc.Location.loc_end.Lexing.pos_cnum in + let exp_loc = p_exp.Parsetree.pexp_loc in + let exp_loc_end = exp_loc.Location.loc_end.Lexing.pos_cnum in + let s = get_string_of_file exp_loc_end loc_end in + Printf.sprintf "(val ...%s" s + in + (* let name = Odoc_env.full_module_type_name env (Name.from_path (fst pkg_type)) in *) + let name = + match tt_modtype with + | Tmty_ident p -> + Odoc_env.full_module_type_name env (Name.from_path p) + | _ -> "" + in + let alias = { mta_name = name ; mta_module = None } in + { m_base with + m_type = Odoc_env.subst_module_type env tt_modtype ; + m_kind = Module_unpack (code, alias) ; + } + + | (parsetree, typedtree) -> + (*DEBUG*)let s_parse = + (*DEBUG*) match parsetree with + (*DEBUG*) Parsetree.Pmod_ident _ -> "Pmod_ident" + (*DEBUG*) | Parsetree.Pmod_structure _ -> "Pmod_structure" + (*DEBUG*) | Parsetree.Pmod_functor _ -> "Pmod_functor" + (*DEBUG*) | Parsetree.Pmod_apply _ -> "Pmod_apply" + (*DEBUG*) | Parsetree.Pmod_constraint _ -> "Pmod_constraint" + (*DEBUG*) | Parsetree.Pmod_unpack _ -> "Pmod_unpack" + (*DEBUG*)in + (*DEBUG*)let s_typed = + (*DEBUG*) match typedtree with + (*DEBUG*) Typedtree.Tmod_ident _ -> "Tmod_ident" + (*DEBUG*) | Typedtree.Tmod_structure _ -> "Tmod_structure" + (*DEBUG*) | Typedtree.Tmod_functor _ -> "Tmod_functor" + (*DEBUG*) | Typedtree.Tmod_apply _ -> "Tmod_apply" + (*DEBUG*) | Typedtree.Tmod_constraint _ -> "Tmod_constraint" + (*DEBUG*) | Typedtree.Tmod_unpack _ -> "Tmod_unpack" + (*DEBUG*)in + (*DEBUG*)let code = get_string_of_file pos_start pos_end in + print_DEBUG (Printf.sprintf "code=%s\ns_parse=%s\ns_typed=%s\n" code s_parse s_typed); + + raise (Failure "analyse_module: parsetree and typedtree don't match.") + + let analyse_typed_tree source_file input_file + (parsetree : Parsetree.structure) (typedtree : typedtree) = + let (tree_structure, _) = typedtree in + let complete_source_file = + try + let curdir = Sys.getcwd () in + let (dirname, basename) = (Filename.dirname source_file, Filename.basename source_file) in + Sys.chdir dirname ; + let complete = Filename.concat (Sys.getcwd ()) basename in + Sys.chdir curdir ; + complete + with + Sys_error s -> + prerr_endline s ; + incr Odoc_global.errors ; + source_file + in + prepare_file complete_source_file input_file; + (* We create the t_module for this file. *) + let mod_name = String.capitalize (Filename.basename (Filename.chop_extension source_file)) in + let (len,info_opt) = My_ir.first_special !file_name !file in + + (* we must complete the included modules *) + let elements = analyse_structure Odoc_env.empty mod_name len (String.length !file) parsetree tree_structure in + let included_modules_from_tt = tt_get_included_module_list tree_structure in + let elements2 = replace_dummy_included_modules elements included_modules_from_tt in + let kind = Module_struct elements2 in + { + m_name = mod_name ; + m_type = Types.Tmty_signature [] ; + m_info = info_opt ; + m_is_interface = false ; + m_file = !file_name ; + m_kind = kind ; + m_loc = { loc_impl = Some (!file_name, 0) ; loc_inter = None } ; + m_top_deps = [] ; + m_code = (if !Odoc_global.keep_code then Some !file else None) ; + m_code_intf = None ; + m_text_only = false ; + } + end diff --git a/ocaml-binary-annot/ocamldoc/odoc_ast.mli b/ocaml-binary-annot/ocamldoc/odoc_ast.mli new file mode 100644 index 0000000000..48ba98bfb3 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_ast.mli @@ -0,0 +1,104 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** The module for analysing the typed abstract syntax tree and source code and creating modules, classes, ..., elements.*) + +type typedtree = Typedtree.structure * Typedtree.module_coercion + +(** This module is used to search for structure items by name in a [Typedtree.structure]. *) +module Typedtree_search : + sig + type ele + + type tab = (ele, Typedtree.structure_item) Hashtbl.t + type tab_values = (Odoc_name.t, Typedtree.pattern * Typedtree.expression) Hashtbl.t + + (** Create hash tables used to search by some of the functions below. *) + val tables : Typedtree.structure_item list -> tab * tab_values + + (** This function returns the [Typedtree.module_expr] associated to the given module name, + in the given table. + @raise Not_found if the module was not found.*) + val search_module : tab -> string -> Typedtree.module_expr + + (** This function returns the [Types.module_type] associated to the given module type name, + in the given table. + @raise Not_found if the module type was not found.*) + val search_module_type : tab -> string -> Types.module_type + + (** This function returns the [Types.exception_declaration] associated to the given exception name, + in the given table. + @raise Not_found if the exception was not found.*) + val search_exception : tab -> string -> Types.exception_declaration + + (** This function returns the [Path.t] associated to the given exception rebind name, + in the table. + @raise Not_found if the exception rebind was not found.*) + val search_exception_rebind : tab -> string -> Path.t + + (** This function returns the [Typedtree.type_declaration] associated to the given type name, + in the given table. + @raise Not_found if the type was not found. *) + val search_type_declaration : tab -> string -> Types.type_declaration + + (** This function returns the [Typedtree.class_expr] and type parameters + associated to the given class name, in the given table. + @raise Not_found if the class was not found. *) + val search_class_exp : tab -> string -> (Typedtree.class_expr * (Types.type_expr list)) + + (** This function returns the [Types.cltype_declaration] associated to the given class type name, + in the given table. + @raise Not_found if the class type was not found. *) + val search_class_type_declaration : tab -> string -> Types.cltype_declaration + + (** This function returns the couple (pat, exp) for the given value name, in the + given table of values. + @raise Not found if no value matches the name.*) + val search_value : tab_values -> string -> Typedtree.pattern * Typedtree.expression + + (** This function returns the [type_expr] for the given primitive name, in the + given table. + @raise Not found if no value matches the name.*) + val search_primitive : tab -> string -> Types.type_expr + + (** This function returns the [Typedtree.class_expr] associated to + the n'th inherit in the given class structure of typed tree. + @raise Not_found if the class expression could not be found.*) + val get_nth_inherit_class_expr : + Typedtree.class_structure -> int -> Typedtree.class_expr + + (** This function returns the [Types.type_expr] of the attribute + whose name is given, in a given class structure. + @raise Not_found if the class attribute could not be found.*) + val search_attribute_type : + Typedtree.class_structure -> string -> Types.type_expr + + (** This function returns the [Types.expression] of the method whose name is given, in a given class structure. + @raise Not_found if the class method could not be found.*) + val search_method_expression : + Typedtree.class_structure -> string -> Typedtree.expression + end + +(** The module which performs the analysis of a typed tree. + The module uses the module {!Odoc_sig.Analyser}. + @param My_ir The module used to retrieve comments and special comments.*) +module Analyser : + functor (My_ir : Odoc_sig.Info_retriever) -> + sig + (** This function takes a file name, a file containg the code and + the typed tree obtained from the compiler. + It goes through the tree, creating values for encountered + functions, modules, ..., and looking in the source file for comments.*) + val analyse_typed_tree : + string -> string -> Parsetree.structure -> typedtree -> Odoc_module.t_module + end diff --git a/ocaml-binary-annot/ocamldoc/odoc_class.ml b/ocaml-binary-annot/ocamldoc/odoc_class.ml new file mode 100644 index 0000000000..676d0ebc37 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_class.ml @@ -0,0 +1,253 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Representation and manipulation of classes and class types.*) + +module Name = Odoc_name + +(** To keep the order of elements in a class *) +type class_element = + Class_attribute of Odoc_value.t_attribute + | Class_method of Odoc_value.t_method + | Class_comment of Odoc_types.text + +(** Used when we can reference t_class or t_class_type. *) +type cct = + Cl of t_class + | Cltype of t_class_type * Types.type_expr list (** class type and type parameters *) + +and inherited_class = { + ic_name : Name.t ; (** Complete name of the inherited class *) + mutable ic_class : cct option ; (** The associated t_class or t_class_type *) + ic_text : Odoc_types.text option ; (** The inheritance comment, if any *) + } + +and class_apply = { + capp_name : Name.t ; (** The complete name of the applied class *) + mutable capp_class : t_class option; (** The associated t_class if we found it *) + capp_params : Types.type_expr list; (** The type of expressions the class is applied to *) + capp_params_code : string list ; (** The code of these expressions *) + } + +and class_constr = { + cco_name : Name.t ; (** The complete name of the applied class *) + mutable cco_class : cct option; (** The associated class ot class type if we found it *) + cco_type_parameters : Types.type_expr list; (** The type parameters of the class, if needed *) + } + + +and class_kind = + Class_structure of inherited_class list * class_element list + (** an explicit class structure, used in implementation and interface *) + | Class_apply of class_apply (** application/alias of a class, used in implementation only *) + | Class_constr of class_constr (** a class used to give the type of the defined class, + instead of a structure, used in interface only. + For example, it will be used with the name "M1.M2....tutu" + when the class to is defined like this : + class toto : int -> tutu *) + | Class_constraint of class_kind * class_type_kind + (** A class definition with a constraint. *) + +(** Representation of a class. *) +and t_class = { + cl_name : Name.t ; (** Name of the class *) + mutable cl_info : Odoc_types.info option ; (** The optional associated user information *) + cl_type : Types.class_type ; + cl_type_parameters : Types.type_expr list ; (** Type parameters *) + cl_virtual : bool ; (** true = virtual *) + mutable cl_kind : class_kind ; + mutable cl_parameters : Odoc_parameter.parameter list ; + mutable cl_loc : Odoc_types.location ; + } + +and class_type_alias = { + cta_name : Name.t ; + mutable cta_class : cct option ; (** we can have a t_class or a t_class_type *) + cta_type_parameters : Types.type_expr list ; (** the type parameters *) + } + +and class_type_kind = + Class_signature of inherited_class list * class_element list + | Class_type of class_type_alias (** a class type eventually applied to type args *) + +(** Representation of a class type. *) +and t_class_type = { + clt_name : Name.t ; + mutable clt_info : Odoc_types.info option ; (** The optional associated user information *) + clt_type : Types.class_type ; + clt_type_parameters : Types.type_expr list ; (** type parameters *) + clt_virtual : bool ; (** true = virtual *) + mutable clt_kind : class_type_kind ; + mutable clt_loc : Odoc_types.location ; + } + + +(** {2 Functions} *) + +(** Returns the text associated to the given parameter label + in the given class, or None. *) +let class_parameter_text_by_name cl label = + match cl.cl_info with + None -> None + | Some i -> + try + let t = List.assoc label i.Odoc_types.i_params in + Some t + with + Not_found -> + None + +(** Returns the list of elements of a t_class. *) +let rec class_elements ?(trans=true) cl = + let rec iter_kind k = + match k with + Class_structure (_, elements) -> elements + | Class_constraint (c_kind, ct_kind) -> + iter_kind c_kind + (* A VOIR : utiliser le c_kind ou le ct_kind ? + Pour l'instant, comme le ct_kind n'est pas analysé, + on cherche dans le c_kind + class_type_elements ~trans: trans + { clt_name = "" ; clt_info = None ; + clt_type_parameters = [] ; + clt_virtual = false ; + clt_kind = ct_kind } + *) + | Class_apply capp -> + ( + match capp.capp_class with + Some c when trans -> class_elements ~trans: trans c + | _ -> [] + ) + | Class_constr cco -> + ( + match cco.cco_class with + Some (Cl c) when trans -> class_elements ~trans: trans c + | Some (Cltype (ct,_)) when trans -> class_type_elements ~trans: trans ct + | _ -> [] + ) + in + iter_kind cl.cl_kind + +(** Returns the list of elements of a t_class_type. *) +and class_type_elements ?(trans=true) clt = + match clt.clt_kind with + Class_signature (_, elements) -> elements + | Class_type { cta_class = Some (Cltype (ct, _)) } when trans -> + class_type_elements ~trans ct + | Class_type { cta_class = Some (Cl c) } when trans -> + class_elements ~trans c + | Class_type _ -> + [] + +(** Returns the attributes of a t_class. *) +let class_attributes ?(trans=true) cl = + List.fold_left + (fun acc -> fun ele -> + match ele with + Class_attribute a -> + acc @ [ a ] + | _ -> + acc + ) + [] + (class_elements ~trans cl) + +(** Returns the methods of a t_class. *) +let class_methods ?(trans=true) cl = + List.fold_left + (fun acc -> fun ele -> + match ele with + Class_method m -> + acc @ [ m ] + | _ -> + acc + ) + [] + (class_elements ~trans cl) + +(** Returns the comments in a t_class. *) +let class_comments ?(trans=true) cl = + List.fold_left + (fun acc -> fun ele -> + match ele with + Class_comment t -> + acc @ [ t ] + | _ -> + acc + ) + [] + (class_elements ~trans cl) + + +(** Update the parameters text of a t_class, according to the cl_info field. *) +let class_update_parameters_text cl = + let f p = + Odoc_parameter.update_parameter_text (class_parameter_text_by_name cl) p + in + List.iter f cl.cl_parameters + +(** Returns the attributes of a t_class_type. *) +let class_type_attributes ?(trans=true) clt = + List.fold_left + (fun acc -> fun ele -> + match ele with + Class_attribute a -> + acc @ [ a ] + | _ -> + acc + ) + [] + (class_type_elements ~trans clt) + +(** Returns the methods of a t_class_type. *) +let class_type_methods ?(trans=true) clt = + List.fold_left + (fun acc -> fun ele -> + match ele with + Class_method m -> + acc @ [ m ] + | _ -> + acc + ) + [] + (class_type_elements ~trans clt) + +(** Returns the comments in a t_class_type. *) +let class_type_comments ?(trans=true) clt = + List.fold_left + (fun acc -> fun ele -> + match ele with + Class_comment m -> + acc @ [ m ] + | _ -> + acc + ) + [] + (class_type_elements ~trans clt) + +(** Returns the text associated to the given parameter label + in the given class type, or None. *) +let class_type_parameter_text_by_name clt label = + match clt.clt_info with + None -> None + | Some i -> + try + let t = List.assoc label i.Odoc_types.i_params in + Some t + with + Not_found -> + None + + +(* eof $Id$ *) diff --git a/ocaml-binary-annot/ocamldoc/odoc_comments.ml b/ocaml-binary-annot/ocamldoc/odoc_comments.ml new file mode 100644 index 0000000000..ea5427e077 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_comments.ml @@ -0,0 +1,348 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Analysis of comments. *) + +open Odoc_types + +let print_DEBUG s = print_string s ; print_newline ();; + +(** This variable contains the regular expression representing a blank but not a '\n'.*) +let simple_blank = "[ \013\009\012]" + +module type Texter = + sig + (** Return a text structure from a string. *) + val text_of_string : string -> text + end + +module Info_retriever = + functor (MyTexter : Texter) -> + struct + let create_see s = + try + let lexbuf = Lexing.from_string s in + let (see_ref, s) = Odoc_parser.see_info Odoc_see_lexer.main lexbuf in + (see_ref, MyTexter.text_of_string s) + with + | Odoc_text.Text_syntax (l, c, s) -> + raise (Failure (Odoc_messages.text_parse_error l c s)) + | _ -> + raise (Failure ("Erreur inconnue lors du parse de see : "^s)) + + let retrieve_info fun_lex file (s : string) = + try + let _ = Odoc_comments_global.init () in + Odoc_lexer.comments_level := 0; + let lexbuf = Lexing.from_string s in + match Odoc_parser.main fun_lex lexbuf with + None -> + (0, None) + | Some (desc, remain_opt) -> + let mem_nb_chars = !Odoc_comments_global.nb_chars in + let _ = + match remain_opt with + None -> + () + | Some s -> + (*DEBUG*)print_string ("remain: "^s); print_newline(); + let lexbuf2 = Lexing.from_string s in + Odoc_parser.info_part2 Odoc_lexer.elements lexbuf2 + in + (mem_nb_chars, + Some + { + i_desc = (match desc with "" -> None | _ -> Some (MyTexter.text_of_string desc)); + i_authors = !Odoc_comments_global.authors; + i_version = !Odoc_comments_global.version; + i_sees = (List.map create_see !Odoc_comments_global.sees) ; + i_since = !Odoc_comments_global.since; + i_before = Odoc_merge.merge_before_tags + (List.map (fun (n, s) -> + (n, MyTexter.text_of_string s)) !Odoc_comments_global.before) + ; + i_deprecated = + (match !Odoc_comments_global.deprecated with + None -> None | Some s -> Some (MyTexter.text_of_string s)); + i_params = + (List.map (fun (n, s) -> + (n, MyTexter.text_of_string s)) !Odoc_comments_global.params); + i_raised_exceptions = + (List.map (fun (n, s) -> + (n, MyTexter.text_of_string s)) !Odoc_comments_global.raised_exceptions); + i_return_value = + (match !Odoc_comments_global.return_value with + None -> None | Some s -> Some (MyTexter.text_of_string s)) ; + i_custom = (List.map + (fun (tag, s) -> (tag, MyTexter.text_of_string s)) + !Odoc_comments_global.customs) + } + ) + with + Failure s -> + incr Odoc_global.errors ; + prerr_endline (file^" : "^s^"\n"); + (0, None) + | Odoc_text.Text_syntax (l, c, s) -> + incr Odoc_global.errors ; + prerr_endline (file^" : "^(Odoc_messages.text_parse_error l c s)); + (0, None) + | _ -> + incr Odoc_global.errors ; + prerr_endline (file^" : "^Odoc_messages.parse_error^"\n"); + (0, None) + + (** This function takes a string where a simple comment may has been found. It returns + false if there is a blank line or the first comment is a special one, or if there is + no comment if the string.*) + let nothing_before_simple_comment s = + (* get the position of the first "(*" *) + try + print_DEBUG ("comment_is_attached: "^s); + let pos = Str.search_forward (Str.regexp "(\\*") s 0 in + let next_char = if (String.length s) >= (pos + 1) then s.[pos + 2] else '_' in + (next_char <> '*') && + ( + (* there is no special comment between the constructor and the coment we got *) + let s2 = String.sub s 0 pos in + print_DEBUG ("s2="^s2); + try + let _ = Str.search_forward (Str.regexp ("['\n']"^simple_blank^"*['\n']")) s2 0 in + (* a blank line was before the comment *) + false + with + Not_found -> + true + ) + with + Not_found -> + false + + (** Return true if the given string contains a blank line. *) + let blank_line s = + try + let _ = Str.search_forward (Str.regexp ("['\n']"^simple_blank^"*['\n']")) s 0 in + (* a blank line was before the comment *) + true + with + Not_found -> + false + + let retrieve_info_special file (s : string) = + retrieve_info Odoc_lexer.main file s + + let retrieve_info_simple file (s : string) = + let _ = Odoc_comments_global.init () in + Odoc_lexer.comments_level := 0; + let lexbuf = Lexing.from_string s in + match Odoc_parser.main Odoc_lexer.simple lexbuf with + None -> + (0, None) + | Some (desc, remain_opt) -> + (!Odoc_comments_global.nb_chars, Some Odoc_types.dummy_info) + + (** Return true if the given string contains a blank line outside a simple comment. *) + let blank_line_outside_simple file s = + let rec iter s2 = + match retrieve_info_simple file s2 with + (_, None) -> + blank_line s2 + | (len, Some _) -> + try + let pos = Str.search_forward (Str.regexp_string "(*") s2 0 in + let s_before = String.sub s2 0 pos in + let s_after = String.sub s2 len ((String.length s2) - len) in + (blank_line s_before) || (iter s_after) + with + Not_found -> + (* we shouldn't get here *) + false + in + iter s + + (** This function returns the first simple comment in + the given string. If strict is [true] then no + comment is returned if a blank line or a special + comment is found before the simple comment. *) + let retrieve_first_info_simple ?(strict=true) file (s : string) = + match retrieve_info_simple file s with + (_, None) -> + (0, None) + | (len, Some d) -> + (* we check if the comment we got was really attached to the constructor, + i.e. that there was no blank line or any special comment "(**" before *) + if (not strict) or (nothing_before_simple_comment s) then + (* ok, we attach the comment to the constructor *) + (len, Some d) + else + (* a blank line or special comment was before the comment, + so we must not attach this comment to the constructor. *) + (0, None) + + let retrieve_last_info_simple file (s : string) = + print_DEBUG ("retrieve_last_info_simple:"^s); + let rec f cur_len cur_d = + try + let s2 = String.sub s cur_len ((String.length s) - cur_len) in + print_DEBUG ("retrieve_last_info_simple.f:"^s2); + match retrieve_info_simple file s2 with + (len, None) -> + print_DEBUG "retrieve_last_info_simple: None"; + (cur_len + len, cur_d) + | (len, Some d) -> + print_DEBUG "retrieve_last_info_simple: Some"; + f (len + cur_len) (Some d) + with + _ -> + print_DEBUG "retrieve_last_info_simple : Erreur String.sub"; + (cur_len, cur_d) + in + f 0 None + + let retrieve_last_special_no_blank_after file (s : string) = + print_DEBUG ("retrieve_last_special_no_blank_after:"^s); + let rec f cur_len cur_d = + try + let s2 = String.sub s cur_len ((String.length s) - cur_len) in + print_DEBUG ("retrieve_last_special_no_blank_after.f:"^s2); + match retrieve_info_special file s2 with + (len, None) -> + print_DEBUG "retrieve_last_special_no_blank_after: None"; + (cur_len + len, cur_d) + | (len, Some d) -> + print_DEBUG "retrieve_last_special_no_blank_after: Some"; + f (len + cur_len) (Some d) + with + _ -> + print_DEBUG "retrieve_last_special_no_blank_after : Erreur String.sub"; + (cur_len, cur_d) + in + f 0 None + + let all_special file s = + print_DEBUG ("all_special: "^s); + let rec iter acc n s2 = + match retrieve_info_special file s2 with + (_, None) -> + (n, acc) + | (n2, Some i) -> + print_DEBUG ("all_special: avant String.sub new_s="^s2); + print_DEBUG ("n2="^(string_of_int n2)) ; + print_DEBUG ("len(s2)="^(string_of_int (String.length s2))) ; + let new_s = String.sub s2 n2 ((String.length s2) - n2) in + print_DEBUG ("all_special: apres String.sub new_s="^new_s); + iter (acc @ [i]) (n + n2) new_s + in + let res = iter [] 0 s in + print_DEBUG ("all_special: end"); + res + + let just_after_special file s = + print_DEBUG ("just_after_special: "^s); + let res = match retrieve_info_special file s with + (_, None) -> + (0, None) + | (len, Some d) -> + (* we must not have a simple comment or a blank line before. *) + match retrieve_info_simple file (String.sub s 0 len) with + (_, None) -> + ( + try + (* if the special comment is the stop comment (**/**), + then we must not associate it. *) + let pos = Str.search_forward (Str.regexp_string "(**") s 0 in + if blank_line (String.sub s 0 pos) or + d.Odoc_types.i_desc = Some [Odoc_types.Raw "/*"] + then + (0, None) + else + (len, Some d) + with + Not_found -> + (* should not occur *) + (0, None) + ) + | (len2, Some d2) -> + (0, None) + in + print_DEBUG ("just_after_special:end"); + res + + let first_special file s = + retrieve_info_special file s + + let get_comments f_create_ele file s = + let (assoc_com, ele_coms) = + (* get the comments *) + let (len, special_coms) = all_special file s in + (* if there is no blank line after the special comments, and + if the last special comment is not the stop special comment, then the + last special comments must be associated to the element. *) + match List.rev special_coms with + [] -> + (None, []) + | h :: q -> + if (blank_line_outside_simple file + (String.sub s len ((String.length s) - len)) ) + or h.Odoc_types.i_desc = Some [Odoc_types.Raw "/*"] + then + (None, special_coms) + else + (Some h, List.rev q) + in + let ele_comments = + List.fold_left + (fun acc -> fun sc -> + match sc.Odoc_types.i_desc with + None -> + acc + | Some t -> + acc @ [f_create_ele t]) + [] + ele_coms + in + (assoc_com, ele_comments) + end + +module Basic_info_retriever = Info_retriever (Odoc_text.Texter) + +let info_of_string s = + let dummy = + { + i_desc = None ; + i_authors = [] ; + i_version = None ; + i_sees = [] ; + i_since = None ; + i_before = [] ; + i_deprecated = None ; + i_params = [] ; + i_raised_exceptions = [] ; + i_return_value = None ; + i_custom = [] ; + } + in + let s2 = Printf.sprintf "(** %s *)" s in + let (_, i_opt) = Basic_info_retriever.first_special "-" s2 in + match i_opt with + None -> dummy + | Some i -> i + +let info_of_comment_file modlist f = + try + let s = Odoc_misc.input_file_as_string f in + let i = info_of_string s in + Odoc_cross.assoc_comments_info "" modlist i + with + Sys_error s -> + failwith s diff --git a/ocaml-binary-annot/ocamldoc/odoc_comments.mli b/ocaml-binary-annot/ocamldoc/odoc_comments.mli new file mode 100644 index 0000000000..28122cda94 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_comments.mli @@ -0,0 +1,74 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Analysis of comments. *) + +val simple_blank : string + +(** The type of modules in argument to Info_retriever *) +module type Texter = + sig + (** Return a text structure from a string. *) + val text_of_string : string -> Odoc_types.text + end + +(** The basic module for special comments analysis.*) +module Basic_info_retriever : + sig + (** Return true if the given string contains a blank line. *) + val blank_line_outside_simple : + string -> string -> bool + + (** This function retrieves all the special comments in the given string. *) + val all_special : string -> string -> int * Odoc_types.info list + + (** [just_after_special file str] return the pair ([length], [info_opt]) + where [info_opt] is the first optional special comment found + in [str], without any blank line before. [length] is the number + of chars from the beginning of [str] to the end of the special comment. *) + val just_after_special : + string -> string -> int * Odoc_types.info option + + (** [first_special file str] return the pair ([length], [info_opt]) + where [info_opt] is the first optional special comment found + in [str]. [length] is the number of chars from the beginning of + [str] to the end of the special comment. *) + val first_special : + string -> string -> int * Odoc_types.info option + + (** Return a pair [(comment_opt, element_comment_list)], where [comment_opt] is the last special + comment found in the given string and not followed by a blank line, + and [element_comment_list] the list of values built from the other + special comments found and the given function. *) + val get_comments : + (Odoc_types.text -> 'a) -> + string -> string -> Odoc_types.info option * 'a list + + end + +(** [info_of_string s] parses the given string + like a regular ocamldoc comment and return an + {!Odoc_types.info} structure. + @return an empty structure if there was a syntax error. TODO: change this +*) +val info_of_string : string -> Odoc_types.info + +(** [info_of_comment_file file] parses the given file + and return an {!Odoc_types.info} structure. The content of the + file must have the same syntax as the content of a special comment. + The given module list is used for cross reference. + @raise Failure is the file could not be opened or there is a + syntax error. +*) +val info_of_comment_file : + Odoc_module.t_module list -> string -> Odoc_types.info diff --git a/ocaml-binary-annot/ocamldoc/odoc_comments_global.ml b/ocaml-binary-annot/ocamldoc/odoc_comments_global.ml new file mode 100644 index 0000000000..a4366ceb71 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_comments_global.ml @@ -0,0 +1,51 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** The global variables used by the special comment parser.*) + +let nb_chars = ref 0 + +let authors = ref ([] : string list) + +let version = ref (None : string option) + +let sees = ref ([] : string list) + +let since = ref (None : string option) + +let before = ref [] + +let deprecated = ref (None : string option) + +let params = ref ([] : (string * string) list) + +let raised_exceptions = ref ([] : (string * string) list) + +let return_value = ref (None : string option) + +let customs = ref [] + +let init () = + nb_chars := 0; + authors := []; + version := None; + sees := []; + since := None; + before := []; + deprecated := None; + params := []; + raised_exceptions := []; + return_value := None ; + customs := [] + +(* eof $Id$ *) diff --git a/ocaml-binary-annot/ocamldoc/odoc_comments_global.mli b/ocaml-binary-annot/ocamldoc/odoc_comments_global.mli new file mode 100644 index 0000000000..e9efbffc59 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_comments_global.mli @@ -0,0 +1,50 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** The global variables used by the special comment parser.*) + +(** the number of chars used in the lexer. *) +val nb_chars : int ref + +(** the authors list *) +val authors : string list ref + +(** the version string *) +val version : string option ref + +(** the see references *) +val sees : string list ref + +(** the since string *) +val since : string option ref + +(** the before tag information *) +val before : (string * string) list ref + +(** the deprecated flag *) +val deprecated : string option ref + +(** parameters, with name and description *) +val params : (string * string) list ref + +(** the raised exceptions, with name and description *) +val raised_exceptions : (string * string) list ref + +(** the description of the return value *) +val return_value : string option ref + +(** the strings associated to custom tags. *) +val customs : (string * string) list ref + +(** this function inits the variables filled by the parser. *) +val init : unit -> unit diff --git a/ocaml-binary-annot/ocamldoc/odoc_config.ml b/ocaml-binary-annot/ocamldoc/odoc_config.ml new file mode 100644 index 0000000000..71769534dc --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_config.ml @@ -0,0 +1,18 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +let custom_generators_path = + Filename.concat Config.standard_library + (Filename.concat "ocamldoc" "custom") + +let print_warnings = ref true diff --git a/ocaml-binary-annot/ocamldoc/odoc_config.mli b/ocaml-binary-annot/ocamldoc/odoc_config.mli new file mode 100644 index 0000000000..fb356084bb --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_config.mli @@ -0,0 +1,20 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Ocamldoc configuration contants. *) + +(** Default path to search for custom generators and to install them. *) +val custom_generators_path : string + +(** A flag to indicate whether to print ocamldoc warnings or not. *) +val print_warnings : bool ref diff --git a/ocaml-binary-annot/ocamldoc/odoc_control.ml b/ocaml-binary-annot/ocamldoc/odoc_control.ml new file mode 100644 index 0000000000..b73796bf8a --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_control.ml @@ -0,0 +1,12 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) diff --git a/ocaml-binary-annot/ocamldoc/odoc_cross.ml b/ocaml-binary-annot/ocamldoc/odoc_cross.ml new file mode 100644 index 0000000000..39965f83b2 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_cross.ml @@ -0,0 +1,1006 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Cross referencing. *) + +module Name = Odoc_name +open Odoc_module +open Odoc_class +open Odoc_exception +open Odoc_types +open Odoc_value +open Odoc_type +open Odoc_parameter + +(*** Replacements of aliases : if e1 = e2 and e2 = e3, then replace e2 by e3 to have e1 = e3, + in order to associate the element with complete information. *) + +(** The module used to keep what refs were modified. *) +module S = Set.Make + ( + struct type t = string * ref_kind option + let compare = Pervasives.compare + end + ) + +let verified_refs = ref S.empty + +let add_verified v = verified_refs := S.add v !verified_refs +let was_verified v = S.mem v !verified_refs + +(** The module with the predicates used to get the aliased modules, classes and exceptions. *) +module P_alias = + struct + type t = int + + let p_module m _ = + (true, + match m.m_kind with + Module_alias _ -> true + | _ -> false + ) + let p_module_type mt _ = + (true, + match mt.mt_kind with + Some (Module_type_alias _) -> true + | _ -> false + ) + let p_class c _ = (false, false) + let p_class_type ct _ = (false, false) + let p_value v _ = false + let p_type t _ = false + let p_exception e _ = e.ex_alias <> None + let p_attribute a _ = false + let p_method m _ = false + let p_section s _ = false + end + +(** The module used to get the aliased elements. *) +module Search_alias = Odoc_search.Search (P_alias) + +type alias_state = + Alias_resolved + | Alias_to_resolve + +(** Couples of module name aliases. *) +let (module_aliases : (Name.t, Name.t * alias_state) Hashtbl.t) = Hashtbl.create 13 ;; + +(** Couples of module or module type name aliases. *) +let module_and_modtype_aliases = Hashtbl.create 13;; + +(** Couples of exception name aliases. *) +let exception_aliases = Hashtbl.create 13;; + +let rec build_alias_list = function + [] -> () + | (Odoc_search.Res_module m) :: q -> + ( + match m.m_kind with + Module_alias ma -> + Hashtbl.add module_aliases m.m_name (ma.ma_name, Alias_to_resolve); + Hashtbl.add module_and_modtype_aliases m.m_name (ma.ma_name, Alias_to_resolve) + | _ -> () + ); + build_alias_list q + | (Odoc_search.Res_module_type mt) :: q -> + ( + match mt.mt_kind with + Some (Module_type_alias mta) -> + Hashtbl.add module_and_modtype_aliases + mt.mt_name (mta.mta_name, Alias_to_resolve) + | _ -> () + ); + build_alias_list q + | (Odoc_search.Res_exception e) :: q -> + ( + match e.ex_alias with + None -> () + | Some ea -> + Hashtbl.add exception_aliases + e.ex_name (ea.ea_name,Alias_to_resolve) + ); + build_alias_list q + | _ :: q -> + build_alias_list q + +(** Retrieve the aliases for modules, module types and exceptions + and put them in global hash tables. *) +let get_alias_names module_list = + Hashtbl.clear module_aliases; + Hashtbl.clear module_and_modtype_aliases; + Hashtbl.clear exception_aliases; + build_alias_list (Search_alias.search module_list 0) + +exception Found of string +let name_alias = + let rec f t name = + try + match Hashtbl.find t name with + (s, Alias_resolved) -> s + | (s, Alias_to_resolve) -> f t s + with + Not_found -> + try + Hashtbl.iter + (fun n2 (n3, _) -> + if Name.prefix n2 name then + let ln2 = String.length n2 in + let s = n3^(String.sub name ln2 ((String.length name) - ln2)) in + raise (Found s) + ) + t ; + Hashtbl.replace t name (name, Alias_resolved); + name + with + Found s -> + let s2 = f t s in + Hashtbl.replace t s2 (s2, Alias_resolved); + s2 + in + fun name alias_tbl -> + f alias_tbl name + + +module Map_ord = + struct + type t = string + let compare = Pervasives.compare + end + +module Ele_map = Map.Make (Map_ord) + +let known_elements = ref Ele_map.empty +let add_known_element name k = + try + let l = Ele_map.find name !known_elements in + let s = Ele_map.remove name !known_elements in + known_elements := Ele_map.add name (k::l) s + with + Not_found -> + known_elements := Ele_map.add name [k] !known_elements + +let rec get_known_elements name = + try Ele_map.find name !known_elements + with Not_found -> [] + +let kind_name_exists kind = + let pred = + match kind with + RK_module -> (fun e -> match e with Odoc_search.Res_module _ -> true | _ -> false) + | RK_module_type -> (fun e -> match e with Odoc_search.Res_module_type _ -> true | _ -> false) + | RK_class -> (fun e -> match e with Odoc_search.Res_class_type _ -> true | _ -> false) + | RK_class_type -> (fun e -> match e with Odoc_search.Res_class_type _ -> true | _ -> false) + | RK_value -> (fun e -> match e with Odoc_search.Res_value _ -> true | _ -> false) + | RK_type -> (fun e -> match e with Odoc_search.Res_type _ -> true | _ -> false) + | RK_exception -> (fun e -> match e with Odoc_search.Res_exception _ -> true | _ -> false) + | RK_attribute -> (fun e -> match e with Odoc_search.Res_attribute _ -> true | _ -> false) + | RK_method -> (fun e -> match e with Odoc_search.Res_method _ -> true | _ -> false) + | RK_section _ -> assert false + in + fun name -> + try List.exists pred (get_known_elements name) + with Not_found -> false + +let module_exists = kind_name_exists RK_module +let module_type_exists = kind_name_exists RK_module_type +let class_exists = kind_name_exists RK_class +let class_type_exists = kind_name_exists RK_class_type +let value_exists = kind_name_exists RK_value +let type_exists = kind_name_exists RK_type +let exception_exists = kind_name_exists RK_exception +let attribute_exists = kind_name_exists RK_attribute +let method_exists = kind_name_exists RK_method + +let lookup_module name = + match List.find + (fun k -> match k with Odoc_search.Res_module _ -> true | _ -> false) + (get_known_elements name) + with + | Odoc_search.Res_module m -> m + | _ -> assert false + +let lookup_module_type name = + match List.find + (fun k -> match k with Odoc_search.Res_module_type _ -> true | _ -> false) + (get_known_elements name) + with + | Odoc_search.Res_module_type m -> m + | _ -> assert false + +let lookup_class name = + match List.find + (fun k -> match k with Odoc_search.Res_class _ -> true | _ -> false) + (get_known_elements name) + with + | Odoc_search.Res_class c -> c + | _ -> assert false + +let lookup_class_type name = + match List.find + (fun k -> match k with Odoc_search.Res_class_type _ -> true | _ -> false) + (get_known_elements name) + with + | Odoc_search.Res_class_type c -> c + | _ -> assert false + +let lookup_exception name = + match List.find + (fun k -> match k with Odoc_search.Res_exception _ -> true | _ -> false) + (get_known_elements name) + with + | Odoc_search.Res_exception e -> e + | _ -> assert false + +class scan = + object + inherit Odoc_scan.scanner + method! scan_value v = + add_known_element v.val_name (Odoc_search.Res_value v) + method! scan_type t = + add_known_element t.ty_name (Odoc_search.Res_type t) + method! scan_exception e = + add_known_element e.ex_name (Odoc_search.Res_exception e) + method! scan_attribute a = + add_known_element a.att_value.val_name + (Odoc_search.Res_attribute a) + method! scan_method m = + add_known_element m.met_value.val_name + (Odoc_search.Res_method m) + method! scan_class_pre c = + add_known_element c.cl_name (Odoc_search.Res_class c); + true + method! scan_class_type_pre c = + add_known_element c.clt_name (Odoc_search.Res_class_type c); + true + method! scan_module_pre m = + add_known_element m.m_name (Odoc_search.Res_module m); + true + method! scan_module_type_pre m = + add_known_element m.mt_name (Odoc_search.Res_module_type m); + true + + end + +let init_known_elements_map module_list = + let c = new scan in + c#scan_module_list module_list + + +(** The type to describe the names not found. *) +type not_found_name = + NF_m of Name.t + | NF_mt of Name.t + | NF_mmt of Name.t + | NF_c of Name.t + | NF_ct of Name.t + | NF_cct of Name.t + | NF_ex of Name.t + +(** Functions to find and associate aliases elements. *) + +let rec associate_in_module module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) m = + let rec iter_kind (acc_b, acc_inc, acc_names) k = + match k with + Module_struct elements -> + List.fold_left + (associate_in_module_element module_list m.m_name) + (acc_b, acc_inc, acc_names) + elements + + | Module_alias ma -> + ( + match ma.ma_module with + Some _ -> + (acc_b, acc_inc, acc_names) + | None -> + let mmt_opt = + try Some (Mod (lookup_module ma.ma_name)) + with Not_found -> + try Some (Modtype (lookup_module_type ma.ma_name)) + with Not_found -> None + in + match mmt_opt with + None -> (acc_b, (Name.head m.m_name) :: acc_inc, + (* we don't want to output warning messages for + "sig ... end" or "struct ... end" modules not found *) + (if ma.ma_name = Odoc_messages.struct_end or + ma.ma_name = Odoc_messages.sig_end then + acc_names + else + (NF_mmt ma.ma_name) :: acc_names) + ) + | Some mmt -> + ma.ma_module <- Some mmt ; + (true, acc_inc, acc_names) + ) + + | Module_functor (_, k) -> + iter_kind (acc_b, acc_inc, acc_names) k + + | Module_with (tk, _) -> + associate_in_module_type module_list (acc_b, acc_inc, acc_names) + { mt_name = "" ; mt_info = None ; mt_type = None ; + mt_is_interface = false ; mt_file = ""; mt_kind = Some tk ; + mt_loc = Odoc_types.dummy_loc } + + | Module_apply (k1, k2) -> + let (acc_b2, acc_inc2, acc_names2) = iter_kind (acc_b, acc_inc, acc_names) k1 in + iter_kind (acc_b2, acc_inc2, acc_names2) k2 + + | Module_constraint (k, tk) -> + let (acc_b2, acc_inc2, acc_names2) = iter_kind (acc_b, acc_inc, acc_names) k in + associate_in_module_type module_list (acc_b2, acc_inc2, acc_names2) + { mt_name = "" ; mt_info = None ; mt_type = None ; + mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ; + mt_loc = Odoc_types.dummy_loc } + + | Module_typeof _ -> + (acc_b, acc_inc, acc_names) + + | Module_unpack (code, mta) -> + begin + match mta.mta_module with + Some _ -> + (acc_b, acc_inc, acc_names) + | None -> + let mt_opt = + try Some (lookup_module_type mta.mta_name) + with Not_found -> None + in + match mt_opt with + None -> (acc_b, (Name.head m.m_name) :: acc_inc, + (* we don't want to output warning messages for + "sig ... end" or "struct ... end" modules not found *) + (if mta.mta_name = Odoc_messages.struct_end or + mta.mta_name = Odoc_messages.sig_end then + acc_names + else + (NF_mt mta.mta_name) :: acc_names) + ) + | Some mt -> + mta.mta_module <- Some mt ; + (true, acc_inc, acc_names) + end + in + iter_kind (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) m.m_kind + +and associate_in_module_type module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) mt = + let rec iter_kind (acc_b, acc_inc, acc_names) k = + match k with + Module_type_struct elements -> + List.fold_left + (associate_in_module_element module_list mt.mt_name) + (acc_b, acc_inc, acc_names) + elements + + | Module_type_functor (_, k) -> + iter_kind (acc_b, acc_inc, acc_names) k + + | Module_type_with (k, _) -> + iter_kind (acc_b, acc_inc, acc_names) k + + | Module_type_alias mta -> + begin + match mta.mta_module with + Some _ -> + (acc_b, acc_inc, acc_names) + | None -> + let mt_opt = + try Some (lookup_module_type mta.mta_name) + with Not_found -> None + in + match mt_opt with + None -> (acc_b, (Name.head mt.mt_name) :: acc_inc, + (* we don't want to output warning messages for + "sig ... end" or "struct ... end" modules not found *) + (if mta.mta_name = Odoc_messages.struct_end or + mta.mta_name = Odoc_messages.sig_end then + acc_names + else + (NF_mt mta.mta_name) :: acc_names) + ) + | Some mt -> + mta.mta_module <- Some mt ; + (true, acc_inc, acc_names) + end + | Module_type_typeof _ -> + (acc_b, acc_inc, acc_names) + in + match mt.mt_kind with + None -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) + | Some k -> iter_kind (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) k + +and associate_in_module_element module_list m_name (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) element = + match element with + Element_module m -> associate_in_module module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) m + | Element_module_type mt -> associate_in_module_type module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) mt + | Element_included_module im -> + ( + match im.im_module with + Some _ -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) + | None -> + let mmt_opt = + try Some (Mod (lookup_module im.im_name)) + with Not_found -> + try Some (Modtype (lookup_module_type im.im_name)) + with Not_found -> None + in + match mmt_opt with + None -> (acc_b_modif, (Name.head m_name) :: acc_incomplete_top_module_names, + (* we don't want to output warning messages for + "sig ... end" or "struct ... end" modules not found *) + (if im.im_name = Odoc_messages.struct_end or + im.im_name = Odoc_messages.sig_end then + acc_names_not_found + else + (NF_mmt im.im_name) :: acc_names_not_found) + ) + | Some mmt -> + im.im_module <- Some mmt ; + (true, acc_incomplete_top_module_names, acc_names_not_found) + ) + | Element_class cl -> associate_in_class module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) cl + | Element_class_type ct -> associate_in_class_type module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) ct + | Element_value _ -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) + | Element_exception ex -> + ( + match ex.ex_alias with + None -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) + | Some ea -> + match ea.ea_ex with + Some _ -> + (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) + | None -> + let ex_opt = + try Some (lookup_exception ea.ea_name) + with Not_found -> None + in + match ex_opt with + None -> (acc_b_modif, (Name.head m_name) :: acc_incomplete_top_module_names, (NF_ex ea.ea_name) :: acc_names_not_found) + | Some e -> + ea.ea_ex <- Some e ; + (true, acc_incomplete_top_module_names, acc_names_not_found) + ) + | Element_type _ -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) + | Element_module_comment _ -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) + +and associate_in_class module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) c = + let rec iter_kind (acc_b, acc_inc, acc_names) k = + match k with + Class_structure (inher_l, _) -> + let f (acc_b2, acc_inc2, acc_names2) ic = + match ic.ic_class with + Some _ -> (acc_b2, acc_inc2, acc_names2) + | None -> + let cct_opt = + try Some (Cl (lookup_class ic.ic_name)) + with Not_found -> + try Some (Cltype (lookup_class_type ic.ic_name, [])) + with Not_found -> None + in + match cct_opt with + None -> (acc_b2, (Name.head c.cl_name) :: acc_inc2, + (* we don't want to output warning messages for "object ... end" classes not found *) + (if ic.ic_name = Odoc_messages.object_end then acc_names2 else (NF_cct ic.ic_name) :: acc_names2)) + | Some cct -> + ic.ic_class <- Some cct ; + (true, acc_inc2, acc_names2) + in + List.fold_left f (acc_b, acc_inc, acc_names) inher_l + + | Class_apply capp -> + ( + match capp.capp_class with + Some _ -> (acc_b, acc_inc, acc_names) + | None -> + let cl_opt = + try Some (lookup_class capp.capp_name) + with Not_found -> None + in + match cl_opt with + None -> (acc_b, (Name.head c.cl_name) :: acc_inc, + (* we don't want to output warning messages for "object ... end" classes not found *) + (if capp.capp_name = Odoc_messages.object_end then acc_names else (NF_c capp.capp_name) :: acc_names)) + | Some c -> + capp.capp_class <- Some c ; + (true, acc_inc, acc_names) + ) + + | Class_constr cco -> + ( + match cco.cco_class with + Some _ -> (acc_b, acc_inc, acc_names) + | None -> + let cl_opt = + try Some (lookup_class cco.cco_name) + with Not_found -> None + in + match cl_opt with + None -> + ( + let clt_opt = + try Some (lookup_class_type cco.cco_name) + with Not_found -> None + in + match clt_opt with + None -> + (acc_b, (Name.head c.cl_name) :: acc_inc, + (* we don't want to output warning messages for "object ... end" classes not found *) + (if cco.cco_name = Odoc_messages.object_end then acc_names else (NF_cct cco.cco_name) :: acc_names)) + | Some ct -> + cco.cco_class <- Some (Cltype (ct, [])) ; + (true, acc_inc, acc_names) + ) + | Some c -> + cco.cco_class <- Some (Cl c) ; + (true, acc_inc, acc_names) + ) + | Class_constraint (ckind, ctkind) -> + let (acc_b2, acc_inc2, acc_names2) = iter_kind (acc_b, acc_inc, acc_names) ckind in + associate_in_class_type module_list (acc_b2, acc_inc2, acc_names2) + { clt_name = "" ; clt_info = None ; + clt_type = c.cl_type ; (* should be ok *) + clt_type_parameters = [] ; + clt_virtual = false ; + clt_kind = ctkind ; + clt_loc = Odoc_types.dummy_loc } + in + iter_kind (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) c.cl_kind + +and associate_in_class_type module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) ct = + let rec iter_kind (acc_b, acc_inc, acc_names) k = + match k with + Class_signature (inher_l, _) -> + let f (acc_b2, acc_inc2, acc_names2) ic = + match ic.ic_class with + Some _ -> (acc_b2, acc_inc2, acc_names2) + | None -> + let cct_opt = + try Some (Cltype (lookup_class_type ic.ic_name, [])) + with Not_found -> + try Some (Cl (lookup_class ic.ic_name)) + with Not_found -> None + in + match cct_opt with + None -> (acc_b2, (Name.head ct.clt_name) :: acc_inc2, + (* we don't want to output warning messages for "object ... end" class types not found *) + (if ic.ic_name = Odoc_messages.object_end then acc_names2 else (NF_cct ic.ic_name) :: acc_names2)) + | Some cct -> + ic.ic_class <- Some cct ; + (true, acc_inc2, acc_names2) + in + List.fold_left f (acc_b, acc_inc, acc_names) inher_l + + | Class_type cta -> + ( + match cta.cta_class with + Some _ -> (acc_b, acc_inc, acc_names) + | None -> + let cct_opt = + try Some (Cltype (lookup_class_type cta.cta_name, [])) + with Not_found -> + try Some (Cl (lookup_class cta.cta_name)) + with Not_found -> None + in + match cct_opt with + None -> (acc_b, (Name.head ct.clt_name) :: acc_inc, + (* we don't want to output warning messages for "object ... end" class types not found *) + (if cta.cta_name = Odoc_messages.object_end then acc_names else (NF_cct cta.cta_name) :: acc_names)) + | Some c -> + cta.cta_class <- Some c ; + (true, acc_inc, acc_names) + ) + in + iter_kind (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) ct.clt_kind + +(*************************************************************) +(** Association of types to elements referenced in comments .*) + +let ao = Odoc_misc.apply_opt + +let not_found_of_kind kind name = + (match kind with + RK_module -> Odoc_messages.cross_module_not_found + | RK_module_type -> Odoc_messages.cross_module_type_not_found + | RK_class -> Odoc_messages.cross_class_not_found + | RK_class_type -> Odoc_messages.cross_class_type_not_found + | RK_value -> Odoc_messages.cross_value_not_found + | RK_type -> Odoc_messages.cross_type_not_found + | RK_exception -> Odoc_messages.cross_exception_not_found + | RK_attribute -> Odoc_messages.cross_attribute_not_found + | RK_method -> Odoc_messages.cross_method_not_found + | RK_section _ -> Odoc_messages.cross_section_not_found + ) name + +let rec assoc_comments_text_elements parent_name module_list t_ele = + match t_ele with + | Raw _ + | Code _ + | CodePre _ + | Latex _ + | Verbatim _ -> t_ele + | Bold t -> Bold (assoc_comments_text parent_name module_list t) + | Italic t -> Italic (assoc_comments_text parent_name module_list t) + | Center t -> Center (assoc_comments_text parent_name module_list t) + | Left t -> Left (assoc_comments_text parent_name module_list t) + | Right t -> Right (assoc_comments_text parent_name module_list t) + | Emphasize t -> Emphasize (assoc_comments_text parent_name module_list t) + | List l -> List (List.map (assoc_comments_text parent_name module_list) l) + | Enum l -> Enum (List.map (assoc_comments_text parent_name module_list) l) + | Newline -> Newline + | Block t -> Block (assoc_comments_text parent_name module_list t) + | Superscript t -> Superscript (assoc_comments_text parent_name module_list t) + | Subscript t -> Subscript (assoc_comments_text parent_name module_list t) + | Title (n, l_opt, t) -> Title (n, l_opt, (assoc_comments_text parent_name module_list t)) + | Link (s, t) -> Link (s, (assoc_comments_text parent_name module_list t)) + | Ref (initial_name, None, text_option) -> + ( + let rec iter_parent ?parent_name name = + let name = Odoc_name.normalize_name name in + let res = + match get_known_elements name with + [] -> + ( + try + let re = Str.regexp ("^"^(Str.quote name)^"$") in + let t = Odoc_search.find_section module_list re in + let v2 = (name, Some (RK_section t)) in + add_verified v2 ; + (name, Some (RK_section t)) + with + Not_found -> + (name, None) + ) + | ele :: _ -> + (* we look for the first element with this name *) + let (name, kind) = + match ele with + Odoc_search.Res_module m -> (m.m_name, RK_module) + | Odoc_search.Res_module_type mt -> (mt.mt_name, RK_module_type) + | Odoc_search.Res_class c -> (c.cl_name, RK_class) + | Odoc_search.Res_class_type ct -> (ct.clt_name, RK_class_type) + | Odoc_search.Res_value v -> (v.val_name, RK_value) + | Odoc_search.Res_type t -> (t.ty_name, RK_type) + | Odoc_search.Res_exception e -> (e.ex_name, RK_exception) + | Odoc_search.Res_attribute a -> (a.att_value.val_name, RK_attribute) + | Odoc_search.Res_method m -> (m.met_value.val_name, RK_method) + | Odoc_search.Res_section (_ ,t)-> assert false + in + add_verified (name, Some kind) ; + (name, Some kind) + in + match res with + | (name, Some k) -> Ref (name, Some k, text_option) + | (_, None) -> + match parent_name with + None -> + Odoc_global.pwarning (Odoc_messages.cross_element_not_found initial_name); + Ref (initial_name, None, text_option) + | Some p -> + let parent_name = + match Name.father p with + "" -> None + | s -> Some s + in + iter_parent ?parent_name (Name.concat p initial_name) + in + iter_parent ~parent_name initial_name + ) + | Ref (initial_name, Some kind, text_option) -> + ( + let rec iter_parent ?parent_name name = + let v = (name, Some kind) in + if was_verified v then + Ref (name, Some kind, text_option) + else + let res = + match kind with + | RK_section _ -> + ( + (** we just verify that we find an element of this kind with this name *) + try + let re = Str.regexp ("^"^(Str.quote name)^"$") in + let t = Odoc_search.find_section module_list re in + let v2 = (name, Some (RK_section t)) in + add_verified v2 ; + (name, Some (RK_section t)) + with + Not_found -> + (name, None) + ) + | _ -> + let f = + match kind with + RK_module -> module_exists + | RK_module_type -> module_type_exists + | RK_class -> class_exists + | RK_class_type -> class_type_exists + | RK_value -> value_exists + | RK_type -> type_exists + | RK_exception -> exception_exists + | RK_attribute -> attribute_exists + | RK_method -> method_exists + | RK_section _ -> assert false + in + if f name then + ( + add_verified v ; + (name, Some kind) + ) + else + (name, None) + in + match res with + | (name, Some k) -> Ref (name, Some k, text_option) + | (_, None) -> + match parent_name with + None -> + Odoc_global.pwarning (not_found_of_kind kind initial_name); + Ref (initial_name, None, text_option) + | Some p -> + let parent_name = + match Name.father p with + "" -> None + | s -> Some s + in + iter_parent ?parent_name (Name.concat p initial_name) + in + iter_parent ~parent_name initial_name + ) + | Module_list l -> + Module_list l + | Index_list -> + Index_list + | Custom (s,t) -> Custom (s, (assoc_comments_text parent_name module_list t)) + | Target (target, code) -> Target (target, code) + +and assoc_comments_text parent_name module_list text = + List.map (assoc_comments_text_elements parent_name module_list) text + +and assoc_comments_info parent_name module_list i = + let ft = assoc_comments_text parent_name module_list in + { + i with + i_desc = ao ft i.i_desc ; + i_sees = List.map (fun (sr, t) -> (sr, ft t)) i.i_sees; + i_deprecated = ao ft i.i_deprecated ; + i_params = List.map (fun (name, t) -> (name, ft t)) i.i_params; + i_raised_exceptions = List.map (fun (name, t) -> (name, ft t)) i.i_raised_exceptions; + i_return_value = ao ft i.i_return_value ; + i_custom = List.map (fun (tag, t) -> (tag, ft t)) i.i_custom ; + } + + +let rec assoc_comments_module_element parent_name module_list m_ele = + match m_ele with + Element_module m -> + Element_module (assoc_comments_module module_list m) + | Element_module_type mt -> + Element_module_type (assoc_comments_module_type module_list mt) + | Element_included_module _ -> + m_ele (* don't go down into the aliases *) + | Element_class c -> + Element_class (assoc_comments_class module_list c) + | Element_class_type ct -> + Element_class_type (assoc_comments_class_type module_list ct) + | Element_value v -> + Element_value (assoc_comments_value module_list v) + | Element_exception e -> + Element_exception (assoc_comments_exception module_list e) + | Element_type t -> + Element_type (assoc_comments_type module_list t) + | Element_module_comment t -> + Element_module_comment (assoc_comments_text parent_name module_list t) + +and assoc_comments_class_element parent_name module_list c_ele = + match c_ele with + Class_attribute a -> + Class_attribute (assoc_comments_attribute module_list a) + | Class_method m -> + Class_method (assoc_comments_method module_list m) + | Class_comment t -> + Class_comment (assoc_comments_text parent_name module_list t) + +and assoc_comments_module_kind parent_name module_list mk = + match mk with + | Module_struct eles -> + Module_struct + (List.map (assoc_comments_module_element parent_name module_list) eles) + | Module_alias _ + | Module_functor _ -> + mk + | Module_apply (mk1, mk2) -> + Module_apply (assoc_comments_module_kind parent_name module_list mk1, + assoc_comments_module_kind parent_name module_list mk2) + | Module_with (mtk, s) -> + Module_with (assoc_comments_module_type_kind parent_name module_list mtk, s) + | Module_constraint (mk1, mtk) -> + Module_constraint + (assoc_comments_module_kind parent_name module_list mk1, + assoc_comments_module_type_kind parent_name module_list mtk) + | Module_typeof _ -> mk + | Module_unpack _ -> mk + +and assoc_comments_module_type_kind parent_name module_list mtk = + match mtk with + | Module_type_struct eles -> + Module_type_struct + (List.map (assoc_comments_module_element parent_name module_list) eles) + | Module_type_functor (params, mtk1) -> + Module_type_functor + (params, assoc_comments_module_type_kind parent_name module_list mtk1) + | Module_type_alias _ -> + mtk + | Module_type_with (mtk1, s) -> + Module_type_with + (assoc_comments_module_type_kind parent_name module_list mtk1, s) + | Module_type_typeof _ -> mtk + +and assoc_comments_class_kind parent_name module_list ck = + match ck with + Class_structure (inher, eles) -> + let inher2 = + List.map + (fun ic -> + { ic with + ic_text = ao (assoc_comments_text parent_name module_list) ic.ic_text }) + inher + in + Class_structure + (inher2, List.map (assoc_comments_class_element parent_name module_list) eles) + + | Class_apply _ + | Class_constr _ -> ck + | Class_constraint (ck1, ctk) -> + Class_constraint (assoc_comments_class_kind parent_name module_list ck1, + assoc_comments_class_type_kind parent_name module_list ctk) + +and assoc_comments_class_type_kind parent_name module_list ctk = + match ctk with + Class_signature (inher, eles) -> + let inher2 = + List.map + (fun ic -> { ic with + ic_text = ao (assoc_comments_text parent_name module_list) ic.ic_text }) + inher + in + Class_signature (inher2, List.map (assoc_comments_class_element parent_name module_list) eles) + + | Class_type _ -> ctk + + +and assoc_comments_module module_list m = + m.m_info <- ao (assoc_comments_info m.m_name module_list) m.m_info ; + m.m_kind <- assoc_comments_module_kind m.m_name module_list m.m_kind ; + m + +and assoc_comments_module_type module_list mt = + mt.mt_info <- ao (assoc_comments_info mt.mt_name module_list) mt.mt_info ; + mt.mt_kind <- ao (assoc_comments_module_type_kind mt.mt_name module_list) mt.mt_kind ; + mt + +and assoc_comments_class module_list c = + c.cl_info <- ao (assoc_comments_info c.cl_name module_list) c.cl_info ; + c.cl_kind <- assoc_comments_class_kind c.cl_name module_list c.cl_kind ; + assoc_comments_parameter_list c.cl_name module_list c.cl_parameters; + c + +and assoc_comments_class_type module_list ct = + ct.clt_info <- ao (assoc_comments_info ct.clt_name module_list) ct.clt_info ; + ct.clt_kind <- assoc_comments_class_type_kind ct.clt_name module_list ct.clt_kind ; + ct + +and assoc_comments_parameter parent_name module_list p = + match p with + Simple_name sn -> + sn.sn_text <- ao (assoc_comments_text parent_name module_list) sn.sn_text + | Tuple (l, t) -> + List.iter (assoc_comments_parameter parent_name module_list) l + +and assoc_comments_parameter_list parent_name module_list pl = + List.iter (assoc_comments_parameter parent_name module_list) pl + +and assoc_comments_value module_list v = + let parent = Name.father v.val_name in + v.val_info <- ao (assoc_comments_info parent module_list) v.val_info ; + assoc_comments_parameter_list parent module_list v.val_parameters; + v + +and assoc_comments_exception module_list e = + let parent = Name.father e.ex_name in + e.ex_info <- ao (assoc_comments_info parent module_list) e.ex_info ; + e + +and assoc_comments_type module_list t = + let parent = Name.father t.ty_name in + t.ty_info <- ao (assoc_comments_info parent module_list) t.ty_info ; + (match t.ty_kind with + Type_abstract -> () + | Type_variant vl -> + List.iter + (fun vc -> vc.vc_text <- ao (assoc_comments_text parent module_list) vc.vc_text) + vl + | Type_record fl -> + List.iter + (fun rf -> rf.rf_text <- ao (assoc_comments_text parent module_list) rf.rf_text) + fl + ); + t + +and assoc_comments_attribute module_list a = + let _ = assoc_comments_value module_list a.att_value in + a + +and assoc_comments_method module_list m = + let parent_name = Name.father m.met_value.val_name in + let _ = assoc_comments_value module_list m.met_value in + assoc_comments_parameter_list parent_name module_list m.met_value.val_parameters; + m + + +let associate_type_of_elements_in_comments module_list = + List.map (assoc_comments_module module_list) module_list + + +(***********************************************************) +(** The function which performs all the cross referencing. *) +let associate module_list = + get_alias_names module_list ; + init_known_elements_map module_list; + let rec remove_doubles acc = function + [] -> acc + | h :: q -> + if List.mem h acc then remove_doubles acc q + else remove_doubles (h :: acc) q + in + let rec iter incomplete_modules = + let (b_modif, remaining_inc_modules, acc_names_not_found) = + List.fold_left (associate_in_module module_list) (false, [], []) incomplete_modules + in + let remaining_no_doubles = remove_doubles [] remaining_inc_modules in + let remaining_modules = List.filter + (fun m -> List.mem m.m_name remaining_no_doubles) + incomplete_modules + in + if b_modif then + (* we may be able to associate something else *) + iter remaining_modules + else + (* nothing changed, we won't be able to associate any more *) + acc_names_not_found + in + let names_not_found = iter module_list in + ( + match names_not_found with + [] -> + () + | l -> + List.iter + (fun nf -> + Odoc_global.pwarning + ( + match nf with + NF_m n -> Odoc_messages.cross_module_not_found n + | NF_mt n -> Odoc_messages.cross_module_type_not_found n + | NF_mmt n -> Odoc_messages.cross_module_or_module_type_not_found n + | NF_c n -> Odoc_messages.cross_class_not_found n + | NF_ct n -> Odoc_messages.cross_class_type_not_found n + | NF_cct n -> Odoc_messages.cross_class_or_class_type_not_found n + | NF_ex n -> Odoc_messages.cross_exception_not_found n + ); + ) + l + ) ; + + (* Find a type for each name of element which is referenced in comments. *) + ignore (associate_type_of_elements_in_comments module_list) diff --git a/ocaml-binary-annot/ocamldoc/odoc_cross.mli b/ocaml-binary-annot/ocamldoc/odoc_cross.mli new file mode 100644 index 0000000000..2fce2c48c1 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_cross.mli @@ -0,0 +1,20 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Cross-referencing. *) + +val associate : Odoc_module.t_module list -> unit + +val assoc_comments_info : + string -> Odoc_module.t_module list -> + Odoc_types.info -> Odoc_types.info diff --git a/ocaml-binary-annot/ocamldoc/odoc_dag2html.ml b/ocaml-binary-annot/ocamldoc/odoc_dag2html.ml new file mode 100644 index 0000000000..cfdf9abcb4 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_dag2html.ml @@ -0,0 +1,1750 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** The types and functions to create a html table representing a dag. Thanks to Daniel De Rauglaudre. *) + +type 'a dag = { mutable dag : 'a node array } +and 'a node = + { mutable pare : idag list; valu : 'a; mutable chil : idag list } +and idag = int +;; + +external int_of_idag : idag -> int = "%identity";; +external idag_of_int : int -> idag = "%identity";; + +type 'a table = { mutable table : 'a data array array } +and 'a data = { mutable elem : 'a elem; mutable span : span_id } +and 'a elem = Elem of 'a | Ghost of ghost_id | Nothing +and span_id +and ghost_id +;; + +external span_id_of_int : int -> span_id = "%identity";; +external int_of_span_id : span_id -> int = "%identity";; +external ghost_id_of_int : int -> ghost_id = "%identity";; +external int_of_ghost_id : ghost_id -> int = "%identity";; + +let new_span_id = let i = ref 0 in fun () -> incr i; span_id_of_int !i;; + +let new_ghost_id = let i = ref 0 in fun () -> incr i; ghost_id_of_int !i;; + +(** creating the html table structure *) + +type align = LeftA | CenterA | RightA;; +type table_data = TDstring of string | TDhr of align;; +type html_table = (int * align * table_data) array array;; + +let html_table_struct indi_txt phony d t = + let phony = + function + Elem e -> phony d.dag.(int_of_idag e) + | Ghost _ -> false + | Nothing -> true + in + let elem_txt = + function + Elem e -> indi_txt d.dag.(int_of_idag e) + | Ghost _ -> "|" + | Nothing -> " " + in + let bar_txt = + function + Elem _ | Ghost _ -> "|" + | Nothing -> " " + in + let all_empty i = + let rec loop j = + if j = Array.length t.table.(i) then true + else + match t.table.(i).(j).elem with + Nothing -> loop (j + 1) + | e -> if phony e then loop (j + 1) else false + in + loop 0 + in + let line_elem_txt i = + let les = + let rec loop les j = + if j = Array.length t.table.(i) then les + else + let x = t.table.(i).(j) in + let next_j = + let rec loop j = + if j = Array.length t.table.(i) then j + else if t.table.(i).(j) = x then loop (j + 1) + else j + in + loop (j + 1) + in + let colspan = 3 * (next_j - j) in + let les = (1, LeftA, TDstring " ") :: les in + let les = + let s = + if t.table.(i).(j).elem = Nothing then " " + else elem_txt t.table.(i).(j).elem + in + (colspan - 2, CenterA, TDstring s) :: les + in + let les = (1, LeftA, TDstring " ") :: les in loop les next_j + in + loop [] 0 + in + Array.of_list (List.rev les) + in + let vbars_txt k i = + let les = + let rec loop les j = + if j = Array.length t.table.(i) then les + else + let x = t.table.(i).(j) in + let next_j = + let rec loop j = + if j = Array.length t.table.(i) then j + else if t.table.(i).(j) = x then loop (j + 1) + else j + in + loop (j + 1) + in + let colspan = 3 * (next_j - j) in + let les = (1, LeftA, TDstring " ") :: les in + let les = + let s = + if k > 0 && t.table.(k - 1).(j).elem = Nothing || + t.table.(k).(j).elem = Nothing then + " " + else if phony t.table.(i).(j).elem then " " + else bar_txt t.table.(i).(j).elem + in + (colspan - 2, CenterA, TDstring s) :: les + in + let les = (1, LeftA, TDstring " ") :: les in loop les next_j + in + loop [] 0 + in + Array.of_list (List.rev les) + in + let alone_bar_txt i = + let les = + let rec loop les j = + if j = Array.length t.table.(i) then les + else + let next_j = + let x = t.table.(i).(j).span in + let rec loop j = + if j = Array.length t.table.(i) then j + else if t.table.(i).(j).span = x then loop (j + 1) + else j + in + loop (j + 1) + in + let colspan = 3 * (next_j - j) - 2 in + let les = (1, LeftA, TDstring " ") :: les in + let les = + if t.table.(i).(j).elem = Nothing || + t.table.(i + 1).(j).elem = Nothing then + (colspan, LeftA, TDstring " ") :: les + else + let s = + let all_ph = + let rec loop j = + if j = next_j then true + else if phony t.table.(i + 1).(j).elem then loop (j + 1) + else false + in + loop j + in + if all_ph then " " else "|" + in + (colspan, CenterA, TDstring s) :: les + in + let les = (1, LeftA, TDstring " ") :: les in loop les next_j + in + loop [] 0 + in + Array.of_list (List.rev les) + in + let exist_several_branches i k = + let rec loop j = + if j = Array.length t.table.(i) then false + else + let x = t.table.(i).(j).span in + let e = t.table.(k).(j).elem in + let rec loop1 j = + if j = Array.length t.table.(i) then false + else if t.table.(i).(j).elem = Nothing then loop j + else if t.table.(i).(j).span <> x then loop j + else if t.table.(k).(j).elem <> e then true + else loop1 (j + 1) + in + loop1 (j + 1) + in + loop 0 + in + let hbars_txt i k = + let les = + let rec loop les j = + if j = Array.length t.table.(i) then les + else + let next_j = + let e = t.table.(i).(j).elem in + let x = t.table.(i).(j).span in + let rec loop j = + if j = Array.length t.table.(i) then j + else if e = Nothing && t.table.(i).(j).elem = Nothing then + loop (j + 1) + else if t.table.(i).(j).span = x then loop (j + 1) + else j + in + loop (j + 1) + in + let rec loop1 les l = + if l = next_j then loop les next_j + else + let next_l = + let y = t.table.(k).(l) in + match y.elem with + Elem _ | Ghost _ -> + let rec loop l = + if l = Array.length t.table.(i) then l + else if t.table.(k).(l) = y then loop (l + 1) + else l + in + loop (l + 1) + | _ -> l + 1 + in + if next_l > next_j then + begin + Printf.eprintf + "assert false i %d k %d l %d next_l %d next_j %d\n" i k l + next_l next_j; + flush stderr + end; + let next_l = min next_l next_j in + let colspan = 3 * (next_l - l) - 2 in + let les = + match t.table.(i).(l).elem, t.table.(i + 1).(l).elem with + Nothing, _ | _, Nothing -> + (colspan + 2, LeftA, TDstring " ") :: les + | _ -> + let ph s = + if phony t.table.(k).(l).elem then TDstring " " + else s + in + if l = j && next_l = next_j then + let les = (1, LeftA, TDstring " ") :: les in + let s = ph (TDstring "|") in + let les = (colspan, CenterA, s) :: les in + let les = (1, LeftA, TDstring " ") :: les in les + else if l = j then + let les = (1, LeftA, TDstring " ") :: les in + let s = ph (TDhr RightA) in + let les = (colspan, RightA, s) :: les in + let s = ph (TDhr CenterA) in + let les = (1, LeftA, s) :: les in les + else if next_l = next_j then + let s = ph (TDhr CenterA) in + let les = (1, LeftA, s) :: les in + let s = ph (TDhr LeftA) in + let les = (colspan, LeftA, s) :: les in + let les = (1, LeftA, TDstring " ") :: les in les + else + let s = ph (TDhr CenterA) in + (colspan + 2, LeftA, s) :: les + in + loop1 les next_l + in + loop1 les j + in + loop [] 0 + in + Array.of_list (List.rev les) + in + let hts = + let rec loop hts i = + if i = Array.length t.table then hts + else if i = Array.length t.table - 1 && all_empty i then hts + else + let hts = line_elem_txt i :: hts in + let hts = + if i < Array.length t.table - 1 then + let hts = vbars_txt (i + 1) i :: hts in + let hts = + if exist_several_branches i i then + alone_bar_txt i :: hbars_txt i i :: hts + else hts + in + let hts = + if exist_several_branches i (i + 1) && + (i < Array.length t.table - 2 || + not (all_empty (i + 1))) then + vbars_txt (i + 1) (i + 1) :: hbars_txt i (i + 1) :: hts + else hts + in + hts + else hts + in + loop hts (i + 1) + in + loop [] 0 + in + Array.of_list (List.rev hts) +;; + +(** transforming dag into table *) + +let ancestors d = + let rec loop i = + if i = Array.length d.dag then [] + else + let n = d.dag.(i) in + if n.pare = [] then idag_of_int i :: loop (i + 1) else loop (i + 1) + in + loop 0 +;; + +let get_children d parents = + let rec merge_children children el = + List.fold_right + (fun (x, _) children -> + match x with + Elem e -> + let e = d.dag.(int_of_idag e) in + List.fold_right + (fun c children -> + if List.mem c children then children else c :: children) + e.chil children + | _ -> []) + el children + in + merge_children [] parents +;; + +let rec get_block t i j = + if j = Array.length t.table.(i) then None + else if j = Array.length t.table.(i) - 1 then + let x = t.table.(i).(j) in Some ([x.elem, 1], 1, x.span) + else + let x = t.table.(i).(j) in + let y = t.table.(i).(j + 1) in + if y.span = x.span then + match get_block t i (j + 1) with + Some ((x1, c1) :: list, mpc, span) -> + let (list, mpc) = + if x1 = x.elem then (x1, c1 + 1) :: list, max mpc (c1 + 1) + else (x.elem, 1) :: (x1, c1) :: list, max mpc c1 + in + Some (list, mpc, span) + | _ -> assert false + else Some ([x.elem, 1], 1, x.span) +;; + +let group_by_common_children d list = + let module O = struct type t = idag;; let compare = compare;; end + in + let module S = Set.Make (O) + in + let nlcsl = + List.map + (fun id -> + let n = d.dag.(int_of_idag id) in + let cs = List.fold_right S.add n.chil S.empty in [id], cs) + list + in + let nlcsl = + let rec loop = + function + [] -> [] + | (nl, cs) :: rest -> + let rec loop1 beg = + function + (nl1, cs1) :: rest1 -> + if S.is_empty (S.inter cs cs1) then + loop1 ((nl1, cs1) :: beg) rest1 + else + loop ((nl @ nl1, S.union cs cs1) :: (List.rev beg @ rest1)) + | [] -> (nl, cs) :: loop rest + in + loop1 [] rest + in + loop nlcsl + in + List.fold_right + (fun (nl, _) a -> + let span = new_span_id () in + List.fold_right (fun n a -> {elem = Elem n; span = span} :: a) nl a) + nlcsl [] +;; + +let copy_data d = {elem = d.elem; span = d.span};; + +let insert_columns t nb j = + let t1 = Array.create (Array.length t.table) [| |] in + for i = 0 to Array.length t.table - 1 do + let line = t.table.(i) in + let line1 = Array.create (Array.length line + nb) line.(0) in + t1.(i) <- line1; + let rec loop k = + if k = Array.length line then () + else + begin + if k < j then line1.(k) <- copy_data line.(k) + else if k = j then + for r = 0 to nb do line1.(k + r) <- copy_data line.(k) done + else line1.(k + nb) <- copy_data line.(k); + loop (k + 1) + end + in + loop 0 + done; + {table = t1} +;; + +let rec gcd a b = + if a < b then gcd b a else if b = 0 then a else gcd b (a mod b) +;; + +let treat_new_row d t = + let i = Array.length t.table - 1 in + let rec loop t i j = + match get_block t i j with + Some (parents, max_parent_colspan, span) -> + let children = get_children d parents in + let children = + if children = [] then [{elem = Nothing; span = new_span_id ()}] + else + List.map (fun n -> {elem = Elem n; span = new_span_id ()}) + children + in + let simple_parents_colspan = + List.fold_left (fun x (_, c) -> x + c) 0 parents + in + if simple_parents_colspan mod List.length children = 0 then + let j = j + simple_parents_colspan in + let children = + let cnt = simple_parents_colspan / List.length children in + List.fold_right + (fun d list -> + let rec loop cnt list = + if cnt = 1 then d :: list + else copy_data d :: loop (cnt - 1) list + in + loop cnt list) + children [] + in + let (t, children_rest) = loop t i j in t, children @ children_rest + else + let parent_colspan = + List.fold_left + (fun scm (_, c) -> let g = gcd scm c in scm / g * c) + max_parent_colspan parents + in + let (t, parents, _) = + List.fold_left + (fun (t, parents, j) (x, c) -> + let to_add = parent_colspan / c - 1 in + let t = + let rec loop cc t j = + if cc = 0 then t + else + let t = insert_columns t to_add j in + loop (cc - 1) t (j + to_add + 1) + in + loop c t j + in + t, (x, parent_colspan) :: parents, j + parent_colspan) + (t, [], j) parents + in + let parents = List.rev parents in + let parents_colspan = parent_colspan * List.length parents in + let children_colspan = List.length children in + let g = gcd parents_colspan children_colspan in + let (t, j) = + let cnt = children_colspan / g in + List.fold_left + (fun (t, j) (_, c) -> + let rec loop cc t j = + if cc = 0 then t, j + else + let t = insert_columns t (cnt - 1) j in + let j = j + cnt in loop (cc - 1) t j + in + loop c t j) + (t, j) parents + in + let children = + let cnt = parents_colspan / g in + List.fold_right + (fun d list -> + let rec loop cnt list = + if cnt = 0 then list else d :: loop (cnt - 1) list + in + loop cnt list) + children [] + in + let (t, children_rest) = loop t i j in t, children @ children_rest + | None -> t, [] + in + loop t i 0 +;; + +let down_it t i k y = + t.table.(Array.length t.table - 1).(k) <- t.table.(i).(k); + for r = i to Array.length t.table - 2 do + t.table.(r).(k) <- {elem = Ghost (new_ghost_id ()); span = new_span_id ()} + done +;; + +(* equilibrate: + in the last line, for all elem A, make fall all As, which are located at + its right side above, to its line, + A | + i.e. transform all . into | + A....... A......A +*) + +let equilibrate t = + let ilast = Array.length t.table - 1 in + let last = t.table.(ilast) in + let len = Array.length last in + let rec loop j = + if j = len then () + else + match last.(j).elem with + Elem x -> + let rec loop1 i = + if i = ilast then loop (j + 1) + else + let rec loop2 k = + if k = len then loop1 (i + 1) + else + match t.table.(i).(k).elem with + Elem y when x = y -> down_it t i k y; loop 0 + | _ -> loop2 (k + 1) + in + loop2 0 + in + loop1 0 + | _ -> loop (j + 1) + in + loop 0 +;; + +(* group_elem: + transform all x y into x x + A A A A *) + +let group_elem t = + for i = 0 to Array.length t.table - 2 do + for j = 1 to Array.length t.table.(0) - 1 do + match t.table.(i + 1).(j - 1).elem, t.table.(i + 1).(j).elem with + Elem x, Elem y when x = y -> + t.table.(i).(j).span <- t.table.(i).(j - 1).span + | _ -> () + done + done +;; + +(* group_ghost: + x x x x |a |a |a |a + transform all |a |b into |a |a and all x y into x x + y z y y A A A A *) + +let group_ghost t = + for i = 0 to Array.length t.table - 2 do + for j = 1 to Array.length t.table.(0) - 1 do + begin match t.table.(i + 1).(j - 1).elem, t.table.(i + 1).(j).elem with + Ghost x, Ghost _ -> + if t.table.(i).(j - 1).span = t.table.(i).(j).span then + t.table.(i + 1).(j) <- + {elem = Ghost x; span = t.table.(i + 1).(j - 1).span} + | _ -> () + end; + match t.table.(i).(j - 1).elem, t.table.(i).(j).elem with + Ghost x, Ghost _ -> + if t.table.(i + 1).(j - 1).elem = t.table.(i + 1).(j).elem then + begin + t.table.(i).(j) <- + {elem = Ghost x; span = t.table.(i).(j - 1).span}; + if i > 0 then + t.table.(i - 1).(j).span <- t.table.(i - 1).(j - 1).span + end + | _ -> () + done + done +;; + +(* group_children: + transform all A A into A A + x y x x *) + +let group_children t = + for i = 0 to Array.length t.table - 1 do + let line = t.table.(i) in + let len = Array.length line in + for j = 1 to len - 1 do + if line.(j).elem = line.(j - 1).elem && line.(j).elem <> Nothing then + line.(j).span <- line.(j - 1).span + done + done +;; + +(* group_span_by_common_children: + in the last line, transform all + A B into A B + x y x x + if A and B have common children *) + +let group_span_by_common_children d t = + let module O = struct type t = idag;; let compare = compare;; end + in + let module S = Set.Make (O) + in + let i = Array.length t.table - 1 in + let line = t.table.(i) in + let rec loop j cs = + if j = Array.length line then () + else + match line.(j).elem with + Elem id -> + let n = d.dag.(int_of_idag id) in + let curr_cs = List.fold_right S.add n.chil S.empty in + if S.is_empty (S.inter cs curr_cs) then loop (j + 1) curr_cs + else + begin + line.(j).span <- line.(j - 1).span; + loop (j + 1) (S.union cs curr_cs) + end + | _ -> loop (j + 1) S.empty + in + loop 0 S.empty +;; + +let find_same_parents t i j1 j2 j3 j4 = + let rec loop i j1 j2 j3 j4 = + if i = 0 then i, j1, j2, j3, j4 + else + let x1 = t.(i - 1).(j1) in + let x2 = t.(i - 1).(j2) in + let x3 = t.(i - 1).(j3) in + let x4 = t.(i - 1).(j4) in + if x1.span = x4.span then i, j1, j2, j3, j4 + else + let j1 = + let rec loop j = + if j < 0 then 0 + else if t.(i - 1).(j).span = x1.span then loop (j - 1) + else j + 1 + in + loop (j1 - 1) + in + let j2 = + let rec loop j = + if j >= Array.length t.(i) then j - 1 + else if t.(i - 1).(j).span = x2.span then loop (j + 1) + else j - 1 + in + loop (j2 + 1) + in + let j3 = + let rec loop j = + if j < 0 then 0 + else if t.(i - 1).(j).span = x3.span then loop (j - 1) + else j + 1 + in + loop (j3 - 1) + in + let j4 = + let rec loop j = + if j >= Array.length t.(i) then j - 1 + else if t.(i - 1).(j).span = x4.span then loop (j + 1) + else j - 1 + in + loop (j4 + 1) + in + loop (i - 1) j1 j2 j3 j4 + in + loop i j1 j2 j3 j4 +;; + +let find_linked_children t i j1 j2 j3 j4 = + let rec loop i j1 j2 j3 j4 = + if i = Array.length t - 1 then j1, j2, j3, j4 + else + let x1 = t.(i).(j1) in + let x2 = t.(i).(j2) in + let x3 = t.(i).(j3) in + let x4 = t.(i).(j4) in + let j1 = + let rec loop j = + if j < 0 then 0 + else if t.(i).(j).span = x1.span then loop (j - 1) + else j + 1 + in + loop (j1 - 1) + in + let j2 = + let rec loop j = + if j >= Array.length t.(i) then j - 1 + else if t.(i).(j).span = x2.span then loop (j + 1) + else j - 1 + in + loop (j2 + 1) + in + let j3 = + let rec loop j = + if j < 0 then 0 + else if t.(i).(j).span = x3.span then loop (j - 1) + else j + 1 + in + loop (j3 - 1) + in + let j4 = + let rec loop j = + if j >= Array.length t.(i) then j - 1 + else if t.(i).(j).span = x4.span then loop (j + 1) + else j - 1 + in + loop (j4 + 1) + in + loop (i + 1) j1 j2 j3 j4 + in + loop i j1 j2 j3 j4 +;; + +let mirror_block t i1 i2 j1 j2 = + for i = i1 to i2 do + let line = t.(i) in + let rec loop j1 j2 = + if j1 >= j2 then () + else + let v = line.(j1) in + line.(j1) <- line.(j2); line.(j2) <- v; loop (j1 + 1) (j2 - 1) + in + loop j1 j2 + done +;; + +let exch_blocks t i1 i2 j1 j2 j3 j4 = + for i = i1 to i2 do + let line = t.(i) in + let saved = Array.copy line in + for j = j1 to j2 do line.(j4 - j2 + j) <- saved.(j) done; + for j = j3 to j4 do line.(j1 - j3 + j) <- saved.(j) done + done +;; + +let find_block_with_parents t i jj1 jj2 jj3 jj4 = + let rec loop ii jj1 jj2 jj3 jj4 = + let (nii, njj1, njj2, njj3, njj4) = + find_same_parents t i jj1 jj2 jj3 jj4 + in + if nii <> ii || njj1 <> jj1 || njj2 <> jj2 || njj3 <> jj3 || + njj4 <> jj4 then + let nii = min ii nii in + let (jj1, jj2, jj3, jj4) = + find_linked_children t nii njj1 njj2 njj3 njj4 + in + if njj1 <> jj1 || njj2 <> jj2 || njj3 <> jj3 || njj4 <> jj4 then + loop nii jj1 jj2 jj3 jj4 + else nii, jj1, jj2, jj3, jj4 + else ii, jj1, jj2, jj3, jj4 + in + loop i jj1 jj2 jj3 jj4 +;; + +let push_to_right d t i j1 j2 = + let line = t.(i) in + let rec loop j = + if j = j2 then j - 1 + else + let ini_jj1 = + match line.(j - 1).elem with + Nothing -> j - 1 + | x -> + let rec same_value j = + if j < 0 then 0 + else if line.(j).elem = x then same_value (j - 1) + else j + 1 + in + same_value (j - 2) + in + let jj1 = ini_jj1 in + let jj2 = j - 1 in + let jj3 = j in + let jj4 = + match line.(j).elem with + Nothing -> j + | x -> + let rec same_value j = + if j >= Array.length line then j - 1 + else if line.(j).elem = x then same_value (j + 1) + else j - 1 + in + same_value (j + 1) + in + let (ii, jj1, jj2, jj3, jj4) = + find_block_with_parents t i jj1 jj2 jj3 jj4 + in + if jj4 < j2 && jj2 < jj3 then + begin exch_blocks t ii i jj1 jj2 jj3 jj4; loop (jj4 + 1) end + else if jj4 < j2 && jj1 = ini_jj1 && jj2 <= jj4 then + begin mirror_block t ii i jj1 jj4; loop (jj4 + 1) end + else j - 1 + in + loop (j1 + 1) +;; + +let push_to_left d t i j1 j2 = + let line = t.(i) in + let rec loop j = + if j = j1 then j + 1 + else + let jj1 = + match line.(j).elem with + Nothing -> j + | x -> + let rec same_value j = + if j < 0 then 0 + else if line.(j).elem = x then same_value (j - 1) + else j + 1 + in + same_value (j - 1) + in + let jj2 = j in + let jj3 = j + 1 in + let ini_jj4 = + match line.(j + 1).elem with + Nothing -> j + 1 + | x -> + let rec same_value j = + if j >= Array.length line then j - 1 + else if line.(j).elem = x then same_value (j + 1) + else j - 1 + in + same_value (j + 2) + in + let jj4 = ini_jj4 in + let (ii, jj1, jj2, jj3, jj4) = + find_block_with_parents t i jj1 jj2 jj3 jj4 + in + if jj1 > j1 && jj2 < jj3 then + begin exch_blocks t ii i jj1 jj2 jj3 jj4; loop (jj1 - 1) end + else if jj1 > j1 && jj4 = ini_jj4 && jj3 >= jj1 then + begin mirror_block t ii i jj1 jj4; loop (jj1 - 1) end + else j + 1 + in + loop (j2 - 1) +;; + +let fill_gap d t i j1 j2 = + let t1 = + let t1 = Array.copy t.table in + for i = 0 to Array.length t.table - 1 do + t1.(i) <- Array.copy t.table.(i); + for j = 0 to Array.length t1.(i) - 1 do + t1.(i).(j) <- copy_data t.table.(i).(j) + done + done; + t1 + in + let j2 = push_to_left d t1 i j1 j2 in + let j1 = push_to_right d t1 i j1 j2 in + if j1 = j2 - 1 then + let line = t1.(i - 1) in + let x = line.(j1).span in + let y = line.(j2).span in + let rec loop y j = + if j >= Array.length line then () + else if line.(j).span = y || t1.(i).(j).elem = t1.(i).(j - 1).elem then + let y = line.(j).span in + line.(j).span <- x; + if i > 0 then t1.(i - 1).(j).span <- t1.(i - 1).(j - 1).span; + loop y (j + 1) + in + loop y j2; Some ({table = t1}, true) + else None +;; + +let treat_gaps d t = + let i = Array.length t.table - 1 in + let rec loop t j = + let line = t.table.(i) in + if j = Array.length line then t + else + match line.(j).elem with + Elem _ as y -> + if y = line.(j - 1).elem then loop t (j + 1) + else + let rec loop1 t j1 = + if j1 < 0 then loop t (j + 1) + else if y = line.(j1).elem then + match fill_gap d t i j1 j with + Some (t, ok) -> if ok then loop t 2 else loop t (j + 1) + | None -> loop t (j + 1) + else loop1 t (j1 - 1) + in + loop1 t (j - 2) + | _ -> loop t (j + 1) + in + if Array.length t.table.(i) = 1 then t else loop t 2 +;; + +let group_span_last_row t = + let row = t.table.(Array.length t.table - 1) in + let rec loop i = + if i >= Array.length row then () + else + begin + begin match row.(i).elem with + Elem _ | Ghost _ as x -> + if x = row.(i - 1).elem then row.(i).span <- row.(i - 1).span + | _ -> () + end; + loop (i + 1) + end + in + loop 1 +;; + +let has_phony_children phony d t = + let line = t.table.(Array.length t.table - 1) in + let rec loop j = + if j = Array.length line then false + else + match line.(j).elem with + Elem x -> if phony d.dag.(int_of_idag x) then true else loop (j + 1) + | _ -> loop (j + 1) + in + loop 0 +;; + +let tablify phony no_optim no_group d = + let a = ancestors d in + let r = group_by_common_children d a in + let t = {table = [| Array.of_list r |]} in + let rec loop t = + let (t, new_row) = treat_new_row d t in + if List.for_all (fun x -> x.elem = Nothing) new_row then t + else + let t = {table = Array.append t.table [| Array.of_list new_row |]} in + let t = + if no_group && not (has_phony_children phony d t) then t + else + let _ = if no_optim then () else equilibrate t in + let _ = group_elem t in + let _ = group_ghost t in + let _ = group_children t in + let _ = group_span_by_common_children d t in + let t = if no_optim then t else treat_gaps d t in + let _ = group_span_last_row t in t + in + loop t + in + loop t +;; + +let fall d t = + for i = 1 to Array.length t.table - 1 do + let line = t.table.(i) in + let rec loop j = + if j = Array.length line then () + else + match line.(j).elem with + Ghost x -> + let j2 = + let rec loop j = + if j = Array.length line then j - 1 + else + match line.(j).elem with + Ghost y when y = x -> loop (j + 1) + | _ -> j - 1 + in + loop (j + 1) + in + let i1 = + let rec loop i = + if i < 0 then i + 1 + else + let line = t.table.(i) in + if (j = 0 || line.(j - 1).span <> line.(j).span) && + (j2 = Array.length line - 1 || + line.(j2 + 1).span <> line.(j2).span) then + loop (i - 1) + else i + 1 + in + loop (i - 1) + in + let i1 = + if i1 = i then i1 + else if i1 = 0 then i1 + else if t.table.(i1).(j).elem = Nothing then i1 + else i + in + if i1 < i then + begin + for k = i downto i1 + 1 do + for j = j to j2 do + t.table.(k).(j).elem <- t.table.(k - 1).(j).elem; + if k < i then + t.table.(k).(j).span <- t.table.(k - 1).(j).span + done + done; + for l = j to j2 do + if i1 = 0 || t.table.(i1 - 1).(l).elem = Nothing then + t.table.(i1).(l).elem <- Nothing + else + t.table.(i1).(l) <- + if l = j || + t.table.(i1 - 1).(l - 1).span <> + t.table.(i1 - 1).(l).span then + {elem = Ghost (new_ghost_id ()); + span = new_span_id ()} + else copy_data t.table.(i1).(l - 1) + done + end; + loop (j2 + 1) + | _ -> loop (j + 1) + in + loop 0 + done +;; + +let fall2_cool_right t i1 i2 i3 j1 j2 = + let span = t.table.(i2 - 1).(j1).span in + for i = i2 - 1 downto 0 do + for j = j1 to j2 - 1 do + t.table.(i).(j) <- + if i - i2 + i1 >= 0 then t.table.(i - i2 + i1).(j) + else {elem = Nothing; span = new_span_id ()} + done + done; + for i = Array.length t.table - 1 downto 0 do + for j = j2 to Array.length t.table.(i) - 1 do + t.table.(i).(j) <- + if i - i2 + i1 >= 0 then t.table.(i - i2 + i1).(j) + else {elem = Nothing; span = new_span_id ()} + done + done; + let old_span = t.table.(i2 - 1).(j1).span in + let rec loop j = + if j = Array.length t.table.(i2 - 1) then () + else if t.table.(i2 - 1).(j).span = old_span then + begin t.table.(i2 - 1).(j).span <- span; loop (j + 1) end + in + loop j1 +;; + +let fall2_cool_left t i1 i2 i3 j1 j2 = + let span = t.table.(i2 - 1).(j2).span in + for i = i2 - 1 downto 0 do + for j = j1 + 1 to j2 do + t.table.(i).(j) <- + if i - i2 + i1 >= 0 then t.table.(i - i2 + i1).(j) + else {elem = Nothing; span = new_span_id ()} + done + done; + for i = Array.length t.table - 1 downto 0 do + for j = j1 downto 0 do + t.table.(i).(j) <- + if i - i2 + i1 >= 0 then t.table.(i - i2 + i1).(j) + else {elem = Nothing; span = new_span_id ()} + done + done; + let old_span = t.table.(i2 - 1).(j2).span in + let rec loop j = + if j < 0 then () + else if t.table.(i2 - 1).(j).span = old_span then + begin t.table.(i2 - 1).(j).span <- span; loop (j - 1) end + in + loop j2 +;; + +let do_fall2_right t i1 i2 j1 j2 = + let i3 = + let rec loop_i i = + if i < 0 then 0 + else + let rec loop_j j = + if j = Array.length t.table.(i) then loop_i (i - 1) + else + match t.table.(i).(j).elem with + Nothing -> loop_j (j + 1) + | _ -> i + 1 + in + loop_j j2 + in + loop_i (Array.length t.table - 1) + in + let new_height = i3 + i2 - i1 in + let t = + if new_height > Array.length t.table then + let rec loop cnt t = + if cnt = 0 then t + else + let new_line = + Array.init (Array.length t.table.(0)) + (fun i -> {elem = Nothing; span = new_span_id ()}) + in + let t = {table = Array.append t.table [| new_line |]} in + loop (cnt - 1) t + in + loop (new_height - Array.length t.table) t + else t + in + fall2_cool_right t i1 i2 i3 j1 j2; t +;; + +let do_fall2_left t i1 i2 j1 j2 = + let i3 = + let rec loop_i i = + if i < 0 then 0 + else + let rec loop_j j = + if j < 0 then loop_i (i - 1) + else + match t.table.(i).(j).elem with + Nothing -> loop_j (j - 1) + | _ -> i + 1 + in + loop_j j1 + in + loop_i (Array.length t.table - 1) + in + let new_height = i3 + i2 - i1 in + let t = + if new_height > Array.length t.table then + let rec loop cnt t = + if cnt = 0 then t + else + let new_line = + Array.init (Array.length t.table.(0)) + (fun i -> {elem = Nothing; span = new_span_id ()}) + in + let t = {table = Array.append t.table [| new_line |]} in + loop (cnt - 1) t + in + loop (new_height - Array.length t.table) t + else t + in + fall2_cool_left t i1 i2 i3 j1 j2; t +;; + +let do_shorten_too_long t i1 j1 j2 = + for i = i1 to Array.length t.table - 2 do + for j = j1 to j2 - 1 do t.table.(i).(j) <- t.table.(i + 1).(j) done + done; + let i = Array.length t.table - 1 in + for j = j1 to j2 - 1 do + t.table.(i).(j) <- {elem = Nothing; span = new_span_id ()} + done; + t +;; + +let try_fall2_right t i j = + match t.table.(i).(j).elem with + Ghost _ -> + let i1 = + let rec loop i = + if i < 0 then 0 + else + match t.table.(i).(j).elem with + Ghost _ -> loop (i - 1) + | _ -> i + 1 + in + loop (i - 1) + in + let separated1 = + let rec loop i = + if i < 0 then true + else if + j > 0 && t.table.(i).(j - 1).span = t.table.(i).(j).span then + false + else loop (i - 1) + in + loop (i1 - 1) + in + let j2 = + let x = t.table.(i).(j).span in + let rec loop j2 = + if j2 = Array.length t.table.(i) then j2 + else + match t.table.(i).(j2) with + {elem = Ghost _; span = y} when y = x -> loop (j2 + 1) + | _ -> j2 + in + loop (j + 1) + in + let separated2 = + let rec loop i = + if i = Array.length t.table then true + else if j2 = Array.length t.table.(i) then false + else if t.table.(i).(j2 - 1).span = t.table.(i).(j2).span then false + else loop (i + 1) + in + loop (i + 1) + in + if not separated1 || not separated2 then None + else Some (do_fall2_right t i1 (i + 1) j j2) + | _ -> None +;; + +let try_fall2_left t i j = + match t.table.(i).(j).elem with + Ghost _ -> + let i1 = + let rec loop i = + if i < 0 then 0 + else + match t.table.(i).(j).elem with + Ghost _ -> loop (i - 1) + | _ -> i + 1 + in + loop (i - 1) + in + let separated1 = + let rec loop i = + if i < 0 then true + else if + j < Array.length t.table.(i) - 1 && + t.table.(i).(j).span = t.table.(i).(j + 1).span then + false + else loop (i - 1) + in + loop (i1 - 1) + in + let j1 = + let x = t.table.(i).(j).span in + let rec loop j1 = + if j1 < 0 then j1 + else + match t.table.(i).(j1) with + {elem = Ghost _; span = y} when y = x -> loop (j1 - 1) + | _ -> j1 + in + loop (j - 1) + in + let separated2 = + let rec loop i = + if i = Array.length t.table then true + else if j1 < 0 then false + else if t.table.(i).(j1).span = t.table.(i).(j1 + 1).span then false + else loop (i + 1) + in + loop (i + 1) + in + if not separated1 || not separated2 then None + else Some (do_fall2_left t i1 (i + 1) j1 j) + | _ -> None +;; + +let try_shorten_too_long t i j = + match t.table.(i).(j).elem with + Ghost _ -> + let j2 = + let x = t.table.(i).(j).span in + let rec loop j2 = + if j2 = Array.length t.table.(i) then j2 + else + match t.table.(i).(j2) with + {elem = Ghost _; span = y} when y = x -> loop (j2 + 1) + | _ -> j2 + in + loop (j + 1) + in + let i1 = + let rec loop i = + if i = Array.length t.table then i + else + match t.table.(i).(j).elem with + Elem _ -> loop (i + 1) + | _ -> i + in + loop (i + 1) + in + let i2 = + let rec loop i = + if i = Array.length t.table then i + else + match t.table.(i).(j).elem with + Nothing -> loop (i + 1) + | _ -> i + in + loop i1 + in + let separated_left = + let rec loop i = + if i = i2 then true + else if + j > 0 && t.table.(i).(j).span = t.table.(i).(j - 1).span then + false + else loop (i + 1) + in + loop i + in + let separated_right = + let rec loop i = + if i = i2 then true + else if + j2 < Array.length t.table.(i) && + t.table.(i).(j2 - 1).span = t.table.(i).(j2).span then + false + else loop (i + 1) + in + loop i + in + if not separated_left || not separated_right then None + else if i2 < Array.length t.table then None + else Some (do_shorten_too_long t i j j2) + | _ -> None +;; + +let fall2_right t = + let rec loop_i i t = + if i <= 0 then t + else + let rec loop_j j t = + if j < 0 then loop_i (i - 1) t + else + match try_fall2_right t i j with + Some t -> loop_i (Array.length t.table - 1) t + | None -> loop_j (j - 1) t + in + loop_j (Array.length t.table.(i) - 2) t + in + loop_i (Array.length t.table - 1) t +;; + +let fall2_left t = + let rec loop_i i t = + if i <= 0 then t + else + let rec loop_j j t = + if j >= Array.length t.table.(i) then loop_i (i - 1) t + else + match try_fall2_left t i j with + Some t -> loop_i (Array.length t.table - 1) t + | None -> loop_j (j + 1) t + in + loop_j 1 t + in + loop_i (Array.length t.table - 1) t +;; + +let shorten_too_long t = + let rec loop_i i t = + if i <= 0 then t + else + let rec loop_j j t = + if j >= Array.length t.table.(i) then loop_i (i - 1) t + else + match try_shorten_too_long t i j with + Some t -> loop_i (Array.length t.table - 1) t + | None -> loop_j (j + 1) t + in + loop_j 1 t + in + loop_i (Array.length t.table - 1) t +;; + +(* top_adjust: + deletes all empty rows that might have appeared on top of the table + after the falls *) + +let top_adjust t = + let di = + let rec loop i = + if i = Array.length t.table then i + else + let rec loop_j j = + if j = Array.length t.table.(i) then loop (i + 1) + else if t.table.(i).(j).elem <> Nothing then i + else loop_j (j + 1) + in + loop_j 0 + in + loop 0 + in + if di > 0 then + begin + for i = 0 to Array.length t.table - 1 - di do + t.table.(i) <- t.table.(i + di) + done; + {table = Array.sub t.table 0 (Array.length t.table - di)} + end + else t +;; + +(* bottom_adjust: + deletes all empty rows that might have appeared on bottom of the table + after the falls *) + +let bottom_adjust t = + let last_i = + let rec loop i = + if i < 0 then i + else + let rec loop_j j = + if j = Array.length t.table.(i) then loop (i - 1) + else if t.table.(i).(j).elem <> Nothing then i + else loop_j (j + 1) + in + loop_j 0 + in + loop (Array.length t.table - 1) + in + if last_i < Array.length t.table - 1 then + {table = Array.sub t.table 0 (last_i + 1)} + else t +;; + +(* invert *) + +let invert_dag d = + let d = {dag = Array.copy d.dag} in + for i = 0 to Array.length d.dag - 1 do + let n = d.dag.(i) in + d.dag.(i) <- + {pare = List.map (fun x -> x) n.chil; valu = n.valu; + chil = List.map (fun x -> x) n.pare} + done; + d +;; + +let invert_table t = + let t' = {table = Array.copy t.table} in + let len = Array.length t.table in + for i = 0 to len - 1 do + t'.table.(i) <- + Array.init (Array.length t.table.(0)) + (fun j -> + let d = t.table.(len - 1 - i).(j) in + {elem = d.elem; span = d.span}); + if i < len - 1 then + for j = 0 to Array.length t'.table.(i) - 1 do + t'.table.(i).(j).span <- t.table.(len - 2 - i).(j).span + done + done; + t' +;; + +(* main *) + +let table_of_dag phony no_optim invert no_group d = + let d = if invert then invert_dag d else d in + let t = tablify phony no_optim no_group d in + let t = if invert then invert_table t else t in + let _ = fall () t in + let t = fall2_right t in + let t = fall2_left t in + let t = shorten_too_long t in + let t = top_adjust t in let t = bottom_adjust t in t +;; + + +let version = "1.01";; + +(* input dag *) + +let strip_spaces str = + let start = + let rec loop i = + if i == String.length str then i + else + match str.[i] with + ' ' | '\013' | '\n' | '\t' -> loop (i + 1) + | _ -> i + in + loop 0 + in + let stop = + let rec loop i = + if i == -1 then i + 1 + else + match str.[i] with + ' ' | '\013' | '\n' | '\t' -> loop (i - 1) + | _ -> i + 1 + in + loop (String.length str - 1) + in + if start == 0 && stop == String.length str then str + else if start > stop then "" + else String.sub str start (stop - start) +;; + +let rec get_line ic = + try + let line = input_line ic in + if String.length line > 0 && line.[0] = '#' then get_line ic + else Some (strip_spaces line) + with + End_of_file -> None +;; + +let input_dag ic = + let rec find cnt s = + function + n :: nl -> + if n.valu = s then n, idag_of_int cnt else find (cnt - 1) s nl + | [] -> raise Not_found + in + let add_node pl cl nl cnt = + let cl = List.rev cl in + let pl = List.rev pl in + let (pl, pnl, nl, cnt) = + List.fold_left + (fun (pl, pnl, nl, cnt) p -> + try + let (n, p) = find (cnt - 1) p nl in p :: pl, n :: pnl, nl, cnt + with + Not_found -> + let n = {pare = []; valu = p; chil = []} in + let p = idag_of_int cnt in p :: pl, n :: pnl, n :: nl, cnt + 1) + ([], [], nl, cnt) pl + in + let pl = List.rev pl in + let (cl, nl, cnt) = + List.fold_left + (fun (cl, nl, cnt) c -> + try + let (n, c) = find (cnt - 1) c nl in + n.pare <- n.pare @ pl; c :: cl, nl, cnt + with + Not_found -> + let n = {pare = pl; valu = c; chil = []} in + let c = idag_of_int cnt in c :: cl, n :: nl, cnt + 1) + ([], nl, cnt) cl + in + let cl = List.rev cl in + List.iter (fun p -> p.chil <- p.chil @ cl) pnl; nl, cnt + in + let rec input_parents nl pl cnt = + function + Some "" -> input_parents nl pl cnt (get_line ic) + | Some line -> + begin match line.[0] with + 'o' -> + let p = + strip_spaces (String.sub line 1 (String.length line - 1)) + in + if p = "" then failwith line + else input_parents nl (p :: pl) cnt (get_line ic) + | '-' -> + if pl = [] then failwith line + else input_children nl pl [] cnt (Some line) + | _ -> failwith line + end + | None -> if pl = [] then nl, cnt else failwith "end of file 1" + and input_children nl pl cl cnt = + function + Some "" -> input_children nl pl cl cnt (get_line ic) + | Some line -> + begin match line.[0] with + 'o' -> + if cl = [] then failwith line + else + let (nl, cnt) = add_node pl cl nl cnt in + input_parents nl [] cnt (Some line) + | '-' -> + let c = + strip_spaces (String.sub line 1 (String.length line - 1)) + in + if c = "" then failwith line + else input_children nl pl (c :: cl) cnt (get_line ic) + | _ -> failwith line + end + | None -> + if cl = [] then failwith "end of file 2" else add_node pl cl nl cnt + in + let (nl, _) = input_parents [] [] 0 (get_line ic) in + {dag = Array.of_list (List.rev nl)} +;; + +(* testing *) + +let map_dag f d = + let a = + Array.map (fun d -> {pare = d.pare; valu = f d.valu; chil = d.chil}) d.dag + in + {dag = a} +;; + +let tag_dag d = + let c = ref 'A' in + map_dag + (fun v -> + let v = !c in + c := + if !c = 'Z' then 'a' + else if !c = 'z' then '1' + else Char.chr (Char.code !c + 1); + String.make 1 v) + d +;; + +(* *) + +let phony _ = false;; +let indi_txt n = n.valu;; + +let string_table border hts = + let buf = Buffer.create 30 in + Printf.bprintf buf "<center><table border=%d" border; + Printf.bprintf buf " cellspacing=0 cellpadding=0>\n"; + for i = 0 to Array.length hts - 1 do + Printf.bprintf buf "<tr>\n"; + for j = 0 to Array.length hts.(i) - 1 do + let (colspan, align, td) = hts.(i).(j) in + Printf.bprintf buf "<td"; + if colspan = 1 && (td = TDstring " " || td = TDhr CenterA) then () + else Printf.bprintf buf " colspan=%d" colspan; + begin match align, td with + LeftA, TDhr LeftA -> Printf.bprintf buf " align=left" + | LeftA, _ -> () + | CenterA, _ -> Printf.bprintf buf " align=center" + | RightA, _ -> Printf.bprintf buf " align=right" + end; + Printf.bprintf buf ">"; + begin match td with + TDstring s -> Printf.bprintf buf "%s" s + | TDhr align -> + Printf.bprintf buf "<hr noshade size=1"; + begin match align with + LeftA -> Printf.bprintf buf " width=\"50%%\" align=left" + | RightA -> Printf.bprintf buf " width=\"50%%\" align=right" + | _ -> () + end; + Printf.bprintf buf ">"; + () + end; + Printf.bprintf buf "</td>\n"; + () + done + done; + Printf.bprintf buf "</table></center>\n"; + Buffer.contents buf +;; + +let fname = ref "";; +let invert = ref false;; +let char = ref false;; +let border = ref 0;; +let no_optim = ref false;; +let no_group = ref false;; + +let html_of_dag d = + let t = table_of_dag phony !no_optim !invert !no_group d in + let hts = html_table_struct indi_txt phony d t in + string_table !border hts +;; + + +(********************************* Max's code **********************************) +(** This function takes a list of classes and a list of class types + and create the associate dag. *) +let create_class_dag cl_list clt_list = + let module M = Odoc_info.Class in + (* the list of all the classes concerned *) + let cl_list2 = List.map (fun c -> (c.M.cl_name, Some (M.Cl c))) cl_list in + let clt_list2 = List.map (fun ct -> (ct.M.clt_name, Some (M.Cltype (ct, [])))) clt_list in + let list = cl_list2 @ clt_list2 in + let all_classes = + let rec iter list2 = + List.fold_left + (fun acc -> fun (name, cct_opt) -> + let l = + match cct_opt with + None -> [] + | Some (M.Cl c) -> + iter + (List.map + (fun inh ->(inh.M.ic_name, inh.M.ic_class)) + (match c.M.cl_kind with + M.Class_structure (inher_l, _) -> + inher_l + | _ -> + [] + ) + ) + | Some (M.Cltype (ct, _)) -> + iter + (List.map + (fun inh ->(inh.M.ic_name, inh.M.ic_class)) + (match ct.M.clt_kind with + M.Class_signature (inher_l, _) -> + inher_l + | _ -> + [] + ) + ) + in + (name, cct_opt) :: (acc @ l) + ) + [] + list2 + in + iter list + in + let rec distinct acc = function + [] -> + acc + | (name, cct_opt) :: q -> + if List.exists (fun (name2, _) -> name = name2) acc then + distinct acc q + else + distinct ((name, cct_opt) :: acc) q + in + let distinct_classes = distinct [] all_classes in + let liste_index = + let rec f n = function + [] -> [] + | (name, _) :: q -> (name, n) :: (f (n+1) q) + in + f 0 distinct_classes + in + let array1 = Array.of_list distinct_classes in + (* create the dag array, filling parents and values *) + let fmap (name, cct_opt) = + { pare = List.map + (fun inh -> List.assoc inh.M.ic_name liste_index ) + (match cct_opt with + None -> [] + | Some (M.Cl c) -> + (match c.M.cl_kind with + M.Class_structure (inher_l, _) -> + inher_l + | _ -> + [] + ) + | Some (M.Cltype (ct, _)) -> + (match ct.M.clt_kind with + M.Class_signature (inher_l, _) -> + inher_l + | _ -> + [] + ) + ); + valu = (name, cct_opt) ; + chil = [] + } + in + let dag = { dag = Array.map fmap array1 } in + (* fill the children *) + let fiter i node = + let l = Array.to_list dag.dag in + let l2 = List.map (fun n -> n.valu) + (List.filter (fun n -> List.mem i n.pare) l) + in + node.chil <- List.map (fun (name,_) -> List.assoc name liste_index) l2 + in + Array.iteri fiter dag.dag; + dag diff --git a/ocaml-binary-annot/ocamldoc/odoc_dag2html.mli b/ocaml-binary-annot/ocamldoc/odoc_dag2html.mli new file mode 100644 index 0000000000..d377bce2ee --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_dag2html.mli @@ -0,0 +1,29 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** The types and functions to create a html table representing a dag. + Thanks to Daniel de Rauglaudre. *) + +type 'a dag = { mutable dag : 'a node array } +and 'a node = + { mutable pare : idag list; valu : 'a; mutable chil : idag list } +and idag = int + +(** This function returns the html code to represent the given dag. *) +val html_of_dag : string dag -> string + +(** This function takes a list of classes and a list of class types and creates the associate dag. *) +val create_class_dag : + Odoc_info.Class.t_class list -> + Odoc_info.Class.t_class_type list -> + (Odoc_info.Name.t * Odoc_info.Class.cct option) dag diff --git a/ocaml-binary-annot/ocamldoc/odoc_dep.ml b/ocaml-binary-annot/ocamldoc/odoc_dep.ml new file mode 100644 index 0000000000..86a0f247c9 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_dep.ml @@ -0,0 +1,219 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Top modules dependencies. *) + +module StrS = Depend.StringSet +module Module = Odoc_module +module Type = Odoc_type + +let set_to_list s = + let l = ref [] in + StrS.iter (fun e -> l := e :: !l) s; + !l + +let impl_dependencies ast = + Depend.free_structure_names := StrS.empty; + Depend.add_use_file StrS.empty [Parsetree.Ptop_def ast]; + set_to_list !Depend.free_structure_names + +let intf_dependencies ast = + Depend.free_structure_names := StrS.empty; + Depend.add_signature StrS.empty ast; + set_to_list !Depend.free_structure_names + + +module Dep = + struct + type id = string + + module S = Set.Make (struct type t = string let compare = compare end) + + let set_to_list s = + let l = ref [] in + S.iter (fun e -> l := e :: !l) s; + !l + + type node = { + id : id ; + mutable near : S.t ; (** fils directs *) + mutable far : (id * S.t) list ; (** fils indirects, par quel fils *) + reflex : bool ; (** reflexive or not, we keep + information here to remove the node itself from its direct children *) + } + + type graph = node list + + let make_node s children = + let set = List.fold_right + S.add + children + S.empty + in + { id = s; + near = S.remove s set ; + far = [] ; + reflex = List.mem s children ; + } + + let get_node graph s = + try List.find (fun n -> n.id = s) graph + with Not_found -> + make_node s [] + + let rec trans_closure graph acc n = + if S.mem n.id acc then + acc + else + (* optimisation plus tard : utiliser le champ far si non vide ? *) + S.fold + (fun child -> fun acc2 -> + trans_closure graph acc2 (get_node graph child)) + n.near + (S.add n.id acc) + + let node_trans_closure graph n = + let far = List.map + (fun child -> + let set = trans_closure graph S.empty (get_node graph child) in + (child, set) + ) + (set_to_list n.near) + in + n.far <- far + + let compute_trans_closure graph = + List.iter (node_trans_closure graph) graph + + let prune_node graph node = + S.iter + (fun child -> + let set_reachables = List.fold_left + (fun acc -> fun (ch, reachables) -> + if child = ch then + acc + else + S.union acc reachables + ) + S.empty + node.far + in + let set = S.remove node.id set_reachables in + if S.exists (fun n2 -> S.mem child (get_node graph n2).near) set then + ( + node.near <- S.remove child node.near ; + node.far <- List.filter (fun (ch,_) -> ch <> child) node.far + ) + else + () + ) + node.near; + if node.reflex then + node.near <- S.add node.id node.near + else + () + + let kernel graph = + (* compute transitive closure *) + compute_trans_closure graph ; + + (* remove edges to keep a transitive kernel *) + List.iter (prune_node graph) graph; + + graph + + end + +(** [type_deps t] returns the list of fully qualified type names + [t] depends on. *) +let type_deps t = + let module T = Odoc_type in + let l = ref [] in + let re = Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)" in + let f s = + let s2 = Str.matched_string s in + l := s2 :: !l ; + s2 + in + (match t.T.ty_kind with + T.Type_abstract -> () + | T.Type_variant cl -> + List.iter + (fun c -> + List.iter + (fun e -> + let s = Odoc_print.string_of_type_expr e in + ignore (Str.global_substitute re f s) + ) + c.T.vc_args + ) + cl + | T.Type_record rl -> + List.iter + (fun r -> + let s = Odoc_print.string_of_type_expr r.T.rf_type in + ignore (Str.global_substitute re f s) + ) + rl + ); + + (match t.T.ty_manifest with + None -> () + | Some e -> + let s = Odoc_print.string_of_type_expr e in + ignore (Str.global_substitute re f s) + ); + + !l + +(** Modify the modules depencies of the given list of modules, + to get the minimum transitivity kernel. *) +let kernel_deps_of_modules modules = + let graph = List.map + (fun m -> Dep.make_node m.Module.m_name m.Module.m_top_deps) + modules + in + let k = Dep.kernel graph in + List.iter + (fun m -> + let node = Dep.get_node k m.Module.m_name in + m.Module.m_top_deps <- + List.filter (fun m2 -> Dep.S.mem m2 node.Dep.near) m.Module.m_top_deps) + modules + +(** Return the list of dependencies between the given types, + in the form of a list [(type, names of types it depends on)]. + @param kernel indicates if we must keep only the transitivity kernel + of the dependencies. Default is [false]. +*) +let deps_of_types ?(kernel=false) types = + let deps_pre = List.map (fun t -> (t, type_deps t)) types in + let deps = + if kernel then + ( + let graph = List.map + (fun (t, names) -> Dep.make_node t.Type.ty_name names) + deps_pre + in + let k = Dep.kernel graph in + List.map + (fun t -> + let node = Dep.get_node k t.Type.ty_name in + (t, Dep.set_to_list node.Dep.near) + ) + types + ) + else + deps_pre + in + deps diff --git a/ocaml-binary-annot/ocamldoc/odoc_dot.ml b/ocaml-binary-annot/ocamldoc/odoc_dot.ml new file mode 100644 index 0000000000..8d4fa2f3c9 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_dot.ml @@ -0,0 +1,146 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Definition of a class which outputs a dot file showing + top modules dependencies.*) + +open Odoc_info + +module F = Format + +let dot_include_all = ref false + +let dot_types = ref false + +let dot_reduce = ref false + +let dot_colors = ref (List.flatten Odoc_messages.default_dot_colors) + +module Generator = +struct + +(** This class generates a dot file showing the top modules dependencies. *) +class dot = + object (self) + + (** To store the colors associated to locations of modules. *) + val mutable loc_colors = [] + + (** the list of modules we know. *) + val mutable modules = [] + + (** Colors to use when finding new locations of modules. *) + val mutable colors = !dot_colors + + (** Graph header. *) + method header = + "digraph G {\n"^ + " size=\"10,7.5\";\n"^ + " ratio=\"fill\";\n"^ + " rotate=90;\n"^ + " fontsize=\"12pt\";\n"^ + " rankdir = TB ;\n" + + method get_one_color = + match colors with + [] -> None + | h :: q -> + colors <- q ; + Some h + + method node_color s = + try Some (List.assoc s loc_colors) + with + Not_found -> + match self#get_one_color with + None -> None + | Some c -> + loc_colors <- (s, c) :: loc_colors ; + Some c + + method print_module_atts fmt m = + match self#node_color (Filename.dirname m.Module.m_file) with + None -> () + | Some col -> F.fprintf fmt "\"%s\" [style=filled, color=%s];\n" m.Module.m_name col + + method print_type_atts fmt t = + match self#node_color (Name.father t.Type.ty_name) with + None -> () + | Some col -> F.fprintf fmt "\"%s\" [style=filled, color=%s];\n" t.Type.ty_name col + + method print_one_dep fmt src dest = + F.fprintf fmt "\"%s\" -> \"%s\";\n" src dest + + method generate_for_module fmt m = + let l = List.filter + (fun n -> + !dot_include_all or + (List.exists (fun m -> m.Module.m_name = n) modules)) + m.Module.m_top_deps + in + self#print_module_atts fmt m; + List.iter (self#print_one_dep fmt m.Module.m_name) l + + method generate_for_type fmt (t, l) = + self#print_type_atts fmt t; + List.iter + (self#print_one_dep fmt t.Type.ty_name) + l + + method generate_types types = + try + let oc = open_out !Global.out_file in + let fmt = F.formatter_of_out_channel oc in + F.fprintf fmt "%s" self#header; + let graph = Odoc_info.Dep.deps_of_types + ~kernel: !dot_reduce + types + in + List.iter (self#generate_for_type fmt) graph; + F.fprintf fmt "}\n" ; + F.pp_print_flush fmt (); + close_out oc + with + Sys_error s -> + raise (Failure s) + + method generate_modules modules_list = + try + modules <- modules_list ; + let oc = open_out !Global.out_file in + let fmt = F.formatter_of_out_channel oc in + F.fprintf fmt "%s" self#header; + + if !dot_reduce then + Odoc_info.Dep.kernel_deps_of_modules modules_list; + + List.iter (self#generate_for_module fmt) modules_list; + F.fprintf fmt "}\n" ; + F.pp_print_flush fmt (); + close_out oc + with + Sys_error s -> + raise (Failure s) + + (** Generate the dot code in the file {!Odoc_info.Args.out_file}. *) + method generate (modules_list : Odoc_info.Module.t_module list) = + colors <- !dot_colors; + if !dot_types then + self#generate_types (Odoc_info.Search.types modules_list) + else + self#generate_modules modules_list + end +end + +module type Dot_generator = module type of Generator + diff --git a/ocaml-binary-annot/ocamldoc/odoc_env.ml b/ocaml-binary-annot/ocamldoc/odoc_env.ml new file mode 100644 index 0000000000..a108cf416a --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_env.ml @@ -0,0 +1,249 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Environment for finding complete names from relative names. *) + +let print_DEBUG s = print_string s ; print_newline ();; + +module Name = Odoc_name + +(** relative name * complete name *) +type env_element = Name.t * Name.t + +type env = { + env_values : env_element list ; + env_types : env_element list ; + env_class_types : env_element list ; + env_classes : env_element list ; + env_modules : env_element list ; + env_module_types : env_element list ; + env_exceptions : env_element list ; + } + +let empty = { + env_values = [] ; + env_types = [] ; + env_class_types = [] ; + env_classes = [] ; + env_modules = [] ; + env_module_types = [] ; + env_exceptions = [] ; + } + +(** Add a signature to an environment. *) +let rec add_signature env root ?rel signat = + let qualify id = Name.concat root (Name.from_ident id) in + let rel_name id = + let n = Name.from_ident id in + match rel with + None -> n + | Some r -> Name.concat r n + in + let f env item = + match item with + Types.Tsig_value (ident, _) -> { env with env_values = (rel_name ident, qualify ident) :: env.env_values } + | Types.Tsig_type (ident,_,_) -> { env with env_types = (rel_name ident, qualify ident) :: env.env_types } + | Types.Tsig_exception (ident, _) -> { env with env_exceptions = (rel_name ident, qualify ident) :: env.env_exceptions } + | Types.Tsig_module (ident, modtype, _) -> + let env2 = + match modtype with (* A VOIR : le cas où c'est un identificateur, dans ce cas on n'a pas de signature *) + Types.Tmty_signature s -> add_signature env (qualify ident) ~rel: (rel_name ident) s + | _ -> env + in + { env2 with env_modules = (rel_name ident, qualify ident) :: env2.env_modules } + | Types.Tsig_modtype (ident, modtype_decl) -> + let env2 = + match modtype_decl with + Types.Tmodtype_abstract -> + env + | Types.Tmodtype_manifest modtype -> + match modtype with + (* A VOIR : le cas où c'est un identificateur, dans ce cas on n'a pas de signature *) + Types.Tmty_signature s -> add_signature env (qualify ident) ~rel: (rel_name ident) s + | _ -> env + in + { env2 with env_module_types = (rel_name ident, qualify ident) :: env2.env_module_types } + | Types.Tsig_class (ident, _, _) -> { env with env_classes = (rel_name ident, qualify ident) :: env.env_classes } + | Types.Tsig_cltype (ident, _, _) -> { env with env_class_types = (rel_name ident, qualify ident) :: env.env_class_types } + in + List.fold_left f env signat + +let add_exception env full_name = + let simple_name = Name.simple full_name in + { env with env_exceptions = (simple_name, full_name) :: env.env_exceptions } + +let add_type env full_name = + let simple_name = Name.simple full_name in + { env with env_types = (simple_name, full_name) :: env.env_types } + +let add_value env full_name = + let simple_name = Name.simple full_name in + { env with env_values = (simple_name, full_name) :: env.env_values } + +let add_module env full_name = + let simple_name = Name.simple full_name in + { env with env_modules = (simple_name, full_name) :: env.env_modules } + +let add_module_type env full_name = + let simple_name = Name.simple full_name in + { env with env_module_types = (simple_name, full_name) :: env.env_module_types } + +let add_class env full_name = + let simple_name = Name.simple full_name in + { env with + env_classes = (simple_name, full_name) :: env.env_classes ; + (* we also add a type 'cause the class name may appear as a type *) + env_types = (simple_name, full_name) :: env.env_types + } + +let add_class_type env full_name = + let simple_name = Name.simple full_name in + { env with + env_class_types = (simple_name, full_name) :: env.env_class_types ; + (* we also add a type 'cause the class type name may appear as a type *) + env_types = (simple_name, full_name) :: env.env_types + } + +let full_module_name env n = + try List.assoc n env.env_modules + with Not_found -> + print_DEBUG ("Module "^n^" not found with env="); + List.iter (fun (sn, fn) -> print_DEBUG ("("^sn^", "^fn^")")) env.env_modules; + n + +let full_module_type_name env n = + try List.assoc n env.env_module_types + with Not_found -> + print_DEBUG ("Module "^n^" not found with env="); + List.iter (fun (sn, fn) -> print_DEBUG ("("^sn^", "^fn^")")) env.env_modules; + n + +let full_module_or_module_type_name env n = + try List.assoc n env.env_modules + with Not_found -> full_module_type_name env n + +let full_type_name env n = + try + let full = List.assoc n env.env_types in +(** print_string ("type "^n^" is "^full); + print_newline ();*) + full + with Not_found -> +(** print_string ("type "^n^" not found"); + print_newline ();*) + n + +let full_value_name env n = + try List.assoc n env.env_values + with Not_found -> n + +let full_exception_name env n = + try List.assoc n env.env_exceptions + with Not_found -> + print_DEBUG ("Exception "^n^" not found with env="); + List.iter (fun (sn, fn) -> print_DEBUG ("("^sn^", "^fn^")")) env.env_exceptions; + n + +let full_class_name env n = + try List.assoc n env.env_classes + with Not_found -> + print_DEBUG ("Class "^n^" not found with env="); + List.iter (fun (sn, fn) -> print_DEBUG ("("^sn^", "^fn^")")) env.env_classes; + n + +let full_class_type_name env n = + try List.assoc n env.env_class_types + with Not_found -> + print_DEBUG ("Class type "^n^" not found with env="); + List.iter (fun (sn, fn) -> print_DEBUG ("("^sn^", "^fn^")")) env.env_class_types; + n + +let full_class_or_class_type_name env n = + try List.assoc n env.env_classes + with Not_found -> full_class_type_name env n + +let print_env_types env = + List.iter (fun (s1,s2) -> Printf.printf "%s = %s\n" s1 s2) env.env_types + +let subst_type env t = +(* + print_string "Odoc_env.subst_type\n"; + print_env_types env ; + print_newline (); +*) + Printtyp.mark_loops t; + let deja_vu = ref [] in + let rec iter t = + if List.memq t !deja_vu then () else begin + deja_vu := t :: !deja_vu; + Btype.iter_type_expr iter t; + match t.Types.desc with + | Types.Tconstr (p, [ty], a) when Path.same p Predef.path_option -> + () + | Types.Tconstr (p, l, a) -> + let new_p = + Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in + t.Types.desc <- Types.Tconstr (new_p, l, a) + | Types.Tpackage (p, n, l) -> + let new_p = + Odoc_name.to_path (full_module_type_name env (Odoc_name.from_path p)) in + t.Types.desc <- Types.Tpackage (new_p, n, l) + | Types.Tobject (_, ({contents=Some(p,tyl)} as r)) -> + let new_p = + Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in + r := Some (new_p, tyl) + | Types.Tvariant ({Types.row_name=Some(p, tyl)} as row) -> + let new_p = + Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in + t.Types.desc <- + Types.Tvariant {row with Types.row_name=Some(new_p, tyl)} + | _ -> + () + end + in + iter t; + t + + +let subst_module_type env t = + let rec iter t = + match t with + Types.Tmty_ident p -> + let new_p = Odoc_name.to_path (full_module_type_name env (Odoc_name.from_path p)) in + Types.Tmty_ident new_p + | Types.Tmty_signature _ -> + t + | Types.Tmty_functor (id, mt1, mt2) -> + Types.Tmty_functor (id, iter mt1, iter mt2) + in + iter t + +let subst_class_type env t = + let rec iter t = + match t with + Types.Tcty_constr (p,texp_list,ct) -> + let new_p = Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in + let new_texp_list = List.map (subst_type env) texp_list in + let new_ct = iter ct in + Types.Tcty_constr (new_p, new_texp_list, new_ct) + | Types.Tcty_signature cs -> + (* on ne s'occupe pas des vals et methods *) + t + | Types.Tcty_fun (l, texp, ct) -> + let new_texp = subst_type env texp in + let new_ct = iter ct in + Types.Tcty_fun (l, new_texp, new_ct) + in + iter t + +(* eof $Id$ *) diff --git a/ocaml-binary-annot/ocamldoc/odoc_env.mli b/ocaml-binary-annot/ocamldoc/odoc_env.mli new file mode 100644 index 0000000000..75c0b38a4d --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_env.mli @@ -0,0 +1,76 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Environment for finding complete names from relative names. *) + +(** An environment of known names, + from simple name to complete name. *) +type env + +(** The empty environment. *) +val empty : env + +(** Extending an environment *) + +val add_signature : env -> string -> ?rel:string -> Types.signature -> env +val add_exception : env -> Odoc_name.t -> env +val add_type : env -> Odoc_name.t -> env +val add_value : env -> Odoc_name.t -> env +val add_module : env -> Odoc_name.t -> env +val add_module_type : env -> Odoc_name.t -> env +val add_class : env -> Odoc_name.t -> env +val add_class_type : env -> Odoc_name.t -> env + +(** Retrieving fully qualified names from an environment *) + +(** Get the fully qualified module name from a name.*) +val full_module_name : env -> Odoc_name.t -> Odoc_name.t + +(** Get the fully qualified module type name from a name.*) +val full_module_type_name : env -> Odoc_name.t -> Odoc_name.t + +(** Get the fully qualified module or module type name from a name. + We look for a module type if we don't find a module.*) +val full_module_or_module_type_name : env -> Odoc_name.t -> Odoc_name.t + +(** Get the fully qualified type name from a name.*) +val full_type_name : env -> Odoc_name.t -> Odoc_name.t + +(** Get the fully qualified value name from a name.*) +val full_value_name : env -> Odoc_name.t -> Odoc_name.t + +(** Get the fully qualified exception name from a name.*) +val full_exception_name : env -> Odoc_name.t -> Odoc_name.t + +(** Get the fully qualified class name from a name.*) +val full_class_name : env -> Odoc_name.t -> Odoc_name.t + +(** Get the fully qualified class type name from a name.*) +val full_class_type_name : env -> Odoc_name.t -> Odoc_name.t + +(** Get the fully qualified class or class type name from a name.*) +val full_class_or_class_type_name : env -> Odoc_name.t -> Odoc_name.t + +(** Substitutions *) + +(** Replace the [Path.t] by a complete [Path.t] in a [Types.type_expr].*) +val subst_type : env -> Types.type_expr -> Types.type_expr + +(** Replace the [Path.t] by a complete [Path.t] in a [Types.module_type].*) +val subst_module_type : env -> Types.module_type -> Types.module_type + +(** Replace the [Path.t] by a complete [Path.t] in a [Types.class_type]. + Also empty the structures to get only [object end] when the type + is printed. +*) +val subst_class_type : env -> Types.class_type -> Types.class_type diff --git a/ocaml-binary-annot/ocamldoc/odoc_exception.ml b/ocaml-binary-annot/ocamldoc/odoc_exception.ml new file mode 100644 index 0000000000..74a2fb5a20 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_exception.ml @@ -0,0 +1,30 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Representation and manipulation of exceptions. *) + +module Name = Odoc_name + +type exception_alias = { + ea_name : Name.t ; + mutable ea_ex : t_exception option ; + } + +and t_exception = { + ex_name : Name.t ; + mutable ex_info : Odoc_types.info option ; (** optional user information *) + ex_args : Types.type_expr list ; (** the types of the parameters *) + ex_alias : exception_alias option ; + mutable ex_loc : Odoc_types.location ; + mutable ex_code : string option ; + } diff --git a/ocaml-binary-annot/ocamldoc/odoc_gen.ml b/ocaml-binary-annot/ocamldoc/odoc_gen.ml new file mode 100644 index 0000000000..260aed4df4 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_gen.ml @@ -0,0 +1,38 @@ +(** *) + +class type doc_generator = + object method generate : Odoc_module.t_module list -> unit end;; + +module type Base = sig + class generator : doc_generator + end;; + +type generator = + | Html of (module Odoc_html.Html_generator) + | Latex of (module Odoc_latex.Latex_generator) + | Texi of (module Odoc_texi.Texi_generator) + | Man of (module Odoc_man.Man_generator) + | Dot of (module Odoc_dot.Dot_generator) + | Other of (module Base) +;; + +let get_minimal_generator = function + Html m -> + let module M = (val m : Odoc_html.Html_generator) in + (new M.html :> doc_generator) +| Latex m -> + let module M = (val m : Odoc_latex.Latex_generator) in + (new M.latex :> doc_generator) +| Man m -> + let module M = (val m : Odoc_man.Man_generator) in + (new M.man :> doc_generator) +| Texi m -> + let module M = (val m : Odoc_texi.Texi_generator) in + (new M.texi :> doc_generator) +| Dot m -> + let module M = (val m : Odoc_dot.Dot_generator) in + (new M.dot :> doc_generator) +| Other m -> + let module M = (val m : Base) in + new M.generator + ;;
\ No newline at end of file diff --git a/ocaml-binary-annot/ocamldoc/odoc_gen.mli b/ocaml-binary-annot/ocamldoc/odoc_gen.mli new file mode 100644 index 0000000000..1200a7c420 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_gen.mli @@ -0,0 +1,22 @@ +(** The types of generators. *) + +(** The minimal class type of documentation generators. *) +class type doc_generator = + object method generate : Odoc_module.t_module list -> unit end;; + +(** The module type of minimal generators. *) +module type Base = sig + class generator : doc_generator + end;; + +(** Various ways to create a generator. *) +type generator = + | Html of (module Odoc_html.Html_generator) + | Latex of (module Odoc_latex.Latex_generator) + | Texi of (module Odoc_texi.Texi_generator) + | Man of (module Odoc_man.Man_generator) + | Dot of (module Odoc_dot.Dot_generator) + | Other of (module Base) +;; + +val get_minimal_generator : generator -> doc_generator
\ No newline at end of file diff --git a/ocaml-binary-annot/ocamldoc/odoc_global.ml b/ocaml-binary-annot/ocamldoc/odoc_global.ml new file mode 100644 index 0000000000..0b2ab6a2bb --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_global.ml @@ -0,0 +1,89 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Global variables. *) + +(* Tell ocaml compiler not to generate files. *) +let _ = Clflags.dont_write_files := true + +open Clflags + +type source_file = + Impl_file of string + | Intf_file of string + | Text_file of string + +let include_dirs = Clflags.include_dirs + +let errors = ref 0 + +let warn_error = ref false + +let pwarning s = + if !Odoc_config.print_warnings then prerr_endline (Odoc_messages.warning^": "^s); + if !warn_error then incr errors + +let merge_options = ref ([] : Odoc_types.merge_option list) + +let classic = Clflags.classic + +let dump = ref (None : string option) + +let load = ref ([] : string list) + +(** Allow arbitrary recursive types. *) +let recursive_types = Clflags.recursive_types + +(** Optional preprocessor command. *) +let preprocessor = Clflags.preprocessor + +let sort_modules = ref false + +let no_custom_tags = ref false + +let no_stop = ref false + +let remove_stars = ref false + +let keep_code = ref false + +let inverse_merge_ml_mli = ref false + +let filter_with_module_constraints = ref true + +let hidden_modules = ref ([] : string list) + +let files = ref [] + + + +let out_file = ref Odoc_messages.default_out_file + +let verbose = ref false + +let target_dir = ref Filename.current_dir_name + +let title = ref (None : string option) + +let intro_file = ref (None : string option) + +let with_header = ref true + +let with_trailer = ref true + +let with_toc = ref true + +let with_index = ref true + + + diff --git a/ocaml-binary-annot/ocamldoc/odoc_global.mli b/ocaml-binary-annot/ocamldoc/odoc_global.mli new file mode 100644 index 0000000000..454bb8535b --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_global.mli @@ -0,0 +1,104 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Global variables. *) + +(** The kind of source file in arguments. *) +type source_file = + Impl_file of string + | Intf_file of string + | Text_file of string + +(** The include_dirs in the OCaml compiler. *) +val include_dirs : string list ref + +(** Optional preprocessor command to pass to ocaml compiler. *) +val preprocessor : string option ref + +(** Recursive types flag to passe to ocaml compiler. *) +val recursive_types : bool ref + +(** The merge options to be used. *) +val merge_options : Odoc_types.merge_option list ref + +(** Classic mode or not. *) +val classic : bool ref + +(** The optional file name to dump the collected information into.*) +val dump : string option ref + +(** The list of information files to load. *) +val load : string list ref + +(** We must sort the list of top modules or not.*) +val sort_modules : bool ref + +(** We must not stop at the stop special comments. Default is false (we stop).*) +val no_stop : bool ref + +(** We must raise an exception when we find an unknown @-tag. *) +val no_custom_tags : bool ref + +(** We must remove the the first characters of each comment line, until the first asterisk '*'. *) +val remove_stars : bool ref + +(** To keep the code while merging, when we have both .ml and .mli files for a module. *) +val keep_code : bool ref + +(** To inverse implementation and interface files when merging. *) +val inverse_merge_ml_mli : bool ref + +(** To filter module elements according to module type constraints. *) +val filter_with_module_constraints : bool ref + +(** The list of module names to hide. *) +val hidden_modules : string list ref + +(** The files to be analysed. *) +val files : source_file list ref +(** A counter for errors. *) +val errors : int ref + +(** Indicate if a warning is an error. *) +val warn_error : bool ref + +(** Print the given warning, adding it to the list of {!errors} +if {!warn_error} is [true]. *) +val pwarning : string -> unit + +(** The file used by the generators outputting only one file. *) +val out_file : string ref + +(** Verbose mode or not. *) +val verbose : bool ref + +(** The optional file whose content can be used as intro text. *) +val intro_file : string option ref + +(** The optional title to use in the generated documentation. *) +val title : string option ref + +(** The directory where files have to be generated. *) +val target_dir : string ref + +(** The flag which indicates if we must generate a table of contents. *) +val with_toc : bool ref + +(** The flag which indicates if we must generate an index. *) +val with_index : bool ref + +(** The flag which indicates if we must generate a header.*) +val with_header : bool ref + +(** The flag which indicates if we must generate a trailer.*) +val with_trailer : bool ref diff --git a/ocaml-binary-annot/ocamldoc/odoc_html.ml b/ocaml-binary-annot/ocamldoc/odoc_html.ml new file mode 100644 index 0000000000..fecef08502 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_html.ml @@ -0,0 +1,2577 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Generation of html documentation.*) + +let print_DEBUG s = print_string s ; print_newline () + +open Odoc_info +open Parameter +open Value +open Type +open Exception +open Class +open Module + +let with_parameter_list = ref false +let css_style = ref None +let index_only = ref false +let colorize_code = ref false +let html_short_functors = ref false + + +(** The functions used for naming files and html marks.*) +module Naming = + struct + (** The prefix for types marks. *) + let mark_type = "TYPE" + + (** The prefix for functions marks. *) + let mark_function = "FUN" + + (** The prefix for exceptions marks. *) + let mark_exception = "EXCEPTION" + + (** The prefix for values marks. *) + let mark_value = "VAL" + + (** The prefix for attributes marks. *) + let mark_attribute = "ATT" + + (** The prefix for methods marks. *) + let mark_method = "METHOD" + + (** The prefix for code files.. *) + let code_prefix = "code_" + + (** The prefix for type files.. *) + let type_prefix = "type_" + + (** Return the two html files names for the given module or class name.*) + let html_files name = + let qual = + try + let i = String.rindex name '.' in + match name.[i + 1] with + | 'A'..'Z' -> "" + | _ -> "-c" + with Not_found -> "" + in + let prefix = name^qual in + let html_file = prefix^".html" in + let html_frame_file = prefix^"-frame.html" in + (html_file, html_frame_file) + + (** Return the target for the given prefix and simple name. *) + let target pref simple_name = pref^simple_name + + (** Return the complete link target (file#target) for the given prefix string and complete name.*) + let complete_target pref complete_name = + let simple_name = Name.simple complete_name in + let module_name = + let s = Name.father complete_name in + if s = "" then simple_name else s + in + let (html_file, _) = html_files module_name in + html_file^"#"^(target pref simple_name) + + (** Return the link target for the given type. *) + let type_target t = target mark_type (Name.simple t.ty_name) + + (** Return the complete link target for the given type. *) + let complete_type_target t = complete_target mark_type t.ty_name + + (** Return the link target for the given exception. *) + let exception_target e = target mark_exception (Name.simple e.ex_name) + + (** Return the complete link target for the given exception. *) + let complete_exception_target e = complete_target mark_exception e.ex_name + + (** Return the link target for the given value. *) + let value_target v = target mark_value (Name.simple v.val_name) + + (** Return the given value name where symbols accepted in infix values + are replaced by strings, to avoid clashes with the filesystem.*) + let subst_infix_symbols name = + let len = String.length name in + let buf = Buffer.create len in + let ch c = Buffer.add_char buf c in + let st s = Buffer.add_string buf s in + for i = 0 to len - 1 do + match name.[i] with + | '|' -> st "_pipe_" + | '<' -> st "_lt_" + | '>' -> st "_gt_" + | '@' -> st "_at_" + | '^' -> st "_exp_" + | '&' -> st "_amp_" + | '+' -> st "_plus_" + | '-' -> st "_minus_" + | '*' -> st "_star_" + | '/' -> st "_slash_" + | '$' -> st "_dollar_" + | '%' -> st "_percent_" + | '=' -> st "_equal_" + | ':' -> st "_column_" + | '~' -> st "_tilde_" + | '!' -> st "_bang_" + | '?' -> st "_questionmark_" + | c -> ch c + done; + Buffer.contents buf + + (** Return the complete link target for the given value. *) + let complete_value_target v = complete_target mark_value v.val_name + + (** Return the complete filename for the code of the given value. *) + let file_code_value_complete_target v = + let f = code_prefix^mark_value^(subst_infix_symbols v.val_name)^".html" in + f + + (** Return the link target for the given attribute. *) + let attribute_target a = target mark_attribute (Name.simple a.att_value.val_name) + + (** Return the complete link target for the given attribute. *) + let complete_attribute_target a = complete_target mark_attribute a.att_value.val_name + + (** Return the complete filename for the code of the given attribute. *) + let file_code_attribute_complete_target a = + let f = code_prefix^mark_attribute^a.att_value.val_name^".html" in + f + + (** Return the link target for the given method. *) + let method_target m = target mark_method (Name.simple m.met_value.val_name) + + (** Return the complete link target for the given method. *) + let complete_method_target m = complete_target mark_method m.met_value.val_name + + (** Return the complete filename for the code of the given method. *) + let file_code_method_complete_target m = + let f = code_prefix^mark_method^m.met_value.val_name^".html" in + f + + (** Return the link target for the given label section. *) + let label_target l = target "" l + + (** Return the complete link target for the given section label. *) + let complete_label_target l = complete_target "" l + + (** Return the complete filename for the code of the type of the + given module or module type name. *) + let file_type_module_complete_target name = + let f = type_prefix^name^".html" in + f + + (** Return the complete filename for the code of the + given module name. *) + let file_code_module_complete_target name = + let f = code_prefix^name^".html" in + f + + (** Return the complete filename for the code of the type of the + given class or class type name. *) + let file_type_class_complete_target name = + let f = type_prefix^name^".html" in + f + end + +module StringSet = Set.Make (struct type t = string let compare = compare end) + +(** A class with a method to colorize a string which represents OCaml code. *) +class ocaml_code = + object(self) + method html_of_code b ?(with_pre=true) code = + Odoc_ocamlhtml.html_of_code b ~with_pre: with_pre code + end + +let new_buf () = Buffer.create 1024 +let bp = Printf.bprintf +let bs = Buffer.add_string + + +(** Generation of html code from text structures. *) +class virtual text = + object (self) + (** We want to display colorized code. *) + inherit ocaml_code + + (** Escape the strings which would clash with html syntax, and + make some replacements (double newlines replaced by <br>). *) + method escape s = Odoc_ocamlhtml.escape_base s + + method keep_alpha_num s = + let len = String.length s in + let buf = Buffer.create len in + for i = 0 to len - 1 do + match s.[i] with + 'a'..'z' | 'A'..'Z' | '0'..'9' -> Buffer.add_char buf s.[i] + | _ -> () + done; + Buffer.contents buf + + (** Return a label created from the first sentence of a text. *) + method label_of_text t= + let t2 = Odoc_info.first_sentence_of_text t in + let s = Odoc_info.string_of_text t2 in + let s2 = self#keep_alpha_num s in + s2 + + (** Create a label for the associated title. + Return the label specified by the user or a label created + from the title level and the first sentence of the title. *) + method create_title_label (n,label_opt,t) = + match label_opt with + Some s -> s + | None -> Printf.sprintf "%d_%s" n (self#label_of_text t) + + (** Print the html code corresponding to the [text] parameter. *) + method html_of_text b t = + List.iter (self#html_of_text_element b) t + + (** Print the html code for the [text_element] in parameter. *) + method html_of_text_element b te = + print_DEBUG "text::html_of_text_element"; + match te with + | Odoc_info.Raw s -> self#html_of_Raw b s + | Odoc_info.Code s -> self#html_of_Code b s + | Odoc_info.CodePre s -> self#html_of_CodePre b s + | Odoc_info.Verbatim s -> self#html_of_Verbatim b s + | Odoc_info.Bold t -> self#html_of_Bold b t + | Odoc_info.Italic t -> self#html_of_Italic b t + | Odoc_info.Emphasize t -> self#html_of_Emphasize b t + | Odoc_info.Center t -> self#html_of_Center b t + | Odoc_info.Left t -> self#html_of_Left b t + | Odoc_info.Right t -> self#html_of_Right b t + | Odoc_info.List tl -> self#html_of_List b tl + | Odoc_info.Enum tl -> self#html_of_Enum b tl + | Odoc_info.Newline -> self#html_of_Newline b + | Odoc_info.Block t -> self#html_of_Block b t + | Odoc_info.Title (n, l_opt, t) -> self#html_of_Title b n l_opt t + | Odoc_info.Latex s -> self#html_of_Latex b s + | Odoc_info.Link (s, t) -> self#html_of_Link b s t + | Odoc_info.Ref (name, ref_opt, text_opt) -> + self#html_of_Ref b name ref_opt text_opt + | Odoc_info.Superscript t -> self#html_of_Superscript b t + | Odoc_info.Subscript t -> self#html_of_Subscript b t + | Odoc_info.Module_list l -> self#html_of_Module_list b l + | Odoc_info.Index_list -> self#html_of_Index_list b + | Odoc_info.Custom (s,t) -> self#html_of_custom_text b s t + | Odoc_info.Target (target, code) -> self#html_of_Target b ~target ~code + + method html_of_custom_text b s t = () + + method html_of_Target b ~target ~code = + if String.lowercase target = "html" then bs b code else () + + method html_of_Raw b s = bs b (self#escape s) + + method html_of_Code b s = + if !colorize_code then + self#html_of_code b ~with_pre: false s + else + ( + bs b "<code class=\""; + bs b Odoc_ocamlhtml.code_class ; + bs b "\">"; + bs b (self#escape s); + bs b "</code>" + ) + + method html_of_CodePre = + let remove_useless_newlines s = + let len = String.length s in + let rec iter_first n = + if n >= len then + None + else + match s.[n] with + | '\n' -> iter_first (n+1) + | _ -> Some n + in + match iter_first 0 with + None -> "" + | Some first -> + let rec iter_last n = + if n <= first then + None + else + match s.[n] with + '\t' -> iter_last (n-1) + | _ -> Some n + in + match iter_last (len-1) with + None -> String.sub s first 1 + | Some last -> String.sub s first ((last-first)+1) + in + fun b s -> + if !colorize_code then + ( + bs b "<pre></pre>"; + self#html_of_code b (remove_useless_newlines s); + bs b "<pre></pre>" + ) + else + ( + bs b "<pre><code class=\""; + bs b Odoc_ocamlhtml.code_class; + bs b "\">" ; + bs b (self#escape (remove_useless_newlines s)); + bs b "</code></pre>" + ) + + method html_of_Verbatim b s = + bs b "<pre>"; + bs b (self#escape s); + bs b "</pre>" + + method html_of_Bold b t = + bs b "<b>"; + self#html_of_text b t; + bs b "</b>" + + method html_of_Italic b t = + bs b "<i>" ; + self#html_of_text b t; + bs b "</i>" + + method html_of_Emphasize b t = + bs b "<em>" ; + self#html_of_text b t ; + bs b "</em>" + + method html_of_Center b t = + bs b "<center>"; + self#html_of_text b t; + bs b "</center>" + + method html_of_Left b t = + bs b "<div align=left>"; + self#html_of_text b t; + bs b "</div>" + + method html_of_Right b t = + bs b "<div align=right>"; + self#html_of_text b t; + bs b "</div>" + + method html_of_List b tl = + bs b "<ul>\n"; + List.iter + (fun t -> bs b "<li>"; self#html_of_text b t; bs b "</li>\n") + tl; + bs b "</ul>\n" + + method html_of_Enum b tl = + bs b "<OL>\n"; + List.iter + (fun t -> bs b "<li>"; self#html_of_text b t; bs b"</li>\n") + tl; + bs b "</OL>\n" + + method html_of_Newline b = bs b "\n<p>\n" + + method html_of_Block b t = + bs b "<blockquote>\n"; + self#html_of_text b t; + bs b "</blockquote>\n" + + method html_of_Title b n label_opt t = + let label1 = self#create_title_label (n, label_opt, t) in + bp b "<span id=\"%s\">" (Naming.label_target label1); + let (tag_o, tag_c) = + if n > 6 then + (Printf.sprintf "div class=\"h%d\"" n, "div") + else + let t = Printf.sprintf "h%d" n in (t, t) + in + bs b "<"; + bs b tag_o; + bs b ">"; + self#html_of_text b t; + bs b "</"; + bs b tag_c; + bs b ">"; + bs b "</span>" + + method html_of_Latex b _ = () + (* don't care about LaTeX stuff in HTML. *) + + method html_of_Link b s t = + bs b "<a href=\""; + bs b s ; + bs b "\">"; + self#html_of_text b t; + bs b "</a>" + + method html_of_Ref b name ref_opt text_opt = + match ref_opt with + None -> + let text = + match text_opt with + None -> [Odoc_info.Code name] + | Some t -> t + in + self#html_of_text b text + | Some kind -> + let h name = Odoc_info.Code (Odoc_info.use_hidden_modules name) in + let (target, text) = + match kind with + Odoc_info.RK_module + | Odoc_info.RK_module_type + | Odoc_info.RK_class + | Odoc_info.RK_class_type -> + let (html_file, _) = Naming.html_files name in + (html_file, h name) + | Odoc_info.RK_value -> (Naming.complete_target Naming.mark_value name, h name) + | Odoc_info.RK_type -> (Naming.complete_target Naming.mark_type name, h name) + | Odoc_info.RK_exception -> (Naming.complete_target Naming.mark_exception name, h name) + | Odoc_info.RK_attribute -> (Naming.complete_target Naming.mark_attribute name, h name) + | Odoc_info.RK_method -> (Naming.complete_target Naming.mark_method name, h name) + | Odoc_info.RK_section t -> (Naming.complete_label_target name, + Odoc_info.Italic [Raw (Odoc_info.string_of_text t)]) + in + let text = + match text_opt with + None -> [text] + | Some text -> text + in + bs b ("<a href=\""^target^"\">"); + self#html_of_text b text; + bs b "</a>" + + method html_of_Superscript b t = + bs b "<sup class=\"superscript\">"; + self#html_of_text b t; + bs b "</sup>" + + method html_of_Subscript b t = + bs b "<sub class=\"subscript\">"; + self#html_of_text b t; + bs b "</sub>" + + method virtual html_of_info_first_sentence : _ + + method html_of_Module_list b l = + bs b "<br>\n<table class=\"indextable\">\n"; + List.iter + (fun name -> + bs b "<tr><td>"; + ( + try + let m = + List.find (fun m -> m.m_name = name) self#list_modules + in + let (html, _) = Naming.html_files m.m_name in + bp b "<a href=\"%s\">%s</a></td>" html m.m_name; + bs b "<td>"; + self#html_of_info_first_sentence b m.m_info; + with + Not_found -> + Odoc_global.pwarning (Odoc_messages.cross_module_not_found name); + bp b "%s</td><td>" name + ); + bs b "</td></tr>\n" + ) + l; + bs b "</table>\n" + + method html_of_Index_list b = + let index_if_not_empty l url m = + match l with + [] -> () + | _ -> bp b "<a href=\"%s\">%s</a><br>\n" url m + in + index_if_not_empty self#list_types self#index_types Odoc_messages.index_of_types; + index_if_not_empty self#list_exceptions self#index_exceptions Odoc_messages.index_of_exceptions; + index_if_not_empty self#list_values self#index_values Odoc_messages.index_of_values; + index_if_not_empty self#list_attributes self#index_attributes Odoc_messages.index_of_attributes; + index_if_not_empty self#list_methods self#index_methods Odoc_messages.index_of_methods; + index_if_not_empty self#list_classes self#index_classes Odoc_messages.index_of_classes; + index_if_not_empty self#list_class_types self#index_class_types Odoc_messages.index_of_class_types; + index_if_not_empty self#list_modules self#index_modules Odoc_messages.index_of_modules; + index_if_not_empty self#list_module_types self#index_module_types Odoc_messages.index_of_module_types + + method virtual list_types : Odoc_info.Type.t_type list + method virtual index_types : string + method virtual list_exceptions : Odoc_info.Exception.t_exception list + method virtual index_exceptions : string + method virtual list_values : Odoc_info.Value.t_value list + method virtual index_values : string + method virtual list_attributes : Odoc_info.Value.t_attribute list + method virtual index_attributes : string + method virtual list_methods : Odoc_info.Value.t_method list + method virtual index_methods : string + method virtual list_classes : Odoc_info.Class.t_class list + method virtual index_classes : string + method virtual list_class_types : Odoc_info.Class.t_class_type list + method virtual index_class_types : string + method virtual list_modules : Odoc_info.Module.t_module list + method virtual index_modules : string + method virtual list_module_types : Odoc_info.Module.t_module_type list + method virtual index_module_types : string + + end + +(** A class used to generate html code for info structures. *) +class virtual info = + object (self) + (** The list of pairs [(tag, f)] where [f] is a function taking + the [text] associated to [tag] and returning html code. + Add a pair here to handle a tag.*) + val mutable tag_functions = ([] : (string * (Odoc_info.text -> string)) list) + + (** The method used to get html code from a [text]. *) + method virtual html_of_text : Buffer.t -> Odoc_info.text -> unit + + (** Print html for an author list. *) + method html_of_author_list b l = + match l with + [] -> () + | _ -> + bp b "<b>%s:</b> %s<br>\n" + Odoc_messages.authors + (String.concat ", " l) + + (** Print html code for the given optional version information.*) + method html_of_version_opt b v_opt = + match v_opt with + None -> () + | Some v -> + bp b "<b>%s:</b> %s<br>\n" Odoc_messages.version v + + (** Print html code for the given optional since information.*) + method html_of_since_opt b s_opt = + match s_opt with + None -> () + | Some s -> + bp b "<b>%s</b> %s<br>\n" Odoc_messages.since s + + (** Print html code for the given "before" information.*) + method html_of_before b l = + let f (v, text) = + bp b "<b>%s %s </b> " Odoc_messages.before v; + self#html_of_text b text; + bs b "<br>\n" + in + List.iter f l + + (** Print html code for the given list of raised exceptions.*) + method html_of_raised_exceptions b l = + match l with + [] -> () + | (s, t) :: [] -> + bp b "<b>%s</b> <code>%s</code> " + Odoc_messages.raises + s; + self#html_of_text b t; + bs b "<br>\n" + | _ -> + bp b "<b>%s</b><ul>" Odoc_messages.raises; + List.iter + (fun (ex, desc) -> + bp b "<li><code>%s</code> " ex ; + self#html_of_text b desc; + bs b "</li>\n" + ) + l; + bs b "</ul>\n" + + (** Print html code for the given "see also" reference. *) + method html_of_see b (see_ref, t) = + let t_ref = + match see_ref with + Odoc_info.See_url s -> [ Odoc_info.Link (s, t) ] + | Odoc_info.See_file s -> (Odoc_info.Code s) :: (Odoc_info.Raw " ") :: t + | Odoc_info.See_doc s -> (Odoc_info.Italic [Odoc_info.Raw s]) :: (Odoc_info.Raw " ") :: t + in + self#html_of_text b t_ref + + (** Print html code for the given list of "see also" references.*) + method html_of_sees b l = + match l with + [] -> () + | see :: [] -> + bp b "<b>%s</b> " Odoc_messages.see_also; + self#html_of_see b see; + bs b "<br>\n" + | _ -> + bp b "<b>%s</b><ul>" Odoc_messages.see_also; + List.iter + (fun see -> + bs b "<li>" ; + self#html_of_see b see; + bs b "</li>\n" + ) + l; + bs b "</ul>\n" + + (** Print html code for the given optional return information.*) + method html_of_return_opt b return_opt = + match return_opt with + None -> () + | Some s -> + bp b "<b>%s</b> " Odoc_messages.returns; + self#html_of_text b s; + bs b "<br>\n" + + (** Print html code for the given list of custom tagged texts. *) + method html_of_custom b l = + List.iter + (fun (tag, text) -> + try + let f = List.assoc tag tag_functions in + Buffer.add_string b (f text) + with + Not_found -> + Odoc_info.warning (Odoc_messages.tag_not_handled tag) + ) + l + + (** Print html code for a description, except for the [i_params] field. + @param indent can be specified not to use the style of info comments; + default is [true]. + *) + method html_of_info ?(indent=true) b info_opt = + match info_opt with + None -> + () + | Some info -> + let module M = Odoc_info in + if indent then bs b "<div class=\"info\">\n"; + ( + match info.M.i_deprecated with + None -> () + | Some d -> + bs b "<span class=\"warning\">"; + bs b Odoc_messages.deprecated ; + bs b "</span>" ; + self#html_of_text b d; + bs b "<br>\n" + ); + ( + match info.M.i_desc with + None -> () + | Some d when d = [Odoc_info.Raw ""] -> () + | Some d -> self#html_of_text b d; bs b "<br>\n" + ); + self#html_of_author_list b info.M.i_authors; + self#html_of_version_opt b info.M.i_version; + self#html_of_before b info.M.i_before; + self#html_of_since_opt b info.M.i_since; + self#html_of_raised_exceptions b info.M.i_raised_exceptions; + self#html_of_return_opt b info.M.i_return_value; + self#html_of_sees b info.M.i_sees; + self#html_of_custom b info.M.i_custom; + if indent then bs b "</div>\n" + + (** Print html code for the first sentence of a description. + The titles and lists in this first sentence has been removed.*) + method html_of_info_first_sentence b info_opt = + match info_opt with + None -> () + | Some info -> + let module M = Odoc_info in + let dep = info.M.i_deprecated <> None in + bs b "<div class=\"info\">\n"; + if dep then bs b "<font color=\"#CCCCCC\">"; + ( + match info.M.i_desc with + None -> () + | Some d when d = [Odoc_info.Raw ""] -> () + | Some d -> + self#html_of_text b + (Odoc_info.text_no_title_no_list + (Odoc_info.first_sentence_of_text d)); + bs b "\n" + ); + if dep then bs b "</font>"; + bs b "</div>\n" + + end + + + +let opt = Odoc_info.apply_opt + +let print_concat b sep f = + let rec iter = function + [] -> () + | [c] -> f c + | c :: q -> + f c; + bs b sep; + iter q + in + iter + +let newline_to_indented_br s = + let len = String.length s in + let b = Buffer.create len in + for i = 0 to len - 1 do + match s.[i] with + '\n' -> Buffer.add_string b "<br> " + | c -> Buffer.add_char b c + done; + Buffer.contents b + +module Generator = + struct +(** This class is used to create objects which can generate a simple html documentation. *) +class html = + object (self) + inherit text + inherit info + + val mutable doctype = + "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">\n" + val mutable character_encoding = + "<meta content=\"text/html; charset=iso-8859-1\" http-equiv=\"Content-Type\">\n" + + (** The default style options. *) + val mutable default_style_options = + ["a:visited {color : #416DFF; text-decoration : none; }" ; + "a:link {color : #416DFF; text-decoration : none;}" ; + "a:hover {color : Red; text-decoration : none; background-color: #5FFF88}" ; + "a:active {color : Red; text-decoration : underline; }" ; + ".keyword { font-weight : bold ; color : Red }" ; + ".keywordsign { color : #C04600 }" ; + ".superscript { font-size : 4 }" ; + ".subscript { font-size : 4 }" ; + ".comment { color : Green }" ; + ".constructor { color : Blue }" ; + ".type { color : #5C6585 }" ; + ".string { color : Maroon }" ; + ".warning { color : Red ; font-weight : bold }" ; + ".info { margin-left : 3em; margin-right : 3em }" ; + ".param_info { margin-top: 4px; margin-left : 3em; margin-right : 3em }" ; + ".code { color : #465F91 ; }" ; + "h1 { font-size : 20pt ; text-align: center; }" ; + + "h2 { font-size : 20pt ; border: 1px solid #000000; "^ + "margin-top: 5px; margin-bottom: 2px;"^ + "text-align: center; background-color: #90BDFF ;"^ + "padding: 2px; }" ; + + "h3 { font-size : 20pt ; border: 1px solid #000000; "^ + "margin-top: 5px; margin-bottom: 2px;"^ + "text-align: center; background-color: #90DDFF ;"^ + "padding: 2px; }" ; + + "h4 { font-size : 20pt ; border: 1px solid #000000; "^ + "margin-top: 5px; margin-bottom: 2px;"^ + "text-align: center; background-color: #90EDFF ;"^ + "padding: 2px; }" ; + + "h5 { font-size : 20pt ; border: 1px solid #000000; "^ + "margin-top: 5px; margin-bottom: 2px;"^ + "text-align: center; background-color: #90FDFF ;"^ + "padding: 2px; }" ; + + "h6 { font-size : 20pt ; border: 1px solid #000000; "^ + "margin-top: 5px; margin-bottom: 2px;"^ + "text-align: center; background-color: #C0FFFF ; "^ + "padding: 2px; }" ; + + "div.h7 { font-size : 20pt ; border: 1px solid #000000; "^ + "margin-top: 5px; margin-bottom: 2px;"^ + "text-align: center; background-color: #E0FFFF ; "^ + "padding: 2px; }" ; + + "div.h8 { font-size : 20pt ; border: 1px solid #000000; "^ + "margin-top: 5px; margin-bottom: 2px;"^ + "text-align: center; background-color: #F0FFFF ; "^ + "padding: 2px; }" ; + + "div.h9 { font-size : 20pt ; border: 1px solid #000000; "^ + "margin-top: 5px; margin-bottom: 2px;"^ + "text-align: center; background-color: #FFFFFF ; "^ + "padding: 2px; }" ; + + ".typetable { border-style : hidden }" ; + ".indextable { border-style : hidden }" ; + ".paramstable { border-style : hidden ; padding: 5pt 5pt}" ; + "body { background-color : White }" ; + "tr { background-color : White }" ; + "td.typefieldcomment { background-color : #FFFFFF ; font-size: smaller ;}" ; + "pre { margin-bottom: 4px }" ; + + "div.sig_block {margin-left: 2em}" ; + + "*:target { background: yellow; } " ; + ] + + (** The style file for all pages. *) + val mutable style_file = "style.css" + + (** The code to import the style. Initialized in [init_style]. *) + val mutable style = "" + + (** The known types names. + Used to know if we must create a link to a type + when printing a type. *) + val mutable known_types_names = StringSet.empty + + (** The known class and class type names. + Used to know if we must create a link to a class + or class type or not when printing a type. *) + val mutable known_classes_names = StringSet.empty + + (** The known modules and module types names. + Used to know if we must create a link to a type or not + when printing a module type. *) + val mutable known_modules_names = StringSet.empty + + method index_prefix = + if !Odoc_global.out_file = Odoc_messages.default_out_file then + "index" + else + Filename.basename !Odoc_global.out_file + + (** The main file. *) + method index = + let p = self#index_prefix in + Printf.sprintf "%s.html" p + + (** The file for the index of values. *) + method index_values = Printf.sprintf "%s_values.html" self#index_prefix + (** The file for the index of types. *) + method index_types = Printf.sprintf "%s_types.html" self#index_prefix + (** The file for the index of exceptions. *) + method index_exceptions = Printf.sprintf "%s_exceptions.html" self#index_prefix + (** The file for the index of attributes. *) + method index_attributes = Printf.sprintf "%s_attributes.html" self#index_prefix + (** The file for the index of methods. *) + method index_methods = Printf.sprintf "%s_methods.html" self#index_prefix + (** The file for the index of classes. *) + method index_classes = Printf.sprintf "%s_classes.html" self#index_prefix + (** The file for the index of class types. *) + method index_class_types = Printf.sprintf "%s_class_types.html" self#index_prefix + (** The file for the index of modules. *) + method index_modules = Printf.sprintf "%s_modules.html" self#index_prefix + (** The file for the index of module types. *) + method index_module_types = Printf.sprintf "%s_module_types.html" self#index_prefix + + + (** The list of attributes. Filled in the [generate] method. *) + val mutable list_attributes = [] + method list_attributes = list_attributes + (** The list of methods. Filled in the [generate] method. *) + val mutable list_methods = [] + method list_methods = list_methods + (** The list of values. Filled in the [generate] method. *) + val mutable list_values = [] + method list_values = list_values + (** The list of exceptions. Filled in the [generate] method. *) + val mutable list_exceptions = [] + method list_exceptions = list_exceptions + (** The list of types. Filled in the [generate] method. *) + val mutable list_types = [] + method list_types = list_types + (** The list of modules. Filled in the [generate] method. *) + val mutable list_modules = [] + method list_modules = list_modules + (** The list of module types. Filled in the [generate] method. *) + val mutable list_module_types = [] + method list_module_types = list_module_types + (** The list of classes. Filled in the [generate] method. *) + val mutable list_classes = [] + method list_classes = list_classes + (** The list of class types. Filled in the [generate] method. *) + val mutable list_class_types = [] + method list_class_types = list_class_types + + (** The header of pages. Must be prepared by the [prepare_header] method.*) + val mutable header = fun b -> fun ?(nav=None) -> fun ?(comments=[]) -> fun _ -> () + + (** Init the style. *) + method init_style = + (match !css_style with + None -> + let default_style = String.concat "\n" default_style_options in + ( + try + let file = Filename.concat !Global.target_dir style_file in + if Sys.file_exists file then + Odoc_info.verbose (Odoc_messages.file_exists_dont_generate file) + else + ( + let chanout = open_out file in + output_string chanout default_style ; + flush chanout ; + close_out chanout; + Odoc_info.verbose (Odoc_messages.file_generated file) + ) + with + Sys_error s -> + prerr_endline s ; + incr Odoc_info.errors ; + ) + | Some f -> + style_file <- f + ); + style <- "<link rel=\"stylesheet\" href=\""^style_file^"\" type=\"text/css\">\n" + + (** Get the title given by the user *) + method title = match !Global.title with None -> "" | Some t -> self#escape t + + (** Get the title given by the user completed with the given subtitle. *) + method inner_title s = + (match self#title with "" -> "" | t -> t^" : ")^ + (self#escape s) + + (** Get the page header. *) + method print_header b ?nav ?comments title = header b ?nav ?comments title + + (** A function to build the header of pages. *) + method prepare_header module_list = + let f b ?(nav=None) ?(comments=[]) t = + let link_if_not_empty l m url = + match l with + [] -> () + | _ -> + bp b "<link title=\"%s\" rel=Appendix href=\"%s\">\n" m url + in + bs b "<head>\n"; + bs b style; + bs b character_encoding ; + bs b "<link rel=\"Start\" href=\""; + bs b self#index; + bs b "\">\n" ; + ( + match nav with + None -> () + | Some (pre_opt, post_opt, name) -> + (match pre_opt with + None -> () + | Some name -> + bp b "<link rel=\"previous\" href=\"%s\">\n" + (fst (Naming.html_files name)); + ); + (match post_opt with + None -> () + | Some name -> + bp b "<link rel=\"next\" href=\"%s\">\n" + (fst (Naming.html_files name)); + ); + ( + let father = Name.father name in + let href = if father = "" then self#index else fst (Naming.html_files father) in + bp b "<link rel=\"Up\" href=\"%s\">\n" href + ) + ); + link_if_not_empty self#list_types Odoc_messages.index_of_types self#index_types; + link_if_not_empty self#list_exceptions Odoc_messages.index_of_exceptions self#index_exceptions; + link_if_not_empty self#list_values Odoc_messages.index_of_values self#index_values; + link_if_not_empty self#list_attributes Odoc_messages.index_of_attributes self#index_attributes; + link_if_not_empty self#list_methods Odoc_messages.index_of_methods self#index_methods; + link_if_not_empty self#list_classes Odoc_messages.index_of_classes self#index_classes; + link_if_not_empty self#list_class_types Odoc_messages.index_of_class_types self#index_class_types; + link_if_not_empty self#list_modules Odoc_messages.index_of_modules self#index_modules; + link_if_not_empty self#list_module_types Odoc_messages.index_of_module_types self#index_module_types; + let print_one m = + let html_file = fst (Naming.html_files m.m_name) in + bp b "<link title=\"%s\" rel=\"Chapter\" href=\"%s\">" + m.m_name html_file + in + print_concat b "\n" print_one module_list; + self#html_sections_links b comments; + bs b "<title>"; + bs b t ; + bs b "</title>\n</head>\n" + in + header <- f + + (** Build the html code for the link tags in the header, defining section and + subsections for the titles found in the given comments.*) + method html_sections_links b comments = + let titles = List.flatten (List.map Odoc_info.get_titles_in_text comments) in + let levels = + let rec iter acc l = + match l with + [] -> acc + | (n,_,_) :: q -> + if List.mem n acc + then iter acc q + else iter (n::acc) q + in + iter [] titles + in + let sorted_levels = List.sort compare levels in + let (section_level, subsection_level) = + match sorted_levels with + [] -> (None, None) + | [n] -> (Some n, None) + | n :: m :: _ -> (Some n, Some m) + in + let titles_per_level level_opt = + match level_opt with + None -> [] + | Some n -> List.filter (fun (m,_,_) -> m = n) titles + in + let section_titles = titles_per_level section_level in + let subsection_titles = titles_per_level subsection_level in + let print_lines s_rel titles = + List.iter + (fun (n,lopt,t) -> + let s = Odoc_info.string_of_text t in + let label = self#create_title_label (n,lopt,t) in + bp b "<link title=\"%s\" rel=\"%s\" href=\"#%s\">\n" s s_rel label + ) + titles + in + print_lines "Section" section_titles ; + print_lines "Subsection" subsection_titles + + + (** Html code for navigation bar. + @param pre optional name for optional previous module/class + @param post optional name for optional next module/class + @param name name of current module/class *) + method print_navbar b pre post name = + bs b "<div class=\"navbar\">"; + ( + match pre with + None -> () + | Some name -> + bp b "<a href=\"%s\">%s</a>\n" + (fst (Naming.html_files name)) + Odoc_messages.previous + ); + bs b " "; + let father = Name.father name in + let href = if father = "" then self#index else fst (Naming.html_files father) in + bp b "<a href=\"%s\">%s</a>\n" href Odoc_messages.up; + bs b " "; + ( + match post with + None -> () + | Some name -> + bp b "<a href=\"%s\">%s</a>\n" + (fst (Naming.html_files name)) + Odoc_messages.next + ); + bs b "</div>\n" + + (** Return html code with the given string in the keyword style.*) + method keyword s = + "<span class=\"keyword\">"^s^"</span>" + + (** Return html code with the given string in the constructor style. *) + method constructor s = "<span class=\"constructor\">"^s^"</span>" + + (** Output the given ocaml code to the given file name. *) + method private output_code in_title file code = + try + let chanout = open_out file in + let b = new_buf () in + bs b "<html>"; + self#print_header b (self#inner_title in_title); + bs b"<body>\n"; + self#html_of_code b code; + bs b "</body></html>"; + Buffer.output_buffer chanout b; + close_out chanout + with + Sys_error s -> + incr Odoc_info.errors ; + prerr_endline s + + (** Take a string and return the string where fully qualified + type (or class or class type) idents + have been replaced by links to the type referenced by the ident.*) + method create_fully_qualified_idents_links m_name s = + let f str_t = + let match_s = Str.matched_string str_t in + let rel = Name.get_relative m_name match_s in + let s_final = Odoc_info.apply_if_equal + Odoc_info.use_hidden_modules + match_s + rel + in + if StringSet.mem match_s known_types_names then + "<a href=\""^(Naming.complete_target Naming.mark_type match_s)^"\">"^ + s_final^ + "</a>" + else + if StringSet.mem match_s known_classes_names then + let (html_file, _) = Naming.html_files match_s in + "<a href=\""^html_file^"\">"^s_final^"</a>" + else + s_final + in + let s2 = Str.global_substitute + (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)") + f + s + in + s2 + + (** Take a string and return the string where fully qualified module idents + have been replaced by links to the module referenced by the ident.*) + method create_fully_qualified_module_idents_links m_name s = + let f str_t = + let match_s = Str.matched_string str_t in + let rel = Name.get_relative m_name match_s in + let s_final = Odoc_info.apply_if_equal + Odoc_info.use_hidden_modules + match_s + rel + in + if StringSet.mem match_s known_modules_names then + let (html_file, _) = Naming.html_files match_s in + "<a href=\""^html_file^"\">"^s_final^"</a>" + else + s_final + in + let s2 = Str.global_substitute + (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([A-Z][a-zA-Z_'0-9]*\\)") + f + s + in + s2 + + (** Print html code to display a [Types.type_expr]. *) + method html_of_type_expr b m_name t = + let s = Odoc_info.remove_ending_newline (Odoc_info.string_of_type_expr t) in + let s2 = newline_to_indented_br s in + bs b "<code class=\"type\">"; + bs b (self#create_fully_qualified_idents_links m_name s2); + bs b "</code>" + + (** Print html code to display a [Types.type_expr list]. *) + method html_of_type_expr_list ?par b m_name sep l = + print_DEBUG "html#html_of_type_expr_list"; + let s = Odoc_info.string_of_type_list ?par sep l in + print_DEBUG "html#html_of_type_expr_list: 1"; + let s2 = newline_to_indented_br s in + print_DEBUG "html#html_of_type_expr_list: 2"; + bs b "<code class=\"type\">"; + bs b (self#create_fully_qualified_idents_links m_name s2); + bs b "</code>" + + (** Print html code to display a [Types.type_expr list] as type parameters + of a class of class type. *) + method html_of_class_type_param_expr_list b m_name l = + let s = Odoc_info.string_of_class_type_param_list l in + let s2 = newline_to_indented_br s in + bs b "<code class=\"type\">["; + bs b (self#create_fully_qualified_idents_links m_name s2); + bs b "]</code>" + + method html_of_class_parameter_list b father c = + let s = Odoc_info.string_of_class_params c in + let s = Odoc_info.remove_ending_newline s in + let s2 = newline_to_indented_br s in + bs b "<code class=\"type\">"; + bs b (self#create_fully_qualified_idents_links father s2); + bs b "</code>" + + (** Print html code to display a list of type parameters for the given type.*) + method html_of_type_expr_param_list b m_name t = + let s = Odoc_info.string_of_type_param_list t in + let s2 = newline_to_indented_br s in + bs b "<code class=\"type\">"; + bs b (self#create_fully_qualified_idents_links m_name s2); + bs b "</code>" + + (** Print html code to display a [Types.module_type]. *) + method html_of_module_type b ?code m_name t = + let s = Odoc_info.remove_ending_newline (Odoc_info.string_of_module_type ?code t) in + bs b "<code class=\"type\">"; + bs b (self#create_fully_qualified_module_idents_links m_name s); + bs b "</code>" + + (** Print html code to display the given module kind. *) + method html_of_module_kind b father ?modu kind = + match kind with + Module_struct eles -> + self#html_of_text b [Code "sig"]; + ( + match modu with + None -> + bs b "<div class=\"sig_block\">"; + List.iter (self#html_of_module_element b father) eles; + bs b "</div>" + | Some m -> + let (html_file, _) = Naming.html_files m.m_name in + bp b " <a href=\"%s\">..</a> " html_file + ); + self#html_of_text b [Code "end"] + | Module_alias a -> + bs b "<code class=\"type\">"; + bs b (self#create_fully_qualified_module_idents_links father a.ma_name); + bs b "</code>" + | Module_functor (p, k) -> + if !html_short_functors then + bs b " " + else + bs b "<div class=\"sig_block\">"; + self#html_of_module_parameter b father p; + ( + match k with + Module_functor _ -> () + | _ when !html_short_functors -> + bs b ": " + | _ -> () + ); + self#html_of_module_kind b father ?modu k; + if not !html_short_functors then + bs b "</div>" + | Module_apply (k1, k2) -> + (* TODO: l'application n'est pas correcte dans un .mli. + Que faire ? -> afficher le module_type du typedtree *) + self#html_of_module_kind b father k1; + self#html_of_text b [Code "("]; + self#html_of_module_kind b father k2; + self#html_of_text b [Code ")"] + | Module_with (k, s) -> + (* TODO: à modifier quand Module_with sera plus détaillé *) + self#html_of_module_type_kind b father ?modu k; + bs b "<code class=\"type\"> "; + bs b (self#create_fully_qualified_module_idents_links father s); + bs b "</code>" + | Module_constraint (k, tk) -> + (* TODO: on affiche quoi ? *) + self#html_of_module_kind b father ?modu k + | Module_typeof s -> + bs b "<code class=\"type\">module type of "; + bs b (self#create_fully_qualified_module_idents_links father s); + bs b "</code>" + | Module_unpack (code, mta) -> + bs b "<code class=\"type\">"; + begin + match mta.mta_module with + None -> + bs b (self#create_fully_qualified_module_idents_links father (self#escape code)) + | Some mt -> + let (html_file, _) = Naming.html_files mt.mt_name in + bp b " <a href=\"%s\">%s</a> " html_file (self#escape code) + end; + bs b "</code>" + + + method html_of_module_parameter b father p = + let (s_functor,s_arrow) = + if !html_short_functors then + "", "" + else + "functor ", "-> " + in + self#html_of_text b + [ + Code (s_functor^"("); + Code p.mp_name ; + Code " : "; + ] ; + self#html_of_module_type_kind b father p.mp_kind; + self#html_of_text b [ Code (") "^s_arrow)] + + method html_of_module_element b father ele = + match ele with + Element_module m -> + self#html_of_module b ~complete: false m + | Element_module_type mt -> + self#html_of_modtype b ~complete: false mt + | Element_included_module im -> + self#html_of_included_module b im + | Element_class c -> + self#html_of_class b ~complete: false c + | Element_class_type ct -> + self#html_of_class_type b ~complete: false ct + | Element_value v -> + self#html_of_value b v + | Element_exception e -> + self#html_of_exception b e + | Element_type t -> + self#html_of_type b t + | Element_module_comment text -> + self#html_of_module_comment b text + + (** Print html code to display the given module type kind. *) + method html_of_module_type_kind b father ?modu ?mt kind = + match kind with + Module_type_struct eles -> + self#html_of_text b [Code "sig"]; + ( + match mt with + None -> + ( + match modu with + None -> + bs b "<div class=\"sig_block\">"; + List.iter (self#html_of_module_element b father) eles; + bs b "</div>" + | Some m -> + let (html_file, _) = Naming.html_files m.m_name in + bp b " <a href=\"%s\">..</a> " html_file + ) + | Some mt -> + let (html_file, _) = Naming.html_files mt.mt_name in + bp b " <a href=\"%s\">..</a> " html_file + ); + self#html_of_text b [Code "end"] + | Module_type_functor (p, k) -> + self#html_of_module_parameter b father p; + self#html_of_module_type_kind b father ?modu ?mt k + | Module_type_alias a -> + bs b "<code class=\"type\">"; + bs b (self#create_fully_qualified_module_idents_links father a.mta_name); + bs b "</code>" + | Module_type_with (k, s) -> + self#html_of_module_type_kind b father ?modu ?mt k; + bs b "<code class=\"type\"> "; + bs b (self#create_fully_qualified_module_idents_links father s); + bs b "</code>" + | Module_type_typeof s -> + bs b "<code class=\"type\">module type of "; + bs b (self#create_fully_qualified_module_idents_links father s); + bs b "</code>" + + (** Print html code to display the type of a module parameter.. *) + method html_of_module_parameter_type b m_name p = + self#html_of_module_type b m_name ~code: p.mp_type_code p.mp_type + + (** Generate a file containing the module type in the given file name. *) + method output_module_type in_title file mtyp = + let s = Odoc_info.remove_ending_newline (Odoc_info.string_of_module_type ~complete: true mtyp) in + self#output_code in_title file s + + (** Generate a file containing the class type in the given file name. *) + method output_class_type in_title file ctyp = + let s = Odoc_info.remove_ending_newline (Odoc_info.string_of_class_type ~complete: true ctyp) in + self#output_code in_title file s + + (** Print html code for a value. *) + method html_of_value b v = + Odoc_info.reset_type_names (); + bs b "<pre>" ; + bp b "<span id=\"%s\">" (Naming.value_target v); + bs b (self#keyword "val"); + bs b " "; + ( + match v.val_code with + None -> bs b (self#escape (Name.simple v.val_name)) + | Some c -> + let file = Naming.file_code_value_complete_target v in + self#output_code v.val_name (Filename.concat !Global.target_dir file) c; + bp b "<a href=\"%s\">%s</a>" file (self#escape (Name.simple v.val_name)) + ); + bs b "</span>"; + bs b " : "; + self#html_of_type_expr b (Name.father v.val_name) v.val_type; + bs b "</pre>"; + self#html_of_info b v.val_info; + ( + if !with_parameter_list then + self#html_of_parameter_list b (Name.father v.val_name) v.val_parameters + else + self#html_of_described_parameter_list b (Name.father v.val_name) v.val_parameters + ) + + (** Print html code for an exception. *) + method html_of_exception b e = + Odoc_info.reset_type_names (); + bs b "<pre>"; + bp b "<span id=\"%s\">" (Naming.exception_target e); + bs b (self#keyword "exception"); + bs b " "; + bs b (Name.simple e.ex_name); + bs b "</span>"; + ( + match e.ex_args with + [] -> () + | _ -> + bs b (" "^(self#keyword "of")^" "); + self#html_of_type_expr_list + ~par: false b (Name.father e.ex_name) " * " e.ex_args + ); + ( + match e.ex_alias with + None -> () + | Some ea -> + bs b " = "; + ( + match ea.ea_ex with + None -> bs b ea.ea_name + | Some e -> + bp b "<a href=\"%s\">%s</a>" (Naming.complete_exception_target e) e.ex_name + ) + ); + bs b "</pre>\n"; + self#html_of_info b e.ex_info + + (** Print html code for a type. *) + method html_of_type b t = + Odoc_info.reset_type_names (); + let father = Name.father t.ty_name in + bs b + (match t.ty_manifest, t.ty_kind with + None, Type_abstract -> "<pre>" + | None, Type_variant _ + | None, Type_record _ -> "<br><code>" + | Some _, Type_abstract -> "<pre>" + | Some _, Type_variant _ + | Some _, Type_record _ -> "<pre>" + ); + bp b "<span id=\"%s\">" (Naming.type_target t); + bs b ((self#keyword "type")^" "); + self#html_of_type_expr_param_list b father t; + (match t.ty_parameters with [] -> () | _ -> bs b " "); + bs b (Name.simple t.ty_name); + bs b "</span> "; + let priv = t.ty_private = Asttypes.Private in + ( + match t.ty_manifest with + None -> () + | Some typ -> + bs b "= "; + if priv then bs b "private "; + self#html_of_type_expr b father typ; + bs b " " + ); + (match t.ty_kind with + Type_abstract -> bs b "</pre>" + | Type_variant l -> + bs b "= "; + if priv then bs b "private "; + bs b + ( + match t.ty_manifest with + None -> "</code>" + | Some _ -> "</pre>" + ); + bs b "<table class=\"typetable\">\n"; + let print_one constr = + bs b "<tr>\n<td align=\"left\" valign=\"top\" >\n"; + bs b "<code>"; + bs b (self#keyword "|"); + bs b "</code></td>\n<td align=\"left\" valign=\"top\" >\n"; + bs b "<code>"; + bs b (self#constructor constr.vc_name); + ( + match constr.vc_args with + [] -> () + | l -> + bs b (" " ^ (self#keyword "of") ^ " "); + self#html_of_type_expr_list ~par: false b father " * " l; + ); + bs b "</code></td>\n"; + ( + match constr.vc_text with + None -> () + | Some t -> + bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >"; + bs b "<code>"; + bs b "(*"; + bs b "</code></td>"; + bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >"; + self#html_of_text b t; + bs b "</td>"; + bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"bottom\" >"; + bs b "<code>"; + bs b "*)"; + bs b "</code></td>"; + ); + bs b "\n</tr>" + in + print_concat b "\n" print_one l; + bs b "</table>\n" + + | Type_record l -> + bs b "= "; + if priv then bs b "private " ; + bs b "{"; + bs b + ( + match t.ty_manifest with + None -> "</code>" + | Some _ -> "</pre>" + ); + bs b "<table class=\"typetable\">\n" ; + let print_one r = + bs b "<tr>\n<td align=\"left\" valign=\"top\" >\n"; + bs b "<code> </code>"; + bs b "</td>\n<td align=\"left\" valign=\"top\" >\n"; + bs b "<code>"; + if r.rf_mutable then bs b (self#keyword "mutable ") ; + bs b (r.rf_name ^ " : ") ; + self#html_of_type_expr b father r.rf_type; + bs b ";</code></td>\n"; + ( + match r.rf_text with + None -> () + | Some t -> + bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >"; + bs b "<code>"; + bs b "(*"; + bs b "</code></td>"; + bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >"; + self#html_of_text b t; + bs b "</td><td class=\"typefieldcomment\" align=\"left\" valign=\"bottom\" >"; + bs b "<code>*)</code></td>"; + ); + bs b "\n</tr>" + in + print_concat b "\n" print_one l; + bs b "</table>\n}\n" + ); + bs b "\n"; + self#html_of_info b t.ty_info; + bs b "\n" + + (** Print html code for a class attribute. *) + method html_of_attribute b a = + let module_name = Name.father (Name.father a.att_value.val_name) in + bs b "<pre>" ; + bp b "<span id=\"%s\">" (Naming.attribute_target a); + bs b (self#keyword "val"); + bs b " "; + ( + if a.att_virtual then + bs b ((self#keyword "virtual")^ " ") + else + () + ); + ( + if a.att_mutable then + bs b ((self#keyword Odoc_messages.mutab)^ " ") + else + () + );( + match a.att_value.val_code with + None -> bs b (Name.simple a.att_value.val_name) + | Some c -> + let file = Naming.file_code_attribute_complete_target a in + self#output_code a.att_value.val_name (Filename.concat !Global.target_dir file) c; + bp b "<a href=\"%s\">%s</a>" file (Name.simple a.att_value.val_name); + ); + bs b "</span>"; + bs b " : "; + self#html_of_type_expr b module_name a.att_value.val_type; + bs b "</pre>"; + self#html_of_info b a.att_value.val_info + + (** Print html code for a class method. *) + method html_of_method b m = + let module_name = Name.father (Name.father m.met_value.val_name) in + bs b "<pre>"; + (* html mark *) + bp b "<span id=\"%s\">" (Naming.method_target m); + bs b ((self#keyword "method")^" "); + if m.met_private then bs b ((self#keyword "private")^" "); + if m.met_virtual then bs b ((self#keyword "virtual")^" "); + ( + match m.met_value.val_code with + None -> bs b (Name.simple m.met_value.val_name) + | Some c -> + let file = Naming.file_code_method_complete_target m in + self#output_code m.met_value.val_name (Filename.concat !Global.target_dir file) c; + bp b "<a href=\"%s\">%s</a>" file (Name.simple m.met_value.val_name); + ); + bs b "</span>"; + bs b " : "; + self#html_of_type_expr b module_name m.met_value.val_type; + bs b "</pre>"; + self#html_of_info b m.met_value.val_info; + ( + if !with_parameter_list then + self#html_of_parameter_list b + module_name m.met_value.val_parameters + else + self#html_of_described_parameter_list b + module_name m.met_value.val_parameters + ) + + (** Print html code for the description of a function parameter. *) + method html_of_parameter_description b p = + match Parameter.names p with + [] -> + () + | name :: [] -> + ( + (* Only one name, no need for label for the description. *) + match Parameter.desc_by_name p name with + None -> () + | Some t -> self#html_of_text b t + ) + | l -> + (* A list of names, we display those with a description. *) + let l2 = List.filter + (fun n -> (Parameter.desc_by_name p n) <> None) + l + in + let print_one n = + match Parameter.desc_by_name p n with + None -> () + | Some t -> + bs b "<code>"; + bs b n; + bs b "</code> : "; + self#html_of_text b t + in + print_concat b "<br>\n" print_one l2 + + (** Print html code for a list of parameters. *) + method html_of_parameter_list b m_name l = + match l with + [] -> () + | _ -> + bs b "<div class=\"param_info\">"; + bs b "<table border=\"0\" cellpadding=\"3\" width=\"100%\">\n"; + bs b "<tr>\n<td align=\"left\" valign=\"top\" width=\"1%\">"; + bs b "<b>"; + bs b Odoc_messages.parameters; + bs b ": </b></td>\n" ; + bs b "<td>\n<table class=\"paramstable\">\n"; + let print_one p = + bs b "<tr>\n<td align=\"center\" valign=\"top\" width=\"15%\" class=\"code\">\n"; + bs b + ( + match Parameter.complete_name p with + "" -> "?" + | s -> s + ); + bs b "</td>\n<td align=\"center\" valign=\"top\">:</td>\n"; + bs b "<td>"; + self#html_of_type_expr b m_name (Parameter.typ p); + bs b "<br>\n"; + self#html_of_parameter_description b p; + bs b "\n</tr>\n"; + in + List.iter print_one l; + bs b "</table>\n</td>\n</tr>\n</table></div>\n" + + (** Print html code for the parameters which have a name and description. *) + method html_of_described_parameter_list b m_name l = + (* get the params which have a name, and at least one name described. *) + let l2 = List.filter + (fun p -> + List.exists + (fun n -> (Parameter.desc_by_name p n) <> None) + (Parameter.names p)) + l + in + let f p = + bs b "<div class=\"param_info\"><code class=\"code\">"; + bs b (Parameter.complete_name p); + bs b "</code> : " ; + self#html_of_parameter_description b p; + bs b "</div>\n" + in + List.iter f l2 + + (** Print html code for a list of module parameters. *) + method html_of_module_parameter_list b m_name l = + match l with + [] -> + () + | _ -> + bs b "<table border=\"0\" cellpadding=\"3\" width=\"100%\">\n"; + bs b "<tr>\n"; + bs b "<td align=\"left\" valign=\"top\" width=\"1%%\"><b>"; + bs b Odoc_messages.parameters ; + bs b ": </b></td>\n<td>\n"; + bs b "<table class=\"paramstable\">\n"; + List.iter + (fun (p, desc_opt) -> + bs b "<tr>\n"; + bs b "<td align=\"center\" valign=\"top\" width=\"15%\">\n<code>" ; + bs b p.mp_name; + bs b "</code></td>\n" ; + bs b "<td align=\"center\" valign=\"top\">:</td>\n"; + bs b "<td>" ; + self#html_of_module_parameter_type b m_name p; + bs b "\n"; + ( + match desc_opt with + None -> () + | Some t -> + bs b "<br>"; + self#html_of_text b t; + bs b "\n</tr>\n" ; + ) + ) + l; + bs b "</table>\n</td>\n</tr>\n</table>\n" + + (** Print html code for a module. *) + method html_of_module b ?(info=true) ?(complete=true) ?(with_link=true) m = + let (html_file, _) = Naming.html_files m.m_name in + let father = Name.father m.m_name in + bs b "<pre>"; + bs b ((self#keyword "module")^" "); + ( + if with_link then + bp b "<a href=\"%s\">%s</a>" html_file (Name.simple m.m_name) + else + bs b (Name.simple m.m_name) + ); + ( + match m.m_kind with + Module_functor _ when !html_short_functors -> + () + | _ -> bs b ": " + ); + self#html_of_module_kind b father ~modu: m m.m_kind; + bs b "</pre>"; + if info then + ( + if complete then + self#html_of_info ~indent: false + else + self#html_of_info_first_sentence + ) b m.m_info + else + () + + (** Print html code for a module type. *) + method html_of_modtype b ?(info=true) ?(complete=true) ?(with_link=true) mt = + let (html_file, _) = Naming.html_files mt.mt_name in + let father = Name.father mt.mt_name in + bs b "<pre>"; + bs b ((self#keyword "module type")^" "); + ( + if with_link then + bp b "<a href=\"%s\">%s</a>" html_file (Name.simple mt.mt_name) + else + bs b (Name.simple mt.mt_name) + ); + (match mt.mt_kind with + None -> () + | Some k -> + bs b " = "; + self#html_of_module_type_kind b father ~mt k + ); + bs b "</pre>"; + if info then + ( + if complete then + self#html_of_info ~indent: false + else + self#html_of_info_first_sentence + ) b mt.mt_info + else + () + + (** Print html code for an included module. *) + method html_of_included_module b im = + bs b "<pre>"; + bs b ((self#keyword "include")^" "); + ( + match im.im_module with + None -> + bs b im.im_name + | Some mmt -> + let (file, name) = + match mmt with + Mod m -> + let (html_file, _) = Naming.html_files m.m_name in + (html_file, m.m_name) + | Modtype mt -> + let (html_file, _) = Naming.html_files mt.mt_name in + (html_file, mt.mt_name) + in + bp b "<a href=\"%s\">%s</a>" file name + ); + bs b "</pre>\n"; + self#html_of_info b im.im_info + + method html_of_class_element b element = + match element with + Class_attribute a -> + self#html_of_attribute b a + | Class_method m -> + self#html_of_method b m + | Class_comment t -> + self#html_of_class_comment b t + + method html_of_class_kind b father ?cl kind = + match kind with + Class_structure (inh, eles) -> + self#html_of_text b [Code "object"]; + ( + match cl with + None -> + bs b "\n"; + ( + match inh with + [] -> () + | _ -> + self#generate_inheritance_info b inh + ); + List.iter (self#html_of_class_element b) eles; + | Some cl -> + let (html_file, _) = Naming.html_files cl.cl_name in + bp b " <a href=\"%s\">..</a> " html_file + ); + self#html_of_text b [Code "end"] + + | Class_apply capp -> + (* TODO: afficher le type final à partir du typedtree *) + self#html_of_text b [Raw "class application not handled yet"] + + | Class_constr cco -> + ( + match cco.cco_type_parameters with + [] -> () + | l -> + self#html_of_class_type_param_expr_list b father l; + bs b " " + ); + bs b "<code class=\"type\">"; + bs b (self#create_fully_qualified_idents_links father cco.cco_name); + bs b "</code>" + + | Class_constraint (ck, ctk) -> + self#html_of_text b [Code "( "] ; + self#html_of_class_kind b father ck; + self#html_of_text b [Code " : "] ; + self#html_of_class_type_kind b father ctk; + self#html_of_text b [Code " )"] + + method html_of_class_type_kind b father ?ct kind = + match kind with + Class_type cta -> + ( + match cta.cta_type_parameters with + [] -> () + | l -> + self#html_of_class_type_param_expr_list b father l; + bs b " " + ); + bs b "<code class=\"type\">"; + bs b (self#create_fully_qualified_idents_links father cta.cta_name); + bs b "</code>" + + | Class_signature (inh, eles) -> + self#html_of_text b [Code "object"]; + ( + match ct with + None -> + bs b "\n"; + ( + match inh with + [] -> () + | _ -> self#generate_inheritance_info b inh + ); + List.iter (self#html_of_class_element b) eles + | Some ct -> + let (html_file, _) = Naming.html_files ct.clt_name in + bp b " <a href=\"%s\">..</a> " html_file + ); + self#html_of_text b [Code "end"] + + (** Print html code for a class. *) + method html_of_class b ?(complete=true) ?(with_link=true) c = + let father = Name.father c.cl_name in + Odoc_info.reset_type_names (); + let (html_file, _) = Naming.html_files c.cl_name in + bs b "<pre>"; + (* we add a html id, the same as for a type so we can + go directly here when the class name is used as a type name *) + bp b "<span name=\"%s\">" + (Naming.type_target + { ty_name = c.cl_name ; + ty_info = None ; ty_parameters = [] ; + ty_kind = Type_abstract ; ty_private = Asttypes.Public; ty_manifest = None ; + ty_loc = Odoc_info.dummy_loc ; + ty_code = None ; + } + ); + bs b ((self#keyword "class")^" "); + print_DEBUG "html#html_of_class : virtual or not" ; + if c.cl_virtual then bs b ((self#keyword "virtual")^" "); + ( + match c.cl_type_parameters with + [] -> () + | l -> + self#html_of_class_type_param_expr_list b father l; + bs b " " + ); + print_DEBUG "html#html_of_class : with link or not" ; + ( + if with_link then + bp b "<a href=\"%s\">%s</a>" html_file (Name.simple c.cl_name) + else + bs b (Name.simple c.cl_name) + ); + bs b "</span>"; + bs b " : " ; + self#html_of_class_parameter_list b father c ; + self#html_of_class_kind b father ~cl: c c.cl_kind; + bs b "</pre>" ; + print_DEBUG "html#html_of_class : info" ; + ( + if complete then + self#html_of_info ~indent: false + else + self#html_of_info_first_sentence + ) b c.cl_info + + (** Print html code for a class type. *) + method html_of_class_type b ?(complete=true) ?(with_link=true) ct = + Odoc_info.reset_type_names (); + let father = Name.father ct.clt_name in + let (html_file, _) = Naming.html_files ct.clt_name in + bs b "<pre>"; + (* we add a html id, the same as for a type so we can + go directly here when the class type name is used as a type name *) + bp b "<span id=\"%s\">" + (Naming.type_target + { ty_name = ct.clt_name ; + ty_info = None ; ty_parameters = [] ; + ty_kind = Type_abstract ; ty_private = Asttypes.Public; ty_manifest = None ; + ty_loc = Odoc_info.dummy_loc ; + ty_code = None ; + } + ); + bs b ((self#keyword "class type")^" "); + if ct.clt_virtual then bs b ((self#keyword "virtual")^" "); + ( + match ct.clt_type_parameters with + [] -> () + | l -> + self#html_of_class_type_param_expr_list b father l; + bs b " " + ); + + if with_link then + bp b "<a href=\"%s\">%s</a>" html_file (Name.simple ct.clt_name) + else + bs b (Name.simple ct.clt_name); + + bs b "</span>"; + bs b " = "; + self#html_of_class_type_kind b father ~ct ct.clt_kind; + bs b "</pre>"; + ( + if complete then + self#html_of_info ~indent: false + else + self#html_of_info_first_sentence + ) b ct.clt_info + + (** Return html code to represent a dag, represented as in Odoc_dag2html. *) + method html_of_dag dag = + let f n = + let (name, cct_opt) = n.Odoc_dag2html.valu in + (* if we have a c_opt = Some class then we take its information + because we are sure the name is complete. *) + let (name2, html_file) = + match cct_opt with + None -> (name, fst (Naming.html_files name)) + | Some (Cl c) -> (c.cl_name, fst (Naming.html_files c.cl_name)) + | Some (Cltype (ct, _)) -> (ct.clt_name, fst (Naming.html_files ct.clt_name)) + in + let new_v = + "<table border=1>\n<tr><td>"^ + "<a href=\""^html_file^"\">"^name2^"</a>"^ + "</td></tr>\n</table>\n" + in + { n with Odoc_dag2html.valu = new_v } + in + let a = Array.map f dag.Odoc_dag2html.dag in + Odoc_dag2html.html_of_dag { Odoc_dag2html.dag = a } + + (** Print html code for a module comment.*) + method html_of_module_comment b text = + bs b "<br>\n"; + self#html_of_text b text; + bs b "<br>\n" + + (** Print html code for a class comment.*) + method html_of_class_comment b text = + (* Add some style if there is no style for the first part of the text. *) + let text2 = + match text with + | (Odoc_info.Raw s) :: q -> + (Odoc_info.Title (2, None, [Odoc_info.Raw s])) :: q + | _ -> text + in + self#html_of_text b text2 + + (** Generate html code for the given list of inherited classes.*) + method generate_inheritance_info b inher_l = + let f inh = + match inh.ic_class with + None -> (* we can't make the link. *) + (Odoc_info.Code inh.ic_name) :: + (match inh.ic_text with + None -> [] + | Some t -> (Odoc_info.Raw " ") :: t) + | Some cct -> + (* we can create the link. *) + let real_name = (* even if it should be the same *) + match cct with + Cl c -> c.cl_name + | Cltype (ct, _) -> ct.clt_name + in + let (class_file, _) = Naming.html_files real_name in + (Odoc_info.Link (class_file, [Odoc_info.Code real_name])) :: + (match inh.ic_text with + None -> [] + | Some t -> (Odoc_info.Raw " ") :: t) + in + let text = [ + Odoc_info.Bold [Odoc_info.Raw Odoc_messages.inherits] ; + Odoc_info.List (List.map f inher_l) + ] + in + self#html_of_text b text + + (** Generate html code for the inherited classes of the given class. *) + method generate_class_inheritance_info b cl = + let rec iter_kind k = + match k with + Class_structure ([], _) -> + () + | Class_structure (l, _) -> + self#generate_inheritance_info b l + | Class_constraint (k, ct) -> + iter_kind k + | Class_apply _ + | Class_constr _ -> + () + in + iter_kind cl.cl_kind + + (** Generate html code for the inherited classes of the given class type. *) + method generate_class_type_inheritance_info b clt = + match clt.clt_kind with + Class_signature ([], _) -> + () + | Class_signature (l, _) -> + self#generate_inheritance_info b l + | Class_type _ -> + () + + (** A method to create index files. *) + method generate_elements_index : + 'a. + 'a list -> + ('a -> Odoc_info.Name.t) -> + ('a -> Odoc_info.info option) -> + ('a -> string) -> string -> string -> unit = + fun elements name info target title simple_file -> + try + let chanout = open_out (Filename.concat !Global.target_dir simple_file) in + let b = new_buf () in + bs b "<html>\n"; + self#print_header b (self#inner_title title); + bs b "<body>\n<center><h1>"; + bs b title; + bs b "</h1></center>\n" ; + + let sorted_elements = List.sort + (fun e1 e2 -> compare (Name.simple (name e1)) (Name.simple (name e2))) + elements + in + let groups = Odoc_info.create_index_lists sorted_elements (fun e -> Name.simple (name e)) in + let f_ele e = + let simple_name = Name.simple (name e) in + let father_name = Name.father (name e) in + bp b "<tr><td><a href=\"%s\">%s</a> " (target e) (self#escape simple_name); + if simple_name <> father_name && father_name <> "" then + bp b "[<a href=\"%s\">%s</a>]" (fst (Naming.html_files father_name)) father_name; + bs b "</td>\n<td>"; + self#html_of_info_first_sentence b (info e); + bs b "</td></tr>\n"; + in + let f_group l = + match l with + [] -> () + | e :: _ -> + let s = + match (Char.uppercase (Name.simple (name e)).[0]) with + 'A'..'Z' as c -> String.make 1 c + | _ -> "" + in + bs b "<tr><td align=\"left\"><br>"; + bs b s ; + bs b "</td></tr>\n" ; + List.iter f_ele l + in + bs b "<table>\n"; + List.iter f_group groups ; + bs b "</table><br>\n" ; + bs b "</body>\n</html>"; + Buffer.output_buffer chanout b; + close_out chanout + with + Sys_error s -> + raise (Failure s) + + (** A method to generate a list of module/class files. *) + method generate_elements : + 'a. ('a option -> 'a option -> 'a -> unit) -> 'a list -> unit = + fun f_generate l -> + let rec iter pre_opt = function + [] -> () + | ele :: [] -> f_generate pre_opt None ele + | ele1 :: ele2 :: q -> + f_generate pre_opt (Some ele2) ele1 ; + iter (Some ele1) (ele2 :: q) + in + iter None l + + (** Generate the code of the html page for the given class.*) + method generate_for_class pre post cl = + Odoc_info.reset_type_names (); + let (html_file, _) = Naming.html_files cl.cl_name in + let type_file = Naming.file_type_class_complete_target cl.cl_name in + try + let chanout = open_out (Filename.concat !Global.target_dir html_file) in + let b = new_buf () in + let pre_name = opt (fun c -> c.cl_name) pre in + let post_name = opt (fun c -> c.cl_name) post in + bs b doctype ; + bs b "<html>\n"; + self#print_header b + ~nav: (Some (pre_name, post_name, cl.cl_name)) + ~comments: (Class.class_comments cl) + (self#inner_title cl.cl_name); + bs b "<body>\n"; + self#print_navbar b pre_name post_name cl.cl_name; + bs b "<center><h1>"; + bs b (Odoc_messages.clas^" "); + if cl.cl_virtual then bs b "virtual " ; + bp b "<a href=\"%s\">%s</a>" type_file cl.cl_name; + bs b "</h1></center>\n<br>\n"; + self#html_of_class b ~with_link: false cl; + (* parameters *) + self#html_of_described_parameter_list b + (Name.father cl.cl_name) cl.cl_parameters; + (* class inheritance *) + self#generate_class_inheritance_info b cl; + (* a horizontal line *) + bs b "<hr width=\"100%\">\n"; + (* the various elements *) + List.iter (self#html_of_class_element b) + (Class.class_elements ~trans:false cl); + bs b "</body></html>"; + Buffer.output_buffer chanout b; + close_out chanout; + + (* generate the file with the complete class type *) + self#output_class_type + cl.cl_name + (Filename.concat !Global.target_dir type_file) + cl.cl_type + with + Sys_error s -> + raise (Failure s) + + (** Generate the code of the html page for the given class type.*) + method generate_for_class_type pre post clt = + Odoc_info.reset_type_names (); + let (html_file, _) = Naming.html_files clt.clt_name in + let type_file = Naming.file_type_class_complete_target clt.clt_name in + try + let chanout = open_out (Filename.concat !Global.target_dir html_file) in + let b = new_buf () in + let pre_name = opt (fun ct -> ct.clt_name) pre in + let post_name = opt (fun ct -> ct.clt_name) post in + bs b doctype ; + bs b "<html>\n"; + self#print_header b + ~nav: (Some (pre_name, post_name, clt.clt_name)) + ~comments: (Class.class_type_comments clt) + (self#inner_title clt.clt_name); + + bs b "<body>\n"; + self#print_navbar b pre_name post_name clt.clt_name; + bs b "<center><h1>"; + bs b (Odoc_messages.class_type^" "); + if clt.clt_virtual then bs b "virtual "; + bp b "<a href=\"%s\">%s</a>" type_file clt.clt_name; + bs b "</h1></center>\n<br>\n"; + self#html_of_class_type b ~with_link: false clt; + + (* class inheritance *) + self#generate_class_type_inheritance_info b clt; + (* a horizontal line *) + bs b "<hr width=\"100%\">\n"; + (* the various elements *) + List.iter (self#html_of_class_element b) + (Class.class_type_elements ~trans: false clt); + bs b "</body></html>"; + Buffer.output_buffer chanout b; + close_out chanout; + + (* generate the file with the complete class type *) + self#output_class_type + clt.clt_name + (Filename.concat !Global.target_dir type_file) + clt.clt_type + with + Sys_error s -> + raise (Failure s) + + (** Generate the html file for the given module type. + @raise Failure if an error occurs.*) + method generate_for_module_type pre post mt = + try + let (html_file, _) = Naming.html_files mt.mt_name in + let type_file = Naming.file_type_module_complete_target mt.mt_name in + let chanout = open_out (Filename.concat !Global.target_dir html_file) in + let b = new_buf () in + let pre_name = opt (fun mt -> mt.mt_name) pre in + let post_name = opt (fun mt -> mt.mt_name) post in + bs b doctype ; + bs b "<html>\n"; + self#print_header b + ~nav: (Some (pre_name, post_name, mt.mt_name)) + ~comments: (Module.module_type_comments mt) + (self#inner_title mt.mt_name); + bs b "<body>\n"; + self#print_navbar b pre_name post_name mt.mt_name; + bp b "<center><h1>"; + bs b (Odoc_messages.module_type^" "); + ( + match mt.mt_type with + Some _ -> bp b "<a href=\"%s\">%s</a>" type_file mt.mt_name + | None-> bs b mt.mt_name + ); + bs b "</h1></center>\n<br>\n" ; + self#html_of_modtype b ~with_link: false mt; + + (* parameters for functors *) + self#html_of_module_parameter_list b + (Name.father mt.mt_name) + (Module.module_type_parameters mt); + (* a horizontal line *) + bs b "<hr width=\"100%\">\n"; + (* module elements *) + List.iter + (self#html_of_module_element b (Name.father mt.mt_name)) + (Module.module_type_elements mt); + + bs b "</body></html>"; + Buffer.output_buffer chanout b; + close_out chanout; + + (* generate html files for submodules *) + self#generate_elements self#generate_for_module (Module.module_type_modules mt); + (* generate html files for module types *) + self#generate_elements self#generate_for_module_type (Module.module_type_module_types mt); + (* generate html files for classes *) + self#generate_elements self#generate_for_class (Module.module_type_classes mt); + (* generate html files for class types *) + self#generate_elements self#generate_for_class_type (Module.module_type_class_types mt); + + (* generate the file with the complete module type *) + ( + match mt.mt_type with + None -> () + | Some mty -> + self#output_module_type + mt.mt_name + (Filename.concat !Global.target_dir type_file) + mty + ) + with + Sys_error s -> + raise (Failure s) + + (** Generate the html file for the given module. + @raise Failure if an error occurs.*) + method generate_for_module pre post modu = + try + Odoc_info.verbose ("Generate for module "^modu.m_name); + let (html_file, _) = Naming.html_files modu.m_name in + let type_file = Naming.file_type_module_complete_target modu.m_name in + let code_file = Naming.file_code_module_complete_target modu.m_name in + let chanout = open_out (Filename.concat !Global.target_dir html_file) in + let b = new_buf () in + let pre_name = opt (fun m -> m.m_name) pre in + let post_name = opt (fun m -> m.m_name) post in + bs b doctype ; + bs b "<html>\n"; + self#print_header b + ~nav: (Some (pre_name, post_name, modu.m_name)) + ~comments: (Module.module_comments modu) + (self#inner_title modu.m_name); + bs b "<body>\n" ; + self#print_navbar b pre_name post_name modu.m_name ; + bs b "<center><h1>"; + if modu.m_text_only then + bs b modu.m_name + else + ( + bs b + ( + if Module.module_is_functor modu then + Odoc_messages.functo + else + Odoc_messages.modul + ); + bp b " <a href=\"%s\">%s</a>" type_file modu.m_name; + ( + match modu.m_code with + None -> () + | Some _ -> bp b " (<a href=\"%s\">.ml</a>)" code_file + ) + ); + bs b "</h1></center>\n<br>\n"; + + if not modu.m_text_only then self#html_of_module b ~with_link: false modu; + + (* parameters for functors *) + self#html_of_module_parameter_list b + (Name.father modu.m_name) + (Module.module_parameters modu); + + (* a horizontal line *) + if not modu.m_text_only then bs b "<hr width=\"100%\">\n"; + + (* module elements *) + List.iter + (self#html_of_module_element b (Name.father modu.m_name)) + (Module.module_elements modu); + + bs b "</body></html>"; + Buffer.output_buffer chanout b; + close_out chanout; + + (* generate html files for submodules *) + self#generate_elements self#generate_for_module (Module.module_modules modu); + (* generate html files for module types *) + self#generate_elements self#generate_for_module_type (Module.module_module_types modu); + (* generate html files for classes *) + self#generate_elements self#generate_for_class (Module.module_classes modu); + (* generate html files for class types *) + self#generate_elements self#generate_for_class_type (Module.module_class_types modu); + + (* generate the file with the complete module type *) + self#output_module_type + modu.m_name + (Filename.concat !Global.target_dir type_file) + modu.m_type; + + match modu.m_code with + None -> () + | Some code -> + self#output_code + modu.m_name + (Filename.concat !Global.target_dir code_file) + code + with + Sys_error s -> + raise (Failure s) + + (** Generate the [<index_prefix>.html] file corresponding to the given module list. + @raise Failure if an error occurs.*) + method generate_index module_list = + try + let chanout = open_out (Filename.concat !Global.target_dir self#index) in + let b = new_buf () in + let title = match !Global.title with None -> "" | Some t -> self#escape t in + bs b doctype ; + bs b "<html>\n"; + self#print_header b self#title; + bs b "<body>\n"; + bs b "<center><h1>"; + bs b title; + bs b "</h1></center>\n" ; + let info = Odoc_info.apply_opt + (Odoc_info.info_of_comment_file module_list) + !Odoc_info.Global.intro_file + in + ( + match info with + None -> + self#html_of_Index_list b; + bs b "<br/>"; + self#html_of_Module_list b + (List.map (fun m -> m.m_name) module_list); + | Some i -> self#html_of_info ~indent: false b info + ); + bs b "</body>\n</html>"; + Buffer.output_buffer chanout b; + close_out chanout + with + Sys_error s -> + raise (Failure s) + + (** Generate the values index in the file [index_values.html]. *) + method generate_values_index module_list = + self#generate_elements_index + self#list_values + (fun v -> v.val_name) + (fun v -> v.val_info) + Naming.complete_value_target + Odoc_messages.index_of_values + self#index_values + + (** Generate the exceptions index in the file [index_exceptions.html]. *) + method generate_exceptions_index module_list = + self#generate_elements_index + self#list_exceptions + (fun e -> e.ex_name) + (fun e -> e.ex_info) + Naming.complete_exception_target + Odoc_messages.index_of_exceptions + self#index_exceptions + + (** Generate the types index in the file [index_types.html]. *) + method generate_types_index module_list = + self#generate_elements_index + self#list_types + (fun t -> t.ty_name) + (fun t -> t.ty_info) + Naming.complete_type_target + Odoc_messages.index_of_types + self#index_types + + (** Generate the attributes index in the file [index_attributes.html]. *) + method generate_attributes_index module_list = + self#generate_elements_index + self#list_attributes + (fun a -> a.att_value.val_name) + (fun a -> a.att_value.val_info) + Naming.complete_attribute_target + Odoc_messages.index_of_attributes + self#index_attributes + + (** Generate the methods index in the file [index_methods.html]. *) + method generate_methods_index module_list = + self#generate_elements_index + self#list_methods + (fun m -> m.met_value.val_name) + (fun m -> m.met_value.val_info) + Naming.complete_method_target + Odoc_messages.index_of_methods + self#index_methods + + (** Generate the classes index in the file [index_classes.html]. *) + method generate_classes_index module_list = + self#generate_elements_index + self#list_classes + (fun c -> c.cl_name) + (fun c -> c.cl_info) + (fun c -> fst (Naming.html_files c.cl_name)) + Odoc_messages.index_of_classes + self#index_classes + + (** Generate the class types index in the file [index_class_types.html]. *) + method generate_class_types_index module_list = + self#generate_elements_index + self#list_class_types + (fun ct -> ct.clt_name) + (fun ct -> ct.clt_info) + (fun ct -> fst (Naming.html_files ct.clt_name)) + Odoc_messages.index_of_class_types + self#index_class_types + + (** Generate the modules index in the file [index_modules.html]. *) + method generate_modules_index module_list = + self#generate_elements_index + self#list_modules + (fun m -> m.m_name) + (fun m -> m.m_info) + (fun m -> fst (Naming.html_files m.m_name)) + Odoc_messages.index_of_modules + self#index_modules + + (** Generate the module types index in the file [index_module_types.html]. *) + method generate_module_types_index module_list = + self#generate_elements_index + self#list_module_types + (fun mt -> mt.mt_name) + (fun mt -> mt.mt_info) + (fun mt -> fst (Naming.html_files mt.mt_name)) + Odoc_messages.index_of_module_types + self#index_module_types + + (** Generate all the html files from a module list. The main + file is [<index_prefix>.html]. *) + method generate module_list = + (* init the style *) + self#init_style ; + (* init the lists of elements *) + list_values <- Odoc_info.Search.values module_list ; + list_exceptions <- Odoc_info.Search.exceptions module_list ; + list_types <- Odoc_info.Search.types module_list ; + list_attributes <- Odoc_info.Search.attributes module_list ; + list_methods <- Odoc_info.Search.methods module_list ; + list_classes <- Odoc_info.Search.classes module_list ; + list_class_types <- Odoc_info.Search.class_types module_list ; + list_modules <- Odoc_info.Search.modules module_list ; + list_module_types <- Odoc_info.Search.module_types module_list ; + + (* prepare the page header *) + self#prepare_header module_list ; + (* Get the names of all known types. *) + let types = Odoc_info.Search.types module_list in + known_types_names <- + List.fold_left + (fun acc t -> StringSet.add t.ty_name acc) + known_types_names + types ; + (* Get the names of all class and class types. *) + let classes = Odoc_info.Search.classes module_list in + let class_types = Odoc_info.Search.class_types module_list in + known_classes_names <- + List.fold_left + (fun acc c -> StringSet.add c.cl_name acc) + known_classes_names + classes ; + known_classes_names <- + List.fold_left + (fun acc ct -> StringSet.add ct.clt_name acc) + known_classes_names + class_types ; + (* Get the names of all known modules and module types. *) + let module_types = Odoc_info.Search.module_types module_list in + let modules = Odoc_info.Search.modules module_list in + known_modules_names <- + List.fold_left + (fun acc m -> StringSet.add m.m_name acc) + known_modules_names + modules ; + known_modules_names <- + List.fold_left + (fun acc mt -> StringSet.add mt.mt_name acc) + known_modules_names + module_types ; + (* generate html for each module *) + if not !index_only then + self#generate_elements self#generate_for_module module_list ; + + try + self#generate_index module_list; + self#generate_values_index module_list ; + self#generate_exceptions_index module_list ; + self#generate_types_index module_list ; + self#generate_attributes_index module_list ; + self#generate_methods_index module_list ; + self#generate_classes_index module_list ; + self#generate_class_types_index module_list ; + self#generate_modules_index module_list ; + self#generate_module_types_index module_list ; + with + Failure s -> + prerr_endline s ; + incr Odoc_info.errors + + initializer + Odoc_ocamlhtml.html_of_comment := + (fun s -> + let b = new_buf () in + self#html_of_text b (Odoc_text.Texter.text_of_string s); + Buffer.contents b + ) + end +end + +module type Html_generator = module type of Generator diff --git a/ocaml-binary-annot/ocamldoc/odoc_info.ml b/ocaml-binary-annot/ocamldoc/odoc_info.ml new file mode 100644 index 0000000000..061d091f53 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_info.ml @@ -0,0 +1,323 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Interface for analysing documented OCaml source files and to the collected information. *) + +type ref_kind = Odoc_types.ref_kind = + RK_module + | RK_module_type + | RK_class + | RK_class_type + | RK_value + | RK_type + | RK_exception + | RK_attribute + | RK_method + | RK_section of text + +and text_element = Odoc_types.text_element = + | Raw of string + | Code of string + | CodePre of string + | Verbatim of string + | Bold of text + | Italic of text + | Emphasize of text + | Center of text + | Left of text + | Right of text + | List of text list + | Enum of text list + | Newline + | Block of text + | Title of int * string option * text + | Latex of string + | Link of string * text + | Ref of string * ref_kind option * text option + | Superscript of text + | Subscript of text + | Module_list of string list + | Index_list + | Custom of string * text + | Target of string * string + +and text = text_element list + +exception Text_syntax = Odoc_text.Text_syntax + +type see_ref = Odoc_types.see_ref = + See_url of string + | See_file of string + | See_doc of string + +type see = see_ref * text + +type param = (string * text) + +type raised_exception = (string * text) + +type info = Odoc_types.info = { + i_desc : text option; + i_authors : string list; + i_version : string option; + i_sees : see list; + i_since : string option; + i_before : (string * text) list ; + i_deprecated : text option; + i_params : param list; + i_raised_exceptions : raised_exception list; + i_return_value : text option ; + i_custom : (string * text) list ; + } + +type location = Odoc_types.location = { + loc_impl : (string * int) option ; + loc_inter : (string * int) option ; + } + +let dummy_loc = { loc_impl = None ; loc_inter = None } + +module Name = Odoc_name +module Parameter = Odoc_parameter +module Exception = Odoc_exception +module Type = Odoc_type +module Value = Odoc_value +module Class = Odoc_class +module Module = Odoc_module + + +let analyse_files + ?(merge_options=([] : Odoc_types.merge_option list)) + ?(include_dirs=([] : string list)) + ?(labels=false) + ?(sort_modules=false) + ?(no_stop=false) + ?(init=[]) + files = + Odoc_global.merge_options := merge_options; + Odoc_global.include_dirs := include_dirs; + Odoc_global.classic := not labels; + Odoc_global.sort_modules := sort_modules; + Odoc_global.no_stop := no_stop; + Odoc_analyse.analyse_files ~init: init files + +let dump_modules = Odoc_analyse.dump_modules + +let load_modules = Odoc_analyse.load_modules + +let reset_type_names = Printtyp.reset + +let string_of_variance t (co,cn) = Odoc_str.string_of_variance t (co, cn) + +let string_of_type_expr t = Odoc_print.string_of_type_expr t + +let string_of_class_params = Odoc_str.string_of_class_params + +let string_of_type_list ?par sep type_list = Odoc_str.string_of_type_list ?par sep type_list + +let string_of_type_param_list t = Odoc_str.string_of_type_param_list t + +let string_of_class_type_param_list l = Odoc_str.string_of_class_type_param_list l + +let string_of_module_type = Odoc_print.string_of_module_type + +let string_of_class_type = Odoc_print.string_of_class_type + +let string_of_text t = Odoc_misc.string_of_text t + +let string_of_info i = Odoc_misc.string_of_info i + +let string_of_type t = Odoc_str.string_of_type t + +let string_of_exception e = Odoc_str.string_of_exception e + +let string_of_value v = Odoc_str.string_of_value v + +let string_of_attribute att = Odoc_str.string_of_attribute att + +let string_of_method m = Odoc_str.string_of_method m + +let first_sentence_of_text = Odoc_misc.first_sentence_of_text + +let first_sentence_and_rest_of_text = Odoc_misc.first_sentence_and_rest_of_text + +let text_no_title_no_list = Odoc_misc.text_no_title_no_list + +let text_concat = Odoc_misc.text_concat + +let get_titles_in_text = Odoc_misc.get_titles_in_text + +let create_index_lists = Odoc_misc.create_index_lists + +let remove_ending_newline = Odoc_misc.remove_ending_newline + +let remove_option = Odoc_misc.remove_option + +let is_optional = Odoc_misc.is_optional + +let label_name = Odoc_misc.label_name + +let use_hidden_modules n = + Odoc_name.hide_given_modules !Odoc_global.hidden_modules n + +let verbose s = + if !Odoc_global.verbose then + (print_string s ; print_newline ()) + else + () + +let warning s = Odoc_global.pwarning s +let print_warnings = Odoc_config.print_warnings + +let errors = Odoc_global.errors + +let apply_opt = Odoc_misc.apply_opt + +let apply_if_equal f v1 v2 = + if v1 = v2 then + f v1 + else + v2 + +let text_of_string = Odoc_text.Texter.text_of_string + +let text_string_of_text = Odoc_text.Texter.string_of_text + + +let escape_arobas s = + let len = String.length s in + let b = Buffer.create len in + for i = 0 to len - 1 do + match s.[i] with + '@' -> Buffer.add_string b "\\@" + | c -> Buffer.add_char b c + done; + Buffer.contents b + +let info_string_of_info i = + let b = Buffer.create 256 in + let p = Printf.bprintf in + ( + match i.i_desc with + None -> () + | Some t -> p b "%s" (escape_arobas (text_string_of_text t)) + ); + List.iter + (fun s -> p b "\n@author %s" (escape_arobas s)) + i.i_authors; + ( + match i.i_version with + None -> () + | Some s -> p b "\n@version %s" (escape_arobas s) + ); + ( + (* TODO: escape characters ? *) + let f_see_ref = function + See_url s -> Printf.sprintf "<%s>" s + | See_file s -> Printf.sprintf "'%s'" s + | See_doc s -> Printf.sprintf "\"%s\"" s + in + List.iter + (fun (sref, t) -> + p b "\n@see %s %s" + (escape_arobas (f_see_ref sref)) + (escape_arobas (text_string_of_text t)) + ) + i.i_sees + ); + ( + match i.i_since with + None -> () + | Some s -> p b "\n@since %s" (escape_arobas s) + ); + ( + match i.i_deprecated with + None -> () + | Some t -> + p b "\n@deprecated %s" + (escape_arobas (text_string_of_text t)) + ); + List.iter + (fun (s, t) -> + p b "\n@param %s %s" + (escape_arobas s) + (escape_arobas (text_string_of_text t)) + ) + i.i_params; + List.iter + (fun (s, t) -> + p b "\n@raise %s %s" + (escape_arobas s) + (escape_arobas (text_string_of_text t)) + ) + i.i_raised_exceptions; + ( + match i.i_return_value with + None -> () + | Some t -> + p b "\n@return %s" + (escape_arobas (text_string_of_text t)) + ); + List.iter + (fun (s, t) -> + p b "\n@%s %s" s + (escape_arobas (text_string_of_text t)) + ) + i.i_custom; + + Buffer.contents b + +let info_of_string = Odoc_comments.info_of_string +let info_of_comment_file = Odoc_comments.info_of_comment_file + +module Search = + struct + type result_element = Odoc_search.result_element = + Res_module of Module.t_module + | Res_module_type of Module.t_module_type + | Res_class of Class.t_class + | Res_class_type of Class.t_class_type + | Res_value of Value.t_value + | Res_type of Type.t_type + | Res_exception of Exception.t_exception + | Res_attribute of Value.t_attribute + | Res_method of Value.t_method + | Res_section of string * text + + type search_result = result_element list + + let search_by_name = Odoc_search.Search_by_name.search + + let values = Odoc_search.values + let exceptions = Odoc_search.exceptions + let types = Odoc_search.types + let attributes = Odoc_search.attributes + let methods = Odoc_search.methods + let classes = Odoc_search.classes + let class_types = Odoc_search.class_types + let modules = Odoc_search.modules + let module_types = Odoc_search.module_types + end + +module Scan = + struct + class scanner = Odoc_scan.scanner + end + +module Dep = + struct + let kernel_deps_of_modules = Odoc_dep.kernel_deps_of_modules + let deps_of_types = Odoc_dep.deps_of_types + end + +module Global = Odoc_global diff --git a/ocaml-binary-annot/ocamldoc/odoc_info.mli b/ocaml-binary-annot/ocamldoc/odoc_info.mli new file mode 100644 index 0000000000..c106b040b7 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_info.mli @@ -0,0 +1,988 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Interface to the information collected in source files. *) + +(** The differents kinds of element references. *) +type ref_kind = Odoc_types.ref_kind = + RK_module + | RK_module_type + | RK_class + | RK_class_type + | RK_value + | RK_type + | RK_exception + | RK_attribute + | RK_method + | RK_section of text + +and text_element = Odoc_types.text_element = + | Raw of string (** Raw text. *) + | Code of string (** The string is source code. *) + | CodePre of string (** The string is pre-formatted source code. *) + | Verbatim of string (** String 'as is'. *) + | Bold of text (** Text in bold style. *) + | Italic of text (** Text in italic. *) + | Emphasize of text (** Emphasized text. *) + | Center of text (** Centered text. *) + | Left of text (** Left alignment. *) + | Right of text (** Right alignment. *) + | List of text list (** A list. *) + | Enum of text list (** An enumerated list. *) + | Newline (** To force a line break. *) + | Block of text (** Like html's block quote. *) + | Title of int * string option * text + (** Style number, optional label, and text. *) + | Latex of string (** A string for latex. *) + | Link of string * text (** A reference string and the link text. *) + | Ref of string * ref_kind option * text option + (** A reference to an element. Complete name and kind. + An optional text can be given to display this text instead + of the element name.*) + | Superscript of text (** Superscripts. *) + | Subscript of text (** Subscripts. *) + | Module_list of string list + (** The table of the given modules with their abstract. *) + | Index_list (** The links to the various indexes (values, types, ...) *) + | Custom of string * text (** to extend \{foo syntax *) + | Target of string * string (** (target, code) : to specify code specific to a target format *) + +(** A text is a list of [text_element]. The order matters. *) +and text = text_element list + +(** The different forms of references in \@see tags. *) +type see_ref = Odoc_types.see_ref = + See_url of string + | See_file of string + | See_doc of string + +(** Raised when parsing string to build a {!Odoc_info.text} + structure. [(line, char, string)] *) +exception Text_syntax of int * int * string + +(** The information in a \@see tag. *) +type see = see_ref * text + +(** Parameter name and description. *) +type param = (string * text) + +(** Raised exception name and description. *) +type raised_exception = (string * text) + +(** Information in a special comment +@before 3.12.0 \@before information was not present. +*) +type info = Odoc_types.info = { + i_desc : text option; (** The description text. *) + i_authors : string list; (** The list of authors in \@author tags. *) + i_version : string option; (** The string in the \@version tag. *) + i_sees : see list; (** The list of \@see tags. *) + i_since : string option; (** The string in the \@since tag. *) + i_before : (string * text) list ; (** the version number and text in \@before tag *) + i_deprecated : text option; (** The of the \@deprecated tag. *) + i_params : param list; (** The list of parameter descriptions. *) + i_raised_exceptions : raised_exception list; (** The list of raised exceptions. *) + i_return_value : text option; (** The description text of the return value. *) + i_custom : (string * text) list ; (** A text associated to a custom @-tag. *) + } + +(** Location of elements in implementation and interface files. *) +type location = Odoc_types.location = { + loc_impl : (string * int) option ; (** implementation file name and position *) + loc_inter : (string * int) option ; (** interface file name and position *) + } + +(** A dummy location. *) +val dummy_loc : location + +(** Representation of element names. *) +module Name : + sig + type t = string + + (** Access to the simple name. *) + val simple : t -> t + + (** [concat t1 t2] returns the concatenation of [t1] and [t2].*) + val concat : t -> t -> t + + (** Return the depth of the name, i.e. the numer of levels to the root. + Example : [depth "Toto.Tutu.name"] = [3]. *) + val depth : t -> int + + (** Take two names n1 and n2 = n3.n4 and return n4 if n3=n1 or else n2. *) + val get_relative : t -> t -> t + + (** Return the name of the 'father' (like [dirname] for a file name).*) + val father : t -> t + end + +(** Representation and manipulation of method / function / class / module parameters.*) +module Parameter : + sig + (** {3 Types} *) + (** Representation of a simple parameter name *) + type simple_name = Odoc_parameter.simple_name = + { + sn_name : string ; + sn_type : Types.type_expr ; + mutable sn_text : text option ; + } + + (** Representation of parameter names. We need it to represent parameter names in tuples. + The value [Tuple ([], t)] stands for an anonymous parameter.*) + type param_info = Odoc_parameter.param_info = + Simple_name of simple_name + | Tuple of param_info list * Types.type_expr + + (** A parameter is just a param_info.*) + type parameter = param_info + + (** {3 Functions} *) + (** Acces to the name as a string. For tuples, parenthesis and commas are added. *) + val complete_name : parameter -> string + + (** Access to the complete type. *) + val typ : parameter -> Types.type_expr + + (** Access to the list of names ; only one for a simple parameter, or + a list for a tuple. *) + val names : parameter -> string list + + (** Access to the description of a specific name. + @raise Not_found if no description is associated to the given name. *) + val desc_by_name : parameter -> string -> text option + + (** Access to the type of a specific name. + @raise Not_found if no type is associated to the given name. *) + val type_by_name : parameter -> string -> Types.type_expr + end + +(** Representation and manipulation of exceptions. *) +module Exception : + sig + (** Used when the exception is a rebind of another exception, + when we have [exception Ex = Target_ex].*) + type exception_alias = Odoc_exception.exception_alias = + { + ea_name : Name.t ; (** The complete name of the target exception. *) + mutable ea_ex : t_exception option ; (** The target exception, if we found it.*) + } + + and t_exception = Odoc_exception.t_exception = + { + ex_name : Name.t ; + mutable ex_info : info option ; (** Information found in the optional associated comment. *) + ex_args : Types.type_expr list ; (** The types of the parameters. *) + ex_alias : exception_alias option ; (** [None] when the exception is not a rebind. *) + mutable ex_loc : location ; + mutable ex_code : string option ; + } + end + +(** Representation and manipulation of types.*) +module Type : + sig + type private_flag = Odoc_type.private_flag = + Private | Public + + (** Description of a variant type constructor. *) + type variant_constructor = Odoc_type.variant_constructor = + { + vc_name : string ; (** Name of the constructor. *) + vc_args : Types.type_expr list ; (** Arguments of the constructor. *) + mutable vc_text : text option ; (** Optional description in the associated comment. *) + } + + (** Description of a record type field. *) + type record_field = Odoc_type.record_field = + { + rf_name : string ; (** Name of the field. *) + rf_mutable : bool ; (** [true] if mutable. *) + rf_type : Types.type_expr ; (** Type of the field. *) + mutable rf_text : text option ; (** Optional description in the associated comment.*) + } + + (** The various kinds of a type. *) + type type_kind = Odoc_type.type_kind = + Type_abstract (** Type is abstract, for example [type t]. *) + | Type_variant of variant_constructor list + (** constructors *) + | Type_record of record_field list + (** fields *) + + (** Representation of a type. *) + type t_type = Odoc_type.t_type = + { + ty_name : Name.t ; (** Complete name of the type. *) + mutable ty_info : info option ; (** Information found in the optional associated comment. *) + ty_parameters : (Types.type_expr * bool * bool) list ; + (** type parameters: (type, covariant, contravariant) *) + ty_kind : type_kind; (** Type kind. *) + ty_private : private_flag; (** Private or public type. *) + ty_manifest : Types.type_expr option; (** Type manifest. *) + mutable ty_loc : location ; + mutable ty_code : string option; + } + + end + +(** Representation and manipulation of values, class attributes and class methods. *) +module Value : + sig + (** Representation of a value. *) + type t_value = Odoc_value.t_value = + { + val_name : Name.t ; (** Complete name of the value. *) + mutable val_info : info option ; (** Information found in the optional associated comment. *) + val_type : Types.type_expr ; (** Type of the value. *) + val_recursive : bool ; (** [true] if the value is recursive. *) + mutable val_parameters : Odoc_parameter.parameter list ; (** The parameters, if any. *) + mutable val_code : string option ; (** The code of the value, if we had the only the implementation file. *) + mutable val_loc : location ; + } + + (** Representation of a class attribute. *) + type t_attribute = Odoc_value.t_attribute = + { + att_value : t_value ; (** an attribute has almost all the same information as a value *) + att_mutable : bool ; (** [true] if the attribute is mutable. *) + att_virtual : bool ; (** [true] if the attribute is virtual. *) + } + + (** Representation of a class method. *) + type t_method = Odoc_value.t_method = + { + met_value : t_value ; (** a method has almost all the same information as a value *) + met_private : bool ; (** [true] if the method is private.*) + met_virtual : bool ; (** [true] if the method is virtual. *) + } + + (** Return [true] if the value is a function, i.e. it has a functional type. *) + val is_function : t_value -> bool + + (** Access to the description associated to the given parameter name.*) + val value_parameter_text_by_name : t_value -> string -> text option + end + +(** Representation and manipulation of classes and class types.*) +module Class : + sig + (** {3 Types} *) + (** To keep the order of elements in a class. *) + type class_element = Odoc_class.class_element = + Class_attribute of Value.t_attribute + | Class_method of Value.t_method + | Class_comment of text + + (** Used when we can reference a t_class or a t_class_type. *) + type cct = Odoc_class.cct = + Cl of t_class + | Cltype of t_class_type * Types.type_expr list (** Class type and type parameters. *) + + and inherited_class = Odoc_class.inherited_class = + { + ic_name : Name.t ; (** Complete name of the inherited class. *) + mutable ic_class : cct option ; (** The associated t_class or t_class_type. *) + ic_text : text option ; (** The inheritance description, if any. *) + } + + and class_apply = Odoc_class.class_apply = + { + capp_name : Name.t ; (** The complete name of the applied class. *) + mutable capp_class : t_class option; (** The associated t_class if we found it. *) + capp_params : Types.type_expr list; (** The type of expressions the class is applied to. *) + capp_params_code : string list ; (** The code of these exprssions. *) + } + + and class_constr = Odoc_class.class_constr = + { + cco_name : Name.t ; (** The complete name of the applied class. *) + mutable cco_class : cct option; + (** The associated class or class type if we found it. *) + cco_type_parameters : Types.type_expr list; (** The type parameters of the class, if needed. *) + } + + and class_kind = Odoc_class.class_kind = + Class_structure of inherited_class list * class_element list + (** An explicit class structure, used in implementation and interface. *) + | Class_apply of class_apply + (** Application/alias of a class, used in implementation only. *) + | Class_constr of class_constr + (** A class used to give the type of the defined class, + instead of a structure, used in interface only. + For example, it will be used with the name [M1.M2....bar] + when the class foo is defined like this : + [class foo : int -> bar] *) + | Class_constraint of class_kind * class_type_kind + (** A class definition with a constraint. *) + + (** Representation of a class. *) + and t_class = Odoc_class.t_class = + { + cl_name : Name.t ; (** Complete name of the class. *) + mutable cl_info : info option ; (** Information found in the optional associated comment. *) + cl_type : Types.class_type ; (** Type of the class. *) + cl_type_parameters : Types.type_expr list ; (** Type parameters. *) + cl_virtual : bool ; (** [true] when the class is virtual. *) + mutable cl_kind : class_kind ; (** The way the class is defined. *) + mutable cl_parameters : Parameter.parameter list ; (** The parameters of the class. *) + mutable cl_loc : location ; + } + + and class_type_alias = Odoc_class.class_type_alias = + { + cta_name : Name.t ; (** Complete name of the target class type. *) + mutable cta_class : cct option ; (** The target t_class or t_class_type, if we found it.*) + cta_type_parameters : Types.type_expr list ; (** The type parameters. A VOIR : mettre des string ? *) + } + + and class_type_kind = Odoc_class.class_type_kind = + Class_signature of inherited_class list * class_element list + | Class_type of class_type_alias (** A class type eventually applied to type args. *) + + (** Representation of a class type. *) + and t_class_type = Odoc_class.t_class_type = + { + clt_name : Name.t ; (** Complete name of the type. *) + mutable clt_info : info option ; (** Information found in the optional associated comment. *) + clt_type : Types.class_type ; + clt_type_parameters : Types.type_expr list ; (** Type parameters. *) + clt_virtual : bool ; (** [true] if the class type is virtual *) + mutable clt_kind : class_type_kind ; (** The way the class type is defined. *) + mutable clt_loc : location ; + } + + (** {3 Functions} *) + + (** Access to the elements of a class. *) + val class_elements : ?trans:bool -> t_class -> class_element list + + (** Access to the list of class attributes. *) + val class_attributes : ?trans:bool -> t_class -> Value.t_attribute list + + (** Access to the description associated to the given class parameter name. *) + val class_parameter_text_by_name : t_class -> string -> text option + + (** Access to the methods of a class. *) + val class_methods : ?trans:bool -> t_class -> Value.t_method list + + (** Access to the comments of a class. *) + val class_comments : ?trans:bool -> t_class -> text list + + (** Access to the elements of a class type. *) + val class_type_elements : ?trans:bool -> t_class_type -> class_element list + + (** Access to the list of class type attributes. *) + val class_type_attributes : ?trans:bool -> t_class_type -> Value.t_attribute list + + (** Access to the description associated to the given class type parameter name. *) + val class_type_parameter_text_by_name : t_class_type -> string -> text option + + (** Access to the methods of a class type. *) + val class_type_methods : ?trans:bool -> t_class_type -> Value.t_method list + + (** Access to the comments of a class type. *) + val class_type_comments : ?trans:bool -> t_class_type -> text list + end + +(** Representation and manipulation of modules and module types. *) +module Module : + sig + (** {3 Types} *) + (** To keep the order of elements in a module. *) + type module_element = Odoc_module.module_element = + Element_module of t_module + | Element_module_type of t_module_type + | Element_included_module of included_module + | Element_class of Class.t_class + | Element_class_type of Class.t_class_type + | Element_value of Value.t_value + | Element_exception of Exception.t_exception + | Element_type of Type.t_type + | Element_module_comment of text + + (** Used where we can reference t_module or t_module_type. *) + and mmt = Odoc_module.mmt = + | Mod of t_module + | Modtype of t_module_type + + and included_module = Odoc_module.included_module = + { + im_name : Name.t ; (** Complete name of the included module. *) + mutable im_module : mmt option ; (** The included module or module type, if we found it. *) + mutable im_info : Odoc_types.info option ; (** comment associated to the includ directive *) + } + + and module_alias = Odoc_module.module_alias = + { + ma_name : Name.t ; (** Complete name of the target module. *) + mutable ma_module : mmt option ; (** The real module or module type if we could associate it. *) + } + + and module_parameter = Odoc_module.module_parameter = { + mp_name : string ; (** the name *) + mp_type : Types.module_type ; (** the type *) + mp_type_code : string ; (** the original code *) + mp_kind : module_type_kind ; (** the way the parameter was built *) + } + + (** Different kinds of a module. *) + and module_kind = Odoc_module.module_kind = + | Module_struct of module_element list (** A complete module structure. *) + | Module_alias of module_alias (** Complete name and corresponding module if we found it *) + | Module_functor of module_parameter * module_kind + (** A functor, with its parameter and the rest of its definition *) + | Module_apply of module_kind * module_kind + (** A module defined by application of a functor. *) + | Module_with of module_type_kind * string + (** A module whose type is a with ... constraint. + Should appear in interface files only. *) + | Module_constraint of module_kind * module_type_kind + (** A module constraint by a module type. *) + | Module_typeof of string (** by now only the code of the module expression *) + | Module_unpack of string * module_type_alias (** code of the expression and module type alias *) + + (** Representation of a module. *) + and t_module = Odoc_module.t_module = + { + m_name : Name.t ; (** Complete name of the module. *) + mutable m_type : Types.module_type ; (** The type of the module. *) + mutable m_info : info option ; (** Information found in the optional associated comment. *) + m_is_interface : bool ; (** [true] for modules read from interface files *) + m_file : string ; (** The file the module is defined in. *) + mutable m_kind : module_kind ; (** The way the module is defined. *) + mutable m_loc : location ; + mutable m_top_deps : Name.t list ; (** The toplevels module names this module depends on. *) + mutable m_code : string option ; (** The whole code of the module *) + mutable m_code_intf : string option ; (** The whole code of the interface of the module *) + m_text_only : bool ; (** [true] if the module comes from a text file *) + } + + and module_type_alias = Odoc_module.module_type_alias = + { + mta_name : Name.t ; (** Complete name of the target module type. *) + mutable mta_module : t_module_type option ; (** The real module type if we could associate it. *) + } + + (** Different kinds of module type. *) + and module_type_kind = Odoc_module.module_type_kind = + | Module_type_struct of module_element list (** A complete module signature. *) + | Module_type_functor of module_parameter * module_type_kind + (** A functor, with its parameter and the rest of its definition *) + | Module_type_alias of module_type_alias + (** Complete alias name and corresponding module type if we found it. *) + | Module_type_with of module_type_kind * string + (** The module type kind and the code of the with constraint. *) + | Module_type_typeof of string + (** by now only the code of the module expression *) + + (** Representation of a module type. *) + and t_module_type = Odoc_module.t_module_type = + { + mt_name : Name.t ; (** Complete name of the module type. *) + mutable mt_info : info option ; (** Information found in the optional associated comment. *) + mutable mt_type : Types.module_type option ; (** [None] means that the module type is abstract. *) + mt_is_interface : bool ; (** [true] for modules read from interface files. *) + mt_file : string ; (** The file the module type is defined in. *) + mutable mt_kind : module_type_kind option ; + (** The way the module is defined. [None] means that module type is abstract. + It is always [None] when the module type was extracted from the implementation file. + That means module types are only analysed in interface files. *) + mutable mt_loc : location ; + } + + (** {3 Functions for modules} *) + + (** Access to the elements of a module. *) + val module_elements : ?trans:bool -> t_module -> module_element list + + (** Access to the submodules of a module. *) + val module_modules : ?trans:bool -> t_module -> t_module list + + (** Access to the module types of a module. *) + val module_module_types : ?trans:bool -> t_module -> t_module_type list + + (** Access to the included modules of a module. *) + val module_included_modules : ?trans:bool-> t_module -> included_module list + + (** Access to the exceptions of a module. *) + val module_exceptions : ?trans:bool-> t_module -> Exception.t_exception list + + (** Access to the types of a module. *) + val module_types : ?trans:bool-> t_module -> Type.t_type list + + (** Access to the values of a module. *) + val module_values : ?trans:bool -> t_module -> Value.t_value list + + (** Access to functional values of a module. *) + val module_functions : ?trans:bool-> t_module -> Value.t_value list + + (** Access to non-functional values of a module. *) + val module_simple_values : ?trans:bool-> t_module -> Value.t_value list + + (** Access to the classes of a module. *) + val module_classes : ?trans:bool-> t_module -> Class.t_class list + + (** Access to the class types of a module. *) + val module_class_types : ?trans:bool-> t_module -> Class.t_class_type list + + (** The list of classes defined in this module and all its submodules and functors. *) + val module_all_classes : ?trans:bool-> t_module -> Class.t_class list + + (** [true] if the module is functor. *) + val module_is_functor : t_module -> bool + + (** The list of couples (module parameter, optional description). *) + val module_parameters : ?trans:bool-> t_module -> (module_parameter * text option) list + + (** The list of module comments. *) + val module_comments : ?trans:bool-> t_module -> text list + + (** {3 Functions for module types} *) + + (** Access to the elements of a module type. *) + val module_type_elements : ?trans:bool-> t_module_type -> module_element list + + (** Access to the submodules of a module type. *) + val module_type_modules : ?trans:bool-> t_module_type -> t_module list + + (** Access to the module types of a module type. *) + val module_type_module_types : ?trans:bool-> t_module_type -> t_module_type list + + (** Access to the included modules of a module type. *) + val module_type_included_modules : ?trans:bool-> t_module_type -> included_module list + + (** Access to the exceptions of a module type. *) + val module_type_exceptions : ?trans:bool-> t_module_type -> Exception.t_exception list + + (** Access to the types of a module type. *) + val module_type_types : ?trans:bool-> t_module_type -> Type.t_type list + + (** Access to the values of a module type. *) + val module_type_values : ?trans:bool-> t_module_type -> Value.t_value list + + (** Access to functional values of a module type. *) + val module_type_functions : ?trans:bool-> t_module_type -> Value.t_value list + + (** Access to non-functional values of a module type. *) + val module_type_simple_values : ?trans:bool-> t_module_type -> Value.t_value list + + (** Access to the classes of a module type. *) + val module_type_classes : ?trans:bool-> t_module_type -> Class.t_class list + + (** Access to the class types of a module type. *) + val module_type_class_types : ?trans:bool-> t_module_type -> Class.t_class_type list + + (** The list of classes defined in this module type and all its submodules and functors. *) + val module_type_all_classes : ?trans:bool-> t_module_type -> Class.t_class list + + (** [true] if the module type is functor. *) + val module_type_is_functor : t_module_type -> bool + + (** The list of couples (module parameter, optional description). *) + val module_type_parameters : ?trans:bool-> t_module_type -> (module_parameter * text option) list + + (** The list of module comments. *) + val module_type_comments : ?trans:bool-> t_module_type -> text list + end + + +(** {3 Getting strings from values} *) + +(** This function is used to reset the names of type variables. + It must be called when printing the whole type of a function, + but not when printing the type of its parameters. Same for + classes (call it) and methods and attributes (don't call it).*) +val reset_type_names : unit -> unit + +(** [string_of_variance t (covariant, invariant)] returns ["+"] if + the given information means "covariant", ["-"] if the it means + "contravariant", orelse [""], and always [""] if the given + type is not an abstract type with no manifest (i.e. no need + for the variance to be printed.*) +val string_of_variance : Type.t_type -> (bool * bool) -> string + +(** This function returns a string representing a Types.type_expr. *) +val string_of_type_expr : Types.type_expr -> string + +(** @return a string to display the parameters of the given class, + in the same form as the compiler. *) +val string_of_class_params : Class.t_class -> string + +(** This function returns a string to represent the given list of types, + with a given separator. *) +val string_of_type_list : ?par: bool -> string -> Types.type_expr list -> string + +(** This function returns a string to represent the list of type parameters + for the given type. *) +val string_of_type_param_list : Type.t_type -> string + +(** This function returns a string to represent the given list of + type parameters of a class or class type, + with a given separator. *) +val string_of_class_type_param_list : Types.type_expr list -> string + +(** This function returns a string representing a [Types.module_type]. + @param complete indicates if we must print complete signatures + or just [sig end]. Default if [false]. + @param code if [complete = false] and the type contains something else + than identificators and functors, then the given code is used. +*) +val string_of_module_type : ?code: string -> ?complete: bool -> Types.module_type -> string + +(** This function returns a string representing a [Types.class_type]. + @param complete indicates if we must print complete signatures + or just [object end]. Default if [false]. +*) +val string_of_class_type : ?complete: bool -> Types.class_type -> string + + +(** Get a string from a text. *) +val string_of_text : text -> string + +(** Get a string from an info structure. *) +val string_of_info : info -> string + +(** @return a string to describe the given type. *) +val string_of_type : Type.t_type -> string + +(** @return a string to describe the given exception. *) +val string_of_exception : Exception.t_exception -> string + +(** @return a string to describe the given value. *) +val string_of_value : Value.t_value -> string + +(** @return a string to describe the given attribute. *) +val string_of_attribute : Value.t_attribute -> string + +(** @return a string to describe the given method. *) +val string_of_method : Value.t_method -> string + +(** {3 Miscelaneous functions} *) + +(** Return the first sentence (until the first dot followed by a blank + or the first blank line) of a text. + Don't stop in the middle of [Code], [CodePre], [Verbatim], [List], [Enum], + [Latex], [Link], [Ref], [Subscript] or [Superscript]. *) +val first_sentence_of_text : text -> text + +(** Return the first sentence (until the first dot followed by a blank + or the first blank line) of a text, and the remaining text after. + Don't stop in the middle of [Code], [CodePre], [Verbatim], [List], [Enum], + [Latex], [Link], [Ref], [Subscript] or [Superscript].*) +val first_sentence_and_rest_of_text : text -> text * text + +(** Return the given [text] without any title or list. *) +val text_no_title_no_list : text -> text + +(** [concat sep l] concats the given list of text [l], each separated with + the text [sep]. *) +val text_concat : Odoc_types.text -> Odoc_types.text list -> Odoc_types.text + +(** Return the list of titles in a [text]. + A title is a title level, an optional label and a text.*) +val get_titles_in_text : text -> (int * string option * text) list + +(** Take a sorted list of elements, a function to get the name + of an element and return the list of list of elements, + where each list group elements beginning by the same letter. + Since the original list is sorted, elements whose name does not + begin with a letter should be in the first returned list.*) +val create_index_lists : 'a list -> ('a -> string) -> 'a list list + +(** Take a type and remove the option top constructor. This is + useful when printing labels, we we then remove the top option contructor + for optional labels.*) +val remove_option : Types.type_expr -> Types.type_expr + +(** Return [true] if the given label is optional.*) +val is_optional : string -> bool + +(** Return the label name for the given label, + i.e. removes the beginning '?' if present.*) +val label_name : string -> string + +(** Return the given name where the module name or + part of it was removed, according to the list of modules + which must be hidden (cf {!Odoc_args.hidden_modules})*) +val use_hidden_modules : Name.t -> Name.t + +(** Print the given string if the verbose mode is activated. *) +val verbose : string -> unit + +(** Print a warning message to stderr. + If warnings must be treated as errors, then the + error counter is incremented. *) +val warning : string -> unit + +(** A flag to indicate whether ocamldoc warnings must be printed or not. *) +val print_warnings : bool ref + +(** Increment this counter when an error is encountered. + The ocamldoc tool will print the number of errors + encountered exit with code 1 if this number is greater + than 0. *) +val errors : int ref + +(** Apply a function to an optional value. *) +val apply_opt : ('a -> 'b) -> 'a option -> 'b option + +(** Apply a function to a first value if it is + not different from a second value. If the two values + are different, return the second one.*) +val apply_if_equal : ('a -> 'a) -> 'a -> 'a -> 'a + +(** [text_of_string s] returns the text structure from the + given string. + @raise Text_syntax if a syntax error is encountered. *) +val text_of_string : string -> text + +(** [text_string_of_text text] returns the string representing + the given [text]. This string can then be parsed again + by {!Odoc_info.text_of_string}.*) +val text_string_of_text : text -> string + +(** [info_of_string s] parses the given string + like a regular ocamldoc comment and return an + {!Odoc_info.info} structure. + @return an empty structure if there was a syntax error. TODO: change this +*) +val info_of_string : string -> info + +(** [info_string_of_info info] returns the string representing + the given [info]. This string can then be parsed again + by {!Odoc_info.info_of_string}.*) +val info_string_of_info : info -> string + +(** [info_of_comment_file file] parses the given file + and return an {!Odoc_info.info} structure. The content of the + file must have the same syntax as the content of a special comment. + The given module list is used for cross reference. + @raise Failure is the file could not be opened or there is a + syntax error. +*) +val info_of_comment_file : Module.t_module list -> string -> info + +(** [remove_ending_newline s] returns [s] without the optional ending newline. *) +val remove_ending_newline : string -> string + +(** Research in elements *) +module Search : + sig + type result_element = Odoc_search.result_element = + Res_module of Module.t_module + | Res_module_type of Module.t_module_type + | Res_class of Class.t_class + | Res_class_type of Class.t_class_type + | Res_value of Value.t_value + | Res_type of Type.t_type + | Res_exception of Exception.t_exception + | Res_attribute of Value.t_attribute + | Res_method of Value.t_method + | Res_section of string * text + + (** The type representing a research result.*) + type search_result = result_element list + + (** Research of the elements whose name matches the given regular expression.*) + val search_by_name : Module.t_module list -> Str.regexp -> search_result + + (** A function to search all the values in a list of modules. *) + val values : Module.t_module list -> Value.t_value list + + (** A function to search all the exceptions in a list of modules. *) + val exceptions : Module.t_module list -> Exception.t_exception list + + (** A function to search all the types in a list of modules. *) + val types : Module.t_module list -> Type.t_type list + + (** A function to search all the class attributes in a list of modules. *) + val attributes : Module.t_module list -> Value.t_attribute list + + (** A function to search all the class methods in a list of modules. *) + val methods : Module.t_module list -> Value.t_method list + + (** A function to search all the classes in a list of modules. *) + val classes : Module.t_module list -> Class.t_class list + + (** A function to search all the class types in a list of modules. *) + val class_types : Module.t_module list -> Class.t_class_type list + + (** A function to search all the modules in a list of modules. *) + val modules : Module.t_module list -> Module.t_module list + + (** A function to search all the module types in a list of modules. *) + val module_types : Module.t_module list -> Module.t_module_type list + + end + +(** Scanning of collected information *) +module Scan : + sig + class scanner : + object + (** Scan of 'leaf elements'. *) + + method scan_value : Value.t_value -> unit + method scan_type : Type.t_type -> unit + method scan_exception : Exception.t_exception -> unit + method scan_attribute : Value.t_attribute -> unit + method scan_method : Value.t_method -> unit + method scan_included_module : Module.included_module -> unit + + (** Scan of a class. *) + + (** Scan of a comment inside a class. *) + method scan_class_comment : text -> unit + + (** Override this method to perform controls on the class comment + and params. This method is called before scanning the class elements. + @return true if the class elements must be scanned.*) + method scan_class_pre : Class.t_class -> bool + + (** This method scan the elements of the given class. *) + method scan_class_elements : Class.t_class -> unit + + (** Scan of a class. Should not be overridden. It calls [scan_class_pre] + and if [scan_class_pre] returns [true], then it calls scan_class_elements.*) + method scan_class : Class.t_class -> unit + + (** Scan of a class type. *) + + (** Scan of a comment inside a class type. *) + method scan_class_type_comment : text -> unit + + (** Override this method to perform controls on the class type comment + and form. This method is called before scanning the class type elements. + @return true if the class type elements must be scanned.*) + method scan_class_type_pre : Class.t_class_type -> bool + + (** This method scan the elements of the given class type. *) + method scan_class_type_elements : Class.t_class_type -> unit + + (** Scan of a class type. Should not be overridden. It calls [scan_class_type_pre] + and if [scan_class_type_pre] returns [true], then it calls scan_class_type_elements.*) + method scan_class_type : Class.t_class_type -> unit + + (** Scan of modules. *) + + (** Scan of a comment inside a module. *) + method scan_module_comment : text -> unit + + (** Override this method to perform controls on the module comment + and form. This method is called before scanning the module elements. + @return true if the module elements must be scanned.*) + method scan_module_pre : Module.t_module -> bool + + (** This method scan the elements of the given module. *) + method scan_module_elements : Module.t_module -> unit + + (** Scan of a module. Should not be overridden. It calls [scan_module_pre] + and if [scan_module_pre] returns [true], then it calls scan_module_elements.*) + method scan_module : Module.t_module -> unit + + (** Scan of module types. *) + + (** Scan of a comment inside a module type. *) + method scan_module_type_comment : text -> unit + + (** Override this method to perform controls on the module type comment + and form. This method is called before scanning the module type elements. + @return true if the module type elements must be scanned. *) + method scan_module_type_pre : Module.t_module_type -> bool + + (** This method scan the elements of the given module type. *) + method scan_module_type_elements : Module.t_module_type -> unit + + (** Scan of a module type. Should not be overridden. It calls [scan_module_type_pre] + and if [scan_module_type_pre] returns [true], then it calls scan_module_type_elements.*) + method scan_module_type : Module.t_module_type -> unit + + (** Main scanning method. *) + + (** Scan a list of modules. *) + method scan_module_list : Module.t_module list -> unit + end + end + +(** Computation of dependencies. *) +module Dep : + sig + (** Modify the modules depencies of the given list of modules, + to get the minimum transitivity kernel. *) + val kernel_deps_of_modules : Module.t_module list -> unit + + (** Return the list of dependencies between the given types, + in the form of a list [(type name, names of types it depends on)]. + @param kernel indicates if we must keep only the transitivity kernel + of the dependencies. Default is [false]. + *) + val deps_of_types : ?kernel: bool -> Type.t_type list -> (Type.t_type * (Name.t list)) list + end + +(** {2 Some global variables} *) + +module Global : + sig + val errors : int ref + val warn_error : bool ref + + (** The file used by the generators outputting only one file. *) + val out_file : string ref + + (** Verbose mode or not. *) + val verbose : bool ref + + (** The directory where files have to be generated. *) + val target_dir : string ref + + (** The optional title to use in the generated documentation. *) + val title : string option ref + + (** The optional file whose content can be used as intro text. *) + val intro_file : string option ref + + (** The flag which indicates if we must generate a table of contents. *) + val with_toc : bool ref + + (** The flag which indicates if we must generate an index. *) + val with_index : bool ref + + (** The flag which indicates if we must generate a header.*) + val with_header : bool ref + + (** The flag which indicates if we must generate a trailer.*) + val with_trailer : bool ref +end + +(** Analysis of the given source files. + @param init is the list of modules already known from a previous analysis. + @return the list of analysed top modules. *) +val analyse_files : + ?merge_options:Odoc_types.merge_option list -> + ?include_dirs:string list -> + ?labels:bool -> + ?sort_modules:bool -> + ?no_stop:bool -> + ?init: Odoc_module.t_module list -> + Odoc_global.source_file list -> + Module.t_module list + +(** Dump of a list of modules into a file. + @raise Failure if an error occurs.*) +val dump_modules : string -> Odoc_module.t_module list -> unit + +(** Load of a list of modules from a file. + @raise Failure if an error occurs.*) +val load_modules : string -> Odoc_module.t_module list diff --git a/ocaml-binary-annot/ocamldoc/odoc_inherit.ml b/ocaml-binary-annot/ocamldoc/odoc_inherit.ml new file mode 100644 index 0000000000..b73796bf8a --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_inherit.ml @@ -0,0 +1,12 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) diff --git a/ocaml-binary-annot/ocamldoc/odoc_latex.ml b/ocaml-binary-annot/ocamldoc/odoc_latex.ml new file mode 100644 index 0000000000..c20c344b51 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_latex.ml @@ -0,0 +1,1201 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Generation of LaTeX documentation. *) + +let print_DEBUG s = print_string s ; print_newline () + +open Odoc_info +open Parameter +open Value +open Type +open Exception +open Class +open Module + + + +let separate_files = ref false + +let latex_titles = ref [ + 1, "section" ; + 2, "subsection" ; + 3, "subsubsection" ; + 4, "paragraph" ; + 5, "subparagraph" ; +] + +let latex_value_prefix = ref Odoc_messages.default_latex_value_prefix +let latex_type_prefix = ref Odoc_messages.default_latex_type_prefix +let latex_exception_prefix = ref Odoc_messages.default_latex_exception_prefix +let latex_module_prefix = ref Odoc_messages.default_latex_module_prefix +let latex_module_type_prefix = ref Odoc_messages.default_latex_module_type_prefix +let latex_class_prefix = ref Odoc_messages.default_latex_class_prefix +let latex_class_type_prefix = ref Odoc_messages.default_latex_class_type_prefix +let latex_attribute_prefix = ref Odoc_messages.default_latex_attribute_prefix +let latex_method_prefix = ref Odoc_messages.default_latex_method_prefix + +let new_buf () = Buffer.create 1024 +let new_fmt () = + let b = new_buf () in + let fmt = Format.formatter_of_buffer b in + (fmt, + fun () -> + Format.pp_print_flush fmt (); + let s = Buffer.contents b in + Buffer.reset b; + s + ) + +let p = Format.fprintf +let ps f s = Format.fprintf f "%s" s + + +let bp = Printf.bprintf +let bs = Buffer.add_string + +let print_concat fmt sep f = + let rec iter = function + [] -> () + | [c] -> f c + | c :: q -> + f c; + ps fmt sep; + iter q + in + iter + +(** Generation of LaTeX code from text structures. *) +class text = + object (self) + (** Return latex code to make a sectionning according to the given level, + and with the given latex code. *) + method section_style level s = + try + let sec = List.assoc level !latex_titles in + "\\"^sec^"{"^s^"}\n" + with Not_found -> s + + (** Associations of strings to subsitute in latex code. *) + val mutable subst_strings = [ + ("MAXENCE"^"ZZZ", "\\$"); + ("MAXENCE"^"YYY", "\\&"); + ("MAXENCE"^"XXX", "{\\textbackslash}") ; + ("à", "\\`a") ; + ("â", "\\^a") ; + ("é", "\\'e") ; + ("è", "\\`e") ; + ("ê", "\\^e") ; + ("ë", "\\\"e") ; + ("ç", "\\c{c}") ; + ("ô", "\\^o") ; + ("ö", "\\\"o") ; + ("î", "\\^i") ; + ("ï", "\\\"i") ; + ("ù", "\\`u") ; + ("û", "\\^u") ; + ("%", "\\%") ; + ("_", "\\_"); + ("\\.\\.\\.", "$\\ldots$"); + ("~", "\\~{}"); + ("#", "\\verb`#`"); + ("}", "\\}"); + ("{", "\\{"); + ("&", "\\&"); + (">", "$>$"); + ("<", "$<$"); + ("=", "$=$"); + (">=", "$\\geq$"); + ("<=", "$\\leq$"); + ("->", "$\\rightarrow$") ; + ("<-", "$\\leftarrow$"); + ("|", "\\textbar "); + ("\\^", "\\textasciicircum ") ; + ("\\.\\.\\.", "$\\ldots$"); + ("\\\\", "MAXENCE"^"XXX") ; + ("&", "MAXENCE"^"YYY") ; + ("\\$", "MAXENCE"^"ZZZ"); + ] + + val mutable subst_strings_simple = + [ + ("MAXENCE"^"XXX", "{\\textbackslash}") ; + "}", "\\}" ; + "{", "\\{" ; + ("\\\\", "MAXENCE"^"XXX") ; + ] + + val mutable subst_strings_code = [ + ("MAXENCE"^"ZZZ", "\\$"); + ("MAXENCE"^"YYY", "\\&"); + ("MAXENCE"^"XXX", "{\\textbackslash}") ; + ("%", "\\%") ; + ("_", "\\_"); + ("~", "\\~{}"); + ("#", "\\verb`#`"); + ("}", "\\}"); + ("{", "\\{"); + ("&", "\\&"); + ("\\^", "\\textasciicircum ") ; + ("&", "MAXENCE"^"YYY") ; + ("\\$", "MAXENCE"^"ZZZ") ; + ("\\\\", "MAXENCE"^"XXX") ; + ] + + method subst l s = + List.fold_right + (fun (s, s2) -> fun acc -> Str.global_replace (Str.regexp s) s2 acc) + l + s + + (** Escape the strings which would clash with LaTeX syntax. *) + method escape s = self#subst subst_strings s + + (** Escape the ['\'], ['{'] and ['}'] characters. *) + method escape_simple s = self#subst subst_strings_simple s + + (** Escape some characters for the code style. *) + method escape_code s = self#subst subst_strings_code s + + (** Make a correct latex label from a name. *) + (* The following characters are forbidden in LaTeX \index: + \ { } $ & # ^ _ % ~ ! " @ | (" to close the double quote) + The following characters are forbidden in LaTeX \label: + \ { } $ & # ^ _ % ~ + So we will use characters not forbidden in \index if no_ = true. + *) + method label ?(no_=true) name = + let len = String.length name in + let buf = Buffer.create len in + for i = 0 to len - 1 do + let (s_no_, s) = + match name.[i] with + '_' -> ("-underscore", "_") + | '~' -> ("-tilde", "~") + | '%' -> ("-percent", "%") + | '@' -> ("-at", "\"@") + | '!' -> ("-bang", "\"!") + | '|' -> ("-pipe", "\"|") + | '<' -> ("-lt", "<") + | '>' -> ("-gt", ">") + | '^' -> ("-exp", "^") + | '&' -> ("-ampersand", "&") + | '+' -> ("-plus", "+") + | '-' -> ("-minus", "-") + | '*' -> ("-star", "*") + | '/' -> ("-slash", "/") + | '$' -> ("-dollar", "$") + | '=' -> ("-equal", "=") + | ':' -> ("-colon", ":") + | c -> (String.make 1 c, String.make 1 c) + in + Buffer.add_string buf (if no_ then s_no_ else s) + done; + Buffer.contents buf + + (** Make a correct label from a value name. *) + method value_label ?no_ name = !latex_value_prefix^(self#label ?no_ name) + + (** Make a correct label from an attribute name. *) + method attribute_label ?no_ name = !latex_attribute_prefix^(self#label ?no_ name) + + (** Make a correct label from a method name. *) + method method_label ?no_ name = !latex_method_prefix^(self#label ?no_ name) + + (** Make a correct label from a class name. *) + method class_label ?no_ name = !latex_class_prefix^(self#label ?no_ name) + + (** Make a correct label from a class type name. *) + method class_type_label ?no_ name = !latex_class_type_prefix^(self#label ?no_ name) + + (** Make a correct label from a module name. *) + method module_label ?no_ name = !latex_module_prefix^(self#label ?no_ name) + + (** Make a correct label from a module type name. *) + method module_type_label ?no_ name = !latex_module_type_prefix^(self#label ?no_ name) + + (** Make a correct label from an exception name. *) + method exception_label ?no_ name = !latex_exception_prefix^(self#label ?no_ name) + + (** Make a correct label from a type name. *) + method type_label ?no_ name = !latex_type_prefix^(self#label ?no_ name) + + (** Return latex code for the label of a given label. *) + method make_label label = "\\label{"^label^"}" + + (** Return latex code for the ref to a given label. *) + method make_ref label = "\\ref{"^label^"}" + + (** Print the LaTeX code corresponding to the [text] parameter.*) + method latex_of_text fmt t = + List.iter (self#latex_of_text_element fmt) t + + (** Print the LaTeX code for the [text_element] in parameter. *) + method latex_of_text_element fmt te = + match te with + | Odoc_info.Raw s -> self#latex_of_Raw fmt s + | Odoc_info.Code s -> self#latex_of_Code fmt s + | Odoc_info.CodePre s -> self#latex_of_CodePre fmt s + | Odoc_info.Verbatim s -> self#latex_of_Verbatim fmt s + | Odoc_info.Bold t -> self#latex_of_Bold fmt t + | Odoc_info.Italic t -> self#latex_of_Italic fmt t + | Odoc_info.Emphasize t -> self#latex_of_Emphasize fmt t + | Odoc_info.Center t -> self#latex_of_Center fmt t + | Odoc_info.Left t -> self#latex_of_Left fmt t + | Odoc_info.Right t -> self#latex_of_Right fmt t + | Odoc_info.List tl -> self#latex_of_List fmt tl + | Odoc_info.Enum tl -> self#latex_of_Enum fmt tl + | Odoc_info.Newline -> self#latex_of_Newline fmt + | Odoc_info.Block t -> self#latex_of_Block fmt t + | Odoc_info.Title (n, l_opt, t) -> self#latex_of_Title fmt n l_opt t + | Odoc_info.Latex s -> self#latex_of_Latex fmt s + | Odoc_info.Link (s, t) -> self#latex_of_Link fmt s t + | Odoc_info.Ref (name, ref_opt, text_opt) -> + self#latex_of_Ref fmt name ref_opt text_opt + | Odoc_info.Superscript t -> self#latex_of_Superscript fmt t + | Odoc_info.Subscript t -> self#latex_of_Subscript fmt t + | Odoc_info.Module_list _ -> () + | Odoc_info.Index_list -> () + | Odoc_info.Custom (s,t) -> self#latex_of_custom_text fmt s t + | Odoc_info.Target (target, code) -> self#latex_of_Target fmt ~target ~code + + method latex_of_custom_text fmt s t = () + + method latex_of_Target fmt ~target ~code = + if String.lowercase target = "latex" then + self#latex_of_Latex fmt code + else + () + + method latex_of_Raw fmt s = + ps fmt (self#escape s) + + method latex_of_Code fmt s = + let s2 = self#escape_code s in + let s3 = Str.global_replace (Str.regexp "\n") ("\\\\\n") s2 in + p fmt "{\\tt{%s}}" s3 + + method latex_of_CodePre fmt s = + ps fmt "\\begin{ocamldoccode}\n"; + ps fmt (self#escape_simple s); + ps fmt "\n\\end{ocamldoccode}\n" + + method latex_of_Verbatim fmt s = + ps fmt "\\begin{verbatim}"; + ps fmt s; + ps fmt "\\end{verbatim}" + + method latex_of_Bold fmt t = + ps fmt "{\\bf "; + self#latex_of_text fmt t; + ps fmt "}" + + method latex_of_Italic fmt t = + ps fmt "{\\it "; + self#latex_of_text fmt t; + ps fmt "}" + + method latex_of_Emphasize fmt t = + ps fmt "{\\em "; + self#latex_of_text fmt t; + ps fmt "}" + + method latex_of_Center fmt t = + ps fmt "\\begin{center}\n"; + self#latex_of_text fmt t; + ps fmt "\\end{center}\n" + + method latex_of_Left fmt t = + ps fmt "\\begin{flushleft}\n"; + self#latex_of_text fmt t; + ps fmt "\\end{flushleft}\n" + + method latex_of_Right fmt t = + ps fmt "\\begin{flushright}\n"; + self#latex_of_text fmt t; + ps fmt "\\end{flushright}\n" + + method latex_of_List fmt tl = + ps fmt "\\begin{itemize}\n"; + List.iter + (fun t -> + ps fmt "\\item "; + self#latex_of_text fmt t; + ps fmt "\n" + ) + tl; + ps fmt "\\end{itemize}\n" + + method latex_of_Enum fmt tl = + ps fmt "\\begin{enumerate}\n"; + List.iter + (fun t -> + ps fmt "\\item "; + self#latex_of_text fmt t; + ps fmt "\n" + ) + tl; + ps fmt "\\end{enumerate}\n" + + method latex_of_Newline fmt = ps fmt "\n\n" + + method latex_of_Block fmt t = + ps fmt "\\begin{ocamldocdescription}\n"; + self#latex_of_text fmt t; + ps fmt "\n\\end{ocamldocdescription}\n" + + method latex_of_Title fmt n label_opt t = + let (fmt2, flush) = new_fmt () in + self#latex_of_text fmt2 t; + let s_title2 = self#section_style n (flush ()) in + ps fmt s_title2; + ( + match label_opt with + None -> () + | Some l -> + ps fmt (self#make_label (self#label ~no_: false l)) + ) + + method latex_of_Latex fmt s = ps fmt s + + method latex_of_Link fmt s t = + self#latex_of_text fmt t ; + ps fmt "[\\url{"; + ps fmt s ; + ps fmt "}]" + + method latex_of_Ref fmt name ref_opt text_opt = + match ref_opt with + None -> + self#latex_of_text fmt + (match text_opt with + None -> + [Odoc_info.Code (Odoc_info.use_hidden_modules name)] + | Some t -> t + ) + | Some (RK_section _) -> + self#latex_of_text_element fmt + (Latex ("["^(self#make_ref (self#label ~no_:false (Name.simple name)))^"]")) + | Some kind -> + let f_label = + match kind with + Odoc_info.RK_module -> self#module_label + | Odoc_info.RK_module_type -> self#module_type_label + | Odoc_info.RK_class -> self#class_label + | Odoc_info.RK_class_type -> self#class_type_label + | Odoc_info.RK_value -> self#value_label + | Odoc_info.RK_type -> self#type_label + | Odoc_info.RK_exception -> self#exception_label + | Odoc_info.RK_attribute -> self#attribute_label + | Odoc_info.RK_method -> self#method_label + | Odoc_info.RK_section _ -> assert false + in + let text = + match text_opt with + None -> [Odoc_info.Code (Odoc_info.use_hidden_modules name)] + | Some t -> t + in + self#latex_of_text fmt + (text @ [Latex ("["^(self#make_ref (f_label name))^"]")]) + + method latex_of_Superscript fmt t = + ps fmt "$^{"; + self#latex_of_text fmt t; + ps fmt "}$" + + method latex_of_Subscript fmt t = + ps fmt "$_{"; + self#latex_of_text fmt t; + ps fmt "}$" + + end + +(** A class used to generate LaTeX code for info structures. *) +class virtual info = + object (self) + (** The method used to get LaTeX code from a [text]. *) + method virtual latex_of_text : Format.formatter -> Odoc_info.text -> unit + + (** The method used to get a [text] from an optionel info structure. *) + method virtual text_of_info : ?block: bool -> Odoc_info.info option -> Odoc_info.text + + (** Print LaTeX code for a description, except for the [i_params] field. *) + method latex_of_info fmt ?(block=false) info_opt = + self#latex_of_text fmt + (self#text_of_info ~block info_opt) + end + +module Generator = +struct +(** This class is used to create objects which can generate a simple LaTeX documentation. *) +class latex = + object (self) + inherit text + inherit Odoc_to_text.to_text as to_text + inherit info + + (** Get the first sentence and the rest of a description, + from an optional [info] structure. The first sentence + can be empty if it would not appear right in a title. + In the first sentence, the titles and lists has been removed, + since it is used in LaTeX titles and would make LaTeX complain + if we has two nested \section commands. + *) + method first_and_rest_of_info i_opt = + match i_opt with + None -> ([], []) + | Some i -> + match i.Odoc_info.i_desc with + None -> ([], self#text_of_info ~block: true i_opt) + | Some t -> + let (first,_) = Odoc_info.first_sentence_and_rest_of_text t in + let (_, rest) = Odoc_info.first_sentence_and_rest_of_text (self#text_of_info ~block: false i_opt) in + (Odoc_info.text_no_title_no_list first, rest) + + (** Print LaTeX code for a value. *) + method latex_of_value fmt v = + Odoc_info.reset_type_names () ; + let label = self#value_label v.val_name in + let latex = self#make_label label in + self#latex_of_text fmt + ((Latex latex) :: + (to_text#text_of_value v)) + + (** Print LaTeX code for a class attribute. *) + method latex_of_attribute fmt a = + self#latex_of_text fmt + ((Latex (self#make_label (self#attribute_label a.att_value.val_name))) :: + (to_text#text_of_attribute a)) + + (** Print LaTeX code for a class method. *) + method latex_of_method fmt m = + self#latex_of_text fmt + ((Latex (self#make_label (self#method_label m.met_value.val_name))) :: + (to_text#text_of_method m)) + + (** Print LaTeX code for the parameters of a type. *) + method latex_of_type_params fmt m_name t = + let print_one (p, co, cn) = + ps fmt (Odoc_info.string_of_variance t (co,cn)); + ps fmt (self#normal_type m_name p) + in + match t.ty_parameters with + [] -> () + | [(p,co,cn)] -> print_one (p, co, cn) + | l -> + ps fmt "("; + print_concat fmt ", " print_one t.ty_parameters; + ps fmt ")" + + method latex_of_class_parameter_list fmt father c = + self#latex_of_text fmt + (self#text_of_class_params father c) + + (** Print LaTeX code for a type. *) + method latex_of_type fmt t = + let s_name = Name.simple t.ty_name in + let text = + let (fmt2, flush2) = new_fmt () in + Odoc_info.reset_type_names () ; + let mod_name = Name.father t.ty_name in + Format.fprintf fmt2 "@[<h 2>type "; + self#latex_of_type_params fmt2 mod_name t; + (match t.ty_parameters with [] -> () | _ -> ps fmt2 " "); + ps fmt2 s_name; + let priv = t.ty_private = Asttypes.Private in + ( + match t.ty_manifest with + None -> () + | Some typ -> + p fmt2 " = %s%s" (if priv then "private " else "") (self#normal_type mod_name typ) + ); + let s_type3 = + p fmt2 + " %s" + ( + match t.ty_kind with + Type_abstract -> "" + | Type_variant _ -> "="^(if priv then " private" else "") + | Type_record _ -> "= "^(if priv then "private " else "")^"{" + ) ; + flush2 () + in + + let defs = + match t.ty_kind with + Type_abstract -> [] + | Type_variant l -> + (List.flatten + (List.map + (fun constr -> + let s_cons = + p fmt2 "@[<h 6> | %s" constr.vc_name; + ( + match constr.vc_args with + [] -> () + | l -> + p fmt2 " %s@ %s" + "of" + (self#normal_type_list ~par: false mod_name " * " l) + ); + flush2 () + in + [ CodePre s_cons ] @ + (match constr.vc_text with + None -> [] + | Some t -> + let s = + ps fmt2 "\\begin{ocamldoccomment}\n"; + self#latex_of_text fmt2 t; + ps fmt2 "\n\\end{ocamldoccomment}\n"; + flush2 () + in + [ Latex s] + ) + ) + l + ) + ) + | Type_record l -> + (List.flatten + (List.map + (fun r -> + let s_field = + p fmt2 + "@[<h 6> %s%s :@ %s ;" + (if r.rf_mutable then "mutable " else "") + r.rf_name + (self#normal_type mod_name r.rf_type); + flush2 () + in + [ CodePre s_field ] @ + (match r.rf_text with + None -> [] + | Some t -> + let s = + ps fmt2 "\\begin{ocamldoccomment}\n"; + self#latex_of_text fmt2 t; + ps fmt2 "\n\\end{ocamldoccomment}\n"; + flush2 () + in + [ Latex s] + ) + ) + l + ) + ) @ + [ CodePre "}" ] + in + let defs2 = (CodePre s_type3) :: defs in + let rec iter = function + [] -> [] + | [e] -> [e] + | (CodePre s1) :: (CodePre s2) :: q -> + iter ((CodePre (s1^"\n"^s2)) :: q) + | e :: q -> + e :: (iter q) + in + (iter defs2) @ + [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @ + (self#text_of_info t.ty_info) + in + self#latex_of_text fmt + ((Latex (self#make_label (self#type_label t.ty_name))) :: text) + + (** Print LaTeX code for an exception. *) + method latex_of_exception fmt e = + Odoc_info.reset_type_names () ; + self#latex_of_text fmt + ((Latex (self#make_label (self#exception_label e.ex_name))) :: + (to_text#text_of_exception e)) + + method latex_of_module_parameter fmt m_name p = + self#latex_of_text fmt + [ + Code "functor ("; + Code p.mp_name ; + Code " : "; + ] ; + self#latex_of_module_type_kind fmt m_name p.mp_kind; + self#latex_of_text fmt [ Code ") -> "] + + + method latex_of_module_type_kind fmt father kind = + match kind with + Module_type_struct eles -> + self#latex_of_text fmt [Latex "\\begin{ocamldocsigend}\n"]; + List.iter (self#latex_of_module_element fmt father) eles; + self#latex_of_text fmt [Latex "\\end{ocamldocsigend}\n"] + | Module_type_functor (p, k) -> + self#latex_of_module_parameter fmt father p; + self#latex_of_module_type_kind fmt father k + | Module_type_alias a -> + self#latex_of_text fmt + [Code (self#relative_module_idents father a.mta_name)] + | Module_type_with (k, s) -> + self#latex_of_module_type_kind fmt father k; + self#latex_of_text fmt + [ Code " "; + Code (self#relative_idents father s); + ] + | Module_type_typeof s -> + self#latex_of_text fmt + [ Code "module type of "; + Code (self#relative_idents father s); + ] + + method latex_of_module_kind fmt father kind = + match kind with + Module_struct eles -> + self#latex_of_text fmt [Latex "\\begin{ocamldocsigend}\n"]; + List.iter (self#latex_of_module_element fmt father) eles; + self#latex_of_text fmt [Latex "\\end{ocamldocsigend}\n"] + | Module_alias a -> + self#latex_of_text fmt + [Code (self#relative_module_idents father a.ma_name)] + | Module_functor (p, k) -> + self#latex_of_module_parameter fmt father p; + self#latex_of_module_kind fmt father k + | Module_apply (k1, k2) -> + (* TODO: l'application n'est pas correcte dans un .mli. + Que faire ? -> afficher le module_type du typedtree *) + self#latex_of_module_kind fmt father k1; + self#latex_of_text fmt [Code "("]; + self#latex_of_module_kind fmt father k2; + self#latex_of_text fmt [Code ")"] + | Module_with (k, s) -> + (* TODO: à modifier quand Module_with sera plus détaillé *) + self#latex_of_module_type_kind fmt father k; + self#latex_of_text fmt + [ Code " "; + Code (self#relative_idents father s) ; + ] + | Module_constraint (k, tk) -> + (* TODO: on affiche quoi ? *) + self#latex_of_module_kind fmt father k + | Module_typeof s -> + self#latex_of_text fmt + [ Code "module type of "; + Code (self#relative_idents father s); + ] + | Module_unpack (s, _) -> + self#latex_of_text fmt + [ + Code (self#relative_idents father s); + ] + + method latex_of_class_kind fmt father kind = + match kind with + Class_structure (inh, eles) -> + self#latex_of_text fmt [Latex "\\begin{ocamldocobjectend}\n"]; + self#generate_inheritance_info fmt inh; + List.iter (self#latex_of_class_element fmt father) eles; + self#latex_of_text fmt [Latex "\\end{ocamldocobjectend}\n"] + + | Class_apply capp -> + (* TODO: afficher le type final à partir du typedtree *) + self#latex_of_text fmt [Raw "class application not handled yet"] + + | Class_constr cco -> + ( + match cco.cco_type_parameters with + [] -> () + | l -> + self#latex_of_text fmt + ( + Code "[" :: + (self#text_of_class_type_param_expr_list father l) @ + [Code "] "] + ) + ); + self#latex_of_text fmt + [Code (self#relative_idents father cco.cco_name)] + + | Class_constraint (ck, ctk) -> + self#latex_of_text fmt [Code "( "] ; + self#latex_of_class_kind fmt father ck; + self#latex_of_text fmt [Code " : "] ; + self#latex_of_class_type_kind fmt father ctk; + self#latex_of_text fmt [Code " )"] + + method latex_of_class_type_kind fmt father kind = + match kind with + Class_type cta -> + ( + match cta.cta_type_parameters with + [] -> () + | l -> + self#latex_of_text fmt + (Code "[" :: + (self#text_of_class_type_param_expr_list father l) @ + [Code "] "] + ) + ); + self#latex_of_text fmt + [Code (self#relative_idents father cta.cta_name)] + + | Class_signature (inh, eles) -> + self#latex_of_text fmt [Latex "\\begin{ocamldocobjectend}\n"]; + self#generate_inheritance_info fmt inh; + List.iter (self#latex_of_class_element fmt father) eles; + self#latex_of_text fmt [Latex "\\end{ocamldocobjectend}\n"] + + method latex_for_module_index fmt m = + let s_name = Name.simple m.m_name in + self#latex_of_text fmt + [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^ + (self#label ~no_:false s_name)^"`}\n" + ) + ] + + method latex_for_module_type_index fmt mt = + let s_name = Name.simple mt.mt_name in + self#latex_of_text fmt + [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^ + (self#label ~no_:false (Name.simple s_name))^"`}\n" + ) + ] + + method latex_for_module_label fmt m = + ps fmt (self#make_label (self#module_label m.m_name)) + + method latex_for_module_type_label fmt mt = + ps fmt (self#make_label (self#module_type_label mt.mt_name)) + + + method latex_for_class_index fmt c = + let s_name = Name.simple c.cl_name in + self#latex_of_text fmt + [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^ + (self#label ~no_:false s_name)^"`}\n" + ) + ] + + method latex_for_class_type_index fmt ct = + let s_name = Name.simple ct.clt_name in + self#latex_of_text fmt + [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^ + (self#label ~no_:false s_name)^"`}\n" + ) + ] + + method latex_for_class_label fmt c = + ps fmt (self#make_label (self#class_label c.cl_name)) + + method latex_for_class_type_label fmt ct = + ps fmt (self#make_label (self#class_type_label ct.clt_name)) + + (** Print the LaTeX code for the given module. *) + method latex_of_module fmt m = + let father = Name.father m.m_name in + let t = + [ + Latex "\\begin{ocamldoccode}\n" ; + Code "module "; + Code (Name.simple m.m_name); + Code " : "; + ] + in + self#latex_of_text fmt t; + self#latex_of_text fmt [ Latex "\\end{ocamldoccode}\n" ]; + self#latex_for_module_label fmt m; + self#latex_for_module_index fmt m; + p fmt "@[<h 4>"; + self#latex_of_module_kind fmt father m.m_kind; + ( + match Module.module_is_functor m with + false -> () + | true -> + self#latex_of_text fmt [Newline]; + ( + match List.filter (fun (_,d) -> d <> None) + (module_parameters ~trans: false m) + with + [] -> () + | l -> + let t = + [ Bold [Raw "Parameters: "]; + List + (List.map + (fun (p,text_opt) -> + let t = match text_opt with None -> [] | Some t -> t in + ( Raw p.mp_name :: Raw ": " :: t) + ) + l + ) + ] + in + self#latex_of_text fmt t + ); + ); + self#latex_of_text fmt [Newline]; + self#latex_of_info fmt ~block: true m.m_info; + p fmt "@]"; + + + (** Print the LaTeX code for the given module type. *) + method latex_of_module_type fmt mt = + let father = Name.father mt.mt_name in + let t = + [ + Latex "\\begin{ocamldoccode}\n" ; + Code "module type " ; + Code (Name.simple mt.mt_name); + ] + in + self#latex_of_text fmt t; + ( + match mt.mt_type, mt.mt_kind with + | Some mtyp, Some kind -> + self#latex_of_text fmt [ Code " = " ]; + self#latex_of_text fmt [ Latex "\\end{ocamldoccode}\n" ]; + self#latex_for_module_type_label fmt mt; + self#latex_for_module_type_index fmt mt; + p fmt "@[<h 4>"; + self#latex_of_module_type_kind fmt father kind + | _ -> + self#latex_of_text fmt [ Latex "\\end{ocamldoccode}\n" ]; + self#latex_for_module_type_index fmt mt; + p fmt "@[<h 4>"; + ); + ( + match Module.module_type_is_functor mt with + false -> () + | true -> + self#latex_of_text fmt [Newline]; + ( + match List.filter (fun (_,d) -> d <> None) + (module_type_parameters ~trans: false mt) + with + [] -> () + | l -> + let t = + [ Bold [Raw "Parameters: "]; + List + (List.map + (fun (p,text_opt) -> + let t = match text_opt with None -> [] | Some t -> t in + ( Raw p.mp_name :: Raw ": " :: t) + ) + l + ) + ] + in + self#latex_of_text fmt t + ); + ); + self#latex_of_text fmt [Newline]; + self#latex_of_info fmt ~block: true mt.mt_info; + p fmt "@]"; + + (** Print the LaTeX code for the given included module. *) + method latex_of_included_module fmt im = + self#latex_of_text fmt + ((Code "include ") :: + (Code + (match im.im_module with + None -> im.im_name + | Some (Mod m) -> m.m_name + | Some (Modtype mt) -> mt.mt_name) + ) :: + (self#text_of_info im.im_info) + ) + + (** Print the LaTeX code for the given class. *) + method latex_of_class fmt c = + Odoc_info.reset_type_names () ; + let father = Name.father c.cl_name in + let type_params = + match c.cl_type_parameters with + [] -> "" + | l -> (self#normal_class_type_param_list father l)^" " + in + let t = + [ + Latex "\\begin{ocamldoccode}\n" ; + Code (Printf.sprintf + "class %s%s%s : " + (if c.cl_virtual then "virtual " else "") + type_params + (Name.simple c.cl_name) + ) + ] + in + self#latex_of_text fmt t; + self#latex_of_class_parameter_list fmt father c; + (* avoid a big gap if the kind is a consrt *) + ( + match c.cl_kind with + Class.Class_constr _ -> + self#latex_of_class_kind fmt father c.cl_kind + | _ -> + () + ); + self#latex_of_text fmt [ Latex "\\end{ocamldoccode}\n" ]; + self#latex_for_class_label fmt c; + self#latex_for_class_index fmt c; + p fmt "@[<h 4>"; + (match c.cl_kind with + Class.Class_constr _ -> () + | _ -> self#latex_of_class_kind fmt father c.cl_kind + ); + self#latex_of_text fmt [Newline]; + self#latex_of_info fmt ~block: true c.cl_info; + p fmt "@]" + + (** Print the LaTeX code for the given class type. *) + method latex_of_class_type fmt ct = + Odoc_info.reset_type_names () ; + let father = Name.father ct.clt_name in + let type_params = + match ct.clt_type_parameters with + [] -> "" + | l -> (self#normal_class_type_param_list father l)^" " + in + let t = + [ + Latex "\\begin{ocamldoccode}\n" ; + Code (Printf.sprintf + "class type %s%s%s = " + (if ct.clt_virtual then "virtual " else "") + type_params + (Name.simple ct.clt_name) + ) + ] + in + self#latex_of_text fmt t; + + self#latex_of_text fmt [ Latex "\\end{ocamldoccode}\n" ]; + self#latex_for_class_type_label fmt ct; + self#latex_for_class_type_index fmt ct; + p fmt "@[<h 4>"; + self#latex_of_class_type_kind fmt father ct.clt_kind; + self#latex_of_text fmt [Newline]; + self#latex_of_info fmt ~block: true ct.clt_info; + p fmt "@]" + + (** Print the LaTeX code for the given class element. *) + method latex_of_class_element fmt class_name class_ele = + self#latex_of_text fmt [Newline]; + match class_ele with + Class_attribute att -> self#latex_of_attribute fmt att + | Class_method met -> self#latex_of_method fmt met + | Class_comment t -> + match t with + | [] -> () + | (Title (_,_,_)) :: _ -> self#latex_of_text fmt t + | _ -> self#latex_of_text fmt [ Title ((Name.depth class_name) + 2, None, t) ] + + (** Print the LaTeX code for the given module element. *) + method latex_of_module_element fmt module_name module_ele = + self#latex_of_text fmt [Newline]; + match module_ele with + Element_module m -> self#latex_of_module fmt m + | Element_module_type mt -> self#latex_of_module_type fmt mt + | Element_included_module im -> self#latex_of_included_module fmt im + | Element_class c -> self#latex_of_class fmt c + | Element_class_type ct -> self#latex_of_class_type fmt ct + | Element_value v -> self#latex_of_value fmt v + | Element_exception e -> self#latex_of_exception fmt e + | Element_type t -> self#latex_of_type fmt t + | Element_module_comment t -> self#latex_of_text fmt t + + (** Generate the LaTeX code for the given list of inherited classes.*) + method generate_inheritance_info fmt inher_l = + let f inh = + match inh.ic_class with + None -> (* we can't make the reference *) + Newline :: + Code ("inherit "^inh.ic_name) :: + (match inh.ic_text with + None -> [] + | Some t -> Newline :: t + ) + | Some cct -> + let label = + match cct with + Cl _ -> self#class_label inh.ic_name + | Cltype _ -> self#class_type_label inh.ic_name + in + (* we can create the reference *) + Newline :: + Odoc_info.Code ("inherit "^inh.ic_name) :: + (Odoc_info.Latex (" ["^(self#make_ref label)^"]")) :: + (match inh.ic_text with + None -> [] + | Some t -> Newline :: t + ) + in + List.iter (self#latex_of_text fmt) (List.map f inher_l) + + (** Generate the LaTeX code for the inherited classes of the given class. *) + method generate_class_inheritance_info fmt cl = + let rec iter_kind k = + match k with + Class_structure ([], _) -> + () + | Class_structure (l, _) -> + self#generate_inheritance_info fmt l + | Class_constraint (k, _) -> + iter_kind k + | Class_apply _ + | Class_constr _ -> + () + in + iter_kind cl.cl_kind + + (** Generate the LaTeX code for the inherited classes of the given class type. *) + method generate_class_type_inheritance_info fmt clt = + match clt.clt_kind with + Class_signature ([], _) -> + () + | Class_signature (l, _) -> + self#generate_inheritance_info fmt l + | Class_type _ -> + () + + (** Generate the LaTeX code for the given top module, in the given buffer. *) + method generate_for_top_module fmt m = + let (first_t, rest_t) = self#first_and_rest_of_info m.m_info in + let text = + if m.m_text_only then + [ Title (1, None, [Raw m.m_name] @ + (match first_t with + [] -> [] + | t -> (Raw " : ") :: t) + ) ; + ] + else + [ Title (1, None, + [ Raw (Odoc_messages.modul^" ") ; Code m.m_name ] @ + (match first_t with + [] -> [] + | t -> (Raw " : ") :: t)) ; + ] + in + self#latex_of_text fmt text; + self#latex_for_module_label fmt m; + self#latex_for_module_index fmt m; + self#latex_of_text fmt rest_t ; + + self#latex_of_text fmt [ Newline ] ; + if not m.m_text_only then ps fmt "\\ocamldocvspace{0.5cm}\n\n"; + List.iter + (fun ele -> + self#latex_of_module_element fmt m.m_name ele; + ps fmt "\n\n" + ) + (Module.module_elements ~trans: false m) + + (** Print the header of the TeX document. *) + method latex_header fmt module_list = + ps fmt "\\documentclass[11pt]{article} \n"; + ps fmt "\\usepackage[latin1]{inputenc} \n"; + ps fmt "\\usepackage[T1]{fontenc} \n"; + ps fmt "\\usepackage{fullpage} \n"; + ps fmt "\\usepackage{url} \n"; + ps fmt "\\usepackage{ocamldoc}\n"; + ( + match !Global.title with + None -> () + | Some s -> + ps fmt "\\title{"; + ps fmt (self#escape s); + ps fmt "}\n" + ); + ps fmt "\\begin{document}\n"; + (match !Global.title with + None -> () | + Some _ -> ps fmt "\\maketitle\n" + ); + if !Global.with_toc then ps fmt "\\tableofcontents\n"; + ( + let info = Odoc_info.apply_opt + (Odoc_info.info_of_comment_file module_list) + !Odoc_info.Global.intro_file + in + (match info with None -> () | Some _ -> ps fmt "\\vspace{0.2cm}"); + self#latex_of_info fmt info; + (match info with None -> () | Some _ -> ps fmt "\n\n") + ) + + + (** Generate the LaTeX style file, if it does not exists. *) + method generate_style_file = + try + let dir = Filename.dirname !Global.out_file in + let file = Filename.concat dir "ocamldoc.sty" in + if Sys.file_exists file then + Odoc_info.verbose (Odoc_messages.file_exists_dont_generate file) + else + ( + let chanout = open_out file in + output_string chanout Odoc_latex_style.content ; + flush chanout ; + close_out chanout; + Odoc_info.verbose (Odoc_messages.file_generated file) + ) + with + Sys_error s -> + prerr_endline s ; + incr Odoc_info.errors ; + + (** Generate the LaTeX file from a module list, in the {!Odoc_info.Global.out_file} file. *) + method generate module_list = + self#generate_style_file ; + let main_file = !Global.out_file in + let dir = Filename.dirname main_file in + if !separate_files then + ( + let f m = + try + let chanout = + open_out ((Filename.concat dir (Name.simple m.m_name))^".tex") + in + let fmt = Format.formatter_of_out_channel chanout in + self#generate_for_top_module fmt m ; + Format.pp_print_flush fmt (); + close_out chanout + with + Failure s + | Sys_error s -> + prerr_endline s ; + incr Odoc_info.errors + in + List.iter f module_list + ); + + try + let chanout = open_out main_file in + let fmt = Format.formatter_of_out_channel chanout in + if !Global.with_header then self#latex_header fmt module_list; + List.iter + (fun m -> + if !separate_files then + ps fmt ("\\input{"^((Name.simple m.m_name))^".tex}\n") + else + self#generate_for_top_module fmt m + ) + module_list ; + if !Global.with_trailer then ps fmt "\\end{document}"; + Format.pp_print_flush fmt (); + close_out chanout + with + Failure s + | Sys_error s -> + prerr_endline s ; + incr Odoc_info.errors + end +end + +module type Latex_generator = module type of Generator diff --git a/ocaml-binary-annot/ocamldoc/odoc_latex_style.ml b/ocaml-binary-annot/ocamldoc/odoc_latex_style.ml new file mode 100644 index 0000000000..a689b26866 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_latex_style.ml @@ -0,0 +1,91 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(** The content of the LaTeX style to generate when generating LaTeX code. *) + +(* $Id$ *) + +let content ="\n\ +%% Support macros for LaTeX documentation generated by ocamldoc.\n\ +%% This file is in the public domain; do what you want with it.\n\ +\n\ +\\NeedsTeXFormat{LaTeX2e}\n\ +\\ProvidesPackage{ocamldoc}\n\ + [2001/12/04 v1.0 ocamldoc support]\n\ +\n\ +\\newenvironment{ocamldoccode}{%\n\ + \\bgroup\n\ + \\leftskip\\@totalleftmargin\n\ + \\rightskip\\z@skip\n\ + \\parindent\\z@\n\ + \\parfillskip\\@flushglue\n\ + \\parskip\\z@skip\n\ + %\\noindent\n\ + \\@@par\\smallskip\n\ + \\@tempswafalse\n\ + \\def\\par{%\n\ + \\if@tempswa\n\ + \\leavevmode\\null\\@@par\\penalty\\interlinepenalty\n\ + \\else\n\ + \\@tempswatrue\n\ + \\ifhmode\\@@par\\penalty\\interlinepenalty\\fi\n\ + \\fi}\n\ + \\obeylines\n\ + \\verbatim@font\n\ + \\let\\org@prime~%\n\ + \\@noligs\n\ + \\let\\org@dospecials\\dospecials\n\ + \\g@remfrom@specials{\\\\}\n\ + \\g@remfrom@specials{\\{}\n\ + \\g@remfrom@specials{\\}}\n\ + \\let\\do\\@makeother\n\ + \\dospecials\n\ + \\let\\dospecials\\org@dospecials\n\ + \\frenchspacing\\@vobeyspaces\n\ + \\everypar \\expandafter{\\the\\everypar \\unpenalty}}\n\ +{\\egroup\\par}\n\ +\n\ +\\def\\g@remfrom@specials#1{%\n\ + \\def\\@new@specials{}\n\ + \\def\\@remove##1{%\n\ + \\ifx##1#1\\else\n\ + \\g@addto@macro\\@new@specials{\\do ##1}\\fi}\n\ + \\let\\do\\@remove\\dospecials\n\ + \\let\\dospecials\\@new@specials\n\ + }\n\ +\n\ +\\newenvironment{ocamldocdescription}\n\ +{\\list{}{\\rightmargin0pt \\topsep0pt}\\raggedright\\item\\noindent\\relax\\ignorespaces}\n\ +{\\endlist\\medskip}\n\ +\n\ +\\newenvironment{ocamldoccomment}\n\ +{\\list{}{\\leftmargin 2\\leftmargini \\rightmargin0pt \\topsep0pt}\\raggedright\\item\\noindent\\relax}\n\ +{\\endlist}\n\ +\n\ +\\let \\ocamldocparagraph \\paragraph\n\ +\\def \\paragraph #1{\\ocamldocparagraph {#1}\\noindent}\n\ +\\let \\ocamldocsubparagraph \\subparagraph\n\ +\\def \\subparagraph #1{\\ocamldocsubparagraph {#1}\\noindent}\n\ +\n\ +\\let\\ocamldocvspace\\vspace\n\ +\n\ +\\newenvironment{ocamldocindent}{\\list{}{}\\item\\relax}{\\endlist}\n\ +\\newenvironment{ocamldocsigend}\n\ + {\\noindent\\quad\\texttt{sig}\\ocamldocindent}\n\ + {\\endocamldocindent\\vskip -\\lastskip\n\ + \\noindent\\quad\\texttt{end}\\medskip}\n\ +\\newenvironment{ocamldocobjectend}\n\ + {\\noindent\\quad\\texttt{object}\\ocamldocindent}\n\ + {\\endocamldocindent\\vskip -\\lastskip\n\ + \\noindent\\quad\\texttt{end}\\medskip}\n\ +\n\ +\\endinput\n\ +" diff --git a/ocaml-binary-annot/ocamldoc/odoc_lexer.mll b/ocaml-binary-annot/ocamldoc/odoc_lexer.mll new file mode 100644 index 0000000000..318a839fff --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_lexer.mll @@ -0,0 +1,413 @@ +{ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** The lexer for special comments. *) + +open Lexing +open Odoc_parser + +let line_number = ref 0 + + +let string_buffer = Buffer.create 32 + +(** Fonction de remise à zéro de la chaine de caractères tampon *) +let reset_string_buffer () = Buffer.reset string_buffer + +(** Fonction d'ajout d'un caractère dans la chaine de caractères tampon *) +let ajout_char_string = Buffer.add_char string_buffer + +(** Add a string to the buffer. *) +let ajout_string = Buffer.add_string string_buffer + +let lecture_string () = Buffer.contents string_buffer + +(** The variable which will contain the description string. + Is initialized when we encounter the start of a special comment. *) +let description = ref "" + +let blank = "[ \013\009\012]" + +(** The nested comments level. *) +let comments_level = ref 0 + +let print_DEBUG2 s = print_string s; print_newline () + +(** This function returns the given string without the leading and trailing blanks.*) +let remove_blanks s = + print_DEBUG2 ("remove_blanks "^s); + let l = Str.split_delim (Str.regexp "\n") s in + let l2 = + let rec iter liste = + match liste with + h :: q -> + let h2 = Str.global_replace (Str.regexp ("^"^blank^"+")) "" h in + if h2 = "" then + ( + print_DEBUG2 (h^" n'a que des blancs"); + (* we remove this line and must remove leading blanks of the next one *) + iter q + ) + else + (* we don't remove leading blanks in the remaining lines *) + h2 :: q + | _ -> + [] + in iter l + in + let l3 = + let rec iter liste = + match liste with + h :: q -> + let h2 = Str.global_replace (Str.regexp (blank^"+$")) "" h in + if h2 = "" then + ( + print_DEBUG2 (h^" n'a que des blancs"); + (* we remove this line and must remove trailing blanks of the next one *) + iter q + ) + else + (* we don't remove trailing blanks in the remaining lines *) + h2 :: q + | _ -> + [] + in + List.rev (iter (List.rev l2)) + in + String.concat "\n" l3 + +(** Remove first blank characters of each line of a string, until the first '*' *) +let remove_stars s = + let s2 = Str.global_replace (Str.regexp ("^"^blank^"*\\*")) "" s in + s2 +} + +let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] +let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] +let identchar = + ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] + +rule main = parse + [' ' '\013' '\009' '\012'] + + { + Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); + main lexbuf + } + + | [ '\010' ] + { + incr line_number; + incr Odoc_comments_global.nb_chars; + main lexbuf + } + | "(**)" + { + Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); + Description ("", None) + } + + | "(**"("*"+)")" + { + Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); + main lexbuf + } + + | "(***" + { + Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); + incr comments_level; + main lexbuf + } + + | "(**" + { + Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); + incr comments_level; + if !comments_level = 1 then + ( + reset_string_buffer (); + description := ""; + special_comment lexbuf + ) + else + main lexbuf + } + + | eof + { EOF } + + | "*)" + { + Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); + decr comments_level ; + main lexbuf + } + + | "(*" + { + Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); + incr comments_level ; + main lexbuf + } + + | _ + { + incr Odoc_comments_global.nb_chars; + main lexbuf + } + +and special_comment = parse + | "*)" + { + let s = Lexing.lexeme lexbuf in + Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); + if !comments_level = 1 then + ( + (* there is just a description *) + let s2 = lecture_string () in + let s3 = remove_blanks s2 in + let s4 = + if !Odoc_global.remove_stars then + remove_stars s3 + else + s3 + in + Description (s4, None) + ) + else + ( + ajout_string s; + decr comments_level; + special_comment lexbuf + ) + } + + | "(*" + { + let s = Lexing.lexeme lexbuf in + Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); + incr comments_level ; + ajout_string s; + special_comment lexbuf + } + + | "\\@" + { + let s = Lexing.lexeme lexbuf in + let c = (Lexing.lexeme_char lexbuf 1) in + ajout_char_string c; + Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); + special_comment lexbuf + } + + | "@"lowercase+ + { + (* we keep the description before we go further *) + let s = lecture_string () in + description := remove_blanks s; + reset_string_buffer (); + let len = String.length (Lexing.lexeme lexbuf) in + lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - len; + lexbuf.Lexing.lex_curr_p <- + { lexbuf.Lexing.lex_curr_p with + pos_cnum = lexbuf.Lexing.lex_curr_p.pos_cnum - len + } ; + (* we don't increment the Odoc_comments_global.nb_chars *) + special_comment_part2 lexbuf + } + + | _ + { + let c = (Lexing.lexeme_char lexbuf 0) in + ajout_char_string c; + if c = '\010' then incr line_number; + incr Odoc_comments_global.nb_chars; + special_comment lexbuf + } + +and special_comment_part2 = parse + | "*)" + { + let s = Lexing.lexeme lexbuf in + Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); + if !comments_level = 1 then + (* finally we return the description we kept *) + let desc = + if !Odoc_global.remove_stars then + remove_stars !description + else + !description + in + let remain = lecture_string () in + let remain2 = + if !Odoc_global.remove_stars then + remove_stars remain + else + remain + in + Description (desc, Some remain2) + else + ( + ajout_string s ; + decr comments_level ; + special_comment_part2 lexbuf + ) + } + + | "(*" + { + let s = Lexing.lexeme lexbuf in + Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); + ajout_string s; + incr comments_level ; + special_comment_part2 lexbuf + } + + | _ + { + let c = (Lexing.lexeme_char lexbuf 0) in + ajout_char_string c; + if c = '\010' then incr line_number; + incr Odoc_comments_global.nb_chars; + special_comment_part2 lexbuf + } + +and elements = parse + | [' ' '\013' '\009' '\012'] + + { + Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); + elements lexbuf + } + + | [ '\010' ] + { incr line_number; + incr Odoc_comments_global.nb_chars; + print_DEBUG2 "newline"; + elements lexbuf } + + | "@"lowercase+ + { + let s = Lexing.lexeme lexbuf in + Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); + let s2 = String.sub s 1 ((String.length s) - 1) in + print_DEBUG2 s2; + match s2 with + "param" -> + T_PARAM + | "author" -> + T_AUTHOR + | "version" -> + T_VERSION + | "see" -> + T_SEE + | "since" -> + T_SINCE + | "before" -> + T_BEFORE + | "deprecated" -> + T_DEPRECATED + | "raise" -> + T_RAISES + | "return" -> + T_RETURN + | s -> + if !Odoc_global.no_custom_tags then + raise (Failure (Odoc_messages.not_a_valid_tag s)) + else + T_CUSTOM s + } + + | ("\\@" | [^'@'])+ + { + Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); + let s = Lexing.lexeme lexbuf in + let s = Str.global_replace (Str.regexp_string "\\@") "@" s in + let s = remove_blanks s in + print_DEBUG2 ("Desc "^s); + Desc s + } + | eof + { + EOF + } + + +and simple = parse + [' ' '\013' '\009' '\012'] + + { + Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); + simple lexbuf + } + + | [ '\010' ] + { incr line_number; + incr Odoc_comments_global.nb_chars; + simple lexbuf + } + + | "(**"("*"+) + { + Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); + incr comments_level; + simple lexbuf + } + + | "(*"("*"+)")" + { + let s = Lexing.lexeme lexbuf in + Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); + simple lexbuf + } + | "(**" + { + let s = Lexing.lexeme lexbuf in + Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); + incr comments_level; + simple lexbuf + } + + | "(*" + { + let s = Lexing.lexeme lexbuf in + Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); + incr comments_level; + if !comments_level = 1 then + ( + reset_string_buffer (); + description := ""; + special_comment lexbuf + ) + else + ( + ajout_string s; + simple lexbuf + ) + } + + | eof + { EOF } + + | "*)" + { + let s = Lexing.lexeme lexbuf in + Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); + decr comments_level ; + simple lexbuf + } + + | _ + { + incr Odoc_comments_global.nb_chars; + simple lexbuf + } diff --git a/ocaml-binary-annot/ocamldoc/odoc_man.ml b/ocaml-binary-annot/ocamldoc/odoc_man.ml new file mode 100644 index 0000000000..612bc11a02 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_man.ml @@ -0,0 +1,1089 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** The man pages generator. *) +open Odoc_info +open Parameter +open Value +open Type +open Exception +open Class +open Module +open Search + +let man_suffix = ref Odoc_messages.default_man_suffix +let man_section = ref Odoc_messages.default_man_section + +let man_mini = ref false + +let new_buf () = Buffer.create 1024 +let bp = Printf.bprintf +let bs = Buffer.add_string + +(** A class used to get a [text] for info structures. *) +class virtual info = + object (self) + (** The list of pairs [(tag, f)] where [f] is a function taking + the [text] associated to [tag] and returning man code. + Add a pair here to handle a tag.*) + val mutable tag_functions = ([] : (string * (Odoc_info.text -> string)) list) + + (** Return man code for a [text]. *) + method virtual man_of_text : Buffer.t -> Odoc_info.text -> unit + + (** Print groff string for an author list. *) + method man_of_author_list b l = + match l with + [] -> () + | _ -> + bs b ".B \""; + bs b Odoc_messages.authors; + bs b "\"\n:\n"; + bs b (String.concat ", " l); + bs b "\n.sp\n" + + (** Print groff string for the given optional version information.*) + method man_of_version_opt b v_opt = + match v_opt with + None -> () + | Some v -> + bs b ".B \""; + bs b Odoc_messages.version; + bs b "\"\n:\n"; + bs b v; + bs b "\n.sp\n" + + (** Printf groff string for the \@before information. *) + method man_of_before b = function + [] -> () + | l -> + List.iter + (fun (v, text) -> + bp b ".B \"%s" Odoc_messages.before; + bs b v; + bs b "\"\n"; + self#man_of_text b text; + bs b "\n"; + bs b "\n.sp\n" + ) + l + + + (** Print groff string for the given optional since information.*) + method man_of_since_opt b s_opt = + match s_opt with + None -> () + | Some s -> + bs b ".B \""; + bs b Odoc_messages.since; + bs b "\"\n"; + bs b s; + bs b "\n.sp\n" + + (** Print groff string for the given list of raised exceptions.*) + method man_of_raised_exceptions b l = + match l with + [] -> () + | (s, t) :: [] -> + bs b ".B \""; + bs b Odoc_messages.raises; + bs b (" "^s^"\"\n"); + self#man_of_text b t; + bs b "\n.sp\n" + | _ -> + bs b ".B \""; + bs b Odoc_messages.raises; + bs b "\"\n"; + List.iter + (fun (ex, desc) -> + bs b ".sp\n.B \""; + bs b ex; + bs b "\"\n"; + self#man_of_text b desc; + bs b "\n" + ) + l; + bs b "\n.sp\n" + + (** Print groff string for the given "see also" reference. *) + method man_of_see b (see_ref, t) = + let t_ref = + match see_ref with + Odoc_info.See_url s -> [ Odoc_info.Link (s, t) ] + | Odoc_info.See_file s -> (Odoc_info.Code s) :: (Odoc_info.Raw " ") :: t + | Odoc_info.See_doc s -> (Odoc_info.Italic [Odoc_info.Raw s]) :: (Odoc_info.Raw " ") :: t + in + self#man_of_text b t_ref + + (** Print groff string for the given list of "see also" references.*) + method man_of_sees b l = + match l with + [] -> () + | see :: [] -> + bs b ".B \""; + bs b Odoc_messages.see_also; + bs b "\"\n"; + self#man_of_see b see; + bs b "\n.sp\n" + | _ -> + bs b ".B \""; + bs b Odoc_messages.see_also; + bs b "\"\n"; + List.iter + (fun see -> + bs b ".sp\n"; + self#man_of_see b see; + bs b "\n" + ) + l; + bs b "\n.sp\n" + + (** Print groff string for the given optional return information.*) + method man_of_return_opt b return_opt = + match return_opt with + None -> () + | Some s -> + bs b ".B "; + bs b Odoc_messages.returns; + bs b "\n"; + self#man_of_text b s; + bs b "\n.sp\n" + + (** Print man code for the given list of custom tagged texts. *) + method man_of_custom b l = + let buf = Buffer.create 50 in + List.iter + (fun (tag, text) -> + try + let f = List.assoc tag tag_functions in + Buffer.add_string buf (f text) + with + Not_found -> + Odoc_info.warning (Odoc_messages.tag_not_handled tag) + ) + l + + (** Print the groff string to display an optional info structure. *) + method man_of_info b info_opt = + match info_opt with + None -> () + | Some info -> + let module M = Odoc_info in + ( + match info.M.i_deprecated with + None -> () + | Some d -> + bs b ".B \""; + bs b Odoc_messages.deprecated; + bs b "\"\n"; + self#man_of_text b d; + bs b "\n.sp\n" + ); + ( + match info.M.i_desc with + None -> () + | Some d when d = [Odoc_info.Raw ""] -> () + | Some d -> + self#man_of_text b d; + bs b "\n.sp\n" + ); + self#man_of_author_list b info.M.i_authors; + self#man_of_version_opt b info.M.i_version; + self#man_of_before b info.M.i_before; + self#man_of_since_opt b info.M.i_since; + self#man_of_raised_exceptions b info.M.i_raised_exceptions; + self#man_of_return_opt b info.M.i_return_value; + self#man_of_sees b info.M.i_sees; + self#man_of_custom b info.M.i_custom + end + +module Generator = +struct + +(** This class is used to create objects which can generate a simple html documentation. *) +class man = + let re_slash = Str.regexp_string "/" in + object (self) + inherit info + + (** Get a file name from a complete name. *) + method file_name name = + let s = Printf.sprintf "%s.%s" name !man_suffix in + Str.global_replace re_slash "slash" s + + (** Escape special sequences of characters in a string. *) + method escape (s : string) = + let len = String.length s in + let b = Buffer.create len in + for i = 0 to len - 1 do + match s.[i] with + '\\' -> Buffer.add_string b "\\(rs" + | '.' -> Buffer.add_string b "\\&." + | '\'' -> Buffer.add_string b "\\&'" + | '-' -> Buffer.add_string b "\\-" + | c -> Buffer.add_char b c + done; + Buffer.contents b + + (** Open a file for output. Add the target directory.*) + method open_out file = + let f = Filename.concat !Global.target_dir file in + open_out f + + (** Print groff string for a text, without correction of blanks. *) + method private man_of_text2 b t = + List.iter (self#man_of_text_element b) t + + (** Print the groff string for a text, with blanks corrected. *) + method man_of_text b t = + let b2 = new_buf () in + self#man_of_text2 b2 t ; + let s = Buffer.contents b2 in + let s2 = Str.global_replace (Str.regexp "\n[ ]*") "\n" s in + bs b (Str.global_replace (Str.regexp "\n\n") "\n" s2) + + (** Return the given string without no newlines. *) + method remove_newlines s = + Str.global_replace (Str.regexp "[ ]*\n[ ]*") " " s + + (** Print the groff string for a text element. *) + method man_of_text_element b te = + match te with + | Odoc_info.Raw s -> bs b (self#escape s) + | Odoc_info.Code s -> + bs b "\n.B "; + bs b ((Str.global_replace (Str.regexp "\n") "\n.B " (self#escape s))^"\n") + | Odoc_info.CodePre s -> + bs b "\n.B "; + bs b ((Str.global_replace (Str.regexp "\n") "\n.B " (self#escape s))^"\n") + | Odoc_info.Verbatim s -> + bs b (self#escape s) + | Odoc_info.Bold t + | Odoc_info.Italic t + | Odoc_info.Emphasize t + | Odoc_info.Center t + | Odoc_info.Left t + | Odoc_info.Right t -> + self#man_of_text2 b t + | Odoc_info.List tl -> + List.iter + (fun t -> bs b "\n.sp\n \\-"; self#man_of_text2 b t; bs b "\n") + tl; + bs b "\n" + | Odoc_info.Enum tl -> + List.iter + (fun t -> bs b "\n.sp\n \\-"; self#man_of_text2 b t; bs b "\n") + tl; + bs b "\n" + | Odoc_info.Newline -> + bs b "\n.sp\n" + | Odoc_info.Block t -> + bs b "\n.sp\n"; + self#man_of_text2 b t; + bs b "\n.sp\n" + | Odoc_info.Title (n, l_opt, t) -> + self#man_of_text2 b [Odoc_info.Code (Odoc_info.string_of_text t)] + | Odoc_info.Latex _ -> + (* don't care about LaTeX stuff in HTML. *) + () + | Odoc_info.Link (s, t) -> + self#man_of_text2 b t + | Odoc_info.Ref (name, _, _) -> + self#man_of_text_element b + (Odoc_info.Code (Odoc_info.use_hidden_modules name)) + | Odoc_info.Superscript t -> + bs b "^{"; self#man_of_text2 b t + | Odoc_info.Subscript t -> + bs b "_{"; self#man_of_text2 b t + | Odoc_info.Module_list _ -> + () + | Odoc_info.Index_list -> + () + | Odoc_info.Custom (s,t) -> self#man_of_custom_text b s t + | Odoc_info.Target (target, code) -> self#man_of_Target b ~target ~code + + method man_of_custom_text b s t = () + + method man_of_Target b ~target ~code = + if String.lowercase target = "man" then bs b code else () + + (** Print groff string to display code. *) + method man_of_code b s = self#man_of_text b [ Code s ] + + (** Take a string and return the string where fully qualified idents + have been replaced by idents relative to the given module name.*) + method relative_idents m_name s = + let f str_t = + let match_s = Str.matched_string str_t in + Odoc_info.apply_if_equal + Odoc_info.use_hidden_modules + match_s + (Name.get_relative m_name match_s) + in + let s2 = Str.global_substitute + (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)") + f + s + in + s2 + + (** Print groff string to display a [Types.type_expr].*) + method man_of_type_expr b m_name t = + let s = String.concat "\n" + (Str.split (Str.regexp "\n") (Odoc_print.string_of_type_expr t)) + in + let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in + bs b "\n.B "; + bs b (self#relative_idents m_name s2); + bs b "\n" + + (** Print groff string to display a [Types.class_type].*) + method man_of_class_type_expr b m_name t = + let s = String.concat "\n" + (Str.split (Str.regexp "\n") (Odoc_print.string_of_class_type t)) + in + let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in + bs b "\n.B "; + bs b (self#relative_idents m_name s2); + bs b "\n" + + (** Print groff string to display a [Types.type_expr list].*) + method man_of_type_expr_list ?par b m_name sep l = + let s = Odoc_str.string_of_type_list ?par sep l in + let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in + bs b "\n.B "; + bs b (self#relative_idents m_name s2); + bs b "\n" + + (** Print groff string to display the parameters of a type.*) + method man_of_type_expr_param_list b m_name t = + match t.ty_parameters with + [] -> () + | l -> + let s = Odoc_str.string_of_type_param_list t in + let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in + bs b "\n.B "; + bs b (self#relative_idents m_name s2); + bs b "\n" + + (** Print groff string to display a [Types.module_type]. *) + method man_of_module_type b m_name t = + let s = String.concat "\n" + (Str.split (Str.regexp "\n") (Odoc_print.string_of_module_type t)) + in + let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in + bs b "\n.B "; + bs b (self#relative_idents m_name s2); + bs b "\n" + + (** Print groff string code for a value. *) + method man_of_value b v = + Odoc_info.reset_type_names () ; + bs b "\n.I val "; + bs b (Name.simple v.val_name); + bs b " \n: "; + self#man_of_type_expr b (Name.father v.val_name) v.val_type; + bs b ".sp\n"; + self#man_of_info b v.val_info; + bs b "\n.sp\n" + + (** Print groff string code for an exception. *) + method man_of_exception b e = + Odoc_info.reset_type_names () ; + bs b "\n.I exception "; + bs b (Name.simple e.ex_name); + bs b " \n"; + ( + match e.ex_args with + [] -> () + | _ -> + bs b ".B of "; + self#man_of_type_expr_list + ~par: false + b (Name.father e.ex_name) " * " e.ex_args + ); + ( + match e.ex_alias with + None -> () + | Some ea -> + bs b " = "; + bs b + ( + match ea.ea_ex with + None -> ea.ea_name + | Some e -> e.ex_name + ) + ); + bs b "\n.sp\n"; + self#man_of_info b e.ex_info; + bs b "\n.sp\n" + + (** Print groff string for a type. *) + method man_of_type b t = + Odoc_info.reset_type_names () ; + let father = Name.father t.ty_name in + bs b ".I type "; + self#man_of_type_expr_param_list b father t; + ( + match t.ty_parameters with + [] -> () + | _ -> bs b ".I " + ); + bs b (Name.simple t.ty_name); + bs b " \n"; + let priv = t.ty_private = Asttypes.Private in + ( + match t.ty_manifest with + None -> () + | Some typ -> + bs b "= "; + if priv then bs b "private "; + self#man_of_type_expr b father typ + ); + ( + match t.ty_kind with + Type_abstract -> () + | Type_variant l -> + bs b "="; + if priv then bs b " private"; + bs b "\n "; + List.iter + (fun constr -> + bs b ("| "^constr.vc_name); + ( + match constr.vc_args, constr.vc_text with + [], None -> bs b "\n " + | [], (Some t) -> + bs b " (* "; + self#man_of_text b t; + bs b " *)\n " + | l, None -> + bs b "\n.B of "; + self#man_of_type_expr_list ~par: false b father " * " l; + bs b " " + | l, (Some t) -> + bs b "\n.B of "; + self#man_of_type_expr_list ~par: false b father " * " l; + bs b ".I \" \"\n"; + bs b "(* "; + self#man_of_text b t; + bs b " *)\n " + ) + ) + l + | Type_record l -> + bs b "= "; + if priv then bs b "private "; + bs b "{"; + List.iter + (fun r -> + bs b (if r.rf_mutable then "\n\n.B mutable \n" else "\n "); + bs b (r.rf_name^" : "); + self#man_of_type_expr b father r.rf_type; + bs b ";"; + ( + match r.rf_text with + None -> () + | Some t -> + bs b " (* "; + self#man_of_text b t; + bs b " *) " + ); + ) + l; + bs b "\n }\n" + ); + bs b "\n.sp\n"; + self#man_of_info b t.ty_info; + bs b "\n.sp\n" + + (** Print groff string for a class attribute. *) + method man_of_attribute b a = + bs b ".I val "; + if a.att_virtual then bs b ("virtual "); + if a.att_mutable then bs b (Odoc_messages.mutab^" "); + bs b ((Name.simple a.att_value.val_name)^" : "); + self#man_of_type_expr b (Name.father a.att_value.val_name) a.att_value.val_type; + bs b "\n.sp\n"; + self#man_of_info b a.att_value.val_info; + bs b "\n.sp\n" + + (** Print groff string for a class method. *) + method man_of_method b m = + bs b ".I method "; + if m.met_private then bs b "private "; + if m.met_virtual then bs b "virtual "; + bs b ((Name.simple m.met_value.val_name)^" : "); + self#man_of_type_expr b + (Name.father m.met_value.val_name) m.met_value.val_type; + bs b "\n.sp\n"; + self#man_of_info b m.met_value.val_info; + bs b "\n.sp\n" + + (** Groff for a list of parameters. *) + method man_of_parameter_list b m_name l = + match l with + [] -> () + | _ -> + bs b "\n.B "; + bs b Odoc_messages.parameters; + bs b ": \n"; + List.iter + (fun p -> + bs b ".sp\n"; + bs b "\""; + bs b (Parameter.complete_name p); + bs b "\"\n"; + self#man_of_type_expr b m_name (Parameter.typ p); + bs b "\n"; + self#man_of_parameter_description b p; + bs b "\n" + ) + l; + bs b "\n" + + (** Groff for the description of a function parameter. *) + method man_of_parameter_description b p = + match Parameter.names p with + [] -> () + | name :: [] -> + ( + (* Only one name, no need for label for the description. *) + match Parameter.desc_by_name p name with + None -> () + | Some t -> bs b "\n "; self#man_of_text b t + ) + | l -> + (* A list of names, we display those with a description. *) + List.iter + (fun n -> + match Parameter.desc_by_name p n with + None -> () + | Some t -> + self#man_of_code b (n^" : "); + self#man_of_text b t + ) + l + + (** Print groff string for a list of module parameters. *) + method man_of_module_parameter_list b m_name l = + match l with + [] -> () + | _ -> + bs b ".B \""; + bs b Odoc_messages.parameters; + bs b ":\"\n"; + List.iter + (fun (p, desc_opt) -> + bs b ".sp\n"; + bs b ("\""^p.mp_name^"\"\n"); + self#man_of_module_type b m_name p.mp_type; + bs b "\n"; + ( + match desc_opt with + None -> () + | Some t -> self#man_of_text b t + ); + bs b "\n" + ) + l; + bs b "\n\n" + + (** Print groff string for a class. *) + method man_of_class b c = + Odoc_info.reset_type_names () ; + let father = Name.father c.cl_name in + bs b ".I class "; + if c.cl_virtual then bs b "virtual "; + ( + match c.cl_type_parameters with + [] -> () + | l -> + bs b (Odoc_str.string_of_class_type_param_list l); + bs b " " + ); + bs b (Name.simple c.cl_name); + bs b " : " ; + self#man_of_class_type_expr b father c.cl_type; + bs b "\n.sp\n"; + self#man_of_info b c.cl_info; + bs b "\n.sp\n" + + (** Print groff string for a class type. *) + method man_of_class_type b ct = + Odoc_info.reset_type_names () ; + bs b ".I class type "; + if ct.clt_virtual then bs b "virtual " ; + ( + match ct.clt_type_parameters with + [] -> () + | l -> + bs b (Odoc_str.string_of_class_type_param_list l); + bs b " " + ); + bs b (Name.simple ct.clt_name); + bs b " = " ; + self#man_of_class_type_expr b (Name.father ct.clt_name) ct.clt_type; + bs b "\n.sp\n"; + self#man_of_info b ct.clt_info; + bs b "\n.sp\n" + + (** Print groff string for a module. *) + method man_of_module b m = + bs b ".I module "; + bs b (Name.simple m.m_name); + bs b " : "; + self#man_of_module_type b (Name.father m.m_name) m.m_type; + bs b "\n.sp\n"; + self#man_of_info b m.m_info; + bs b "\n.sp\n" + + (** Print groff string for a module type. *) + method man_of_modtype b mt = + bs b ".I module type "; + bs b (Name.simple mt.mt_name); + bs b " = "; + (match mt.mt_type with + None -> () + | Some t -> + self#man_of_module_type b (Name.father mt.mt_name) t + ); + bs b "\n.sp\n"; + self#man_of_info b mt.mt_info; + bs b "\n.sp\n" + + (** Print groff string for a module comment.*) + method man_of_module_comment b text = + bs b "\n.PP\n"; + self#man_of_text b [Code ("=== "^(Odoc_misc.string_of_text text)^" ===")]; + bs b "\n.PP\n" + + (** Print groff string for a class comment.*) + method man_of_class_comment b text = + bs b "\n.PP\n"; + self#man_of_text b [Code ("=== "^(Odoc_misc.string_of_text text)^" ===")]; + bs b "\n.PP\n" + + (** Print groff string for an included module. *) + method man_of_included_module b m_name im = + bs b ".I include "; + ( + match im.im_module with + None -> bs b im.im_name + | Some mmt -> + let name = + match mmt with + Mod m -> m.m_name + | Modtype mt -> mt.mt_name + in + bs b (self#relative_idents m_name name) + ); + bs b "\n.sp\n"; + self#man_of_info b im.im_info; + bs b "\n.sp\n" + + (** Generate the man page for the given class.*) + method generate_for_class cl = + Odoc_info.reset_type_names () ; + let date = Unix.time () in + let file = self#file_name cl.cl_name in + try + let chanout = self#open_out file in + let b = new_buf () in + bs b (".TH \""^cl.cl_name^"\" "); + bs b !man_section ; + bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^" "); + bs b "OCamldoc "; + bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n"); + + let abstract = + match cl.cl_info with + None | Some { i_desc = None } -> "no description" + | Some { i_desc = Some t } -> + let s = Odoc_info.string_of_text (Odoc_info.first_sentence_of_text t) in + self#remove_newlines s + in + + bs b ".SH NAME\n"; + bs b (cl.cl_name^" \\- "^abstract^"\n"); + bs b (".SH "^Odoc_messages.clas^"\n"); + bs b (Odoc_messages.clas^" "^cl.cl_name^"\n"); + bs b (".SH "^Odoc_messages.documentation^"\n"); + bs b ".sp\n"; + self#man_of_class b cl; + + (* parameters *) + self#man_of_parameter_list b "" cl.cl_parameters; + (* a large blank *) + bs b "\n.sp\n.sp\n"; + +(* + (* class inheritance *) + self#generate_class_inheritance_info chanout cl; +*) + (* the various elements *) + List.iter + (fun element -> + match element with + Class_attribute a -> + self#man_of_attribute b a + | Class_method m -> + self#man_of_method b m + | Class_comment t -> + self#man_of_class_comment b t + ) + (Class.class_elements cl); + + Buffer.output_buffer chanout b; + close_out chanout + with + Sys_error s -> + incr Odoc_info.errors ; + prerr_endline s + + (** Generate the man page for the given class type.*) + method generate_for_class_type ct = + Odoc_info.reset_type_names () ; + let date = Unix.time () in + let file = self#file_name ct.clt_name in + try + let chanout = self#open_out file in + let b = new_buf () in + bs b (".TH \""^ct.clt_name^"\" "); + bs b !man_section ; + bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^" "); + bs b "OCamldoc "; + bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n"); + + let abstract = + match ct.clt_info with + None | Some { i_desc = None } -> "no description" + | Some { i_desc = Some t } -> + let s = Odoc_info.string_of_text (Odoc_info.first_sentence_of_text t) in + self#remove_newlines s + in + + bs b ".SH NAME\n"; + bs b (ct.clt_name^" \\- "^abstract^"\n"); + bs b (".SH "^Odoc_messages.class_type^"\n"); + bs b (Odoc_messages.class_type^" "^ct.clt_name^"\n"); + bs b (".SH "^Odoc_messages.documentation^"\n"); + bs b ".sp\n"; + + self#man_of_class_type b ct; + + (* a large blank *) + bs b "\n.sp\n.sp\n"; +(* + (* class inheritance *) + self#generate_class_inheritance_info chanout cl; +*) + (* the various elements *) + List.iter + (fun element -> + match element with + Class_attribute a -> + self#man_of_attribute b a + | Class_method m -> + self#man_of_method b m + | Class_comment t -> + self#man_of_class_comment b t + ) + (Class.class_type_elements ct); + + Buffer.output_buffer chanout b; + close_out chanout + with + Sys_error s -> + incr Odoc_info.errors ; + prerr_endline s + + (** Generate the man file for the given module type. + @raise Failure if an error occurs.*) + method generate_for_module_type mt = + let date = Unix.time () in + let file = self#file_name mt.mt_name in + try + let chanout = self#open_out file in + let b = new_buf () in + bs b (".TH \""^mt.mt_name^"\" "); + bs b !man_section ; + bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^" "); + bs b "OCamldoc "; + bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n"); + + let abstract = + match mt.mt_info with + None | Some { i_desc = None } -> "no description" + | Some { i_desc = Some t } -> + let s = Odoc_info.string_of_text (Odoc_info.first_sentence_of_text t) in + self#remove_newlines s + in + bs b ".SH NAME\n"; + bs b (mt.mt_name^" \\- "^abstract^"\n"); + bs b (".SH "^Odoc_messages.module_type^"\n"); + bs b (Odoc_messages.module_type^" "^mt.mt_name^"\n"); + bs b (".SH "^Odoc_messages.documentation^"\n"); + bs b ".sp\n"; + bs b (Odoc_messages.module_type^"\n"); + bs b (".BI \""^(Name.simple mt.mt_name)^"\"\n"); + bs b " = "; + ( + match mt.mt_type with + None -> () + | Some t -> + self#man_of_module_type b (Name.father mt.mt_name) t + ); + bs b "\n.sp\n"; + self#man_of_info b mt.mt_info; + bs b "\n.sp\n"; + + (* parameters for functors *) + self#man_of_module_parameter_list b "" (Module.module_type_parameters mt); + (* a large blank *) + bs b "\n.sp\n.sp\n"; + + (* module elements *) + List.iter + (fun ele -> + match ele with + Element_module m -> + self#man_of_module b m + | Element_module_type mt -> + self#man_of_modtype b mt + | Element_included_module im -> + self#man_of_included_module b mt.mt_name im + | Element_class c -> + self#man_of_class b c + | Element_class_type ct -> + self#man_of_class_type b ct + | Element_value v -> + self#man_of_value b v + | Element_exception e -> + self#man_of_exception b e + | Element_type t -> + self#man_of_type b t + | Element_module_comment text -> + self#man_of_module_comment b text + ) + (Module.module_type_elements mt); + + Buffer.output_buffer chanout b; + close_out chanout + + with + Sys_error s -> + incr Odoc_info.errors ; + prerr_endline s + + (** Generate the man file for the given module. + @raise Failure if an error occurs.*) + method generate_for_module m = + let date = Unix.time () in + let file = self#file_name m.m_name in + try + let chanout = self#open_out file in + let b = new_buf () in + bs b (".TH \""^m.m_name^"\" "); + bs b !man_section ; + bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^" "); + bs b "OCamldoc "; + bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n"); + + let abstract = + match m.m_info with + None | Some { i_desc = None } -> "no description" + | Some { i_desc = Some t } -> + let s = Odoc_info.string_of_text (Odoc_info.first_sentence_of_text t) in + self#remove_newlines s + in + + bs b ".SH NAME\n"; + bs b (m.m_name^" \\- "^abstract^"\n"); + bs b (".SH "^Odoc_messages.modul^"\n"); + bs b (Odoc_messages.modul^" "^m.m_name^"\n"); + bs b (".SH "^Odoc_messages.documentation^"\n"); + bs b ".sp\n"; + bs b (Odoc_messages.modul^"\n"); + bs b (".BI \""^(Name.simple m.m_name)^"\"\n"); + bs b " : "; + self#man_of_module_type b (Name.father m.m_name) m.m_type; + bs b "\n.sp\n"; + self#man_of_info b m.m_info; + bs b "\n.sp\n"; + + (* parameters for functors *) + self#man_of_module_parameter_list b "" (Module.module_parameters m); + (* a large blank *) + bs b "\n.sp\n.sp\n"; + + (* module elements *) + List.iter + (fun ele -> + match ele with + Element_module m -> + self#man_of_module b m + | Element_module_type mt -> + self#man_of_modtype b mt + | Element_included_module im -> + self#man_of_included_module b m.m_name im + | Element_class c -> + self#man_of_class b c + | Element_class_type ct -> + self#man_of_class_type b ct + | Element_value v -> + self#man_of_value b v + | Element_exception e -> + self#man_of_exception b e + | Element_type t -> + self#man_of_type b t + | Element_module_comment text -> + self#man_of_module_comment b text + ) + (Module.module_elements m); + + Buffer.output_buffer chanout b; + close_out chanout + + with + Sys_error s -> + raise (Failure s) + + (** Create the groups of elements to generate pages for. *) + method create_groups module_list = + let name res_ele = + match res_ele with + Res_module m -> m.m_name + | Res_module_type mt -> mt.mt_name + | Res_class c -> c.cl_name + | Res_class_type ct -> ct.clt_name + | Res_value v -> Name.simple v.val_name + | Res_type t -> Name.simple t.ty_name + | Res_exception e -> Name.simple e.ex_name + | Res_attribute a -> Name.simple a.att_value.val_name + | Res_method m -> Name.simple m.met_value.val_name + | Res_section _ -> assert false + in + let all_items_pre = Odoc_info.Search.search_by_name module_list (Str.regexp ".*") in + let all_items = List.filter + (fun r -> match r with Res_section _ -> false | _ -> true) + all_items_pre + in + let sorted_items = List.sort (fun e1 -> fun e2 -> compare (name e1) (name e2)) all_items in + let rec f acc1 acc2 l = + match l with + [] -> acc2 :: acc1 + | h :: q -> + match acc2 with + [] -> f acc1 [h] q + | h2 :: q2 -> + if (name h) = (name h2) then + if List.mem h acc2 then + f acc1 acc2 q + else + f acc1 (acc2 @ [h]) q + else + f (acc2 :: acc1) [h] q + in + f [] [] sorted_items + + (** Generate a man page for a group of elements with the same name. + A group must not be empty.*) + method generate_for_group l = + let name = + Name.simple + ( + match List.hd l with + Res_module m -> m.m_name + | Res_module_type mt -> mt.mt_name + | Res_class c -> c.cl_name + | Res_class_type ct -> ct.clt_name + | Res_value v -> v.val_name + | Res_type t -> t.ty_name + | Res_exception e -> e.ex_name + | Res_attribute a -> a.att_value.val_name + | Res_method m -> m.met_value.val_name + | Res_section (s,_) -> s + ) + in + let date = Unix.time () in + let file = self#file_name name in + try + let chanout = self#open_out file in + let b = new_buf () in + bs b (".TH \""^name^"\" "); + bs b !man_section ; + bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^" "); + bs b "OCamldoc "; + bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n"); + bs b ".SH NAME\n"; + bs b (name^" \\- all "^name^" elements\n\n"); + + let f ele = + match ele with + Res_value v -> + bs b ("\n.SH "^Odoc_messages.modul^" "^(Name.father v.val_name)^"\n"); + self#man_of_value b v + | Res_type t -> + bs b ("\n.SH "^Odoc_messages.modul^" "^(Name.father t.ty_name)^"\n"); + self#man_of_type b t + | Res_exception e -> + bs b ("\n.SH "^Odoc_messages.modul^" "^(Name.father e.ex_name)^"\n"); + self#man_of_exception b e + | Res_attribute a -> + bs b ("\n.SH "^Odoc_messages.clas^" "^(Name.father a.att_value.val_name)^"\n"); + self#man_of_attribute b a + | Res_method m -> + bs b ("\n.SH "^Odoc_messages.clas^" "^(Name.father m.met_value.val_name)^"\n"); + self#man_of_method b m + | Res_class c -> + bs b ("\n.SH "^Odoc_messages.modul^" "^(Name.father c.cl_name)^"\n"); + self#man_of_class b c + | Res_class_type ct -> + bs b ("\n.SH "^Odoc_messages.modul^" "^(Name.father ct.clt_name)^"\n"); + self#man_of_class_type b ct + | _ -> + (* normalement on ne peut pas avoir de module ici. *) + () + in + List.iter f l; + Buffer.output_buffer chanout b; + close_out chanout + with + Sys_error s -> + incr Odoc_info.errors ; + prerr_endline s + + (** Generate all the man pages from a module list. *) + method generate module_list = + let sorted_module_list = Sort.list (fun m1 -> fun m2 -> m1.m_name < m2.m_name) module_list in + let groups = self#create_groups sorted_module_list in + let f group = + match group with + [] -> + () + | [Res_module m] -> self#generate_for_module m + | [Res_module_type mt] -> self#generate_for_module_type mt + | [Res_class cl] -> self#generate_for_class cl + | [Res_class_type ct] -> self#generate_for_class_type ct + | l -> + if !man_mini then + () + else + self#generate_for_group l + in + List.iter f groups + end +end + +module type Man_generator = module type of Generator diff --git a/ocaml-binary-annot/ocamldoc/odoc_merge.ml b/ocaml-binary-annot/ocamldoc/odoc_merge.ml new file mode 100644 index 0000000000..8d062f9e02 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_merge.ml @@ -0,0 +1,988 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Merge of information from [.ml] and [.mli] for a module.*) + +open Odoc_types + +module Name = Odoc_name +open Odoc_parameter +open Odoc_value +open Odoc_type +open Odoc_exception +open Odoc_class +open Odoc_module + +let merge_before_tags l = + let rec iter acc = function + [] -> List.rev acc + | (v, text) :: q -> + let (l1, l2) = List.partition + (fun (v2,_) -> v = v2) q + in + let acc = + let text = + List.fold_left + (fun acc t -> acc @ [Raw " "] @ t) + text (List.map snd l1) + in + (v, text) :: acc + in + iter acc l2 + in + iter [] l +;; + +(** Merge two Odoctypes.info struture, completing the information of + the first one with the information in the second one. + The merge treatment depends on a given merge_option list. + @return the new info structure.*) +let merge_info merge_options (m1 : info) (m2 : info) = + let new_desc_opt = + match m1.i_desc, m2.i_desc with + None, None -> None + | None, Some d + | Some d, None -> Some d + | Some d1, Some d2 -> + if List.mem Merge_description merge_options then + Some (d1 @ (Newline :: d2)) + else + Some d1 + in + let new_authors = + match m1.i_authors, m2.i_authors with + [], [] -> [] + | l, [] + | [], l -> l + | l1, l2 -> + if List.mem Merge_author merge_options then + l1 @ l2 + else + l1 + in + let new_version = + match m1.i_version , m2.i_version with + None, None -> None + | Some v, None + | None, Some v -> Some v + | Some v1, Some v2 -> + if List.mem Merge_version merge_options then + Some (v1^" "^v2) + else + Some v1 + in + let new_sees = + match m1.i_sees, m2.i_sees with + [], [] -> [] + | l, [] + | [], l -> l + | l1, l2 -> + if List.mem Merge_see merge_options then + l1 @ l2 + else + l1 + in + let new_since = + match m1.i_since, m2.i_since with + None, None -> None + | Some v, None + | None, Some v -> Some v + | Some v1, Some v2 -> + if List.mem Merge_since merge_options then + Some (v1^" "^v2) + else + Some v1 + in + let new_before = merge_before_tags (m1.i_before @ m2.i_before) in + let new_dep = + match m1.i_deprecated, m2.i_deprecated with + None, None -> None + | None, Some t + | Some t, None -> Some t + | Some t1, Some t2 -> + if List.mem Merge_deprecated merge_options then + Some (t1 @ (Newline :: t2)) + else + Some t1 + in + let new_params = + match m1.i_params, m2.i_params with + [], [] -> [] + | l, [] + | [], l -> l + | l1, l2 -> + if List.mem Merge_param merge_options then + ( + let l_in_m1_and_m2, l_in_m2_only = List.partition + (fun (param2, _) -> List.mem_assoc param2 l1) + l2 + in + let rec iter = function + [] -> [] + | (param2, desc2) :: q -> + let desc1 = List.assoc param2 l1 in + (param2, desc1 @ (Newline :: desc2)) :: (iter q) + in + let l1_completed = iter l_in_m1_and_m2 in + l1_completed @ l_in_m2_only + ) + else + l1 + in + let new_raised_exceptions = + match m1.i_raised_exceptions, m2.i_raised_exceptions with + [], [] -> [] + | l, [] + | [], l -> l + | l1, l2 -> + if List.mem Merge_raised_exception merge_options then + ( + let l_in_m1_and_m2, l_in_m2_only = List.partition + (fun (exc2, _) -> List.mem_assoc exc2 l1) + l2 + in + let rec iter = function + [] -> [] + | (exc2, desc2) :: q -> + let desc1 = List.assoc exc2 l1 in + (exc2, desc1 @ (Newline :: desc2)) :: (iter q) + in + let l1_completed = iter l_in_m1_and_m2 in + l1_completed @ l_in_m2_only + ) + else + l1 + in + let new_rv = + match m1.i_return_value, m2.i_return_value with + None, None -> None + | None, Some t + | Some t, None -> Some t + | Some t1, Some t2 -> + if List.mem Merge_return_value merge_options then + Some (t1 @ (Newline :: t2)) + else + Some t1 + in + let new_custom = + match m1.i_custom, m2.i_custom with + [], [] -> [] + | [], l + | l, [] -> l + | l1, l2 -> + if List.mem Merge_custom merge_options then + l1 @ l2 + else + l1 + in + { + Odoc_types.i_desc = new_desc_opt ; + Odoc_types.i_authors = new_authors ; + Odoc_types.i_version = new_version ; + Odoc_types.i_sees = new_sees ; + Odoc_types.i_since = new_since ; + Odoc_types.i_before = new_before ; + Odoc_types.i_deprecated = new_dep ; + Odoc_types.i_params = new_params ; + Odoc_types.i_raised_exceptions = new_raised_exceptions ; + Odoc_types.i_return_value = new_rv ; + Odoc_types.i_custom = new_custom ; + } + +(** Merge of two optional info structures. *) +let merge_info_opt merge_options mli_opt ml_opt = + match mli_opt, ml_opt with + None, Some i -> Some i + | Some i, None -> Some i + | None, None -> None + | Some i1, Some i2 -> Some (merge_info merge_options i1 i2) + +(** merge of two t_type, one for a .mli, another for the .ml. + The .mli type is completed with the information in the .ml type. *) +let merge_types merge_options mli ml = + mli.ty_info <- merge_info_opt merge_options mli.ty_info ml.ty_info; + mli.ty_loc <- { mli.ty_loc with loc_impl = ml.ty_loc.loc_impl } ; + mli.ty_code <- (match mli.ty_code with None -> ml.ty_code | _ -> mli.ty_code) ; + + match mli.ty_kind, ml.ty_kind with + Type_abstract, _ -> + () + + | Type_variant l1, Type_variant l2 -> + let f cons = + try + let cons2 = List.find + (fun c2 -> c2.vc_name = cons.vc_name) + l2 + in + let new_desc = + match cons.vc_text, cons2.vc_text with + None, None -> None + | Some d, None + | None, Some d -> Some d + | Some d1, Some d2 -> + if List.mem Merge_description merge_options then + Some (d1 @ d2) + else + Some d1 + in + cons.vc_text <- new_desc + with + Not_found -> + if !Odoc_global.inverse_merge_ml_mli then + () + else + raise (Failure (Odoc_messages.different_types mli.ty_name)) + in + List.iter f l1 + + | Type_record l1, Type_record l2 -> + let f record = + try + let record2= List.find + (fun r -> r.rf_name = record.rf_name) + l2 + in + let new_desc = + match record.rf_text, record2.rf_text with + None, None -> None + | Some d, None + | None, Some d -> Some d + | Some d1, Some d2 -> + if List.mem Merge_description merge_options then + Some (d1 @ d2) + else + Some d1 + in + record.rf_text <- new_desc + with + Not_found -> + if !Odoc_global.inverse_merge_ml_mli then + () + else + raise (Failure (Odoc_messages.different_types mli.ty_name)) + in + List.iter f l1 + + | _ -> + if !Odoc_global.inverse_merge_ml_mli then + () + else + raise (Failure (Odoc_messages.different_types mli.ty_name)) + +(** Merge of two param_info, one from a .mli, one from a .ml. + The text fields are not handled but will be recreated from the + i_params field of the info structure. + Here, if a parameter in the .mli has no name, we take the one + from the .ml. When two parameters have two different forms, + we take the one from the .mli. *) +let rec merge_param_info pi_mli pi_ml = + match (pi_mli, pi_ml) with + (Simple_name sn_mli, Simple_name sn_ml) -> + if sn_mli.sn_name = "" then + Simple_name { sn_mli with sn_name = sn_ml.sn_name } + else + pi_mli + | (Simple_name _, Tuple _) -> + pi_mli + | (Tuple (_, t_mli), Simple_name sn_ml) -> + (* if we're here, then the tuple in the .mli has no parameter names ; + then we take the name of the parameter of the .ml and the type of the .mli. *) + Simple_name { sn_ml with sn_type = t_mli } + + | (Tuple (l_mli, t_mli), Tuple (l_ml, _)) -> + (* if the two tuples have different lengths + (which should not occurs), we return the pi_mli, + without further investigation.*) + if (List.length l_mli) <> (List.length l_ml) then + pi_mli + else + let new_l = List.map2 merge_param_info l_mli l_ml in + Tuple (new_l, t_mli) + +(** Merge of the parameters of two functions/methods/classes, one for a .mli, another for a .ml. + The prameters in the .mli are completed by the name in the .ml.*) +let rec merge_parameters param_mli param_ml = + match (param_mli, param_ml) with + ([], []) -> [] + | (l, []) | ([], l) -> l + | ((pi_mli :: li), (pi_ml :: l)) -> + (merge_param_info pi_mli pi_ml) :: merge_parameters li l + +(** Merge of two t_class, one for a .mli, another for the .ml. + The .mli class is completed with the information in the .ml class. *) +let merge_classes merge_options mli ml = + mli.cl_info <- merge_info_opt merge_options mli.cl_info ml.cl_info; + mli.cl_loc <- { mli.cl_loc with loc_impl = ml.cl_loc.loc_impl } ; + mli.cl_parameters <- merge_parameters mli.cl_parameters ml.cl_parameters; + + (* we must reassociate comments in @param to the the corresponding + parameters because the associated comment of a parameter may have been changed y the merge.*) + Odoc_class.class_update_parameters_text mli; + + (* merge values *) + List.iter + (fun a -> + try + let _ = List.find + (fun ele -> + match ele with + Class_attribute a2 -> + if a2.att_value.val_name = a.att_value.val_name then + ( + a.att_value.val_info <- merge_info_opt merge_options + a.att_value.val_info a2.att_value.val_info; + a.att_value.val_loc <- { a.att_value.val_loc with loc_impl = a2.att_value.val_loc.loc_impl } ; + if !Odoc_global.keep_code then + a.att_value.val_code <- a2.att_value.val_code; + true + ) + else + false + | _ -> + false + ) + (* we look for the last attribute with this name defined in the implementation *) + (List.rev (Odoc_class.class_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_class.class_attributes mli); + (* merge methods *) + List.iter + (fun m -> + try + let _ = List.find + (fun ele -> + match ele with + Class_method m2 -> + if m2.met_value.val_name = m.met_value.val_name then + ( + m.met_value.val_info <- merge_info_opt + merge_options m.met_value.val_info m2.met_value.val_info; + m.met_value.val_loc <- { m.met_value.val_loc with loc_impl = m2.met_value.val_loc.loc_impl } ; + (* merge the parameter names *) + m.met_value.val_parameters <- (merge_parameters + m.met_value.val_parameters + m2.met_value.val_parameters) ; + (* we must reassociate comments in @param to the corresponding + parameters because the associated comment of a parameter may have been changed by the merge.*) + Odoc_value.update_value_parameters_text m.met_value; + + if !Odoc_global.keep_code then + m.met_value.val_code <- m2.met_value.val_code; + + true + ) + else + false + | _ -> + false + ) + (* we look for the last method with this name defined in the implementation *) + (List.rev (Odoc_class.class_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_class.class_methods mli) + +(** merge of two t_class_type, one for a .mli, another for the .ml. + The .mli class is completed with the information in the .ml class. *) +let merge_class_types merge_options mli ml = + mli.clt_info <- merge_info_opt merge_options mli.clt_info ml.clt_info; + mli.clt_loc <- { mli.clt_loc with loc_impl = ml.clt_loc.loc_impl } ; + (* merge values *) + List.iter + (fun a -> + try + let _ = List.find + (fun ele -> + match ele with + Class_attribute a2 -> + if a2.att_value.val_name = a.att_value.val_name then + ( + a.att_value.val_info <- merge_info_opt merge_options + a.att_value.val_info a2.att_value.val_info; + a.att_value.val_loc <- { a.att_value.val_loc with loc_impl = a2.att_value.val_loc.loc_impl } ; + if !Odoc_global.keep_code then + a.att_value.val_code <- a2.att_value.val_code; + + true + ) + else + false + | _ -> + false + ) + (* we look for the last attribute with this name defined in the implementation *) + (List.rev (Odoc_class.class_type_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_class.class_type_attributes mli); + (* merge methods *) + List.iter + (fun m -> + try + let _ = List.find + (fun ele -> + match ele with + Class_method m2 -> + if m2.met_value.val_name = m.met_value.val_name then + ( + m.met_value.val_info <- merge_info_opt + merge_options m.met_value.val_info m2.met_value.val_info; + m.met_value.val_loc <- { m.met_value.val_loc with loc_impl = m2.met_value.val_loc.loc_impl } ; + m.met_value.val_parameters <- (merge_parameters + m.met_value.val_parameters + m2.met_value.val_parameters) ; + (* we must reassociate comments in @param to the the corresponding + parameters because the associated comment of a parameter may have been changed y the merge.*) + Odoc_value.update_value_parameters_text m.met_value; + + if !Odoc_global.keep_code then + m.met_value.val_code <- m2.met_value.val_code; + + true + ) + else + false + | _ -> + false + ) + (* we look for the last method with this name defined in the implementation *) + (List.rev (Odoc_class.class_type_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_class.class_type_methods mli) + + +(** merge of two t_module_type, one for a .mli, another for the .ml. + The .mli module is completed with the information in the .ml module. *) +let rec merge_module_types merge_options mli ml = + mli.mt_info <- merge_info_opt merge_options mli.mt_info ml.mt_info; + mli.mt_loc <- { mli.mt_loc with loc_impl = ml.mt_loc.loc_impl } ; + (* merge exceptions *) + List.iter + (fun ex -> + try + let _ = List.find + (fun ele -> + match ele with + Element_exception ex2 -> + if ex2.ex_name = ex.ex_name then + ( + ex.ex_info <- merge_info_opt merge_options ex.ex_info ex2.ex_info; + ex.ex_loc <- { ex.ex_loc with loc_impl = ex2.ex_loc.loc_impl } ; + ex.ex_code <- (match ex.ex_code with None -> ex2.ex_code | _ -> ex.ex_code) ; + true + ) + else + false + | _ -> + false + ) + (* we look for the last exception with this name defined in the implementation *) + (List.rev (Odoc_module.module_type_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_module.module_type_exceptions mli); + (* merge types *) + List.iter + (fun ty -> + try + let _ = List.find + (fun ele -> + match ele with + Element_type ty2 -> + if ty2.ty_name = ty.ty_name then + ( + merge_types merge_options ty ty2; + true + ) + else + false + | _ -> + false + ) + (* we look for the last type with this name defined in the implementation *) + (List.rev (Odoc_module.module_type_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_module.module_type_types mli); + (* merge submodules *) + List.iter + (fun m -> + try + let _ = List.find + (fun ele -> + match ele with + Element_module m2 -> + if m2.m_name = m.m_name then + ( + ignore (merge_modules merge_options m m2); +(* + m.m_info <- merge_info_opt merge_options m.m_info m2.m_info; + m.m_loc <- { m.m_loc with loc_impl = m2.m_loc.loc_impl } ; +*) + true + ) + else + false + | _ -> + false + ) + (* we look for the last module with this name defined in the implementation *) + (List.rev (Odoc_module.module_type_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_module.module_type_modules mli); + + (* merge module types *) + List.iter + (fun m -> + try + let _ = List.find + (fun ele -> + match ele with + Element_module_type m2 -> + if m2.mt_name = m.mt_name then + ( + merge_module_types merge_options m m2; + true + ) + else + false + | _ -> + false + ) + (* we look for the last module with this name defined in the implementation *) + (List.rev (Odoc_module.module_type_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_module.module_type_module_types mli); + + (* A VOIR : merge included modules ? *) + + (* merge values *) + List.iter + (fun v -> + try + let _ = List.find + (fun ele -> + match ele with + Element_value v2 -> + if v2.val_name = v.val_name then + ( + v.val_info <- merge_info_opt merge_options v.val_info v2.val_info ; + v.val_loc <- { v.val_loc with loc_impl = v2.val_loc.loc_impl } ; + (* in the .mli we don't know any parameters so we add the ones in the .ml *) + v.val_parameters <- (merge_parameters + v.val_parameters + v2.val_parameters) ; + (* we must reassociate comments in @param to the the corresponding + parameters because the associated comment of a parameter may have been changed y the merge.*) + Odoc_value.update_value_parameters_text v; + + if !Odoc_global.keep_code then + v.val_code <- v2.val_code; + + true + ) + else + false + | _ -> + false + ) + (* we look for the last value with this name defined in the implementation *) + (List.rev (Odoc_module.module_type_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_module.module_type_values mli); + + (* merge classes *) + List.iter + (fun c -> + try + let _ = List.find + (fun ele -> + match ele with + Element_class c2 -> + if c2.cl_name = c.cl_name then + ( + merge_classes merge_options c c2; + true + ) + else + false + | _ -> + false + ) + (* we look for the last value with this name defined in the implementation *) + (List.rev (Odoc_module.module_type_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_module.module_type_classes mli); + + (* merge class types *) + List.iter + (fun c -> + try + let _ = List.find + (fun ele -> + match ele with + Element_class_type c2 -> + if c2.clt_name = c.clt_name then + ( + merge_class_types merge_options c c2; + true + ) + else + false + | _ -> + false + ) + (* we look for the last value with this name defined in the implementation *) + (List.rev (Odoc_module.module_type_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_module.module_type_class_types mli) + +(** merge of two t_module, one for a .mli, another for the .ml. + The .mli module is completed with the information in the .ml module. *) +and merge_modules merge_options mli ml = + mli.m_info <- merge_info_opt merge_options mli.m_info ml.m_info; + mli.m_loc <- { mli.m_loc with loc_impl = ml.m_loc.loc_impl } ; + let rec remove_doubles acc = function + [] -> acc + | h :: q -> + if List.mem h acc then remove_doubles acc q + else remove_doubles (h :: acc) q + in + mli.m_top_deps <- remove_doubles mli.m_top_deps ml.m_top_deps ; + + let code = + if !Odoc_global.keep_code then + match mli.m_code, ml.m_code with + Some s, _ -> Some s + | _, Some s -> Some s + | _ -> None + else + None + in + let code_intf = + if !Odoc_global.keep_code then + match mli.m_code_intf, ml.m_code_intf with + Some s, _ -> Some s + | _, Some s -> Some s + | _ -> None + else + None + in + mli.m_code <- code; + mli.m_code_intf <- code_intf; + + (* merge exceptions *) + List.iter + (fun ex -> + try + let _ = List.find + (fun ele -> + match ele with + Element_exception ex2 -> + if ex2.ex_name = ex.ex_name then + ( + ex.ex_info <- merge_info_opt merge_options ex.ex_info ex2.ex_info; + ex.ex_loc <- { ex.ex_loc with loc_impl = ex.ex_loc.loc_impl } ; + ex.ex_code <- (match ex.ex_code with None -> ex2.ex_code | _ -> ex.ex_code) ; + true + ) + else + false + | _ -> + false + ) + (* we look for the last exception with this name defined in the implementation *) + (List.rev (Odoc_module.module_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_module.module_exceptions mli); + (* merge types *) + List.iter + (fun ty -> + try + let _ = List.find + (fun ele -> + match ele with + Element_type ty2 -> + if ty2.ty_name = ty.ty_name then + ( + merge_types merge_options ty ty2; + true + ) + else + false + | _ -> + false + ) + (* we look for the last type with this name defined in the implementation *) + (List.rev (Odoc_module.module_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_module.module_types mli); + (* merge submodules *) + List.iter + (fun m -> + try + let _ = List.find + (fun ele -> + match ele with + Element_module m2 -> + if m2.m_name = m.m_name then + ( + ignore (merge_modules merge_options m m2); +(* + m.m_info <- merge_info_opt merge_options m.m_info m2.m_info; + m.m_loc <- { m.m_loc with loc_impl = m2.m_loc.loc_impl } ; +*) + true + ) + else + false + | _ -> + false + ) + (* we look for the last module with this name defined in the implementation *) + (List.rev (Odoc_module.module_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_module.module_modules mli); + + (* merge module types *) + List.iter + (fun m -> + try + let _ = List.find + (fun ele -> + match ele with + Element_module_type m2 -> + if m2.mt_name = m.mt_name then + ( + merge_module_types merge_options m m2; + true + ) + else + false + | _ -> + false + ) + (* we look for the last module with this name defined in the implementation *) + (List.rev (Odoc_module.module_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_module.module_module_types mli); + + (* A VOIR : merge included modules ? *) + + (* merge values *) + List.iter + (fun v -> + try + let _ = List.find + (fun v2 -> + if v2.val_name = v.val_name then + ( + v.val_info <- merge_info_opt merge_options v.val_info v2.val_info ; + v.val_loc <- { v.val_loc with loc_impl = v2.val_loc.loc_impl } ; + (* in the .mli we don't know any parameters so we add the ones in the .ml *) + v.val_parameters <- (merge_parameters + v.val_parameters + v2.val_parameters) ; + (* we must reassociate comments in @param to the the corresponding + parameters because the associated comment of a parameter may have been changed y the merge.*) + Odoc_value.update_value_parameters_text v; + + if !Odoc_global.keep_code then + v.val_code <- v2.val_code; + true + ) + else + false + ) + (* we look for the last value with this name defined in the implementation *) + (List.rev (Odoc_module.module_values ml)) + in + () + with + Not_found -> + () + ) + (Odoc_module.module_values mli); + + (* merge classes *) + List.iter + (fun c -> + try + let _ = List.find + (fun ele -> + match ele with + Element_class c2 -> + if c2.cl_name = c.cl_name then + ( + merge_classes merge_options c c2; + true + ) + else + false + | _ -> + false + ) + (* we look for the last value with this name defined in the implementation *) + (List.rev (Odoc_module.module_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_module.module_classes mli); + + (* merge class types *) + List.iter + (fun c -> + try + let _ = List.find + (fun ele -> + match ele with + Element_class_type c2 -> + if c2.clt_name = c.clt_name then + ( + merge_class_types merge_options c c2; + true + ) + else + false + | _ -> + false + ) + (* we look for the last value with this name defined in the implementation *) + (List.rev (Odoc_module.module_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_module.module_class_types mli); + + mli + +let merge merge_options modules_list = + let rec iter = function + [] -> [] + | m :: q -> + (* look for another module with the same name *) + let (l_same, l_others) = List.partition + (fun m2 -> m.m_name = m2.m_name) + q + in + match l_same with + [] -> + (* no other module to merge with *) + m :: (iter l_others) + | m2 :: [] -> + ( + (* we can merge m with m2 if there is an implementation + and an interface.*) + let f b = if !Odoc_global.inverse_merge_ml_mli then not b else b in + match f m.m_is_interface, f m2.m_is_interface with + true, false -> (merge_modules merge_options m m2) :: (iter l_others) + | false, true -> (merge_modules merge_options m2 m) :: (iter l_others) + | false, false -> + if !Odoc_global.inverse_merge_ml_mli then + (* two Module.ts for the .mli ! *) + raise (Failure (Odoc_messages.two_interfaces m.m_name)) + else + (* two Module.t for the .ml ! *) + raise (Failure (Odoc_messages.two_implementations m.m_name)) + | true, true -> + if !Odoc_global.inverse_merge_ml_mli then + (* two Module.t for the .ml ! *) + raise (Failure (Odoc_messages.two_implementations m.m_name)) + else + (* two Module.ts for the .mli ! *) + raise (Failure (Odoc_messages.two_interfaces m.m_name)) + ) + | _ -> + (* two many Module.t ! *) + raise (Failure (Odoc_messages.too_many_module_objects m.m_name)) + + in + iter modules_list diff --git a/ocaml-binary-annot/ocamldoc/odoc_merge.mli b/ocaml-binary-annot/ocamldoc/odoc_merge.mli new file mode 100644 index 0000000000..4f580ee899 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_merge.mli @@ -0,0 +1,35 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Merge of information from [.ml] and [.mli] for a module.*) + +(** Merging \@before tags. *) +val merge_before_tags : + (string * Odoc_types.text) list -> (string * Odoc_types.text) list + +(** Merge of two optional info structures. + Used to merge a comment before and a comment after + an element in [Odoc_sig.Analyser.analyse_signature_item_desc]. *) +val merge_info_opt : + Odoc_types.merge_option list -> + Odoc_types.info option -> + Odoc_types.info option -> + Odoc_types.info option + +(** Merge of modules which represent the same OCaml module, in a list of t_module. + There must be at most two t_module for the same OCaml module, one for a .mli, another for the .ml. + The function returns the list of t_module where same modules have been merged, according + to the given merge_option list.*) +val merge : + Odoc_types.merge_option list -> + Odoc_module.t_module list -> Odoc_module.t_module list diff --git a/ocaml-binary-annot/ocamldoc/odoc_messages.ml b/ocaml-binary-annot/ocamldoc/odoc_messages.ml new file mode 100644 index 0000000000..4d92c5d24f --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_messages.ml @@ -0,0 +1,357 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** The messages of the application. *) + +let ok = "Ok" +let software = "OCamldoc" +let config_version = Config.version +let magic = config_version^"" +let message_version = software^" "^config_version + +(** Messages for command line *) + +let usage = "Usage : "^(Sys.argv.(0))^" [options] <files>\n" +let options_are = "Options are :" +let option_version = "\tPrint version and exit" +let latex_only = "(LaTeX only)" +let texi_only = "(TeXinfo only)" +let latex_texi_only = "(LaTeX and TeXinfo only)" +let html_only = "(HTML only)" +let html_latex_only = "(HTML and LaTeX only)" +let html_latex_texi_only = "(HTML, LaTeX and TeXinfo only)" +let man_only = "(man only)" +let verbose_mode = "\t\tverbose mode" +let include_dirs = "<dir>\tAdd <dir> to the list of include directories" +let rectypes = "\tAllow arbitrary recursive types" +let preprocess = "<command>\tPipe sources through preprocessor <command>" +let option_impl ="<file>\tConsider <file> as a .ml file" +let option_intf ="<file>\tConsider <file> as a .mli file" +let option_text ="<file>\tConsider <file> as a .txt file" +let display_custom_generators_dir = "\tDisplay custom generators standard directory and exit" +let add_load_dir = "<dir>\tAdd the given directory to the search path for custom\n"^ + "\t\tgenerators" +let load_file = "<file.cm[o|a|xs]>\n\t\tLoad file defining a new documentation generator" +let nolabels = "\tIgnore non-optional labels in types" +let werr = "\tTreat ocamldoc warnings as errors" +let hide_warnings = "\n\t\tdo not print ocamldoc warnings" +let target_dir = "<dir>\tGenerate files in directory <dir>, rather than in current\n"^ + "\t\tdirectory (for man and HTML generators)" +let dump = "<file>\tDump collected information into <file>" +let load = "<file>\tLoad information from <file> ; may be used several times" +let css_style = "<file>\n\t\tUse content of <file> as CSS style definition "^html_only +let index_only = "\tGenerate index files only "^html_only +let colorize_code = "\n\t\tColorize code even in documentation pages "^html_only +let html_short_functors = "\n\t\tUse short form to display functor types "^html_only +let generate_html = "\tGenerate HTML documentation" +let generate_latex = "\tGenerate LaTeX documentation" +let generate_texinfo = "\tGenerate TeXinfo documentation" +let generate_man = "\t\tGenerate man pages" +let generate_dot = "\t\tGenerate dot code of top modules dependencies" + +let option_not_in_native_code op = "Option "^op^" not available in native code version." + +let default_out_file = "ocamldoc.out" +let out_file = + "<file>\tSet the ouput file name, used by texi, latex and dot generators\n"^ + "\t\t(default is "^default_out_file^")\n"^ + "\t\tor the prefix of index files for the HTML generator\n"^ + "\t\t(default is index)" + +let dot_include_all = + "\n\t\tInclude all modules in the dot output, not only the\n"^ + "\t\tmodules given on the command line" +let dot_types = "\tGenerate dependency graph for types instead of modules" +let default_dot_colors = + [ [ "darkturquoise" ; "darkgoldenrod2" ; "cyan" ; "green" ; ] ; + [ "magenta" ; "yellow" ; "burlywood1" ; "aquamarine" ; "floralwhite" ; "lightpink" ] ; + [ "lightblue" ; "mediumturquoise" ; "salmon" ; "slategray3"] ; + ] + +let dot_colors = + "<c1,c2,...,cn>\n\t\tUse colors c1,c1,...,cn in the dot output\n"^ + "\t\t(default list is "^ + (String.concat ",\n\t\t" (List.map (String.concat ",") default_dot_colors))^")" + +let dot_reduce = + "\tPerform a transitive reduction on the selected dependency graph\n"^ + "\t\tbefore the dot output" + +let man_mini = "\tGenerate man pages only for modules, module types, classes\n"^ + "\t\tand class types "^man_only +let default_man_section = "3" +let man_section = "<section>\n\t\tUse <section> in man page files "^ + "(default is "^default_man_section^") "^man_only^"\n" + +let default_man_suffix = default_man_section^"o" +let man_suffix = "<suffix>\n\t\tUse <suffix> for man page files "^ + "(default is "^default_man_suffix^") "^man_only^"\n" + +let option_title = "<title>\tUse <title> as title for the generated documentation" +let option_intro = + "<file>\tUse content of <file> as ocamldoc text to use as introduction\n"^ + "\t\t"^(html_latex_texi_only) +let with_parameter_list = "\tDisplay the complete list of parameters for functions and\n"^ + "\t\tmethods "^html_only +let hide_modules = "<M1,M2.M3,...>\n\t\tHide the given complete module names in generated doc" +let no_header = "\tSuppress header in generated documentation\n\t\t"^latex_texi_only +let no_trailer = "\tSuppress trailer in generated documentation\n\t\t"^latex_texi_only +let separate_files = "\tGenerate one file per toplevel module "^latex_only +let latex_title ref_titles = + "n,style\n\t\tAssociate {n } to the given sectionning style\n"^ + "\t\t(e.g. 'section') in the latex output "^latex_only^"\n"^ + "\t\tDefault sectionning is:\n\t\t"^ + (String.concat "\n\t\t" + (List.map (fun (n,t) -> Printf.sprintf " %d -> %s" n t) !ref_titles)) + +let default_latex_value_prefix = "val:" +let latex_value_prefix = + "<string>\n\t\tUse <string> as prefix for the LaTeX labels of values.\n"^ + "\t\t(default is \""^default_latex_value_prefix^"\")" + +let default_latex_type_prefix = "type:" +let latex_type_prefix = + "<string>\n\t\tUse <string> as prefix for the LaTeX labels of types.\n"^ + "\t\t(default is \""^default_latex_type_prefix^"\")" + +let default_latex_exception_prefix = "exception:" +let latex_exception_prefix = + "<string>\n\t\tUse <string> as prefix for the LaTeX labels of exceptions.\n"^ + "\t\t(default is \""^default_latex_exception_prefix^"\")" + +let default_latex_module_prefix = "module:" +let latex_module_prefix = + "<string>\n\t\tUse <string> as prefix for the LaTeX labels of modules.\n"^ + "\t\t(default is \""^default_latex_module_prefix^"\")" + +let default_latex_module_type_prefix = "moduletype:" +let latex_module_type_prefix = + "<string>\n\t\tUse <string> as prefix for the LaTeX labels of module types.\n"^ + "\t\t(default is \""^default_latex_module_type_prefix^"\")" + +let default_latex_class_prefix = "class:" +let latex_class_prefix = + "<string>\n\t\tUse <string> as prefix for the LaTeX labels of classes.\n"^ + "\t\t(default is \""^default_latex_class_prefix^"\")" + +let default_latex_class_type_prefix = "classtype:" +let latex_class_type_prefix = + "<string>\n\t\tUse <string> as prefix for the LaTeX labels of class types.\n"^ + "\t\t(default is \""^default_latex_class_type_prefix^"\")" + +let default_latex_attribute_prefix = "val:" +let latex_attribute_prefix = + "<string>\n\t\tUse <string> as prefix for the LaTeX labels of attributes.\n"^ + "\t\t(default is \""^default_latex_attribute_prefix^"\")" + +let default_latex_method_prefix = "method:" +let latex_method_prefix = + "<string>\n\t\tUse <string> as prefix for the LaTeX labels of methods.\n"^ + "\t\t(default is \""^default_latex_method_prefix^"\")" + +let no_toc = "\tDo not generate table of contents "^latex_only +let sort_modules = "\tSort the list of top modules before generating the documentation" +let no_stop = "\tDo not stop at (**/**) comments" +let no_custom_tags = "\n\t\tDo not allow custom @-tags" +let remove_stars = "\tRemove beginning blanks of comment lines, until the first '*'" +let keep_code = "\tAlways keep code when available" +let inverse_merge_ml_mli = "\n\t\tInverse implementations and interfaces when merging" +let no_filter_with_module_constraints = "\n\t\tDo not filter module elements using module type constraints" +let merge_description = ('d', "merge description") +let merge_author = ('a', "merge @author") +let merge_version = ('v', "merge @version") +let merge_see = ('l', "merge @see") +let merge_since = ('s', "merge @since") +let merge_deprecated = ('o', "merge @deprecated") +let merge_param = ('p', "merge @param") +let merge_raised_exception = ('e', "merge @raise") +let merge_return_value = ('r', "merge @return") +let merge_custom = ('c', "merge custom @-tags") +let merge_all = ('A', "merge all") + +let no_index = "\tDo not build index for Info files "^texi_only +let esc_8bits = "\tEscape accentuated characters in Info files "^texi_only +let info_section = "Specify section of Info directory "^texi_only +let info_entry = "\tSpecify Info directory entry "^texi_only + +let options_can_be = "<options> can be one or more of the following characters:" +let string_of_options_list l = + List.fold_left (fun acc -> fun (c, m) -> acc^"\n\t\t"^(String.make 1 c)^" "^m) + "" + l + +let merge_options = + "<options>\tspecify merge options between .mli and .ml\n\t\t"^ + options_can_be^ + (string_of_options_list + [ merge_description ; + merge_author ; + merge_version ; + merge_see ; + merge_since ; + merge_deprecated ; + merge_param ; + merge_raised_exception ; + merge_return_value ; + merge_custom ; + merge_all ] + ) + + +(** Error and warning messages *) + +let warning = "Warning" + +let bad_magic_number = + "Bad magic number for this ocamldoc dump!\n"^ + "This dump was not created by this version of OCamldoc." + +let not_a_module_name s = s^" is not a valid module name" +let load_file_error f e = "Error while loading file "^f^":\n"^e +let wrong_format s = "Wrong format for \""^s^"\"" +let errors_occured n = (string_of_int n)^" error(s) encountered" +let parse_error = "Parse error" +let text_parse_error l c s = + let lines = Str.split (Str.regexp_string "\n") s in + "Syntax error in text:\n"^s^"\n"^ + "line "^(string_of_int l)^", character "^(string_of_int c)^":\n"^ + (List.nth lines l)^"\n"^ + (String.make c ' ')^"^" + +let file_not_found_in_paths paths name = + Printf.sprintf "No file %s found in the load paths: \n%s" + name + (String.concat "\n" paths) + +let tag_not_handled tag = "Tag @"^tag^" not handled by this generator" +let bad_tree = "Incorrect tree structure." +let not_a_valid_tag s = s^" is not a valid tag." +let fun_without_param f = "Function "^f^" has no parameter.";; +let method_without_param f = "Méthode "^f^" has no parameter.";; +let anonymous_parameters f = "Function "^f^" has anonymous parameters." +let function_colon f = "Function "^f^": " +let implicit_match_in_parameter = "Parameters contain implicit pattern matching." +let unknown_extension f = "Unknown extension for file "^f^"." +let two_implementations name = "There are two implementations of module "^name^"." +let two_interfaces name = "There are two interfaces of module "^name^"." +let too_many_module_objects name = "There are two many interfaces/implementation of module "^name^"." +let exception_not_found_in_implementation exc m = "Exception "^exc^" was not found in implementation of module "^m^"." +let type_not_found_in_implementation exc m = "Type "^exc^" was not found in implementation of module "^m^"." +let module_not_found_in_implementation m m2 = "Module "^m^" was not found in implementation of module "^m2^"." +let value_not_found_in_implementation v m = "Value "^v^" was not found in implementation of module "^m^"." +let class_not_found_in_implementation c m = "Class "^c^" was not found in implementation of module "^m^"." +let attribute_not_found_in_implementation a c = "Attribute "^a^" was not found in implementation of class "^c^"." +let method_not_found_in_implementation m c = "Method "^m^" was not found in implementation of class "^c^"." +let different_types t = "Definition of type "^t^" doesn't match from interface to implementation." +let attribute_type_not_found cl att = "The type of the attribute "^att^" could not be found in the signature of class "^cl^"." +let method_type_not_found cl met = "The type of the method "^met^" could not be found in the signature of class "^cl^"." +let module_not_found m m2 = "The module "^m2^" could not be found in the signature of module "^m^"." +let module_type_not_found m mt = "The module type "^mt^" could not be found in the signature of module "^m^"." +let value_not_found m v = "The value "^v^" could not be found in the signature of module "^m^"." +let exception_not_found m e = "The exception "^e^" could not be found in the signature of module "^m^"." +let type_not_found m t = "The type "^t^" could not be found in the signature of module "^m^"." +let class_not_found m c = "The class "^c^" could not be found in the signature of module "^m^"." +let class_type_not_found m c = "The class type "^c^" could not be found in the signature of module "^m^"." +let type_not_found_in_typedtree t = "Type "^t^" was not found in typed tree." +let exception_not_found_in_typedtree e = "Exception "^e^" was not found in typed tree." +let module_type_not_found_in_typedtree mt = "Module type "^mt^" was not found in typed tree." +let module_not_found_in_typedtree m = "Module "^m^" was not found in typed tree." +let class_not_found_in_typedtree c = "Class "^c^" was not found in typed tree." +let class_type_not_found_in_typedtree ct = "Class type "^ct^" was not found in typed tree." +let inherit_classexp_not_found_in_typedtree n = "Inheritance class expression number "^(string_of_int n)^" was not found in typed tree." +let attribute_not_found_in_typedtree att = "Class attribute "^att^" was not found in typed tree." +let method_not_found_in_typedtree met = "Class method "^met^" was not found in typed tree." +let misplaced_comment file pos = + Printf.sprintf "Misplaced special comment in file %s, character %d." file pos + +let cross_module_not_found n = "Module "^n^" not found" +let cross_module_type_not_found n = "Module type "^n^" not found" +let cross_module_or_module_type_not_found n = "Module or module type "^n^" not found" +let cross_class_not_found n = "Class "^n^" not found" +let cross_class_type_not_found n = "class type "^n^" not found" +let cross_class_or_class_type_not_found n = "Class or class type "^n^" not found" +let cross_exception_not_found n = "Exception "^n^" not found" +let cross_element_not_found n = "Element "^n^" not found" +let cross_method_not_found n = "Method "^n^" not found" +let cross_attribute_not_found n = "Attribute "^n^" not found" +let cross_section_not_found n = "Section "^n^" not found" +let cross_value_not_found n = "Value "^n^" not found" +let cross_type_not_found n = "Type "^n^" not found" + +let object_end = "object ... end" +let struct_end = "struct ... end" +let sig_end = "sig ... end" + +(** Messages for verbose mode. *) + +let analysing f = "Analysing file "^f^"..." +let merging = "Merging..." +let cross_referencing = "Cross referencing..." +let generating_doc = "Generating documentation..." +let loading f = "Loading "^f^"..." +let file_generated f = "File "^f^" generated." +let file_exists_dont_generate f = + "File "^f^" exists, we don't generate it." + +(** Messages for documentation generation.*) + +let modul = "Module" +let modules = "Modules" +let functors = "Functors" +let values = "Simple values" +let types = "Types" +let exceptions = "Exceptions" +let record = "Record" +let variant = "Variant" +let mutab = "mutable" +let functions = "Functions" +let parameters = "Parameters" +let abstract = "Abstract" +let functo = "Functor" +let clas = "Class" +let classes = "Classes" +let attributes = "Attributes" +let methods = "Methods" +let authors = "Author(s)" +let version = "Version" +let since = "Since" +let before = "Before" +let deprecated = "Deprecated." +let raises = "Raises" +let returns = "Returns" +let inherits = "Inherits" +let inheritance = "Inheritance" +let privat = "private" +let module_type = "Module type" +let class_type = "Class type" +let description = "Description" +let interface = "Interface" +let type_parameters = "Type parameters" +let class_types = "Class types" +let module_types = "Module types" +let see_also = "See also" +let documentation = "Documentation" +let index_of = "Index of" +let top = "Top" +let index_of_values = index_of^" values" +let index_of_exceptions = index_of^" exceptions" +let index_of_types = index_of^" types" +let index_of_attributes = index_of^" class attributes" +let index_of_methods = index_of^" class methods" +let index_of_classes = index_of^" classes" +let index_of_class_types = index_of^" class types" +let index_of_modules = index_of^" modules" +let index_of_module_types = index_of^" module types" +let previous = "Previous" +let next = "Next" +let up = "Up" diff --git a/ocaml-binary-annot/ocamldoc/odoc_misc.ml b/ocaml-binary-annot/ocamldoc/odoc_misc.ml new file mode 100644 index 0000000000..c439ef3163 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_misc.ml @@ -0,0 +1,494 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +let no_blanks s = + let len = String.length s in + let buf = Buffer.create len in + for i = 0 to len - 1 do + match s.[i] with + ' ' | '\n' | '\t' | '\r' -> () + | c -> Buffer.add_char buf c + done; + Buffer.contents buf + +let input_file_as_string nom = + let chanin = open_in_bin nom in + let len = 1024 in + let s = String.create len in + let buf = Buffer.create len in + let rec iter () = + try + let n = input chanin s 0 len in + if n = 0 then + () + else + ( + Buffer.add_substring buf s 0 n; + iter () + ) + with + End_of_file -> () + in + iter (); + close_in chanin; + Buffer.contents buf + +let split_string s chars = + let len = String.length s in + let rec iter acc pos = + if pos >= len then + match acc with + "" -> [] + | _ -> [acc] + else + if List.mem s.[pos] chars then + match acc with + "" -> iter "" (pos + 1) + | _ -> acc :: (iter "" (pos + 1)) + else + iter (Printf.sprintf "%s%c" acc s.[pos]) (pos + 1) + in + iter "" 0 + +let split_with_blanks s = split_string s [' ' ; '\n' ; '\r' ; '\t' ] + +let list_concat sep = + let rec iter = function + [] -> [] + | [h] -> [h] + | h :: q -> h :: sep :: q + in + iter + +let rec string_of_longident li = + match li with + | Longident.Lident s -> s + | Longident.Ldot(li, s) -> string_of_longident li ^ "." ^ s + | Longident.Lapply(l1, l2) -> + string_of_longident l1 ^ "(" ^ string_of_longident l2 ^ ")" + +let get_fields type_expr = + let (fields, _) = Ctype.flatten_fields (Ctype.object_fields type_expr) in + List.fold_left + (fun acc -> fun (label, field_kind, typ) -> + match field_kind with + Types.Fabsent -> + acc + | _ -> + if label = "*dummy method*" then + acc + else + acc @ [label, typ] + ) + [] + fields + +let rec string_of_text t = + let rec iter t_ele = + match t_ele with + | Odoc_types.Raw s + | Odoc_types.Code s + | Odoc_types.CodePre s + | Odoc_types.Verbatim s -> s + | Odoc_types.Bold t + | Odoc_types.Italic t + | Odoc_types.Center t + | Odoc_types.Left t + | Odoc_types.Right t + | Odoc_types.Emphasize t -> string_of_text t + | Odoc_types.List l -> + (String.concat "" + (List.map (fun t -> "\n- "^(string_of_text t)) l))^ + "\n" + | Odoc_types.Enum l -> + let rec f n = function + [] -> "\n" + | t :: q -> + "\n"^(string_of_int n)^". "^(string_of_text t)^ + (f (n + 1) q) + in + f 1 l + | Odoc_types.Newline -> "\n" + | Odoc_types.Block t -> "\t"^(string_of_text t)^"\n" + | Odoc_types.Title (_, _, t) -> "\n"^(string_of_text t)^"\n" + | Odoc_types.Latex s -> "{% "^s^" %}" + | Odoc_types.Link (s, t) -> + "["^s^"]"^(string_of_text t) + | Odoc_types.Ref (name, _, Some text) -> + Printf.sprintf "[%s]" (string_of_text text) + | Odoc_types.Ref (name, _, None) -> + iter (Odoc_types.Code name) + | Odoc_types.Superscript t -> + "^{"^(string_of_text t)^"}" + | Odoc_types.Subscript t -> + "^{"^(string_of_text t)^"}" + | Odoc_types.Module_list l -> + string_of_text + (list_concat (Odoc_types.Raw ", ") + (List.map (fun s -> Odoc_types.Code s) l) + ) + | Odoc_types.Index_list -> + "" + | Odoc_types.Custom (_, t) -> string_of_text t + | Odoc_types.Target _ -> "" + in + String.concat "" (List.map iter t) + +let string_of_author_list l = + match l with + [] -> + "" + | _ -> + "* "^Odoc_messages.authors^":\n"^ + (String.concat ", " l)^ + "\n" + +let string_of_version_opt v_opt = + match v_opt with + None -> "" + | Some v -> Odoc_messages.version^": "^v^"\n" + +let string_of_since_opt s_opt = + match s_opt with + None -> "" + | Some s -> Odoc_messages.since^" "^s^"\n" + +let string_of_raised_exceptions l = + match l with + [] -> "" + | (s, t) :: [] -> Odoc_messages.raises^" "^s^" "^(string_of_text t)^"\n" + | _ -> + Odoc_messages.raises^"\n"^ + (String.concat "" + (List.map + (fun (ex, desc) -> "- "^ex^" "^(string_of_text desc)^"\n") + l + ) + )^"\n" + +let string_of_see (see_ref, t) = + let t_ref = + match see_ref with + Odoc_types.See_url s -> [ Odoc_types.Link (s, t) ] + | Odoc_types.See_file s -> (Odoc_types.Code s) :: (Odoc_types.Raw " ") :: t + | Odoc_types.See_doc s -> (Odoc_types.Italic [Odoc_types.Raw s]) :: (Odoc_types.Raw " ") :: t + in + string_of_text t_ref + +let string_of_sees l = + match l with + [] -> "" + | see :: [] -> Odoc_messages.see_also^" "^(string_of_see see)^" \n" + | _ -> + Odoc_messages.see_also^"\n"^ + (String.concat "" + (List.map + (fun see -> "- "^(string_of_see see)^"\n") + l + ) + )^"\n" + +let string_of_return_opt return_opt = + match return_opt with + None -> "" + | Some s -> Odoc_messages.returns^" "^(string_of_text s)^"\n" + +let string_of_info i = + let module M = Odoc_types in + (match i.M.i_deprecated with + None -> "" + | Some d -> Odoc_messages.deprecated^"! "^(string_of_text d)^"\n")^ + (match i.M.i_desc with + None -> "" + | Some d when d = [Odoc_types.Raw ""] -> "" + | Some d -> (string_of_text d)^"\n" + )^ + (string_of_author_list i.M.i_authors)^ + (string_of_version_opt i.M.i_version)^ + (string_of_since_opt i.M.i_since)^ + (string_of_raised_exceptions i.M.i_raised_exceptions)^ + (string_of_return_opt i.M.i_return_value) + +let apply_opt f v_opt = + match v_opt with + None -> None + | Some v -> Some (f v) + +let string_of_date ?(hour=true) d = + let add_0 s = if String.length s < 2 then "0"^s else s in + let t = Unix.localtime d in + (string_of_int (t.Unix.tm_year + 1900))^"-"^ + (add_0 (string_of_int (t.Unix.tm_mon + 1)))^"-"^ + (add_0 (string_of_int t.Unix.tm_mday))^ + ( + if hour then + " "^ + (add_0 (string_of_int t.Unix.tm_hour))^":"^ + (add_0 (string_of_int t.Unix.tm_min)) + else + "" + ) + + +let rec text_list_concat sep l = + match l with + [] -> [] + | [t] -> t + | t :: q -> + t @ (sep :: (text_list_concat sep q)) + +let rec text_no_title_no_list t = + let rec iter t_ele = + match t_ele with + | Odoc_types.Title (_,_,t) -> text_no_title_no_list t + | Odoc_types.List l + | Odoc_types.Enum l -> + (Odoc_types.Raw " ") :: + (text_list_concat + (Odoc_types.Raw ", ") + (List.map text_no_title_no_list l)) + | Odoc_types.Raw _ + | Odoc_types.Code _ + | Odoc_types.CodePre _ + | Odoc_types.Verbatim _ + | Odoc_types.Ref _ + | Odoc_types.Target _ -> [t_ele] + | Odoc_types.Newline -> [Odoc_types.Newline] + | Odoc_types.Block t -> [Odoc_types.Block (text_no_title_no_list t)] + | Odoc_types.Bold t -> [Odoc_types.Bold (text_no_title_no_list t)] + | Odoc_types.Italic t -> [Odoc_types.Italic (text_no_title_no_list t)] + | Odoc_types.Center t -> [Odoc_types.Center (text_no_title_no_list t)] + | Odoc_types.Left t -> [Odoc_types.Left (text_no_title_no_list t)] + | Odoc_types.Right t -> [Odoc_types.Right (text_no_title_no_list t)] + | Odoc_types.Emphasize t -> [Odoc_types.Emphasize (text_no_title_no_list t)] + | Odoc_types.Latex s -> [Odoc_types.Latex s] + | Odoc_types.Link (s, t) -> [Odoc_types.Link (s, (text_no_title_no_list t))] + | Odoc_types.Superscript t -> [Odoc_types.Superscript (text_no_title_no_list t)] + | Odoc_types.Subscript t -> [Odoc_types.Subscript (text_no_title_no_list t)] + | Odoc_types.Module_list l -> + list_concat (Odoc_types.Raw ", ") + (List.map + (fun s -> Odoc_types.Ref (s, Some Odoc_types.RK_module, None)) + l + ) + | Odoc_types.Index_list -> [] + | Odoc_types.Custom (s,t) -> [Odoc_types.Custom (s, text_no_title_no_list t)] + in + List.flatten (List.map iter t) + +let get_titles_in_text t = + let l = ref [] in + let rec iter_ele ele = + match ele with + | Odoc_types.Title (n,lopt,t) -> l := (n,lopt,t) :: !l + | Odoc_types.List l + | Odoc_types.Enum l -> List.iter iter_text l + | Odoc_types.Raw _ + | Odoc_types.Code _ + | Odoc_types.CodePre _ + | Odoc_types.Verbatim _ + | Odoc_types.Ref _ -> () + | Odoc_types.Newline -> () + | Odoc_types.Block t + | Odoc_types.Bold t + | Odoc_types.Italic t + | Odoc_types.Center t + | Odoc_types.Left t + | Odoc_types.Right t + | Odoc_types.Emphasize t -> iter_text t + | Odoc_types.Latex s -> () + | Odoc_types.Link (_, t) + | Odoc_types.Superscript t + | Odoc_types.Subscript t -> iter_text t + | Odoc_types.Module_list _ -> () + | Odoc_types.Index_list -> () + | Odoc_types.Custom (_, t) -> iter_text t + | Odoc_types.Target _ -> () + and iter_text te = + List.iter iter_ele te + in + iter_text t; + List.rev !l + +let text_concat (sep : Odoc_types.text) l = + let rec iter = function + [] -> [] + | [last] -> last + | h :: q -> h @ sep @ (iter q) + in + iter l + +(*********************************************************) +let rec get_before_dot s = + try + let len = String.length s in + let n = String.index s '.' in + if n + 1 >= len then + (* le point est le dernier caractère *) + (true, s, "") + else + match s.[n+1] with + ' ' | '\n' | '\r' | '\t' -> + (true, String.sub s 0 (n+1), + String.sub s (n+1) (len - n - 1)) + | _ -> + let b, s2, s_after = get_before_dot (String.sub s (n + 1) (len - n - 1)) in + (b, (String.sub s 0 (n+1))^s2, s_after) + with + Not_found -> (false, s, "") + +let rec first_sentence_text t = + match t with + [] -> (false, [], []) + | ele :: q -> + let (stop, ele2, ele3_opt) = first_sentence_text_ele ele in + if stop then + (stop, [ele2], + match ele3_opt with None -> q | Some e -> e :: q) + else + let (stop2, q2, rest) = first_sentence_text q in + (stop2, ele2 :: q2, rest) + + +and first_sentence_text_ele text_ele = + match text_ele with + | Odoc_types.Raw s -> + let b, s2, s_after = get_before_dot s in + (b, Odoc_types.Raw s2, Some (Odoc_types.Raw s_after)) + | Odoc_types.Code _ + | Odoc_types.CodePre _ + | Odoc_types.Verbatim _ -> (false, text_ele, None) + | Odoc_types.Bold t -> + let (b, t2, t3) = first_sentence_text t in + (b, Odoc_types.Bold t2, Some (Odoc_types.Bold t3)) + | Odoc_types.Italic t -> + let (b, t2, t3) = first_sentence_text t in + (b, Odoc_types.Italic t2, Some (Odoc_types.Italic t3)) + | Odoc_types.Center t -> + let (b, t2, t3) = first_sentence_text t in + (b, Odoc_types.Center t2, Some (Odoc_types.Center t3)) + | Odoc_types.Left t -> + let (b, t2, t3) = first_sentence_text t in + (b, Odoc_types.Left t2, Some (Odoc_types.Left t3)) + | Odoc_types.Right t -> + let (b, t2, t3) = first_sentence_text t in + (b, Odoc_types.Right t2, Some (Odoc_types.Right t3)) + | Odoc_types.Emphasize t -> + let (b, t2, t3) = first_sentence_text t in + (b, Odoc_types.Emphasize t2, Some (Odoc_types.Emphasize t3)) + | Odoc_types.Block t -> + let (b, t2, t3) = first_sentence_text t in + (b, Odoc_types.Block t2, Some (Odoc_types.Block t3)) + | Odoc_types.Title (n, l_opt, t) -> + let (b, t2, t3) = first_sentence_text t in + (b, + Odoc_types.Title (n, l_opt, t2), + Some (Odoc_types.Title (n, l_opt, t3))) + | Odoc_types.Newline -> + (true, Odoc_types.Raw "", Some Odoc_types.Newline) + | Odoc_types.List _ + | Odoc_types.Enum _ + | Odoc_types.Latex _ + | Odoc_types.Link _ + | Odoc_types.Ref _ + | Odoc_types.Superscript _ + | Odoc_types.Subscript _ + | Odoc_types.Module_list _ + | Odoc_types.Index_list -> (false, text_ele, None) + | Odoc_types.Custom _ + | Odoc_types.Target _ -> (false, text_ele, None) + + +let first_sentence_of_text t = + let (_,t2,_) = first_sentence_text t in + t2 + +let first_sentence_and_rest_of_text t = + let (_,t1, t2) = first_sentence_text t in + (t1, t2) + +let remove_ending_newline s = + let len = String.length s in + if len <= 0 then + s + else + match s.[len-1] with + '\n' -> String.sub s 0 (len-1) + | _ -> s + +let search_string_backward ~pat = + let lenp = String.length pat in + let rec iter s = + let len = String.length s in + match compare len lenp with + -1 -> raise Not_found + | 0 -> if pat = s then 0 else raise Not_found + | _ -> + let pos = len - lenp in + let s2 = String.sub s pos lenp in + if s2 = pat then + pos + else + iter (String.sub s 0 pos) + in + fun ~s -> iter s + + + +(*********************************************************) + +let create_index_lists elements string_of_ele = + let rec f current acc0 acc1 acc2 = function + [] -> (acc0 :: acc1) @ [acc2] + | ele :: q -> + let s = string_of_ele ele in + match s with + "" -> f current acc0 acc1 (acc2 @ [ele]) q + | _ -> + let first = Char.uppercase s.[0] in + match first with + 'A' .. 'Z' -> + if current = first then + f current acc0 acc1 (acc2 @ [ele]) q + else + f first acc0 (acc1 @ [acc2]) [ele] q + | _ -> + f current (acc0 @ [ele]) acc1 acc2 q + in + f '_' [] [] [] elements + + +(*** for labels *) + +let is_optional = Btype.is_optional +let label_name = Btype.label_name + +let remove_option typ = + let rec iter t = + match t with + | Types.Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty.Types.desc + | Types.Tconstr _ + | Types.Tvar + | Types.Tunivar + | Types.Tpoly _ + | Types.Tarrow _ + | Types.Ttuple _ + | Types.Tobject _ + | Types.Tfield _ + | Types.Tnil + | Types.Tvariant _ + | Types.Tpackage _ -> t + | Types.Tlink t2 + | Types.Tsubst t2 -> iter t2.Types.desc + in + { typ with Types.desc = iter typ.Types.desc } diff --git a/ocaml-binary-annot/ocamldoc/odoc_misc.mli b/ocaml-binary-annot/ocamldoc/odoc_misc.mli new file mode 100644 index 0000000000..4fc83fe89b --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_misc.mli @@ -0,0 +1,115 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Miscelaneous functions *) + +(** [no_blanks s] returns the given string without any blank + characters, i.e. '\n' '\r' ' ' '\t'. +*) +val no_blanks : string -> string + +(** This function returns a file in the form of one string.*) +val input_file_as_string : string -> string + +(** [split_with_blanks s] splits the given string [s] according to blanks. *) +val split_with_blanks : string -> string list + +(** This function creates a string from a Longident.t .*) +val string_of_longident : Longident.t -> string + +(** This function returns the list of (label, type_expr) describing + the methods of a type_expr in a Tobject.*) +val get_fields : Types.type_expr -> (string * Types.type_expr) list + +(** get a string from a text *) +val string_of_text : Odoc_types.text -> string + +(** @return a string for an authors list. *) +val string_of_author_list : string list -> string + +(** @return a string for the given optional version information.*) +val string_of_version_opt : string option -> string + +(** @return a string for the given optional since information.*) +val string_of_since_opt : string option -> string + +(** @return a string for the given list of raised exceptions.*) +val string_of_raised_exceptions : (string * Odoc_types.text) list -> string + +(** @return a string for the given "see also" reference.*) +val string_of_see : Odoc_types.see_ref * Odoc_types.text -> string + +(** @return a string for the given list of "see also" references.*) +val string_of_sees : (Odoc_types.see_ref * Odoc_types.text) list -> string + +(** @return a string for the given optional return information.*) +val string_of_return_opt : Odoc_types.text option -> string + +(** get a string from a Odoc_info.info structure *) +val string_of_info : Odoc_types.info -> string + +(** Apply a function to an optional value. *) +val apply_opt : ('a -> 'b) -> 'a option -> 'b option + +(** Return a string representing a date given as a number of seconds + since 1970. The hour is optionnaly displayed. *) +val string_of_date : ?hour:bool -> float -> string + +(** Return the first sentence (until the first dot) of a text. + Don't stop in the middle of [Code], [Verbatim], [List], [Lnum], + [Latex], [Link], or [Ref]. *) +val first_sentence_of_text : Odoc_types.text -> Odoc_types.text + +(** Return the first sentence (until the first dot) of a text, + and the remaining text after. + Don't stop in the middle of [Code], [Verbatim], [List], [Lnum], + [Latex], [Link], or [Ref]. *) +val first_sentence_and_rest_of_text : + Odoc_types.text -> Odoc_types.text * Odoc_types.text + +(** Return the given [text] without any title or list. *) +val text_no_title_no_list : Odoc_types.text -> Odoc_types.text + +(** [concat sep l] concats the given list of text [l], each separated with + the text [sep]. *) +val text_concat : Odoc_types.text -> Odoc_types.text list -> Odoc_types.text + +(** Return the list of titles in a [text]. + A title is a title level, an optional label and a text.*) +val get_titles_in_text : Odoc_types.text -> (int * string option * Odoc_types.text) list + +(** Take a sorted list of elements, a function to get the name + of an element and return the list of list of elements, + where each list group elements beginning by the same letter. + Since the original list is sorted, elements whose name does not + begin with a letter should be in the first returned list.*) +val create_index_lists : 'a list -> ('a -> string) -> 'a list list + +(** [remove_ending_newline s] returns [s] without the optional ending newline. *) +val remove_ending_newline : string -> string + +(** [search_string_backward pat s] searches backward string [pat] in string [s]. + Return position in string [s] where [pat] appears, orelse raise [Not_found]. *) +val search_string_backward : pat: string -> s: string -> int + +(** Take a type and remove the option top constructor. This is + useful when printing labels, we we then remove the top option contructor + for optional labels.*) +val remove_option : Types.type_expr -> Types.type_expr + +(** Return [true] if the given label is optional.*) +val is_optional : string -> bool + +(** Return the label name for the given label, + i.e. removes the beginning '?' if present.*) +val label_name : string -> string diff --git a/ocaml-binary-annot/ocamldoc/odoc_module.ml b/ocaml-binary-annot/ocamldoc/odoc_module.ml new file mode 100644 index 0000000000..cc1fe02ca8 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_module.ml @@ -0,0 +1,535 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Representation and manipulation of modules and module types. *) + +let print_DEBUG s = print_string s ; print_newline () + +module Name = Odoc_name + +(** To keep the order of elements in a module. *) +type module_element = + Element_module of t_module + | Element_module_type of t_module_type + | Element_included_module of included_module + | Element_class of Odoc_class.t_class + | Element_class_type of Odoc_class.t_class_type + | Element_value of Odoc_value.t_value + | Element_exception of Odoc_exception.t_exception + | Element_type of Odoc_type.t_type + | Element_module_comment of Odoc_types.text + +(** Used where we can reference t_module or t_module_type *) +and mmt = + | Mod of t_module + | Modtype of t_module_type + +and included_module = { + im_name : Name.t ; (** the name of the included module *) + mutable im_module : mmt option ; (** the included module or module type *) + mutable im_info : Odoc_types.info option ; (** comment associated to the includ directive *) + } + +and module_alias = { + ma_name : Name.t ; + mutable ma_module : mmt option ; (** the real module or module type if we could associate it *) + } + +and module_parameter = { + mp_name : string ; (** the name *) + mp_type : Types.module_type ; (** the type *) + mp_type_code : string ; (** the original code *) + mp_kind : module_type_kind ; (** the way the parameter was built *) + } + +(** Different kinds of module. *) +and module_kind = + | Module_struct of module_element list + | Module_alias of module_alias (** complete name and corresponding module if we found it *) + | Module_functor of module_parameter * module_kind + | Module_apply of module_kind * module_kind + | Module_with of module_type_kind * string + | Module_constraint of module_kind * module_type_kind + | Module_typeof of string (** by now only the code of the module expression *) + | Module_unpack of string * module_type_alias (** code of the expression and module type alias *) + +(** Representation of a module. *) +and t_module = { + m_name : Name.t ; + mutable m_type : Types.module_type ; + mutable m_info : Odoc_types.info option ; + m_is_interface : bool ; (** true for modules read from interface files *) + m_file : string ; (** the file the module is defined in. *) + mutable m_kind : module_kind ; + mutable m_loc : Odoc_types.location ; + mutable m_top_deps : Name.t list ; (** The toplevels module names this module depends on. *) + mutable m_code : string option ; (** The whole code of the module *) + mutable m_code_intf : string option ; (** The whole code of the interface of the module *) + m_text_only : bool ; (** [true] if the module comes from a text file *) + } + +and module_type_alias = { + mta_name : Name.t ; + mutable mta_module : t_module_type option ; (** the real module type if we could associate it *) + } + +(** Different kinds of module type. *) +and module_type_kind = + | Module_type_struct of module_element list + | Module_type_functor of module_parameter * module_type_kind + | Module_type_alias of module_type_alias (** complete name and corresponding module type if we found it *) + | Module_type_with of module_type_kind * string (** the module type kind and the code of the with constraint *) + | Module_type_typeof of string (** by now only the code of the module expression *) + +(** Representation of a module type. *) +and t_module_type = { + mt_name : Name.t ; + mutable mt_info : Odoc_types.info option ; + mutable mt_type : Types.module_type option ; (** [None] = abstract module type *) + mt_is_interface : bool ; (** true for modules read from interface files *) + mt_file : string ; (** the file the module type is defined in. *) + mutable mt_kind : module_type_kind option ; (** [None] = abstract module type if mt_type = None ; + Always [None] when the module type was extracted from the implementation file. *) + mutable mt_loc : Odoc_types.location ; + } + + +(** {2 Functions} *) + +(** Returns the list of values from a list of module_element. *) +let values l = + List.fold_left + (fun acc -> fun ele -> + match ele with + Element_value v -> acc @ [v] + | _ -> acc + ) + [] + l + +(** Returns the list of types from a list of module_element. *) +let types l = + List.fold_left + (fun acc -> fun ele -> + match ele with + Element_type t -> acc @ [t] + | _ -> acc + ) + [] + l + +(** Returns the list of exceptions from a list of module_element. *) +let exceptions l = + List.fold_left + (fun acc -> fun ele -> + match ele with + Element_exception e -> acc @ [e] + | _ -> acc + ) + [] + l + +(** Returns the list of classes from a list of module_element. *) +let classes l = + List.fold_left + (fun acc -> fun ele -> + match ele with + Element_class c -> acc @ [c] + | _ -> acc + ) + [] + l + +(** Returns the list of class types from a list of module_element. *) +let class_types l = + List.fold_left + (fun acc -> fun ele -> + match ele with + Element_class_type ct -> acc @ [ct] + | _ -> acc + ) + [] + l + +(** Returns the list of modules from a list of module_element. *) +let modules l = + List.fold_left + (fun acc -> fun ele -> + match ele with + Element_module m -> acc @ [m] + | _ -> acc + ) + [] + l + +(** Returns the list of module types from a list of module_element. *) +let mod_types l = + List.fold_left + (fun acc -> fun ele -> + match ele with + Element_module_type mt -> acc @ [mt] + | _ -> acc + ) + [] + l + +(** Returns the list of module comment from a list of module_element. *) +let comments l = + List.fold_left + (fun acc -> fun ele -> + match ele with + Element_module_comment t -> acc @ [t] + | _ -> acc + ) + [] + l + +(** Returns the list of included modules from a list of module_element. *) +let included_modules l = + List.fold_left + (fun acc -> fun ele -> + match ele with + Element_included_module m -> acc @ [m] + | _ -> acc + ) + [] + l + +(** Returns the list of elements of a module. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +let rec module_elements ?(trans=true) m = + let rec iter_kind = function + Module_struct l -> + print_DEBUG "Odoc_module.module_element: Module_struct"; + l + | Module_alias ma -> + print_DEBUG "Odoc_module.module_element: Module_alias"; + if trans then + match ma.ma_module with + None -> [] + | Some (Mod m) -> module_elements m + | Some (Modtype mt) -> module_type_elements mt + else + [] + | Module_functor (_, k) + | Module_apply (k, _) -> + print_DEBUG "Odoc_module.module_element: Module_functor ou Module_apply"; + iter_kind k + | Module_with (tk,_) -> + print_DEBUG "Odoc_module.module_element: Module_with"; + module_type_elements ~trans: trans + { mt_name = "" ; mt_info = None ; mt_type = None ; + mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ; + mt_loc = Odoc_types.dummy_loc ; + } + | Module_constraint (k, tk) -> + print_DEBUG "Odoc_module.module_element: Module_constraint"; + (* A VOIR : utiliser k ou tk ? *) + module_elements ~trans: trans + { m_name = "" ; + m_info = None ; + m_type = Types.Tmty_signature [] ; + m_is_interface = false ; m_file = "" ; m_kind = k ; + m_loc = Odoc_types.dummy_loc ; + m_top_deps = [] ; + m_code = None ; + m_code_intf = None ; + m_text_only = false ; + } + | Module_typeof _ -> [] + | Module_unpack _ -> [] +(* + module_type_elements ~trans: trans + { mt_name = "" ; mt_info = None ; mt_type = None ; + mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ; + mt_loc = Odoc_types.dummy_loc } +*) + in + iter_kind m.m_kind + +(** Returns the list of elements of a module type. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +and module_type_elements ?(trans=true) mt = + let rec iter_kind = function + | None -> [] + | Some (Module_type_struct l) -> l + | Some (Module_type_functor (_, k)) -> iter_kind (Some k) + | Some (Module_type_with (k, _)) -> + if trans then + iter_kind (Some k) + else + [] + | Some (Module_type_alias mta) -> + if trans then + match mta.mta_module with + None -> [] + | Some mt -> module_type_elements mt + else + [] + | Some (Module_type_typeof _) -> [] + in + iter_kind mt.mt_kind + +(** Returns the list of values of a module. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +let module_values ?(trans=true) m = values (module_elements ~trans m) + +(** Returns the list of functional values of a module. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +let module_functions ?(trans=true) m = + List.filter + (fun v -> Odoc_value.is_function v) + (values (module_elements ~trans m)) + +(** Returns the list of non-functional values of a module. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +let module_simple_values ?(trans=true) m = + List.filter + (fun v -> not (Odoc_value.is_function v)) + (values (module_elements ~trans m)) + +(** Returns the list of types of a module. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +let module_types ?(trans=true) m = types (module_elements ~trans m) + +(** Returns the list of excptions of a module. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +let module_exceptions ?(trans=true) m = exceptions (module_elements ~trans m) + +(** Returns the list of classes of a module. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +let module_classes ?(trans=true) m = classes (module_elements ~trans m) + +(** Returns the list of class types of a module. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +let module_class_types ?(trans=true) m = class_types (module_elements ~trans m) + +(** Returns the list of modules of a module. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +let module_modules ?(trans=true) m = modules (module_elements ~trans m) + +(** Returns the list of module types of a module. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +let module_module_types ?(trans=true) m = mod_types (module_elements ~trans m) + +(** Returns the list of included module of a module. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +let module_included_modules ?(trans=true) m = included_modules (module_elements ~trans m) + +(** Returns the list of comments of a module. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +let module_comments ?(trans=true) m = comments (module_elements ~trans m) + +(** Access to the parameters, for a functor type. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +let rec module_type_parameters ?(trans=true) mt = + let rec iter k = + match k with + Some (Module_type_functor (p, k2)) -> + let param = + (* we create the couple (parameter, description opt), using + the description of the parameter if we can find it in the comment.*) + match mt.mt_info with + None -> (p, None) + | Some i -> + try + let d = List.assoc p.mp_name i.Odoc_types.i_params in + (p, Some d) + with + Not_found -> + (p, None) + in + param :: (iter (Some k2)) + | Some (Module_type_alias mta) -> + if trans then + match mta.mta_module with + None -> [] + | Some mt2 -> module_type_parameters ~trans mt2 + else + [] + | Some (Module_type_with (k, _)) -> + if trans then + iter (Some k) + else + [] + | Some (Module_type_struct _) -> + [] + | Some (Module_type_typeof _) -> [] + | None -> + [] + in + iter mt.mt_kind + +(** Access to the parameters, for a functor. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +and module_parameters ?(trans=true) m = + let rec iter = function + Module_functor (p, k) -> + let param = + (* we create the couple (parameter, description opt), using + the description of the parameter if we can find it in the comment.*) + match m.m_info with + None ->(p, None) + | Some i -> + try + let d = List.assoc p.mp_name i.Odoc_types.i_params in + (p, Some d) + with + Not_found -> + (p, None) + in + param :: (iter k) + + | Module_alias ma -> + if trans then + match ma.ma_module with + None -> [] + | Some (Mod m) -> module_parameters ~trans m + | Some (Modtype mt) -> module_type_parameters ~trans mt + else + [] + | Module_constraint (k, tk) -> + module_type_parameters ~trans: trans + { mt_name = "" ; mt_info = None ; mt_type = None ; + mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ; + mt_loc = Odoc_types.dummy_loc } + | Module_struct _ + | Module_apply _ + | Module_with _ + | Module_typeof _ + | Module_unpack _ -> [] + in + iter m.m_kind + +(** access to all submodules and sudmobules of submodules ... of the given module. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +let rec module_all_submodules ?(trans=true) m = + let l = module_modules ~trans m in + List.fold_left + (fun acc -> fun m -> acc @ (module_all_submodules ~trans m)) + l + l + +(** The module type is a functor if is defined as a functor or if it is an alias for a functor. *) +let rec module_type_is_functor mt = + let rec iter k = + match k with + Some (Module_type_functor _) -> true + | Some (Module_type_alias mta) -> + ( + match mta.mta_module with + None -> false + | Some mtyp -> module_type_is_functor mtyp + ) + | Some (Module_type_with (k, _)) -> + iter (Some k) + | Some (Module_type_struct _) + | Some (Module_type_typeof _) + | None -> false + in + iter mt.mt_kind + +(** The module is a functor if is defined as a functor or if it is an alias for a functor. *) +let module_is_functor m = + let rec iter = function + Module_functor _ -> true + | Module_alias ma -> + ( + match ma.ma_module with + None -> false + | Some (Mod mo) -> iter mo.m_kind + | Some (Modtype mt) -> module_type_is_functor mt + ) + | Module_constraint (k, _) -> + iter k + | _ -> false + in + iter m.m_kind + +(** Returns the list of values of a module type. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +let module_type_values ?(trans=true) m = values (module_type_elements ~trans m) + +(** Returns the list of types of a module. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +let module_type_types ?(trans=true) m = types (module_type_elements ~trans m) + +(** Returns the list of excptions of a module. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +let module_type_exceptions ?(trans=true) m = exceptions (module_type_elements ~trans m) + +(** Returns the list of classes of a module. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +let module_type_classes ?(trans=true) m = classes (module_type_elements ~trans m) + +(** Returns the list of class types of a module. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +let module_type_class_types ?(trans=true) m = class_types (module_type_elements ~trans m) + +(** Returns the list of modules of a module. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +let module_type_modules ?(trans=true) m = modules (module_type_elements ~trans m) + +(** Returns the list of module types of a module. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +let module_type_module_types ?(trans=true) m = mod_types (module_type_elements ~trans m) + +(** Returns the list of included module of a module. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +let module_type_included_modules ?(trans=true) m = included_modules (module_type_elements ~trans m) + +(** Returns the list of comments of a module. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +let module_type_comments ?(trans=true) m = comments (module_type_elements ~trans m) + +(** Returns the list of functional values of a module type. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +let module_type_functions ?(trans=true) mt = + List.filter + (fun v -> Odoc_value.is_function v) + (values (module_type_elements ~trans mt)) + +(** Returns the list of non-functional values of a module type. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +let module_type_simple_values ?(trans=true) mt = + List.filter + (fun v -> not (Odoc_value.is_function v)) + (values (module_type_elements ~trans mt)) + +(** {2 Functions for modules and module types} *) + +(** The list of classes defined in this module and all its modules, functors, .... + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +let rec module_all_classes ?(trans=true) m = + List.fold_left + (fun acc -> fun m -> acc @ (module_all_classes ~trans m)) + ( + List.fold_left + (fun acc -> fun mtyp -> acc @ (module_type_all_classes ~trans mtyp)) + (module_classes ~trans m) + (module_module_types ~trans m) + ) + (module_modules ~trans m) + +(** The list of classes defined in this module type and all its modules, functors, .... + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +and module_type_all_classes ?(trans=true) mt = + List.fold_left + (fun acc -> fun m -> acc @ (module_all_classes ~trans m)) + ( + List.fold_left + (fun acc -> fun mtyp -> acc @ (module_type_all_classes ~trans mtyp)) + (module_type_classes ~trans mt) + (module_type_module_types ~trans mt) + ) + (module_type_modules ~trans mt) diff --git a/ocaml-binary-annot/ocamldoc/odoc_name.ml b/ocaml-binary-annot/ocamldoc/odoc_name.ml new file mode 100644 index 0000000000..b82cf87458 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_name.ml @@ -0,0 +1,217 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Representation of element names. *) + +let infix_chars = [ '|' ; + '<' ; + '>' ; + '@' ; + '^' ; + '&' ; + '+' ; + '-' ; + '*' ; + '/' ; + '$' ; + '%' ; + '=' ; + ':' ; + '~' ; + '!' ; + ] + +type t = string + +let strip_string s = + let len = String.length s in + let rec iter_first n = + if n >= len then + None + else + match s.[n] with + ' ' | '\t' | '\n' | '\r' -> iter_first (n+1) + | _ -> Some n + in + match iter_first 0 with + None -> "" + | Some first -> + let rec iter_last n = + if n <= first then + None + else + match s.[n] with + ' ' | '\t' | '\n' | '\r' -> iter_last (n-1) + | _ -> Some n + in + match iter_last (len-1) with + None -> String.sub s first 1 + | Some last -> String.sub s first ((last-first)+1) + +let parens_if_infix name = + match strip_string name with + | "" -> "" + | s when s.[0] = '*' || s.[String.length s - 1] = '*' -> "( " ^ s ^ " )" + | s when List.mem s.[0] infix_chars -> "(" ^ s ^ ")" + | "or" | "mod" | "land" | "lor" | "lxor" | "lsl" | "lsr" | "asr" -> + "(" ^ name ^ ")" + | name -> name +;; + +let cut name = + match name with + "" -> ("", "") + | s -> + let len = String.length s in + match s.[len-1] with + ')' -> + ( + let j = ref 0 in + let buf = [|Buffer.create len ; Buffer.create len |] in + for i = 0 to len - 1 do + match s.[i] with + '.' when !j = 0 -> + if i < len - 1 then + match s.[i+1] with + '(' -> + j := 1 + | _ -> + Buffer.add_char buf.(!j) '.' + else + Buffer.add_char buf.(!j) s.[i] + | c -> + Buffer.add_char buf.(!j) c + done; + (Buffer.contents buf.(0), Buffer.contents buf.(1)) + ) + | _ -> + match List.rev (Str.split (Str.regexp_string ".") s) with + [] -> ("", "") + | h :: q -> + (String.concat "." (List.rev q), h) + +let simple name = snd (cut name) +let father name = fst (cut name) + +let concat n1 n2 = n1^"."^n2 + +let normalize_name name = + let (p,s) = cut name in + let len = String.length s in + let s = + if len >= 2 && + s.[0] = '(' && s.[len - 1] = ')' + then + parens_if_infix (strip_string (String.sub s 1 (len - 2))) + else + s + in + match p with + "" -> s + | p -> concat p s + ;; + +let head_and_tail n = + try + let pos = String.index n '.' in + if pos > 0 then + let h = String.sub n 0 pos in + try + ignore (String.index h '('); + (n, "") + with + Not_found -> + let len = String.length n in + if pos >= (len - 1) then + (h, "") + else + (h, String.sub n (pos + 1) (len - pos - 1)) + else + (n, "") + with + Not_found -> (n, "") + +let head n = fst (head_and_tail n) +let tail n = snd (head_and_tail n) + +let depth name = + try + List.length (Str.split (Str.regexp "\\.") name) + with + _ -> 1 + +let prefix n1 n2 = + (n1 <> n2) & + (try + let len1 = String.length n1 in + ((String.sub n2 0 len1) = n1) & + (n2.[len1] = '.') + with _ -> false) + +let rec get_relative_raw n1 n2 = + let (f1,s1) = head_and_tail n1 in + let (f2,s2) = head_and_tail n2 in + if f1 = f2 then + if f2 = s2 or s2 = "" then + s2 + else + if f1 = s1 or s1 = "" then + s2 + else + get_relative_raw s1 s2 + else + n2 + +let get_relative n1 n2 = + if prefix n1 n2 then + let len1 = String.length n1 in + try + String.sub n2 (len1+1) ((String.length n2) - len1 - 1) + with + _ -> n2 + else + n2 + +let hide_given_modules l s = + let rec iter = function + [] -> s + | h :: q -> + let s2 = get_relative h s in + if s = s2 then + iter q + else + s2 + in + iter l + +let qualified name = String.contains name '.' + +let from_ident ident = Ident.name ident + + +let from_path path = Path.name path + +let to_path n = + match + List.fold_left + (fun acc_opt -> fun s -> + match acc_opt with + None -> Some (Path.Pident (Ident.create s)) + | Some acc -> Some (Path.Pdot (acc, s, 0))) + None + (Str.split (Str.regexp "\\.") n) + with + None -> raise (Failure "to_path") + | Some p -> p + +let from_longident = Odoc_misc.string_of_longident diff --git a/ocaml-binary-annot/ocamldoc/odoc_name.mli b/ocaml-binary-annot/ocamldoc/odoc_name.mli new file mode 100644 index 0000000000..e3b43a7867 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_name.mli @@ -0,0 +1,69 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Representation of element names. *) + +type t = string + +(** Add parenthesis to the given simple name if needed. *) +val parens_if_infix : t -> t + +(** Return a simple name from a name.*) +val simple : t -> t + +(** Return the name of the 'father' (like dirname for a file name).*) +val father : t -> t + +(** Concatenates two names. *) +val concat : t -> t -> t + +(** Normalize the given name by removing the beginning and ending spaces + of the simple name and adding parenthesis if needed. *) +val normalize_name : t -> t + +(** Returns the head of a name. *) +val head : t -> t + +(** Returns the depth of the name, i.e. the numer of levels to the root. + Example : [Toto.Tutu.name] has depth 3. *) +val depth : t -> int + +(** Returns true if the first name is a prefix of the second name. + If the two names are equals, then if is false (strict prefix).*) +val prefix : t -> t -> bool + +(** Take two names n1 and n2 = n3.n4 and return n4 if n3=n1 or else n2. *) +val get_relative : t -> t -> t + +(** Take two names n1=n3.n4 and n2 = n5.n6 and return n6 if n3=n5 or else n2. *) +val get_relative_raw : t -> t -> t + +(** Take a list of module names to hide and a name, + and return the name when the module name (or part of it) + was removed, according to the list of module names to hide.*) +val hide_given_modules : t list -> t -> t + +(** Indicate if a name if qualified or not. *) +val qualified : t -> bool + +(** Get a name from an [Ident.t]. *) +val from_ident : Ident.t -> t + +(** Get a name from a [Path.t]. *) +val from_path : Path.t -> t + +(** Get a [Path.t] from a name.*) +val to_path : t -> Path.t + +(** Get a name from a [Longident.t].*) +val from_longident : Longident.t -> t diff --git a/ocaml-binary-annot/ocamldoc/odoc_ocamlhtml.mll b/ocaml-binary-annot/ocamldoc/odoc_ocamlhtml.mll new file mode 100644 index 0000000000..6364a900f6 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_ocamlhtml.mll @@ -0,0 +1,545 @@ + +{ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Generation of html code to display OCaml code. *) +open Lexing + +exception Fatal_error + +let fatal_error msg = + prerr_string ">> Fatal error: "; prerr_endline msg; raise Fatal_error + +type error = + | Illegal_character of char + | Unterminated_comment + | Unterminated_string + | Unterminated_string_in_comment + | Keyword_as_label of string +;; + +exception Error of error * int * int + +let base_escape_strings = [ + ("&", "&") ; + ("<", "<") ; + (">", ">") ; +] + +let pre_escape_strings = [ + (" ", " ") ; + ("\n", "<br>\n") ; + ("\t", " ") ; + ] + + +let pre = ref false +let fmt = ref Format.str_formatter + +(** Escape the strings which would clash with html syntax, + and some other strings if we want to get a PRE style.*) +let escape s = + List.fold_left + (fun acc -> fun (s, s2) -> Str.global_replace (Str.regexp s) s2 acc) + s + (if !pre then base_escape_strings @ pre_escape_strings else base_escape_strings) + +(** Escape the strings which would clash with html syntax. *) +let escape_base s = + List.fold_left + (fun acc -> fun (s, s2) -> Str.global_replace (Str.regexp s) s2 acc) + s + base_escape_strings + +(** The output functions *) + +let print ?(esc=true) s = + Format.pp_print_string !fmt (if esc then escape s else s) +;; + +let print_class ?(esc=true) cl s = + print ~esc: false ("<span class=\""^cl^"\">"^ + (if esc then escape s else s)^ + "</span>") +;; + +(** The table of keywords with colors *) +let create_hashtable size init = + let tbl = Hashtbl.create size in + List.iter (fun (key, data) -> Hashtbl.add tbl key data) init; + tbl + +(** The function used to return html code for the given comment body. *) +let html_of_comment = ref + (fun (s : string) -> "<b>Odoc_ocamlhtml.html_of_comment not initialized</b>") + +let keyword_table = + create_hashtable 149 [ + "and", "keyword" ; + "as", "keyword" ; + "assert", "keyword" ; + "begin", "keyword" ; + "class", "keyword" ; + "constraint", "keyword" ; + "do", "keyword" ; + "done", "keyword" ; + "downto", "keyword" ; + "else", "keyword" ; + "end", "keyword" ; + "exception", "keyword" ; + "external", "keyword" ; + "false", "keyword" ; + "for", "keyword" ; + "fun", "keyword" ; + "function", "keyword" ; + "functor", "keyword" ; + "if", "keyword" ; + "in", "keyword" ; + "include", "keyword" ; + "inherit", "keyword" ; + "initializer", "keyword" ; + "lazy", "keyword" ; + "let", "keyword" ; + "match", "keyword" ; + "method", "keyword" ; + "module", "keyword" ; + "mutable", "keyword" ; + "new", "keyword" ; + "object", "keyword" ; + "of", "keyword" ; + "open", "keyword" ; + "or", "keyword" ; + "parser", "keyword" ; + "private", "keyword" ; + "rec", "keyword" ; + "sig", "keyword" ; + "struct", "keyword" ; + "then", "keyword" ; + "to", "keyword" ; + "true", "keyword" ; + "try", "keyword" ; + "type", "keyword" ; + "val", "keyword" ; + "virtual", "keyword" ; + "when", "keyword" ; + "while", "keyword" ; + "with", "keyword" ; + + "mod", "keyword" ; + "land", "keyword" ; + "lor", "keyword" ; + "lxor", "keyword" ; + "lsl", "keyword" ; + "lsr", "keyword" ; + "asr", "keyword" ; +] + +let kwsign_class = "keywordsign" +let constructor_class = "constructor" +let comment_class = "comment" +let string_class = "string" +let code_class = "code" + + +(** To buffer and print comments *) + + +let margin = ref 0 + +let comment_buffer = Buffer.create 32 +let reset_comment_buffer () = Buffer.reset comment_buffer +let store_comment_char = Buffer.add_char comment_buffer +let add_comment_string = Buffer.add_string comment_buffer + +let make_margin () = + let rec iter n = + if n <= 0 then "" + else " "^(iter (n-1)) + in + iter !margin + +let print_comment () = + let s = Buffer.contents comment_buffer in + let len = String.length s in + let code = + if len < 1 then + "<span class=\""^comment_class^"\">(*"^(escape s)^"*)</span>" + else + match s.[0] with + '*' -> + ( + try + let html = !html_of_comment (String.sub s 1 (len-1)) in + "</code><table><tr><td>"^(make_margin ())^"</td><td>"^ + "<span class=\""^comment_class^"\">"^ + "(**"^html^"*)"^ + "</span></td></tr></table><code class=\""^code_class^"\">" + with + e -> + prerr_endline (Printexc.to_string e); + "<span class=\""^comment_class^"\">(*"^(escape s)^"*)</span>" + ) + | _ -> + "<span class=\""^comment_class^"\">(*"^(escape s)^"*)</span>" + in + print ~esc: false code + +(** To buffer string literals *) + +let string_buffer = Buffer.create 32 +let reset_string_buffer () = Buffer.reset string_buffer +let store_string_char = Buffer.add_char string_buffer +let get_stored_string () = + let s = Buffer.contents string_buffer in + s + +(** To translate escape sequences *) + +let char_for_backslash = function + | 'n' -> '\010' + | 'r' -> '\013' + | 'b' -> '\008' + | 't' -> '\009' + | c -> c + +let char_for_decimal_code lexbuf i = + let c = 100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + + 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) + + (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in + Char.chr(c land 0xFF) + +let char_for_hexa_code lexbuf i = + let c = 16 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + + (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) in + Char.chr(c land 0xFF) + +(** To store the position of the beginning of a string and comment *) +let string_start_pos = ref 0;; +let comment_start_pos = ref [];; +let in_comment () = !comment_start_pos <> [];; + +(** Error report *) + +open Format + +let report_error ppf = function + | Illegal_character c -> + fprintf ppf "Illegal character (%s)" (Char.escaped c) + | Unterminated_comment -> + fprintf ppf "Comment not terminated" + | Unterminated_string -> + fprintf ppf "String literal not terminated" + | Unterminated_string_in_comment -> + fprintf ppf "This comment contains an unterminated string literal" + | Keyword_as_label kwd -> + fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd +;; + +} + +let blank = [' ' '\010' '\013' '\009' '\012'] +let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] +let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] +let identchar = + ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] +let symbolchar = + ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] +let decimal_literal = ['0'-'9']+ +let hex_literal = '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']+ +let oct_literal = '0' ['o' 'O'] ['0'-'7']+ +let bin_literal = '0' ['b' 'B'] ['0'-'1']+ +let float_literal = + ['0'-'9']+ ('.' ['0'-'9']* )? (['e' 'E'] ['+' '-']? ['0'-'9']+)? + +rule token = parse + blank + { + let s = Lexing.lexeme lexbuf in + ( + match s with + " " -> incr margin + | "\t" -> margin := !margin + 8 + | "\n" -> margin := 0 + | _ -> () + ); + print s; + token lexbuf + } + | "_" + { print "_" ; token lexbuf } + | "~" { print "~" ; token lexbuf } + | "~" lowercase identchar * ':' + { let s = Lexing.lexeme lexbuf in + let name = String.sub s 1 (String.length s - 2) in + if Hashtbl.mem keyword_table name then + raise (Error(Keyword_as_label name, Lexing.lexeme_start lexbuf, + Lexing.lexeme_end lexbuf)); + print s ; token lexbuf } + | "?" { print "?" ; token lexbuf } + | "?" lowercase identchar * ':' + { let s = Lexing.lexeme lexbuf in + let name = String.sub s 1 (String.length s - 2) in + if Hashtbl.mem keyword_table name then + raise (Error(Keyword_as_label name, Lexing.lexeme_start lexbuf, + Lexing.lexeme_end lexbuf)); + print s ; token lexbuf } + | lowercase identchar * + { let s = Lexing.lexeme lexbuf in + try + let cl = Hashtbl.find keyword_table s in + (print_class cl s ; token lexbuf ) + with Not_found -> + (print s ; token lexbuf )} + | uppercase identchar * + { print_class constructor_class (Lexing.lexeme lexbuf) ; token lexbuf } (* No capitalized keywords *) + | decimal_literal | hex_literal | oct_literal | bin_literal + { print (Lexing.lexeme lexbuf) ; token lexbuf } + | float_literal + { print (Lexing.lexeme lexbuf) ; token lexbuf } + | "\"" + { reset_string_buffer(); + let string_start = Lexing.lexeme_start lexbuf in + string_start_pos := string_start; + string lexbuf; + lexbuf.Lexing.lex_start_pos <- + string_start - lexbuf.Lexing.lex_abs_pos; + print_class string_class ("\""^(get_stored_string())^"\"") ; + token lexbuf } + | "'" [^ '\\' '\''] "'" + { print_class string_class (Lexing.lexeme lexbuf) ; + token lexbuf } + | "'" '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'" + { print_class string_class (Lexing.lexeme lexbuf ) ; + token lexbuf } + | "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" + { print_class string_class (Lexing.lexeme lexbuf ) ; + token lexbuf } + | "(*" + { + reset_comment_buffer (); + comment_start_pos := [Lexing.lexeme_start lexbuf]; + comment lexbuf ; + print_comment (); + token lexbuf } + | "(*)" + { reset_comment_buffer (); + comment_start_pos := [Lexing.lexeme_start lexbuf]; + comment lexbuf ; + print_comment (); + token lexbuf + } + | "*)" + { lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; + lexbuf.Lexing.lex_curr_p <- + { lexbuf.Lexing.lex_curr_p with + pos_cnum = lexbuf.Lexing.lex_curr_p.pos_cnum - 1 + } ; + print (Lexing.lexeme lexbuf) ; + token lexbuf + } + | "#" [' ' '\t']* ['0'-'9']+ [^ '\n' '\r'] * ('\n' | '\r' | "\r\n") + (* # linenum ... *) + { + print (Lexing.lexeme lexbuf); + token lexbuf + } + | "#" { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf } + | "&" { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf } + | "&&" { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf } + | "`" { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf } + | "'" { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf } + | "(" { print (Lexing.lexeme lexbuf) ; token lexbuf } + | ")" { print (Lexing.lexeme lexbuf) ; token lexbuf } + | "*" { print (Lexing.lexeme lexbuf) ; token lexbuf } + | "," { print (Lexing.lexeme lexbuf) ; token lexbuf } + | "??" { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf } + | "->" { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf } + | "." { print (Lexing.lexeme lexbuf) ; token lexbuf } + | ".." { print (Lexing.lexeme lexbuf) ; token lexbuf } + | ":" { print (Lexing.lexeme lexbuf) ; token lexbuf } + | "::" { print (Lexing.lexeme lexbuf) ; token lexbuf } + | ":=" { print (Lexing.lexeme lexbuf) ; token lexbuf } + | ":>" { print (Lexing.lexeme lexbuf) ; token lexbuf } + | ";" { print (Lexing.lexeme lexbuf) ; token lexbuf } + | ";;" { print (Lexing.lexeme lexbuf) ; token lexbuf } + | "<" { print (Lexing.lexeme lexbuf) ; token lexbuf } + | "<-" { print (Lexing.lexeme lexbuf) ; token lexbuf } + | "=" { print (Lexing.lexeme lexbuf) ; token lexbuf } + | "[" { print (Lexing.lexeme lexbuf) ; token lexbuf } + | "[|" { print (Lexing.lexeme lexbuf) ; token lexbuf } + | "[<" { print (Lexing.lexeme lexbuf) ; token lexbuf } + | "]" { print (Lexing.lexeme lexbuf) ; token lexbuf } + | "{" { print (Lexing.lexeme lexbuf) ; token lexbuf } + | "{<" { print (Lexing.lexeme lexbuf) ; token lexbuf } + | "|" { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf } + | "||" { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf } + | "|]" { print (Lexing.lexeme lexbuf) ; token lexbuf } + | ">" { print (Lexing.lexeme lexbuf) ; token lexbuf } + | ">]" { print (Lexing.lexeme lexbuf) ; token lexbuf } + | "}" { print (Lexing.lexeme lexbuf) ; token lexbuf } + | ">}" { print (Lexing.lexeme lexbuf) ; token lexbuf } + + | "!=" { print (Lexing.lexeme lexbuf) ; token lexbuf } + | "+" { print (Lexing.lexeme lexbuf) ; token lexbuf } + | "-" { print (Lexing.lexeme lexbuf) ; token lexbuf } + | "-." { print (Lexing.lexeme lexbuf) ; token lexbuf } + + | "!" symbolchar * + { print (Lexing.lexeme lexbuf) ; token lexbuf } + | ['~' '?'] symbolchar + + { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf } + | ['=' '<' '>' '|' '&' '$'] symbolchar * + { print (Lexing.lexeme lexbuf) ; token lexbuf } + | ['@' '^'] symbolchar * + { print (Lexing.lexeme lexbuf) ; token lexbuf } + | ['+' '-'] symbolchar * + { print (Lexing.lexeme lexbuf) ; token lexbuf } + | "**" symbolchar * + { print (Lexing.lexeme lexbuf) ; token lexbuf } + | ['*' '/' '%'] symbolchar * + { print (Lexing.lexeme lexbuf) ; token lexbuf } + | eof { () } + | _ + { raise (Error(Illegal_character ((Lexing.lexeme lexbuf).[0]), + Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)) } + +and comment = parse + "(*" + { comment_start_pos := Lexing.lexeme_start lexbuf :: !comment_start_pos; + store_comment_char '('; + store_comment_char '*'; + comment lexbuf; + } + | "*)" + { match !comment_start_pos with + | [] -> assert false + | [x] -> comment_start_pos := [] + | _ :: l -> + store_comment_char '*'; + store_comment_char ')'; + comment_start_pos := l; + comment lexbuf; + } +(* These filters are useless + | "\"" + { reset_string_buffer(); + string_start_pos := Lexing.lexeme_start lexbuf; + store_comment_char '"'; + begin + try string lexbuf; add_comment_string ((get_stored_string()^"\"")) + with Error (Unterminated_string, _, _) -> + let st = List.hd !comment_start_pos in + raise (Error (Unterminated_string_in_comment, st, st + 2)) + end; + comment lexbuf } + | "'" [^ '\\' '\''] "'" + { + store_comment_char '\''; + store_comment_char (Lexing.lexeme_char lexbuf 1); + store_comment_char '\''; + comment lexbuf } + | "'\\" ['\\' '\'' 'n' 't' 'b' 'r'] "'" + { + store_comment_char '\''; + store_comment_char '\\'; + store_comment_char(char_for_backslash(Lexing.lexeme_char lexbuf 1)) ; + store_comment_char '\''; + comment lexbuf } + | "\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] + { + store_comment_char(char_for_decimal_code lexbuf 1); + comment lexbuf } + | "\\x" ['0'-'9' 'A'-'Z' 'a'-'z' ] ['0'-'9' 'A'-'Z' 'a'-'z'] + { + store_comment_char(char_for_hexa_code lexbuf 2); + string lexbuf } + | "''" + { + store_comment_char '\''; + store_comment_char '\''; + comment lexbuf } +*) + | eof + { let st = List.hd !comment_start_pos in + raise (Error (Unterminated_comment, st, st + 2)); + } + | _ + { store_comment_char(Lexing.lexeme_char lexbuf 0); + comment lexbuf } + +and string = parse + '"' + { () } + | '\\' ("\010" | "\013" | "\013\010") [' ' '\009'] * + { string lexbuf } + | '\\' ['\\' '"' 'n' 't' 'b' 'r' ] + { Buffer.add_string string_buffer (Lexing.lexeme lexbuf) ; + string lexbuf } + | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] + { + Buffer.add_string string_buffer (Lexing.lexeme lexbuf) ; + string lexbuf + } + | '\\' 'x' ['0'-'9' 'A'-'Z' 'a'-'z' ] ['0'-'9' 'A'-'Z' 'a'-'z'] + { Buffer.add_string string_buffer (Lexing.lexeme lexbuf) ; + string lexbuf } + | eof + { raise (Error (Unterminated_string, + !string_start_pos, !string_start_pos+1)) } + | _ + { store_string_char(Lexing.lexeme_char lexbuf 0); + string lexbuf } +{ + +let html_of_code b ?(with_pre=true) code = + let old_pre = !pre in + let old_margin = !margin in + let old_comment_buffer = Buffer.contents comment_buffer in + let old_string_buffer = Buffer.contents string_buffer in + let buf = Buffer.create 256 in + let old_fmt = !fmt in + fmt := Format.formatter_of_buffer buf ; + pre := with_pre; + margin := 0; + + let start = "<code class=\""^code_class^"\">" in + let ending = "</code>" in + let html = + ( + try + print ~esc: false start ; + let lexbuf = Lexing.from_string code in + let _ = token lexbuf in + print ~esc: false ending ; + Format.pp_print_flush !fmt () ; + Buffer.contents buf + with + _ -> + (* flush str_formatter because we already output + something in it *) + Format.pp_print_flush !fmt () ; + start^code^ending + ) + in + pre := old_pre; + margin := old_margin ; + Buffer.reset comment_buffer; + Buffer.add_string comment_buffer old_comment_buffer ; + Buffer.reset string_buffer; + Buffer.add_string string_buffer old_string_buffer ; + fmt := old_fmt ; + + Buffer.add_string b html + +} diff --git a/ocaml-binary-annot/ocamldoc/odoc_parameter.ml b/ocaml-binary-annot/ocamldoc/odoc_parameter.ml new file mode 100644 index 0000000000..56f175ecd4 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_parameter.ml @@ -0,0 +1,123 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Representation and manipulation of method / function / class parameters. *) + +let print_DEBUG s = print_string s ; print_newline () + +(** Types *) + +(** Representation of a simple parameter name *) +type simple_name = { + sn_name : string ; + sn_type : Types.type_expr ; + mutable sn_text : Odoc_types.text option ; + } + +(** Representation of parameter names. We need it to represent parameter names in tuples. + The value [Tuple ([], t)] stands for an anonymous parameter.*) +type param_info = + | Simple_name of simple_name + | Tuple of param_info list * Types.type_expr + +(** A parameter is just a param_info.*) +type parameter = param_info + +(** Functions *) + +(** acces to the name as a string. For tuples, parenthesis and commas are added. *) +let complete_name p = + let rec iter pi = + match pi with + Simple_name sn -> + sn.sn_name + | Tuple ([], _) -> (* anonymous parameter *) + "??" + | Tuple (pi_list, _) -> + "("^(String.concat "," (List.map iter pi_list))^")" + in + iter p + +(** access to the complete type *) +let typ pi = + match pi with + Simple_name sn -> sn.sn_type + | Tuple (_, typ) -> typ + +(** Update the text of a parameter using a function returning + the optional text associated to a parameter name.*) +let update_parameter_text f p = + let rec iter pi = + match pi with + Simple_name sn -> + sn.sn_text <- f sn.sn_name + | Tuple (l, _) -> + List.iter iter l + in + iter p + +(** access to the description of a specific name. + @raise Not_found if no description is associated to the given name. *) +let desc_by_name pi name = + let rec iter acc pi = + match pi with + Simple_name sn -> + (sn.sn_name, sn.sn_text) :: acc + | Tuple (pi_list, _) -> + List.fold_left iter acc pi_list + in + let l = iter [] pi in + List.assoc name l + + +(** acces to the list of names ; only one for a simple parameter, or + a list for tuples. *) +let names pi = + let rec iter acc pi = + match pi with + Simple_name sn -> + sn.sn_name :: acc + | Tuple (pi_list, _) -> + List.fold_left iter acc pi_list + in + iter [] pi + +(** access to the type of a specific name. + @raise Not_found if no type is associated to the given name. *) +let type_by_name pi name = + let rec iter acc pi = + match pi with + Simple_name sn -> + (sn.sn_name, sn.sn_type) :: acc + | Tuple (pi_list, _) -> + List.fold_left iter acc pi_list + in + let l = iter [] pi in + List.assoc name l + +(** access to the optional description of a parameter name from an optional info structure.*) +let desc_from_info_opt info_opt s = + print_DEBUG "desc_from_info_opt"; + match info_opt with + None -> None + | Some i -> + match s with + "" -> None + | _ -> + try + Some (List.assoc s i.Odoc_types.i_params) + with + Not_found -> + print_DEBUG ("desc_from_info_opt "^s^" not found in\n"); + List.iter (fun (s, _) -> print_DEBUG s) i.Odoc_types.i_params; + None diff --git a/ocaml-binary-annot/ocamldoc/odoc_parser.mly b/ocaml-binary-annot/ocamldoc/odoc_parser.mly new file mode 100644 index 0000000000..e62dcc5515 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_parser.mly @@ -0,0 +1,176 @@ +%{ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open Odoc_types +open Odoc_comments_global + +let uppercase = "[A-Z\192-\214\216-\222]" +let identchar = + "[A-Za-z_\192-\214\216-\246\248-\255'0-9]" +let blank = "[ \010\013\009\012]" + +let print_DEBUG s = print_string s; print_newline () +%} + +%token <string * (string option)> Description + +%token <string> See_url +%token <string> See_file +%token <string> See_doc + +%token T_PARAM +%token T_AUTHOR +%token T_VERSION +%token T_SEE +%token T_SINCE +%token T_BEFORE +%token T_DEPRECATED +%token T_RAISES +%token T_RETURN +%token <string> T_CUSTOM + +%token EOF + +%token <string> Desc + +/* Start Symbols */ +%start main info_part2 see_info +%type <(string * (string option)) option> main +%type <unit> info_part2 +%type <Odoc_types.see_ref * string> see_info + + +%% +see_info: + see_ref Desc { ($1, $2) } +; + +see_ref: + See_url { Odoc_types.See_url $1 } +| See_file { Odoc_types.See_file $1 } +| See_doc { Odoc_types.See_doc $1 } +; + +main: + Description { Some $1 } +| EOF { None } +; + +info_part2: + element_list EOF { () } +; + +element_list: + element { () } +| element element_list { () } +; + +element: +| param { () } +| author { () } +| version { () } +| see { () } +| since { () } +| before { () } +| deprecated { () } +| raise_exc { () } +| return { () } +| custom { () } +; + +param: + T_PARAM Desc + { + (* isolate the identificator *) + (* we only look for simple id, no pattern nor tuples *) + let s = $2 in + match Str.split (Str.regexp (blank^"+")) s with + [] + | _ :: [] -> + raise (Failure "usage: @param id description") + | id :: _ -> + print_DEBUG ("Identificator "^id); + let reg = identchar^"+" in + print_DEBUG ("reg="^reg); + if Str.string_match (Str.regexp reg) id 0 then + let remain = String.sub s (String.length id) ((String.length s) - (String.length id)) in + print_DEBUG ("T_PARAM Desc remain="^remain); + let remain2 = Str.replace_first (Str.regexp ("^"^blank^"+")) "" remain in + params := !params @ [(id, remain2)] + else + raise (Failure (id^" is not a valid parameter identificator in \"@param "^s^"\"")) + } +; +author: + T_AUTHOR Desc { authors := !authors @ [ $2 ] } +; +version: + T_VERSION Desc { version := Some $2 } +; +see: + T_SEE Desc { sees := !sees @ [$2] } +; +since: + T_SINCE Desc { since := Some $2 } +; +before: + T_BEFORE Desc + { + (* isolate the version name *) + let s = $2 in + match Str.split (Str.regexp (blank^"+")) s with + [] + | _ :: [] -> + raise (Failure "usage: @before version description") + | id :: _ -> + print_DEBUG ("version "^id); + let remain = String.sub s (String.length id) ((String.length s) - (String.length id)) in + let remain2 = Str.replace_first (Str.regexp ("^"^blank^"+")) "" remain in + before := !before @ [(id, remain2)] + } +; +deprecated: + T_DEPRECATED Desc { deprecated := Some $2 } +; +raise_exc: + T_RAISES Desc + { + (* isolate the exception construtor name *) + let s = $2 in + match Str.split (Str.regexp (blank^"+")) s with + [] + | _ :: [] -> + raise (Failure "usage: @raise Exception description") + | id :: _ -> + print_DEBUG ("exception "^id); + let reg = uppercase^identchar^"*"^"\\(\\."^uppercase^identchar^"*\\)*" in + print_DEBUG ("reg="^reg); + if Str.string_match (Str.regexp reg) id 0 then + let remain = String.sub s (String.length id) ((String.length s) - (String.length id)) in + let remain2 = Str.replace_first (Str.regexp ("^"^blank^"+")) "" remain in + raised_exceptions := !raised_exceptions @ [(id, remain2)] + else + raise (Failure (id^" is not a valid exception constructor in \"@raise "^s^"\"")) + } +; +return: + T_RETURN Desc { return_value := Some $2 } +; + +custom: + T_CUSTOM Desc { customs := !customs @ [($1, $2)] } +; + + +%% diff --git a/ocaml-binary-annot/ocamldoc/odoc_print.ml b/ocaml-binary-annot/ocamldoc/odoc_print.ml new file mode 100644 index 0000000000..5cc8e038c7 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_print.ml @@ -0,0 +1,104 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open Format + +let new_fmt () = + let buf = Buffer.create 512 in + let fmt = formatter_of_buffer buf in + let flush () = + pp_print_flush fmt (); + let s = Buffer.contents buf in + Buffer.reset buf ; + s + in + (fmt, flush) + +let (type_fmt, flush_type_fmt) = new_fmt () +let _ = + let (out, flush, outnewline, outspace) = + pp_get_all_formatter_output_functions type_fmt () + in + pp_set_all_formatter_output_functions type_fmt + ~out ~flush + ~newline: (fun () -> out "\n " 0 3) + ~spaces: outspace + +let (modtype_fmt, flush_modtype_fmt) = new_fmt () + + + + +let string_of_type_expr t = + Printtyp.mark_loops t; + Printtyp.type_scheme_max ~b_reset_names: false type_fmt t; + flush_type_fmt () + +exception Use_code of string + +(** Return the given module type where methods and vals have been removed + from the signatures. Used when we don't want to print a too long module type. + @param code when the code is given, we raise the [Use_code] exception is we + encouter a signature, to that the calling function can use the code rather + than the "emptied" type. +*) +let simpl_module_type ?code t = + let rec iter t = + match t with + Types.Tmty_ident p -> t + | Types.Tmty_signature _ -> + ( + match code with + None -> Types.Tmty_signature [] + | Some s -> raise (Use_code s) + ) + | Types.Tmty_functor (id, mt1, mt2) -> + Types.Tmty_functor (id, iter mt1, iter mt2) + in + iter t + +let string_of_module_type ?code ?(complete=false) t = + try + let t2 = if complete then t else simpl_module_type ?code t in + Printtyp.modtype modtype_fmt t2; + flush_modtype_fmt () + with + Use_code s -> s + +(** Return the given class type where methods and vals have been removed + from the signatures. Used when we don't want to print a too long class type.*) +let simpl_class_type t = + let rec iter t = + match t with + Types.Tcty_constr (p,texp_list,ct) -> t + | Types.Tcty_signature cs -> + (* on vire les vals et methods pour ne pas qu'elles soient imprimées + quand on affichera le type *) + let tnil = { Types.desc = Types.Tnil ; Types.level = 0; Types.id = 0 } in + Types.Tcty_signature { Types.cty_self = { cs.Types.cty_self with + Types.desc = Types.Tobject (tnil, ref None) }; + Types.cty_vars = Types.Vars.empty ; + Types.cty_concr = Types.Concr.empty ; + Types.cty_inher = [] + } + | Types.Tcty_fun (l, texp, ct) -> + let new_ct = iter ct in + Types.Tcty_fun (l, texp, new_ct) + in + iter t + +let string_of_class_type ?(complete=false) t = + let t2 = if complete then t else simpl_class_type t in + (* A VOIR : ma propre version de Printtyp.class_type pour ne pas faire reset_names *) + Printtyp.class_type modtype_fmt t2; + flush_modtype_fmt () diff --git a/ocaml-binary-annot/ocamldoc/odoc_print.mli b/ocaml-binary-annot/ocamldoc/odoc_print.mli new file mode 100644 index 0000000000..01b319c35b --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_print.mli @@ -0,0 +1,32 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Printing functions. *) + +(** This function takes a Types.type_expr and returns a string. + It writes in and flushes [Format.str_formatter].*) +val string_of_type_expr : Types.type_expr -> string + +(** This function returns a string representing a [Types.module_type]. + @param complete indicates if we must print complete signatures + or just [sig end]. Default if [false]. + @param code if [complete = false] and the type contains something else + than identificators and functors, then the given code is used. +*) +val string_of_module_type : ?code: string -> ?complete: bool -> Types.module_type -> string + +(** This function returns a string representing a [Types.class_type]. + @param complete indicates if we must print complete signatures + or just [object end]. Default if [false]. +*) +val string_of_class_type : ?complete: bool -> Types.class_type -> string diff --git a/ocaml-binary-annot/ocamldoc/odoc_scan.ml b/ocaml-binary-annot/ocamldoc/odoc_scan.ml new file mode 100644 index 0000000000..29e1ca2724 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_scan.ml @@ -0,0 +1,156 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Scanning of modules and elements. + + The class scanner defined in this module can be used to + develop generators which perform controls on the elements + and their comments. +*) + +open Odoc_types + +(** Class which defines the scanning of a list of modules and their + elements. Inherit this class to develop your own scanner, by + overriding some methods.*) +class scanner = + object (self) + (** Scan of 'leaf elements'. *) + + method scan_value (v : Odoc_value.t_value) = () + method scan_type (t : Odoc_type.t_type) = () + method scan_exception (e : Odoc_exception.t_exception) = () + method scan_attribute (a : Odoc_value.t_attribute) = () + method scan_method (m : Odoc_value.t_method) = () + method scan_included_module (im : Odoc_module.included_module) = () + + (** Scan of a class. *) + + (** Scan of a comment inside a class. *) + method scan_class_comment (t : text) = () + + (** Override this method to perform controls on the class comment + and params. This method is called before scanning the class elements. + @return true if the class elements must be scanned.*) + method scan_class_pre (c : Odoc_class.t_class) = true + + (** This method scan the elements of the given class. + A VOIR : scan des classes héritées.*) + method scan_class_elements c = + List.iter + (fun ele -> + match ele with + Odoc_class.Class_attribute a -> self#scan_attribute a + | Odoc_class.Class_method m -> self#scan_method m + | Odoc_class.Class_comment t -> self#scan_class_comment t + ) + (Odoc_class.class_elements c) + + (** Scan of a class. Should not be overridden. It calls [scan_class_pre] + and if [scan_class_pre] returns [true], then it calls scan_class_elements.*) + method scan_class c = if self#scan_class_pre c then self#scan_class_elements c + + (** Scan of a class type. *) + + (** Scan of a comment inside a class type. *) + method scan_class_type_comment (t : text) = () + + (** Override this method to perform controls on the class type comment + and form. This method is called before scanning the class type elements. + @return true if the class type elements must be scanned.*) + method scan_class_type_pre (ct : Odoc_class.t_class_type) = true + + (** This method scan the elements of the given class type. + A VOIR : scan des classes héritées.*) + method scan_class_type_elements ct = + List.iter + (fun ele -> + match ele with + Odoc_class.Class_attribute a -> self#scan_attribute a + | Odoc_class.Class_method m -> self#scan_method m + | Odoc_class.Class_comment t -> self#scan_class_type_comment t + ) + (Odoc_class.class_type_elements ct) + + (** Scan of a class type. Should not be overridden. It calls [scan_class_type_pre] + and if [scan_class_type_pre] returns [true], then it calls scan_class_type_elements.*) + method scan_class_type ct = if self#scan_class_type_pre ct then self#scan_class_type_elements ct + + (** Scan of modules. *) + + (** Scan of a comment inside a module. *) + method scan_module_comment (t : text) = () + + (** Override this method to perform controls on the module comment + and form. This method is called before scanning the module elements. + @return true if the module elements must be scanned.*) + method scan_module_pre (m : Odoc_module.t_module) = true + + (** This method scan the elements of the given module. *) + method scan_module_elements m = + List.iter + (fun ele -> + match ele with + Odoc_module.Element_module m -> self#scan_module m + | Odoc_module.Element_module_type mt -> self#scan_module_type mt + | Odoc_module.Element_included_module im -> self#scan_included_module im + | Odoc_module.Element_class c -> self#scan_class c + | Odoc_module.Element_class_type ct -> self#scan_class_type ct + | Odoc_module.Element_value v -> self#scan_value v + | Odoc_module.Element_exception e -> self#scan_exception e + | Odoc_module.Element_type t -> self#scan_type t + | Odoc_module.Element_module_comment t -> self#scan_module_comment t + ) + (Odoc_module.module_elements m) + + (** Scan of a module. Should not be overridden. It calls [scan_module_pre] + and if [scan_module_pre] returns [true], then it calls scan_module_elements.*) + method scan_module m = if self#scan_module_pre m then self#scan_module_elements m + + (** Scan of module types. *) + + (** Scan of a comment inside a module type. *) + method scan_module_type_comment (t : text) = () + + (** Override this method to perform controls on the module type comment + and form. This method is called before scanning the module type elements. + @return true if the module type elements must be scanned. *) + method scan_module_type_pre (mt : Odoc_module.t_module_type) = true + + (** This method scan the elements of the given module type. *) + method scan_module_type_elements mt = + List.iter + (fun ele -> + match ele with + Odoc_module.Element_module m -> self#scan_module m + | Odoc_module.Element_module_type mt -> self#scan_module_type mt + | Odoc_module.Element_included_module im -> self#scan_included_module im + | Odoc_module.Element_class c -> self#scan_class c + | Odoc_module.Element_class_type ct -> self#scan_class_type ct + | Odoc_module.Element_value v -> self#scan_value v + | Odoc_module.Element_exception e -> self#scan_exception e + | Odoc_module.Element_type t -> self#scan_type t + | Odoc_module.Element_module_comment t -> self#scan_module_comment t + ) + (Odoc_module.module_type_elements mt) + + (** Scan of a module type. Should not be overridden. It calls [scan_module_type_pre] + and if [scan_module_type_pre] returns [true], then it calls scan_module_type_elements.*) + method scan_module_type mt = + if self#scan_module_type_pre mt then self#scan_module_type_elements mt + + (** Main scanning method. *) + + (** Scan a list of modules. *) + method scan_module_list l = List.iter self#scan_module l + end diff --git a/ocaml-binary-annot/ocamldoc/odoc_search.ml b/ocaml-binary-annot/ocamldoc/odoc_search.ml new file mode 100644 index 0000000000..65d602d3b9 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_search.ml @@ -0,0 +1,636 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Research of elements through modules. *) + +module Name = Odoc_name +open Odoc_parameter +open Odoc_value +open Odoc_type +open Odoc_exception +open Odoc_class +open Odoc_module + +type result_element = + Res_module of t_module + | Res_module_type of t_module_type + | Res_class of t_class + | Res_class_type of t_class_type + | Res_value of t_value + | Res_type of t_type + | Res_exception of t_exception + | Res_attribute of t_attribute + | Res_method of t_method + | Res_section of string * Odoc_types.text + +type result = result_element list + +module type Predicates = + sig + type t + val p_module : t_module -> t -> bool * bool + val p_module_type : t_module_type -> t -> bool * bool + val p_class : t_class -> t -> bool * bool + val p_class_type : t_class_type -> t -> bool * bool + val p_value : t_value -> t -> bool + val p_type : t_type -> t -> bool + val p_exception : t_exception -> t -> bool + val p_attribute : t_attribute -> t -> bool + val p_method : t_method -> t -> bool + val p_section : string -> t -> bool + end + +module Search = + functor (P : Predicates) -> + struct + let search_section t s v = if P.p_section s v then [Res_section (s,t)] else [] + + let rec search_text root t v = + List.flatten (List.map (fun e -> search_text_ele root e v) t) + + and search_text_ele root e v = + let module T = Odoc_types in + match e with + | T.Raw _ + | T.Code _ + | T.CodePre _ + | T.Latex _ + | T.Verbatim _ + | T.Ref (_, _, _) -> [] + | T.Bold t + | T.Italic t + | T.Center t + | T.Left t + | T.Right t + | T.Emphasize t + | T.Block t + | T.Superscript t + | T.Subscript t + | T.Custom (_,t) + | T.Link (_, t) -> search_text root t v + | T.List l + | T.Enum l -> List.flatten (List.map (fun t -> search_text root t v) l) + | T.Newline + | T.Module_list _ + | T.Index_list -> [] + | T.Target _ -> [] + | T.Title (n, l_opt, t) -> + (match l_opt with + None -> [] + | Some s -> search_section t (Name.concat root s) v) @ + (search_text root t v) + + let search_value va v = if P.p_value va v then [Res_value va] else [] + + let search_type t v = if P.p_type t v then [Res_type t] else [] + + let search_exception e v = if P.p_exception e v then [Res_exception e] else [] + + let search_attribute a v = if P.p_attribute a v then [Res_attribute a] else [] + + let search_method m v = if P.p_method m v then [Res_method m] else [] + + let search_class c v = + let (go_deeper, ok) = P.p_class c v in + let l = + if go_deeper then + let res_att = + List.fold_left + (fun acc -> fun att -> acc @ (search_attribute att v)) + [] + (Odoc_class.class_attributes c) + in + let res_met = + List.fold_left + (fun acc -> fun m -> acc @ (search_method m v)) + [] + (Odoc_class.class_methods c) + in + let res_sec = + List.fold_left + (fun acc -> fun t -> acc @ (search_text c.cl_name t v)) + [] + (Odoc_class.class_comments c) + in + let l = res_att @ res_met @ res_sec in + l + else + [] + in + if ok then + (Res_class c) :: l + else + l + + let search_class_type ct v = + let (go_deeper, ok) = P.p_class_type ct v in + let l = + if go_deeper then + let res_att = + List.fold_left + (fun acc -> fun att -> acc @ (search_attribute att v)) + [] + (Odoc_class.class_type_attributes ct) + in + let res_met = + List.fold_left + (fun acc -> fun m -> acc @ (search_method m v)) + [] + (Odoc_class.class_type_methods ct) + in + let res_sec = + List.fold_left + (fun acc -> fun t -> acc @ (search_text ct.clt_name t v)) + [] + (Odoc_class.class_type_comments ct) + in + let l = res_att @ res_met @ res_sec in + l + else + [] + in + if ok then + (Res_class_type ct) :: l + else + l + + let rec search_module_type mt v = + let (go_deeper, ok) = P.p_module_type mt v in + let l = + if go_deeper then + let res_val = + List.fold_left + (fun acc -> fun va -> acc @ (search_value va v)) + [] + (Odoc_module.module_type_values mt) + in + let res_typ = + List.fold_left + (fun acc -> fun t -> acc @ (search_type t v)) + [] + (Odoc_module.module_type_types mt) + in + let res_exc = + List.fold_left + (fun acc -> fun e -> acc @ (search_exception e v)) + [] + (Odoc_module.module_type_exceptions mt) + in + let res_mod = search (Odoc_module.module_type_modules mt) v in + let res_modtyp = + List.fold_left + (fun acc -> fun mt -> acc @ (search_module_type mt v)) + [] + (Odoc_module.module_type_module_types mt) + in + let res_cl = + List.fold_left + (fun acc -> fun cl -> acc @ (search_class cl v)) + [] + (Odoc_module.module_type_classes mt) + in + let res_cltyp = + List.fold_left + (fun acc -> fun clt -> acc @ (search_class_type clt v)) + [] + (Odoc_module.module_type_class_types mt) + in + let res_sec = + List.fold_left + (fun acc -> fun t -> acc @ (search_text mt.mt_name t v)) + [] + (Odoc_module.module_type_comments mt) + in + let l = res_val @ res_typ @ res_exc @ res_mod @ + res_modtyp @ res_cl @ res_cltyp @ res_sec + in + l + else + [] + in + if ok then + (Res_module_type mt) :: l + else + l + + and search_module m v = + let (go_deeper, ok) = P.p_module m v in + let l = + if go_deeper then + let res_val = + List.fold_left + (fun acc -> fun va -> acc @ (search_value va v)) + [] + (Odoc_module.module_values m) + in + let res_typ = + List.fold_left + (fun acc -> fun t -> acc @ (search_type t v)) + [] + (Odoc_module.module_types m) + in + let res_exc = + List.fold_left + (fun acc -> fun e -> acc @ (search_exception e v)) + [] + (Odoc_module.module_exceptions m) + in + let res_mod = search (Odoc_module.module_modules m) v in + let res_modtyp = + List.fold_left + (fun acc -> fun mt -> acc @ (search_module_type mt v)) + [] + (Odoc_module.module_module_types m) + in + let res_cl = + List.fold_left + (fun acc -> fun cl -> acc @ (search_class cl v)) + [] + (Odoc_module.module_classes m) + in + let res_cltyp = + List.fold_left + (fun acc -> fun clt -> acc @ (search_class_type clt v)) + [] + (Odoc_module.module_class_types m) + in + let res_sec = + List.fold_left + (fun acc -> fun t -> acc @ (search_text m.m_name t v)) + [] + (Odoc_module.module_comments m) + in + let l = res_val @ res_typ @ res_exc @ res_mod @ + res_modtyp @ res_cl @ res_cltyp @ res_sec + in + l + else + [] + in + if ok then + (Res_module m) :: l + else + l + + and search module_list v = + List.fold_left + (fun acc -> fun m -> + List.fold_left + (fun acc2 -> fun ele -> + if List.mem ele acc2 then acc2 else acc2 @ [ele] + ) + acc + (search_module m v) + ) + [] + module_list + end + +module P_name = + struct + type t = Str.regexp + let (=~) name regexp = Str.string_match regexp name 0 + let p_module m r = (true, m.m_name =~ r) + let p_module_type mt r = (true, mt.mt_name =~ r) + let p_class c r = (true, c.cl_name =~ r) + let p_class_type ct r = (true, ct.clt_name =~ r) + let p_value v r = v.val_name =~ r + let p_type t r = t.ty_name =~ r + let p_exception e r = e.ex_name =~ r + let p_attribute a r = a.att_value.val_name =~ r + let p_method m r = m.met_value.val_name =~ r + let p_section s r = s =~ r + end + +module Search_by_name = Search ( P_name ) + +module P_values = + struct + type t = unit + let p_module _ _ = (true, false) + let p_module_type _ _ = (true, false) + let p_class _ _ = (false, false) + let p_class_type _ _ = (false, false) + let p_value _ _ = true + let p_type _ _ = false + let p_exception _ _ = false + let p_attribute _ _ = false + let p_method _ _ = false + let p_section _ _ = false + end +module Search_values = Search ( P_values ) +let values l = + let l_ele = Search_values.search l () in + let p v1 v2 = v1.val_name = v2.val_name in + let rec iter acc = function + (Res_value v) :: q -> if List.exists (p v) acc then iter acc q else iter (v :: acc) q + | _ :: q -> iter acc q + | [] -> acc + in + iter [] l_ele + +module P_exceptions = + struct + type t = unit + let p_module _ _ = (true, false) + let p_module_type _ _ = (true, false) + let p_class _ _ = (false, false) + let p_class_type _ _ = (false, false) + let p_value _ _ = false + let p_type _ _ = false + let p_exception _ _ = true + let p_attribute _ _ = false + let p_method _ _ = false + let p_section _ _ = false + end +module Search_exceptions = Search ( P_exceptions ) +let exceptions l = + let l_ele = Search_exceptions.search l () in + let p e1 e2 = e1.ex_name = e2.ex_name in + let rec iter acc = function + (Res_exception t) :: q -> if List.exists (p t) acc then iter acc q else iter (t :: acc) q + | _ :: q -> iter acc q + | [] -> acc + in + iter [] l_ele + +module P_types = + struct + type t = unit + let p_module _ _ = (true, false) + let p_module_type _ _ = (true, false) + let p_class _ _ = (false, false) + let p_class_type _ _ = (false, false) + let p_value _ _ = false + let p_type _ _ = true + let p_exception _ _ = false + let p_attribute _ _ = false + let p_method _ _ = false + let p_section _ _ = false + end +module Search_types = Search ( P_types ) +let types l = + let l_ele = Search_types.search l () in + let p t1 t2 = t1.ty_name = t2.ty_name in + let rec iter acc = function + (Res_type t) :: q -> if List.exists (p t) acc then iter acc q else iter (t :: acc) q + | _ :: q -> iter acc q + | [] -> acc + in + iter [] l_ele + +module P_attributes = + struct + type t = unit + let p_module _ _ = (true, false) + let p_module_type _ _ = (true, false) + let p_class _ _ = (true, false) + let p_class_type _ _ = (true, false) + let p_value _ _ = false + let p_type _ _ = false + let p_exception _ _ = false + let p_attribute _ _ = true + let p_method _ _ = false + let p_section _ _ = false + end +module Search_attributes = Search ( P_attributes ) +let attributes l = + let l_ele = Search_attributes.search l () in + let p a1 a2 = a1.att_value.val_name = a2.att_value.val_name in + let rec iter acc = function + (Res_attribute t) :: q -> if List.exists (p t) acc then iter acc q else iter (t :: acc) q + | _ :: q -> iter acc q + | [] -> acc + in + iter [] l_ele + +module P_methods = + struct + type t = unit + let p_module _ _ = (true, false) + let p_module_type _ _ = (true, false) + let p_class _ _ = (true, false) + let p_class_type _ _ = (true, false) + let p_value _ _ = false + let p_type _ _ = false + let p_exception _ _ = false + let p_attribute _ _ = false + let p_method _ _ = true + let p_section _ _ = true + end +module Search_methods = Search ( P_methods ) +let methods l = + let l_ele = Search_methods.search l () in + let p m1 m2 = m1.met_value.val_name = m2.met_value.val_name in + let rec iter acc = function + (Res_method t) :: q -> if List.exists (p t) acc then iter acc q else iter (t :: acc) q + | _ :: q -> iter acc q + | [] -> acc + in + iter [] l_ele + +module P_classes = + struct + type t = unit + let p_module _ _ = (true, false) + let p_module_type _ _ = (true, false) + let p_class _ _ = (false, true) + let p_class_type _ _ = (false, false) + let p_value _ _ = false + let p_type _ _ = false + let p_exception _ _ = false + let p_attribute _ _ = false + let p_method _ _ = false + let p_section _ _ = false + end +module Search_classes = Search ( P_classes ) +let classes l = + let l_ele = Search_classes.search l () in + let p c1 c2 = c1.cl_name = c2.cl_name in + let rec iter acc = function + (Res_class c) :: q -> if List.exists (p c) acc then iter acc q else iter (c :: acc) q + | _ :: q -> iter acc q + | [] -> acc + in + iter [] l_ele + +module P_class_types = + struct + type t = unit + let p_module _ _ = (true, false) + let p_module_type _ _ = (true, false) + let p_class _ _ = (false, false) + let p_class_type _ _ = (false, true) + let p_value _ _ = false + let p_type _ _ = false + let p_exception _ _ = false + let p_attribute _ _ = false + let p_method _ _ = false + let p_section _ _ = false + end +module Search_class_types = Search ( P_class_types ) +let class_types l = + let l_ele = Search_class_types.search l () in + let p c1 c2 = c1.clt_name = c2.clt_name in + let rec iter acc = function + (Res_class_type c) :: q -> if List.exists (p c) acc then iter acc q else iter (c :: acc) q + | _ :: q -> iter acc q + | [] -> acc + in + iter [] l_ele + +module P_modules = + struct + type t = unit + let p_module _ _ = (true, true) + let p_module_type _ _ = (true, false) + let p_class _ _ = (false, false) + let p_class_type _ _ = (false, false) + let p_value _ _ = false + let p_type _ _ = false + let p_exception _ _ = false + let p_attribute _ _ = false + let p_method _ _ = false + let p_section _ _ = false + end +module Search_modules = Search ( P_modules ) +let modules l = + let l_ele = Search_modules.search l () in + let p m1 m2 = m1.m_name = m2.m_name in + let rec iter acc = function + (Res_module m) :: q -> if List.exists (p m) acc then iter acc q else iter (m :: acc) q + | _ :: q -> iter acc q + | [] -> acc + in + iter [] l_ele + +module P_module_types = + struct + type t = unit + let p_module _ _ = (true, false) + let p_module_type _ _ = (true, true) + let p_class _ _ = (false, false) + let p_class_type _ _ = (false, false) + let p_value _ _ = false + let p_type _ _ = false + let p_exception _ _ = false + let p_attribute _ _ = false + let p_method _ _ = false + let p_section _ _ = false + end +module Search_module_types = Search ( P_module_types ) +let module_types l = + let l_ele = Search_module_types.search l () in + let p m1 m2 = m1.mt_name = m2.mt_name in + let rec iter acc = function + (Res_module_type m) :: q -> if List.exists (p m) acc then iter acc q else iter (m :: acc) q + | _ :: q -> iter acc q + | [] -> acc + in + iter [] l_ele + +let type_exists mods regexp = + let l = Search_by_name.search mods regexp in + List.exists + (function + Res_type _ -> true + | _ -> false + ) + l + +let value_exists mods regexp = + let l = Search_by_name.search mods regexp in + List.exists + (function + Res_value _ -> true + | _ -> false + ) + l + +let class_exists mods regexp = + let l = Search_by_name.search mods regexp in + List.exists + (function + Res_class _ -> true + | _ -> false + ) + l + +let class_type_exists mods regexp = + let l = Search_by_name.search mods regexp in + List.exists + (function + Res_class_type _ -> true + | _ -> false + ) + l + +let module_exists mods regexp = + let l = Search_by_name.search mods regexp in + List.exists + (function + Res_module _ -> true + | _ -> false + ) + l + +let module_type_exists mods regexp = + let l = Search_by_name.search mods regexp in + List.exists + (function + Res_module_type _ -> true + | _ -> false + ) + l + +let exception_exists mods regexp = + let l = Search_by_name.search mods regexp in + List.exists + (function + Res_exception _ -> true + | _ -> false + ) + l + +let attribute_exists mods regexp = + let l = Search_by_name.search mods regexp in + List.exists + (function + Res_attribute _ -> true + | _ -> false + ) + l + +let method_exists mods regexp = + let l = Search_by_name.search mods regexp in + List.exists + (function + Res_method _ -> true + | _ -> false + ) + l + +let find_section mods regexp = + let l = Search_by_name.search mods regexp in + match + List.find + (function + Res_section _ -> true + | _ -> false + ) + l + with + Res_section (_,t) -> t + | _ -> assert false + +(* eof $Id$ *) diff --git a/ocaml-binary-annot/ocamldoc/odoc_search.mli b/ocaml-binary-annot/ocamldoc/odoc_search.mli new file mode 100644 index 0000000000..d7ace5831a --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_search.mli @@ -0,0 +1,199 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Research of elements through modules. *) + +(** The type for an element of the result of a research. *) +type result_element = + Res_module of Odoc_module.t_module + | Res_module_type of Odoc_module.t_module_type + | Res_class of Odoc_class.t_class + | Res_class_type of Odoc_class.t_class_type + | Res_value of Odoc_value.t_value + | Res_type of Odoc_type.t_type + | Res_exception of Odoc_exception.t_exception + | Res_attribute of Odoc_value.t_attribute + | Res_method of Odoc_value.t_method + | Res_section of string * Odoc_types.text + +(** The type representing a research result.*) +type result = result_element list + +(** The type of modules which contain the predicates used during the research. + Some functions return a couple of booleans ; the first indicates if we + must go deeper in the analysed element, the second if the element satisfies + the predicate. +*) +module type Predicates = + sig + type t + val p_module : Odoc_module.t_module -> t -> bool * bool + val p_module_type : Odoc_module.t_module_type -> t -> bool * bool + val p_class : Odoc_class.t_class -> t -> bool * bool + val p_class_type : Odoc_class.t_class_type -> t -> bool * bool + val p_value : Odoc_value.t_value -> t -> bool + val p_type : Odoc_type.t_type -> t -> bool + val p_exception : Odoc_exception.t_exception -> t -> bool + val p_attribute : Odoc_value.t_attribute -> t -> bool + val p_method : Odoc_value.t_method -> t -> bool + val p_section : string -> t -> bool + end + +(** Search for elements verifying the predicates in the module in parameter.*) +module Search : + functor (P : Predicates) -> + sig + (** search in a section title *) + val search_section : Odoc_types.text -> string -> P.t -> result_element list + + (** search in a value *) + val search_value : Odoc_value.t_value -> P.t -> result_element list + + (** search in a type *) + val search_type : Odoc_type.t_type -> P.t -> result_element list + + (** search in an exception *) + val search_exception : + Odoc_exception.t_exception -> P.t -> result_element list + + (** search in an attribute *) + val search_attribute : + Odoc_value.t_attribute -> P.t -> result_element list + + (** search in a method *) + val search_method : Odoc_value.t_method -> P.t -> result_element list + + (** search in a class *) + val search_class : Odoc_class.t_class -> P.t -> result_element list + + (** search in a class type *) + val search_class_type : + Odoc_class.t_class_type -> P.t -> result_element list + + (** search in a module type *) + val search_module_type : + Odoc_module.t_module_type -> P.t -> result_element list + + (** search in a module *) + val search_module : Odoc_module.t_module -> P.t -> result_element list + + (** search in a list of modules *) + val search : Odoc_module.t_module list -> P.t -> result_element list + end + +(** A module of predicates to search elements by name (and accepting regexps).*) +module P_name : + sig + type t = Str.regexp + val ( =~ ) : string -> Str.regexp -> bool + val p_module : Odoc_module.t_module -> Str.regexp -> bool * bool + val p_module_type : + Odoc_module.t_module_type -> Str.regexp -> bool * bool + val p_class : Odoc_class.t_class -> Str.regexp -> bool * bool + val p_class_type : Odoc_class.t_class_type -> Str.regexp -> bool * bool + val p_value : Odoc_value.t_value -> Str.regexp -> bool + val p_type : Odoc_type.t_type -> Str.regexp -> bool + val p_exception : Odoc_exception.t_exception -> Str.regexp -> bool + val p_attribute : Odoc_value.t_attribute -> Str.regexp -> bool + val p_method : Odoc_value.t_method -> Str.regexp -> bool + end + +(** A module to search elements by name. *) +module Search_by_name : + sig + val search_section : Odoc_types.text -> string -> P_name.t -> result_element list + val search_value : Odoc_value.t_value -> P_name.t -> result_element list + val search_type : Odoc_type.t_type -> P_name.t -> result_element list + val search_exception : + Odoc_exception.t_exception -> P_name.t -> result_element list + val search_attribute : + Odoc_value.t_attribute -> P_name.t -> result_element list + val search_method : + Odoc_value.t_method -> P_name.t -> result_element list + val search_class : Odoc_class.t_class -> P_name.t -> result_element list + val search_class_type : + Odoc_class.t_class_type -> P_name.t -> result_element list + val search_module_type : + Odoc_module.t_module_type -> P_name.t -> result_element list + val search_module : + Odoc_module.t_module -> P_name.t -> result_element list + val search : Odoc_module.t_module list -> P_name.t -> result_element list + end + +(** A function to search all the values in a list of modules. *) +val values : Odoc_module.t_module list -> Odoc_value.t_value list + +(** A function to search all the exceptions in a list of modules. *) +val exceptions : Odoc_module.t_module list -> Odoc_exception.t_exception list + +(** A function to search all the types in a list of modules. *) +val types : Odoc_module.t_module list -> Odoc_type.t_type list + +(** A function to search all the class attributes in a list of modules. *) +val attributes : Odoc_module.t_module list -> Odoc_value.t_attribute list + +(** A function to search all the class methods in a list of modules. *) +val methods : Odoc_module.t_module list -> Odoc_value.t_method list + +(** A function to search all the classes in a list of modules. *) +val classes : Odoc_module.t_module list -> Odoc_class.t_class list + +(** A function to search all the class types in a list of modules. *) +val class_types : Odoc_module.t_module list -> Odoc_class.t_class_type list + +(** A function to search all the modules in a list of modules. *) +val modules : Odoc_module.t_module list -> Odoc_module.t_module list + +(** A function to search all the module types in a list of modules. *) +val module_types : Odoc_module.t_module list -> Odoc_module.t_module_type list + +(** Return [true] if a type with the given complete name (regexp) exists + in the given module list.*) +val type_exists : Odoc_module.t_module list -> Str.regexp -> bool + +(** Return [true] if a value with the given complete name (regexp) exists + in the given module list.*) +val value_exists : Odoc_module.t_module list -> Str.regexp -> bool + +(** Return [true] if a module with the given complete name (regexp) exists + in the given module list.*) +val module_exists : Odoc_module.t_module list -> Str.regexp -> bool + +(** Return [true] if a module type with the given complete name (regexp) exists + in the given module list.*) +val module_type_exists : Odoc_module.t_module list -> Str.regexp -> bool + +(** Return [true] if a class with the given complete name (regexp) exists + in the given module list.*) +val class_exists : Odoc_module.t_module list -> Str.regexp -> bool + +(** Return [true] if a class type with the given complete name (regexp) exists + in the given module list.*) +val class_type_exists : Odoc_module.t_module list -> Str.regexp -> bool + +(** Return [true] if a exception with the given complete name (regexp) exists + in the given module list.*) +val exception_exists : Odoc_module.t_module list -> Str.regexp -> bool + +(** Return [true] if an attribute with the given complete name (regexp) exists + in the given module list.*) +val attribute_exists : Odoc_module.t_module list -> Str.regexp -> bool + +(** Return [true] if a method with the given complete name (regexp) exists + in the given module list.*) +val method_exists : Odoc_module.t_module list -> Str.regexp -> bool + +(** Return the [text] of the section with the given complete name (regexp) + in the given module list. + @raise Not_found if the section was not found.*) +val find_section : Odoc_module.t_module list -> Str.regexp -> Odoc_types.text diff --git a/ocaml-binary-annot/ocamldoc/odoc_see_lexer.mll b/ocaml-binary-annot/ocamldoc/odoc_see_lexer.mll new file mode 100644 index 0000000000..b0570f7832 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_see_lexer.mll @@ -0,0 +1,102 @@ +{ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +let print_DEBUG2 s = print_string s ; print_newline () + +(** the lexer for special comments. *) + +open Lexing +open Odoc_parser + +let buf = Buffer.create 32 + +} + +rule main = parse + [' ' '\013' '\009' '\012'] + + { + print_DEBUG2 "[' ' '\013' '\009' '\012'] +"; + main lexbuf + } + + | [ '\010' ] + { + print_DEBUG2 " [ '\010' ] "; + main lexbuf + } + + | "<" + { + print_DEBUG2 "call url lexbuf" ; + url lexbuf + } + + | "\"" + { + print_DEBUG2 "call doc lexbuf" ; + doc lexbuf + } + + + | '\'' + { + print_DEBUG2 "call file lexbuf" ; + file lexbuf + } + + | eof + { + print_DEBUG2 "EOF"; + EOF + } + + | _ + { + Buffer.reset buf ; + Buffer.add_string buf (Lexing.lexeme lexbuf); + desc lexbuf + } + +and url = parse + | ([^'>'] | '\n')+">" + { + let s = Lexing.lexeme lexbuf in + print_DEBUG2 ("([^'>'] | '\n')+ \">\" with "^s) ; + See_url (String.sub s 0 ((String.length s) -1)) + } + + +and doc = parse + | ([^'"'] | '\n' | "\\'")* "\"" + { + let s = Lexing.lexeme lexbuf in + See_doc (String.sub s 0 ((String.length s) -1)) + } + +and file = parse + | ([^'\''] | '\n' | "\\\"")* "'" + { + let s = Lexing.lexeme lexbuf in + See_file (String.sub s 0 ((String.length s) -1)) + } + + +and desc = parse + eof + { Desc (Buffer.contents buf) } + | _ + { + Buffer.add_string buf (Lexing.lexeme lexbuf); + desc lexbuf + } diff --git a/ocaml-binary-annot/ocamldoc/odoc_sig.ml b/ocaml-binary-annot/ocamldoc/odoc_sig.ml new file mode 100644 index 0000000000..f8308d6c67 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_sig.ml @@ -0,0 +1,1305 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Analysis of interface files. *) + +open Misc +open Asttypes +open Types +open Typedtree +open Path + +let print_DEBUG s = print_string s ; print_newline ();; + +module Name = Odoc_name +open Odoc_parameter +open Odoc_value +open Odoc_type +open Odoc_exception +open Odoc_class +open Odoc_module +open Odoc_types + +module Signature_search = + struct + type ele = + | M of string + | MT of string + | V of string + | T of string + | C of string + | CT of string + | E of string + | ER of string + | P of string + + type tab = (ele, Types.signature_item) Hashtbl.t + + let add_to_hash table signat = + match signat with + Types.Tsig_value (ident, _) -> + Hashtbl.add table (V (Name.from_ident ident)) signat + | Types.Tsig_exception (ident, _) -> + Hashtbl.add table (E (Name.from_ident ident)) signat + | Types.Tsig_type (ident, _, _) -> + Hashtbl.add table (T (Name.from_ident ident)) signat + | Types.Tsig_class (ident, _, _) -> + Hashtbl.add table (C (Name.from_ident ident)) signat + | Types.Tsig_cltype (ident, _, _) -> + Hashtbl.add table (CT (Name.from_ident ident)) signat + | Types.Tsig_module (ident, _, _) -> + Hashtbl.add table (M (Name.from_ident ident)) signat + | Types.Tsig_modtype (ident,_) -> + Hashtbl.add table (MT (Name.from_ident ident)) signat + + let table signat = + let t = Hashtbl.create 13 in + List.iter (add_to_hash t) signat; + t + + let search_value table name = + match Hashtbl.find table (V name) with + | (Types.Tsig_value (_, val_desc)) -> val_desc.Types.val_type + | _ -> assert false + + let search_exception table name = + match Hashtbl.find table (E name) with + | (Types.Tsig_exception (_, type_expr_list)) -> + type_expr_list + | _ -> assert false + + let search_type table name = + match Hashtbl.find table (T name) with + | (Types.Tsig_type (_, type_decl, _)) -> type_decl + | _ -> assert false + + let search_class table name = + match Hashtbl.find table (C name) with + | (Types.Tsig_class (_, class_decl, _)) -> class_decl + | _ -> assert false + + let search_class_type table name = + match Hashtbl.find table (CT name) with + | (Types.Tsig_cltype (_, cltype_decl, _)) -> cltype_decl + | _ -> assert false + + let search_module table name = + match Hashtbl.find table (M name) with + | (Types.Tsig_module (ident, module_type, _)) -> module_type + | _ -> assert false + + let search_module_type table name = + match Hashtbl.find table (MT name) with + | (Types.Tsig_modtype (_, Types.Tmodtype_manifest module_type)) -> + Some module_type + | (Types.Tsig_modtype (_, Types.Tmodtype_abstract)) -> + None + | _ -> assert false + + let search_attribute_type name class_sig = + let (_, _, type_expr) = Types.Vars.find name class_sig.Types.cty_vars in + type_expr + + let search_method_type name class_sig = + let fields = Odoc_misc.get_fields class_sig.Types.cty_self in + List.assoc name fields + end + +module type Info_retriever = + sig + val all_special : string -> string -> int * (Odoc_types.info list) + val blank_line_outside_simple : string -> string -> bool + val just_after_special : string -> string -> (int * Odoc_types.info option) + val first_special : string -> string -> (int * Odoc_types.info option) + val get_comments : + (Odoc_types.text -> 'a) -> string -> string -> (Odoc_types.info option * 'a list) + end + +module Analyser = + functor (My_ir : Info_retriever) -> + struct + (** This variable is used to load a file as a string and retrieve characters from it.*) + let file = ref "" + (** The name of the analysed file. *) + let file_name = ref "" + + (** This function takes two indexes (start and end) and return the string + corresponding to the indexes in the file global variable. The function + prepare_file must have been called to fill the file global variable.*) + let get_string_of_file the_start the_end = + try + let s = String.sub !file the_start (the_end-the_start) in + s + with + Invalid_argument _ -> + "" + + (** This function loads the given file in the file global variable, + and sets file_name.*) + let prepare_file f input_f = + try + let s = Odoc_misc.input_file_as_string input_f in + file := s; + file_name := f + with + e -> + file := ""; + raise e + + (** The function used to get the comments in a class. *) + let get_comments_in_class pos_start pos_end = + My_ir.get_comments (fun t -> Class_comment t) + !file_name + (get_string_of_file pos_start pos_end) + + (** The function used to get the comments in a module. *) + let get_comments_in_module pos_start pos_end = + My_ir.get_comments (fun t -> Element_module_comment t) + !file_name + (get_string_of_file pos_start pos_end) + + let merge_infos = Odoc_merge.merge_info_opt Odoc_types.all_merge_options + + let name_comment_from_type_kind pos_end pos_limit tk = + match tk with + Parsetree.Ptype_abstract -> + (0, []) + | Parsetree.Ptype_variant cons_core_type_list_list -> + let rec f acc cons_core_type_list_list = + match cons_core_type_list_list with + [] -> + (0, acc) + | (name, core_type_list, loc) :: [] -> + let s = get_string_of_file + loc.Location.loc_end.Lexing.pos_cnum + pos_limit + in + let (len, comment_opt) = My_ir.just_after_special !file_name s in + (len, acc @ [ (name, comment_opt) ]) + | (name, core_type_list, loc) :: (name2, core_type_list2, loc2) + :: q -> + let pos_end_first = loc.Location.loc_end.Lexing.pos_cnum in + let pos_start_second = loc2.Location.loc_start.Lexing.pos_cnum in + let s = get_string_of_file pos_end_first pos_start_second in + let (_,comment_opt) = My_ir.just_after_special !file_name s in + f (acc @ [name, comment_opt]) + ((name2, core_type_list2, loc2) :: q) + in + f [] cons_core_type_list_list + + | Parsetree.Ptype_record name_mutable_type_list (* of (string * mutable_flag * core_type) list*) -> + let rec f = function + [] -> + [] + | (name, _, ct, xxloc) :: [] -> + let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in + let s = get_string_of_file pos pos_end in + let (_,comment_opt) = My_ir.just_after_special !file_name s in + [name, comment_opt] + | (name,_,ct,xxloc) :: ((name2,_,ct2,xxloc2) as ele2) :: q -> + let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in + let pos2 = ct2.Parsetree.ptyp_loc.Location.loc_start.Lexing.pos_cnum in + let s = get_string_of_file pos pos2 in + let (_,comment_opt) = My_ir.just_after_special !file_name s in + (name, comment_opt) :: (f (ele2 :: q)) + in + (0, f name_mutable_type_list) + + let get_type_kind env name_comment_list type_kind = + match type_kind with + Types.Type_abstract -> + Odoc_type.Type_abstract + + | Types.Type_variant l -> + let f (constructor_name, type_expr_list) = + let comment_opt = + try + match List.assoc constructor_name name_comment_list with + None -> None + | Some d -> d.Odoc_types.i_desc + with Not_found -> None + in + { + vc_name = constructor_name ; + vc_args = List.map (Odoc_env.subst_type env) type_expr_list ; + vc_text = comment_opt + } + in + Odoc_type.Type_variant (List.map f l) + + | Types.Type_record (l, _) -> + let f (field_name, mutable_flag, type_expr) = + let comment_opt = + try + match List.assoc field_name name_comment_list with + None -> None + | Some d -> d.Odoc_types.i_desc + with Not_found -> None + in + { + rf_name = field_name ; + rf_mutable = mutable_flag = Mutable ; + rf_type = Odoc_env.subst_type env type_expr ; + rf_text = comment_opt + } + in + Odoc_type.Type_record (List.map f l) + + (** Analysis of the elements of a class, from the information in the parsetree and in the class + signature. @return the couple (inherited_class list, elements).*) + let analyse_class_elements env current_class_name last_pos pos_limit + class_type_field_list class_signature = + let get_pos_limit2 q = + match q with + [] -> pos_limit + | ele2 :: _ -> + match ele2 with + Parsetree.Pctf_val (_, _, _, _, loc) + | Parsetree.Pctf_virt (_, _, _, loc) + | Parsetree.Pctf_meth (_, _, _, loc) + | Parsetree.Pctf_cstr (_, _, loc) -> loc.Location.loc_start.Lexing.pos_cnum + | Parsetree.Pctf_inher class_type -> + class_type.Parsetree.pcty_loc.Location.loc_start.Lexing.pos_cnum + in + let get_method name comment_opt private_flag loc q = + let complete_name = Name.concat current_class_name name in + let typ = + try Signature_search.search_method_type name class_signature + with Not_found -> + raise (Failure (Odoc_messages.method_type_not_found current_class_name name)) + in + let subst_typ = Odoc_env.subst_type env typ in + let met = + { + met_value = + { + val_name = complete_name ; + val_info = comment_opt ; + val_type = subst_typ ; + val_recursive = false ; + val_parameters = Odoc_value.dummy_parameter_list subst_typ ; + val_code = None ; + val_loc = { loc_impl = None ; loc_inter = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) }; + } ; + met_private = private_flag = Asttypes.Private ; + met_virtual = false ; + } + in + let pos_limit2 = get_pos_limit2 q in + let pos_end = loc.Location.loc_end.Lexing.pos_cnum in + let (maybe_more, info_after_opt) = + My_ir.just_after_special + !file_name + (get_string_of_file pos_end pos_limit2) + in + met.met_value.val_info <- merge_infos met.met_value.val_info info_after_opt ; + (* update the parameter description *) + Odoc_value.update_value_parameters_text met.met_value; + (met, maybe_more) + in + let rec f last_pos class_type_field_list = + match class_type_field_list with + [] -> + let s = get_string_of_file last_pos pos_limit in + let (_, ele_coms) = My_ir.all_special !file_name s in + let ele_comments = + List.fold_left + (fun acc -> fun sc -> + match sc.Odoc_types.i_desc with + None -> + acc + | Some t -> + acc @ [Class_comment t]) + [] + ele_coms + in + ([], ele_comments) + + | Parsetree.Pctf_val (name, mutable_flag, virtual_flag, _, loc) :: q -> + (* of (string * mutable_flag * core_type option * Location.t)*) + let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in + let complete_name = Name.concat current_class_name name in + let typ = + try Signature_search.search_attribute_type name class_signature + with Not_found -> + raise (Failure (Odoc_messages.attribute_type_not_found current_class_name name)) + in + let subst_typ = Odoc_env.subst_type env typ in + let att = + { + att_value = + { + val_name = complete_name ; + val_info = comment_opt ; + val_type = subst_typ; + val_recursive = false ; + val_parameters = [] ; + val_code = None ; + val_loc = { loc_impl = None ; loc_inter = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum)} ; + } ; + att_mutable = mutable_flag = Asttypes.Mutable ; + att_virtual = virtual_flag = Asttypes.Virtual ; + } + in + let pos_limit2 = get_pos_limit2 q in + let pos_end = loc.Location.loc_end.Lexing.pos_cnum in + let (maybe_more, info_after_opt) = + My_ir.just_after_special + !file_name + (get_string_of_file pos_end pos_limit2) + in + att.att_value.val_info <- merge_infos att.att_value.val_info info_after_opt ; + let (inher_l, eles) = f (pos_end + maybe_more) q in + (inher_l, eles_comments @ ((Class_attribute att) :: eles)) + + | Parsetree.Pctf_virt (name, private_flag, _, loc) :: q -> + (* of (string * private_flag * core_type * Location.t) *) + let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in + let (met, maybe_more) = get_method name comment_opt private_flag loc q in + let met2 = { met with met_virtual = true } in + let (inher_l, eles) = f (loc.Location.loc_end.Lexing.pos_cnum + maybe_more) q in + (inher_l, eles_comments @ ((Class_method met2) :: eles)) + + | Parsetree.Pctf_meth (name, private_flag, _, loc) :: q -> + (* of (string * private_flag * core_type * Location.t) *) + let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in + let (met, maybe_more) = get_method name comment_opt private_flag loc q in + let (inher_l, eles) = f (loc.Location.loc_end.Lexing.pos_cnum + maybe_more) q in + (inher_l, eles_comments @ ((Class_method met) :: eles)) + + | (Parsetree.Pctf_cstr (_, _, loc)) :: q -> + (* of (core_type * core_type * Location.t) *) + (* A VOIR : cela correspond aux contraintes, non ? on ne les garde pas pour l'instant *) + let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in + let (inher_l, eles) = f loc.Location.loc_end.Lexing.pos_cnum q in + (inher_l, eles_comments @ eles) + + | Parsetree.Pctf_inher class_type :: q -> + let loc = class_type.Parsetree.pcty_loc in + let (comment_opt, eles_comments) = + get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum + in + let pos_limit2 = get_pos_limit2 q in + let pos_end = loc.Location.loc_end.Lexing.pos_cnum in + let (maybe_more, info_after_opt) = + My_ir.just_after_special + !file_name + (get_string_of_file pos_end pos_limit2) + in + let comment_opt2 = merge_infos comment_opt info_after_opt in + let text_opt = match comment_opt2 with None -> None | Some i -> i.Odoc_types.i_desc in + let inh = + match class_type.Parsetree.pcty_desc with + Parsetree.Pcty_constr (longident, _) -> + (*of Longident.t * core_type list*) + let name = Name.from_longident longident in + let ic = + { + ic_name = Odoc_env.full_class_or_class_type_name env name ; + ic_class = None ; + ic_text = text_opt ; + } + in + ic + + | Parsetree.Pcty_signature _ + | Parsetree.Pcty_fun _ -> + (* we don't have a name for the class signature, so we call it "object ... end" *) + { + ic_name = Odoc_messages.object_end ; + ic_class = None ; + ic_text = text_opt ; + } + in + let (inher_l, eles) = f (pos_end + maybe_more) q in + (inh :: inher_l , eles_comments @ eles) + in + f last_pos class_type_field_list + + (** Analyse of a .mli parse tree, to get the corresponding elements. + last_pos is the position of the first character which may be used to look for special comments. + *) + let rec analyse_parsetree env signat current_module_name last_pos pos_limit sig_item_list = + let table = Signature_search.table signat in + (* we look for the comment of each item then analyse the item *) + let rec f acc_eles acc_env last_pos = function + [] -> + let s = get_string_of_file last_pos pos_limit in + let (_, ele_coms) = My_ir.all_special !file_name s in + let ele_comments = + List.fold_left + (fun acc -> fun sc -> + match sc.Odoc_types.i_desc with + None -> + acc + | Some t -> + acc @ [Element_module_comment t]) + [] + ele_coms + in + acc_eles @ ele_comments + + | ele :: q -> + let (assoc_com, ele_comments) = get_comments_in_module + last_pos + ele.Parsetree.psig_loc.Location.loc_start.Lexing.pos_cnum + in + let (maybe_more, new_env, elements) = analyse_signature_item_desc + acc_env + signat + table + current_module_name + ele.Parsetree.psig_loc.Location.loc_start.Lexing.pos_cnum + ele.Parsetree.psig_loc.Location.loc_end.Lexing.pos_cnum + (match q with + [] -> pos_limit + | ele2 :: _ -> ele2.Parsetree.psig_loc.Location.loc_start.Lexing.pos_cnum + ) + assoc_com + ele.Parsetree.psig_desc + in + f (acc_eles @ (ele_comments @ elements)) + new_env + (ele.Parsetree.psig_loc.Location.loc_end.Lexing.pos_cnum + maybe_more) + (* for the comments of constructors in types, + which are after the constructor definition and can + go beyond ele.Parsetree.psig_loc.Location.loc_end.Lexing.pos_cnum *) + q + in + f [] env last_pos sig_item_list + + (** Analyse the given signature_item_desc to create the corresponding module element + (with the given attached comment).*) + and analyse_signature_item_desc env signat table current_module_name + pos_start_ele pos_end_ele pos_limit comment_opt sig_item_desc = + match sig_item_desc with + Parsetree.Psig_value (name_pre, value_desc) -> + let type_expr = + try Signature_search.search_value table name_pre + with Not_found -> + raise (Failure (Odoc_messages.value_not_found current_module_name name_pre)) + in + let name = Name.parens_if_infix name_pre in + let subst_typ = Odoc_env.subst_type env type_expr in + let v = + { + val_name = Name.concat current_module_name name ; + val_info = comment_opt ; + val_type = subst_typ ; + val_recursive = false ; + val_parameters = Odoc_value.dummy_parameter_list subst_typ ; + val_code = None ; + val_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele)} + } + in + let (maybe_more, info_after_opt) = + My_ir.just_after_special + !file_name + (get_string_of_file pos_end_ele pos_limit) + in + v.val_info <- merge_infos v.val_info info_after_opt ; + (* update the parameter description *) + Odoc_value.update_value_parameters_text v; + + let new_env = Odoc_env.add_value env v.val_name in + (maybe_more, new_env, [ Element_value v ]) + + | Parsetree.Psig_exception (name, exception_decl) -> + let types_excep_decl = + try Signature_search.search_exception table name + with Not_found -> + raise (Failure (Odoc_messages.exception_not_found current_module_name name)) + in + let e = + { + ex_name = Name.concat current_module_name name ; + ex_info = comment_opt ; + ex_args = List.map (Odoc_env.subst_type env) types_excep_decl ; + ex_alias = None ; + ex_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ; + ex_code = + ( + if !Odoc_global.keep_code then + Some (get_string_of_file pos_start_ele pos_end_ele) + else + None + ) ; + } + in + let (maybe_more, info_after_opt) = + My_ir.just_after_special + !file_name + (get_string_of_file pos_end_ele pos_limit) + in + e.ex_info <- merge_infos e.ex_info info_after_opt ; + let new_env = Odoc_env.add_exception env e.ex_name in + (maybe_more, new_env, [ Element_exception e ]) + + | Parsetree.Psig_type name_type_decl_list -> + (* we start by extending the environment *) + let new_env = + List.fold_left + (fun acc_env -> fun (name, _) -> + let complete_name = Name.concat current_module_name name in + Odoc_env.add_type acc_env complete_name + ) + env + name_type_decl_list + in + let rec f ?(first=false) acc_maybe_more last_pos name_type_decl_list = + match name_type_decl_list with + [] -> + (acc_maybe_more, []) + | (name, type_decl) :: q -> + let (assoc_com, ele_comments) = + if first then + (comment_opt, []) + else + get_comments_in_module + last_pos + type_decl.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum + in + let pos_limit2 = + match q with + [] -> pos_limit + | (_, td) :: _ -> td.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum + in + let (maybe_more, name_comment_list) = + name_comment_from_type_kind + type_decl.Parsetree.ptype_loc.Location.loc_end.Lexing.pos_cnum + pos_limit2 + type_decl.Parsetree.ptype_kind + in + print_DEBUG ("Type "^name^" : "^(match assoc_com with None -> "sans commentaire" | Some c -> Odoc_misc.string_of_info c)); + let f_DEBUG (name, c_opt) = print_DEBUG ("constructor/field "^name^": "^(match c_opt with None -> "sans commentaire" | Some c -> Odoc_misc.string_of_info c)) in + List.iter f_DEBUG name_comment_list; + (* get the information for the type in the signature *) + let sig_type_decl = + try Signature_search.search_type table name + with Not_found -> + raise (Failure (Odoc_messages.type_not_found current_module_name name)) + in + (* get the type kind with the associated comments *) + let type_kind = get_type_kind new_env name_comment_list sig_type_decl.Types.type_kind in + let loc_start = type_decl.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum in + let new_end = type_decl.Parsetree.ptype_loc.Location.loc_end.Lexing.pos_cnum + maybe_more in + (* associate the comments to each constructor and build the [Type.t_type] *) + let new_type = + { + ty_name = Name.concat current_module_name name ; + ty_info = assoc_com ; + ty_parameters = + List.map2 (fun p (co,cn,_) -> + (Odoc_env.subst_type new_env p, + co, cn) + ) + sig_type_decl.Types.type_params + sig_type_decl.Types.type_variance; + ty_kind = type_kind; + ty_private = sig_type_decl.Types.type_private; + ty_manifest = + (match sig_type_decl.Types.type_manifest with + None -> None + | Some t -> Some (Odoc_env.subst_type new_env t)); + ty_loc = + { loc_impl = None ; + loc_inter = Some (!file_name,loc_start) ; + }; + ty_code = + ( + if !Odoc_global.keep_code then + Some (get_string_of_file loc_start new_end) + else + None + ) ; + } + in + let (maybe_more2, info_after_opt) = + My_ir.just_after_special + !file_name + (get_string_of_file new_end pos_limit2) + in + new_type.ty_info <- merge_infos new_type.ty_info info_after_opt ; + let (new_maybe_more, eles) = f + (maybe_more + maybe_more2) + (new_end + maybe_more2) + q + in + (new_maybe_more, (ele_comments @ [Element_type new_type]) @ eles) + in + let (maybe_more, types) = f ~first: true 0 pos_start_ele name_type_decl_list in + (maybe_more, new_env, types) + + | Parsetree.Psig_open _ -> (* A VOIR *) + let ele_comments = match comment_opt with + None -> [] + | Some i -> + match i.i_desc with + None -> [] + | Some t -> [Element_module_comment t] + in + (0, env, ele_comments) + + | Parsetree.Psig_module (name, module_type) -> + let complete_name = Name.concat current_module_name name in + (* get the the module type in the signature by the module name *) + let sig_module_type = + try Signature_search.search_module table name + with Not_found -> + raise (Failure (Odoc_messages.module_not_found current_module_name name)) + in + let module_kind = analyse_module_kind env complete_name module_type sig_module_type in + let code_intf = + if !Odoc_global.keep_code then + let loc = module_type.Parsetree.pmty_loc in + let st = loc.Location.loc_start.Lexing.pos_cnum in + let en = loc.Location.loc_end.Lexing.pos_cnum in + Some (get_string_of_file st en) + else + None + in + let new_module = + { + m_name = complete_name ; + m_type = sig_module_type; + m_info = comment_opt ; + m_is_interface = true ; + m_file = !file_name ; + m_kind = module_kind ; + m_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ; + m_top_deps = [] ; + m_code = None ; + m_code_intf = code_intf ; + m_text_only = false ; + } + in + let (maybe_more, info_after_opt) = + My_ir.just_after_special + !file_name + (get_string_of_file pos_end_ele pos_limit) + in + new_module.m_info <- merge_infos new_module.m_info info_after_opt ; + let new_env = Odoc_env.add_module env new_module.m_name in + let new_env2 = + match new_module.m_type with (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *) + Types.Tmty_signature s -> Odoc_env.add_signature new_env new_module.m_name ~rel: (Name.simple new_module.m_name) s + | _ -> new_env + in + (maybe_more, new_env2, [ Element_module new_module ]) + + | Parsetree.Psig_recmodule decls -> + (* we start by extending the environment *) + let new_env = + List.fold_left + (fun acc_env -> fun (name, _) -> + let complete_name = Name.concat current_module_name name in + let e = Odoc_env.add_module acc_env complete_name in + (* get the information for the module in the signature *) + let sig_module_type = + try Signature_search.search_module table name + with Not_found -> + raise (Failure (Odoc_messages.module_not_found current_module_name name)) + in + match sig_module_type with + (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *) + Types.Tmty_signature s -> + Odoc_env.add_signature e complete_name ~rel: name s + | _ -> + print_DEBUG "not a Tmty_signature"; + e + ) + env + decls + in + let rec f ?(first=false) acc_maybe_more last_pos name_mtype_list = + match name_mtype_list with + [] -> + (acc_maybe_more, []) + | (name, modtype) :: q -> + let complete_name = Name.concat current_module_name name in + let loc_start = modtype.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in + let loc_end = modtype.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in + let (assoc_com, ele_comments) = + if first then + (comment_opt, []) + else + get_comments_in_module + last_pos + loc_start + in + let pos_limit2 = + match q with + [] -> pos_limit + | (_, mty) :: _ -> mty.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum + in + (* get the information for the module in the signature *) + let sig_module_type = + try Signature_search.search_module table name + with Not_found -> + raise (Failure (Odoc_messages.module_not_found current_module_name name)) + in + (* associate the comments to each constructor and build the [Type.t_type] *) + let module_kind = analyse_module_kind new_env complete_name modtype sig_module_type in + let code_intf = + if !Odoc_global.keep_code then + let loc = modtype.Parsetree.pmty_loc in + let st = loc.Location.loc_start.Lexing.pos_cnum in + let en = loc.Location.loc_end.Lexing.pos_cnum in + Some (get_string_of_file st en) + else + None + in + let new_module = + { + m_name = complete_name ; + m_type = sig_module_type; + m_info = assoc_com ; + m_is_interface = true ; + m_file = !file_name ; + m_kind = module_kind ; + m_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ; + m_top_deps = [] ; + m_code = None ; + m_code_intf = code_intf ; + m_text_only = false ; + } + in + let (maybe_more, info_after_opt) = + My_ir.just_after_special + !file_name + (get_string_of_file loc_end pos_limit2) + in + new_module.m_info <- merge_infos new_module.m_info info_after_opt ; + + let (maybe_more2, eles) = f + maybe_more + (loc_end + maybe_more) + q + in + (maybe_more2, (ele_comments @ [Element_module new_module]) @ eles) + in + let (maybe_more, mods) = f ~first: true 0 pos_start_ele decls in + (maybe_more, new_env, mods) + + | Parsetree.Psig_modtype (name, pmodtype_decl) -> + let complete_name = Name.concat current_module_name name in + let sig_mtype = + try Signature_search.search_module_type table name + with Not_found -> + raise (Failure (Odoc_messages.module_type_not_found current_module_name name)) + in + let module_type_kind = + match pmodtype_decl with + Parsetree.Pmodtype_abstract -> None + | Parsetree.Pmodtype_manifest module_type -> + match sig_mtype with + | Some sig_mtype -> Some (analyse_module_type_kind env complete_name module_type sig_mtype) + | None -> None + in + + let mt = + { + mt_name = complete_name ; + mt_info = comment_opt ; + mt_type = sig_mtype ; + mt_is_interface = true ; + mt_file = !file_name ; + mt_kind = module_type_kind ; + mt_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ; + } + in + let (maybe_more, info_after_opt) = + My_ir.just_after_special + !file_name + (get_string_of_file pos_end_ele pos_limit) + in + mt.mt_info <- merge_infos mt.mt_info info_after_opt ; + let new_env = Odoc_env.add_module_type env mt.mt_name in + let new_env2 = + match sig_mtype with (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *) + Some (Types.Tmty_signature s) -> Odoc_env.add_signature new_env mt.mt_name ~rel: (Name.simple mt.mt_name) s + | _ -> new_env + in + (maybe_more, new_env2, [ Element_module_type mt ]) + + | Parsetree.Psig_include module_type -> + let rec f = function + Parsetree.Pmty_ident longident -> + Name.from_longident longident + | Parsetree.Pmty_signature _ -> + "??" + | Parsetree.Pmty_functor _ -> + "??" + | Parsetree.Pmty_with (mt, _) -> + f mt.Parsetree.pmty_desc + | Parsetree.Pmty_typeof mexpr -> + match mexpr.Parsetree.pmod_desc with + Parsetree.Pmod_ident longident -> Name.from_longident longident + | _ -> "??" + in + let name = f module_type.Parsetree.pmty_desc in + let full_name = Odoc_env.full_module_or_module_type_name env name in + let im = + { + im_name = full_name ; + im_module = None ; + im_info = comment_opt; + } + in + (0, env, [ Element_included_module im ]) (* A VOIR : étendre l'environnement ? avec quoi ? *) + + | Parsetree.Psig_class class_description_list -> + (* we start by extending the environment *) + let new_env = + List.fold_left + (fun acc_env -> fun class_desc -> + let complete_name = Name.concat current_module_name class_desc.Parsetree.pci_name in + Odoc_env.add_class acc_env complete_name + ) + env + class_description_list + in + let rec f ?(first=false) acc_maybe_more last_pos class_description_list = + match class_description_list with + [] -> + (acc_maybe_more, []) + | class_desc :: q -> + let (assoc_com, ele_comments) = + if first then + (comment_opt, []) + else + get_comments_in_module + last_pos + class_desc.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum + in + let pos_end = class_desc.Parsetree.pci_loc.Location.loc_end.Lexing.pos_cnum in + let pos_limit2 = + match q with + [] -> pos_limit + | cd :: _ -> cd.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum + in + let name = class_desc.Parsetree.pci_name in + let complete_name = Name.concat current_module_name name in + let sig_class_decl = + try Signature_search.search_class table name + with Not_found -> + raise (Failure (Odoc_messages.class_not_found current_module_name name)) + in + let sig_class_type = sig_class_decl.Types.cty_type in + let (parameters, class_kind) = + analyse_class_kind + new_env + complete_name + class_desc.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum + class_desc.Parsetree.pci_expr + sig_class_type + in + let new_class = + { + cl_name = complete_name ; + cl_info = assoc_com ; + cl_type = Odoc_env.subst_class_type env sig_class_type ; + cl_type_parameters = sig_class_decl.Types.cty_params; + cl_virtual = class_desc.Parsetree.pci_virt = Asttypes.Virtual ; + cl_kind = class_kind ; + cl_parameters = parameters ; + cl_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ; + } + in + let (maybe_more, info_after_opt) = + My_ir.just_after_special + !file_name + (get_string_of_file pos_end pos_limit2) + in + new_class.cl_info <- merge_infos new_class.cl_info info_after_opt ; + Odoc_class.class_update_parameters_text new_class ; + let (new_maybe_more, eles) = + f maybe_more (pos_end + maybe_more) q + in + (new_maybe_more, + ele_comments @ (( Element_class new_class ) :: eles)) + in + let (maybe_more, eles) = + f ~first: true 0 pos_start_ele class_description_list + in + (maybe_more, new_env, eles) + + | Parsetree.Psig_class_type class_type_declaration_list -> + (* we start by extending the environment *) + let new_env = + List.fold_left + (fun acc_env -> fun class_type_decl -> + let complete_name = Name.concat current_module_name class_type_decl.Parsetree.pci_name in + Odoc_env.add_class_type acc_env complete_name + ) + env + class_type_declaration_list + in + let rec f ?(first=false) acc_maybe_more last_pos class_type_description_list = + match class_type_description_list with + [] -> + (acc_maybe_more, []) + | ct_decl :: q -> + let (assoc_com, ele_comments) = + if first then + (comment_opt, []) + else + get_comments_in_module + last_pos + ct_decl.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum + in + let pos_end = ct_decl.Parsetree.pci_loc.Location.loc_end.Lexing.pos_cnum in + let pos_limit2 = + match q with + [] -> pos_limit + | ct_decl2 :: _ -> ct_decl2.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum + in + let name = ct_decl.Parsetree.pci_name in + let complete_name = Name.concat current_module_name name in + let sig_cltype_decl = + try Signature_search.search_class_type table name + with Not_found -> + raise (Failure (Odoc_messages.class_type_not_found current_module_name name)) + in + let sig_class_type = sig_cltype_decl.Types.clty_type in + let kind = analyse_class_type_kind + new_env + complete_name + ct_decl.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum + ct_decl.Parsetree.pci_expr + sig_class_type + in + let ct = + { + clt_name = complete_name ; + clt_info = assoc_com ; + clt_type = Odoc_env.subst_class_type env sig_class_type ; + clt_type_parameters = sig_cltype_decl.clty_params ; + clt_virtual = ct_decl.Parsetree.pci_virt = Asttypes.Virtual ; + clt_kind = kind ; + clt_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ; + } + in + let (maybe_more, info_after_opt) = + My_ir.just_after_special + !file_name + (get_string_of_file pos_end pos_limit2) + in + ct.clt_info <- merge_infos ct.clt_info info_after_opt ; + let (new_maybe_more, eles) = + f maybe_more (pos_end + maybe_more) q + in + (new_maybe_more, + ele_comments @ (( Element_class_type ct) :: eles)) + in + let (maybe_more, eles) = + f ~first: true 0 pos_start_ele class_type_declaration_list + in + (maybe_more, new_env, eles) + + (** Return a module_type_kind from a Parsetree.module_type and a Types.module_type *) + and analyse_module_type_kind env current_module_name module_type sig_module_type = + match module_type.Parsetree.pmty_desc with + Parsetree.Pmty_ident longident -> + let name = + match sig_module_type with + Types.Tmty_ident path -> Name.from_path path + | _ -> Name.from_longident longident + (* A VOIR cela arrive quand on fait module type F : functor ... -> Toto, Toto n'est pas un ident mais une structure *) + in + Module_type_alias { mta_name = Odoc_env.full_module_type_name env name ; + mta_module = None } + + | Parsetree.Pmty_signature ast -> + ( + (* we must have a signature in the module type *) + match sig_module_type with + Types.Tmty_signature signat -> + let pos_start = module_type.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in + let pos_end = module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in + let elements = analyse_parsetree env signat current_module_name pos_start pos_end ast in + Module_type_struct elements + | _ -> + raise (Failure "Parsetree.Pmty_signature signature but not Types.Tmty_signature signat") + ) + + | Parsetree.Pmty_functor (_,pmodule_type2, module_type2) -> + ( + let loc_start = pmodule_type2.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in + let loc_end = pmodule_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in + let mp_type_code = get_string_of_file loc_start loc_end in + print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code); + match sig_module_type with + Types.Tmty_functor (ident, param_module_type, body_module_type) -> + let mp_kind = analyse_module_type_kind env + current_module_name pmodule_type2 param_module_type + in + let param = + { + mp_name = Name.from_ident ident ; + mp_type = Odoc_env.subst_module_type env param_module_type ; + mp_type_code = mp_type_code ; + mp_kind = mp_kind ; + } + in + let k = analyse_module_type_kind env + current_module_name + module_type2 + body_module_type + in + Module_type_functor (param, k) + + | _ -> + (* if we're here something's wrong *) + raise (Failure "Parsetree.Pmty_functor _ but not Types.Tmty_functor _") + ) + + | Parsetree.Pmty_with (module_type2, _) -> + (* of module_type * (Longident.t * with_constraint) list *) + ( + let loc_start = module_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in + let loc_end = module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in + let s = get_string_of_file loc_start loc_end in + let k = analyse_module_type_kind env current_module_name module_type2 sig_module_type in + Module_type_with (k, s) + ) + + | Parsetree.Pmty_typeof module_expr -> + let loc_start = module_expr.Parsetree.pmod_loc.Location.loc_start.Lexing.pos_cnum in + let loc_end = module_expr.Parsetree.pmod_loc.Location.loc_end.Lexing.pos_cnum in + let s = get_string_of_file loc_start loc_end in + Module_type_typeof s + + (** analyse of a Parsetree.module_type and a Types.module_type.*) + and analyse_module_kind env current_module_name module_type sig_module_type = + match module_type.Parsetree.pmty_desc with + Parsetree.Pmty_ident longident -> + let k = analyse_module_type_kind env current_module_name module_type sig_module_type in + Module_with ( k, "" ) + + | Parsetree.Pmty_signature signature -> + ( + match sig_module_type with + Types.Tmty_signature signat -> + Module_struct + (analyse_parsetree + env + signat + current_module_name + module_type.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum + module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum + signature + ) + | _ -> + (* if we're here something's wrong *) + raise (Failure "Parsetree.Pmty_signature signature but not Types.Tmty_signature signat") + ) + | Parsetree.Pmty_functor (_,pmodule_type2,module_type2) (* of string * module_type * module_type *) -> + ( + match sig_module_type with + Types.Tmty_functor (ident, param_module_type, body_module_type) -> + let loc_start = pmodule_type2.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in + let loc_end = pmodule_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in + let mp_type_code = get_string_of_file loc_start loc_end in + print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code); + let mp_kind = analyse_module_type_kind env + current_module_name pmodule_type2 param_module_type + in + let param = + { + mp_name = Name.from_ident ident ; + mp_type = Odoc_env.subst_module_type env param_module_type ; + mp_type_code = mp_type_code ; + mp_kind = mp_kind ; + } + in + let k = analyse_module_kind env + current_module_name + module_type2 + body_module_type + in + Module_functor (param, k) + + | _ -> + (* if we're here something's wrong *) + raise (Failure "Parsetree.Pmty_functor _ but not Types.Tmty_functor _") + ) + | Parsetree.Pmty_with (module_type2, _) -> + (*of module_type * (Longident.t * with_constraint) list*) + ( + let loc_start = module_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in + let loc_end = module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in + let s = get_string_of_file loc_start loc_end in + let k = analyse_module_type_kind env current_module_name module_type2 sig_module_type in + Module_with (k, s) + ) + | Parsetree.Pmty_typeof module_expr -> + let loc_start = module_expr.Parsetree.pmod_loc.Location.loc_start.Lexing.pos_cnum in + let loc_end = module_expr.Parsetree.pmod_loc.Location.loc_end.Lexing.pos_cnum in + let s = get_string_of_file loc_start loc_end in + Module_typeof s + + (** Analyse of a Parsetree.class_type and a Types.class_type to return a couple + (class parameters, class_kind).*) + and analyse_class_kind env current_class_name last_pos parse_class_type sig_class_type = + match parse_class_type.Parsetree.pcty_desc, sig_class_type with + (Parsetree.Pcty_constr (_, _) (*of Longident.t * core_type list *), + Types.Tcty_constr (p, typ_list, _) (*of Path.t * type_expr list * class_type*)) -> + print_DEBUG "Tcty_constr _"; + let path_name = Name.from_path p in + let name = Odoc_env.full_class_or_class_type_name env path_name in + let k = + Class_constr + { + cco_name = name ; + cco_class = None ; + cco_type_parameters = List.map (Odoc_env.subst_type env) typ_list + } + in + ([], k) + + | (Parsetree.Pcty_signature (_, class_type_field_list), Types.Tcty_signature class_signature) -> + (* we get the elements of the class in class_type_field_list *) + let (inher_l, ele) = analyse_class_elements env current_class_name + last_pos + parse_class_type.Parsetree.pcty_loc.Location.loc_end.Lexing.pos_cnum + class_type_field_list + class_signature + in + ([], Class_structure (inher_l, ele)) + + | (Parsetree.Pcty_fun (parse_label, _, pclass_type), Types.Tcty_fun (label, type_expr, class_type)) -> + (* label = string. Dans les signatures, pas de nom de paramètres à l'intérieur des tuples *) + (* si label = "", pas de label. ici on a l'information pour savoir si on a un label explicite. *) + if parse_label = label then + ( + let new_param = Simple_name + { + sn_name = Btype.label_name label ; + sn_type = Odoc_env.subst_type env type_expr ; + sn_text = None ; (* will be updated when the class will be created *) + } + in + let (l, k) = analyse_class_kind env current_class_name last_pos pclass_type class_type in + ( (new_param :: l), k ) + ) + else + ( + raise (Failure "Parsetree.Pcty_fun (parse_label, _, pclass_type), labels différents") + ) + + | _ -> + raise (Failure "analyse_class_kind pas de correspondance dans le match") + + (** Analyse of a Parsetree.class_type and a Types.class_type to return a class_type_kind.*) + and analyse_class_type_kind env current_class_name last_pos parse_class_type sig_class_type = + match parse_class_type.Parsetree.pcty_desc, sig_class_type with + (Parsetree.Pcty_constr (_, _) (*of Longident.t * core_type list *), + Types.Tcty_constr (p, typ_list, _) (*of Path.t * type_expr list * class_type*)) -> + print_DEBUG "Tcty_constr _"; + let k = + Class_type + { + cta_name = Odoc_env.full_class_or_class_type_name env (Name.from_path p) ; + cta_class = None ; + cta_type_parameters = List.map (Odoc_env.subst_type env) typ_list + } + in + k + + | (Parsetree.Pcty_signature (_, class_type_field_list), Types.Tcty_signature class_signature) -> + (* we get the elements of the class in class_type_field_list *) + let (inher_l, ele) = analyse_class_elements env current_class_name + last_pos + parse_class_type.Parsetree.pcty_loc.Location.loc_end.Lexing.pos_cnum + class_type_field_list + class_signature + in + Class_signature (inher_l, ele) + + | (Parsetree.Pcty_fun (parse_label, _, pclass_type), Types.Tcty_fun (label, type_expr, class_type)) -> + raise (Failure "analyse_class_type_kind : Parsetree.Pcty_fun (...) with Types.Tcty_fun (...)") +(* + | (Parsetree.Pcty_constr (longident, _) (*of Longident.t * core_type list *), + Types.Tcty_signature class_signature) -> + (* A VOIR : c'est pour le cas des contraintes de classes : + class type cons = object + method m : int + end + + class ['a] maxou x = + (object + val a = (x : 'a) + method m = a + end : cons ) + ^^^^^^ + *) + let k = + Class_type + { + cta_name = Odoc_env.full_class_name env (Name.from_longident longident) ; + cta_class = None ; + cta_type_parameters = List.map (Odoc_env.subst_type env) typ_list (* ?? *) + } + in + ([], k) +*) + | _ -> + raise (Failure "analyse_class_type_kind pas de correspondance dans le match") + + let analyse_signature source_file input_file + (ast : Parsetree.signature) (signat : Types.signature) = + let complete_source_file = + try + let curdir = Sys.getcwd () in + let (dirname, basename) = (Filename.dirname source_file, Filename.basename source_file) in + Sys.chdir dirname ; + let complete = Filename.concat (Sys.getcwd ()) basename in + Sys.chdir curdir ; + complete + with + Sys_error s -> + prerr_endline s ; + incr Odoc_global.errors ; + source_file + in + prepare_file complete_source_file input_file; + (* We create the t_module for this file. *) + let mod_name = String.capitalize + (Filename.basename (try Filename.chop_extension source_file with _ -> source_file)) + in + let (len,info_opt) = My_ir.first_special !file_name !file in + let elements = + analyse_parsetree Odoc_env.empty signat mod_name len (String.length !file) ast + in + let code_intf = + if !Odoc_global.keep_code then + Some !file + else + None + in + { + m_name = mod_name ; + m_type = Types.Tmty_signature signat ; + m_info = info_opt ; + m_is_interface = true ; + m_file = !file_name ; + m_kind = Module_struct elements ; + m_loc = { loc_impl = None ; loc_inter = Some (!file_name, 0) } ; + m_top_deps = [] ; + m_code = None ; + m_code_intf = code_intf ; + m_text_only = false ; + } + + end diff --git a/ocaml-binary-annot/ocamldoc/odoc_sig.mli b/ocaml-binary-annot/ocamldoc/odoc_sig.mli new file mode 100644 index 0000000000..65ee128fc5 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_sig.mli @@ -0,0 +1,177 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** The module for analysing a signature and source code and creating modules, classes, ..., elements.*) + +(** The functions used to retrieve information from a signature. *) +module Signature_search : + sig + type ele + type tab = (ele, Types.signature_item) Hashtbl.t + + (** Create a table from a signature. This table is used by some + of the search functions below. *) + val table : Types.signature -> tab + + (** This function returns the type expression for the value whose name is given, + in the given signature. + @raise Not_found if error.*) + val search_value : tab -> string -> Types.type_expr + + (** This function returns the type expression list for the exception whose name is given, + in the given table. + @raise Not_found if error.*) + val search_exception : tab -> string -> Types.exception_declaration + + (** This function returns the Types.type_declaration for the type whose name is given, + in the given table. + @raise Not_found if error.*) + val search_type : tab -> string -> Types.type_declaration + + (** This function returns the Types.class_declaration for the class whose name is given, + in the given table. + @raise Not_found if error.*) + val search_class : tab -> string -> Types.class_declaration + + (** This function returns the Types.cltype_declaration for the class type whose name is given, + in the given table. + @raise Not_found if error.*) + val search_class_type : tab -> string -> Types.cltype_declaration + + (** This function returns the Types.module_type for the module whose name is given, + in the given table. + @raise Not_found if error.*) + val search_module : tab -> string -> Types.module_type + + (** This function returns the optional Types.module_type for the module type whose name is given, + in the given table. + @raise Not_found if error.*) + val search_module_type : tab -> string -> Types.module_type option + + (** This function returns the Types.type_expr for the given val name + in the given class signature. + @raise Not_found if error.*) + val search_attribute_type : + Types.Vars.key -> Types.class_signature -> Types.type_expr + + (** This function returns the Types.type_expr for the given method name + in the given class signature. + @raise Not_found if error.*) + val search_method_type : + string -> Types.class_signature -> Types.type_expr + end + +(** Functions to retrieve simple and special comments from strings. *) +module type Info_retriever = + sig + (** Return the couple [(n, list)] where [n] is the number of + characters read to retrieve [list], which is the list + of special comments found in the string. *) + val all_special : + string -> string -> int * Odoc_types.info list + + (** Return true if the given string contains a blank line. *) + val blank_line_outside_simple : + string -> string -> bool + + (** [just_after_special file str] return the pair ([length], [info_opt]) + where [info_opt] is the first optional special comment found + in [str], without any blank line before. [length] is the number + of chars from the beginning of [str] to the end of the special comment. *) + val just_after_special : + string -> string -> (int * Odoc_types.info option) + + (** [first_special file str] return the pair ([length], [info_opt]) + where [info_opt] is the first optional special comment found + in [str]. [length] is the number of chars from the beginning of [str] + to the end of the special comment. *) + val first_special : + string -> string -> (int * Odoc_types.info option) + + (** Return a pair [(comment_opt, element_comment_list)], where [comment_opt] is the last special + comment found in the given string and not followed by a blank line, + and [element_comment_list] the list of values built from the other + special comments found and the given function. *) + val get_comments : + (Odoc_types.text -> 'a) -> string -> string -> (Odoc_types.info option * 'a list) + + end + +module Analyser : + functor (My_ir : Info_retriever) -> + sig + (** This variable is used to load a file as a string and retrieve characters from it.*) + val file : string ref + + (** The name of the analysed file. *) + val file_name : string ref + + (** This function takes two indexes (start and end) and return the string + corresponding to the indexes in the file global variable. The function + prepare_file must have been called to fill the file global variable.*) + val get_string_of_file : int -> int -> string + + (** [prepare_file f input_f] sets [file_name] with [f] and loads the file + [input_f] into [file].*) + val prepare_file : string -> string -> unit + + (** The function used to get the comments in a class. *) + val get_comments_in_class : int -> int -> + (Odoc_types.info option * Odoc_class.class_element list) + + (** The function used to get the comments in a module. *) + val get_comments_in_module : int -> int -> + (Odoc_types.info option * Odoc_module.module_element list) + + (** [name_comment_from_type_kind pos_end pos_limit type_kind]. + This function takes a [Parsetree.type_kind] and returns the list of + (name, optional comment) for the various fields/constructors of the type, + or an empty list for an abstract type. + [pos_end] is last char of the complete type definition. + [pos_limit] is the position of the last char we could use to look for a comment, + i.e. usually the beginning on the next element.*) + val name_comment_from_type_kind : + int -> int -> Parsetree.type_kind -> int * (string * Odoc_types.info option) list + + (** This function converts a [Types.type_kind] into a [Odoc_type.type_kind], + by associating the comment found in the parsetree of each constructor/field, if any.*) + val get_type_kind : + Odoc_env.env -> (string * Odoc_types.info option) list -> + Types.type_kind -> Odoc_type.type_kind + + (** This function merge two optional info structures. *) + val merge_infos : + Odoc_types.info option -> Odoc_types.info option -> + Odoc_types.info option + + (** Return a module_type_kind from a Parsetree.module_type and a Types.module_type *) + val analyse_module_type_kind : + Odoc_env.env -> Odoc_name.t -> + Parsetree.module_type -> Types.module_type -> + Odoc_module.module_type_kind + + (** Analysis of a Parsetree.class_type and a Types.class_type to + return a class_type_kind.*) + val analyse_class_type_kind : Odoc_env.env -> + Odoc_name.t -> int -> Parsetree.class_type -> Types.class_type -> + Odoc_class.class_type_kind + + (** This function takes an interface file name, a file containg the code, a parse tree + and the signature obtained from the compiler. + It goes through the parse tree, creating values for encountered + functions, modules, ..., looking in the source file for comments, + and in the signature for types information. *) + val analyse_signature : + string -> string -> + Parsetree.signature -> Types.signature -> Odoc_module.t_module + end diff --git a/ocaml-binary-annot/ocamldoc/odoc_str.ml b/ocaml-binary-annot/ocamldoc/odoc_str.ml new file mode 100644 index 0000000000..b20cd8b4bc --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_str.ml @@ -0,0 +1,277 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** The functions to get a string from different kinds of elements (types, modules, ...). *) + +module Name = Odoc_name + +let string_of_variance t (co,cn) = + if t.Odoc_type.ty_kind = Odoc_type.Type_abstract && + t.Odoc_type.ty_manifest = None + then + match (co, cn) with + (true, false) -> "+" + | (false, true) -> "-" + | _ -> "" + else + "" +let rec is_arrow_type t = + match t.Types.desc with + Types.Tarrow _ -> true + | Types.Tlink t2 | Types.Tsubst t2 -> is_arrow_type t2 + | Types.Ttuple _ + | Types.Tconstr _ + | Types.Tvar | Types.Tunivar | Types.Tobject _ | Types.Tpoly _ + | Types.Tfield _ | Types.Tnil | Types.Tvariant _ | Types.Tpackage _ -> false + +let raw_string_of_type_list sep type_list = + let buf = Buffer.create 256 in + let fmt = Format.formatter_of_buffer buf in + let rec need_parent t = + match t.Types.desc with + Types.Tarrow _ | Types.Ttuple _ -> true + | Types.Tlink t2 | Types.Tsubst t2 -> need_parent t2 + | Types.Tconstr _ -> + false + | Types.Tvar | Types.Tunivar | Types.Tobject _ | Types.Tpoly _ + | Types.Tfield _ | Types.Tnil | Types.Tvariant _ | Types.Tpackage _ -> false + in + let print_one_type variance t = + Printtyp.mark_loops t; + if need_parent t then + ( + Format.fprintf fmt "(%s" variance; + Printtyp.type_scheme_max ~b_reset_names: false fmt t; + Format.fprintf fmt ")" + ) + else + ( + Format.fprintf fmt "%s" variance; + Printtyp.type_scheme_max ~b_reset_names: false fmt t + ) + in + begin match type_list with + [] -> () + | [(variance, ty)] -> print_one_type variance ty + | (variance, ty) :: tyl -> + Format.fprintf fmt "@[<hov 2>"; + print_one_type variance ty; + List.iter + (fun (variance, t) -> + Format.fprintf fmt "@,%s" sep; + print_one_type variance t + ) + tyl; + Format.fprintf fmt "@]" + end; + Format.pp_print_flush fmt (); + Buffer.contents buf + +let string_of_type_list ?par sep type_list = + let par = + match par with + | Some b -> b + | None -> + match type_list with + [] | [_] -> false + | _ -> true + in + Printf.sprintf "%s%s%s" + (if par then "(" else "") + (raw_string_of_type_list sep (List.map (fun t -> ("", t)) type_list)) + (if par then ")" else "") + +let string_of_type_param_list t = + let par = + match t.Odoc_type.ty_parameters with + [] | [_] -> false + | _ -> true + in + Printf.sprintf "%s%s%s" + (if par then "(" else "") + (raw_string_of_type_list ", " + (List.map + (fun (typ, co, cn) -> (string_of_variance t (co, cn), typ)) + t.Odoc_type.ty_parameters + ) + ) + (if par then ")" else "") + +let string_of_class_type_param_list l = + let par = + match l with + [] | [_] -> false + | _ -> true + in + Printf.sprintf "%s%s%s" + (if par then "[" else "") + (raw_string_of_type_list ", " + (List.map + (fun typ -> ("", typ)) + l + ) + ) + (if par then "]" else "") + +let string_of_class_params c = + let b = Buffer.create 256 in + let rec iter = function + Types.Tcty_fun (label, t, ctype) -> + let parent = is_arrow_type t in + Printf.bprintf b "%s%s%s%s -> " + ( + match label with + "" -> "" + | s -> s^":" + ) + (if parent then "(" else "") + (Odoc_print.string_of_type_expr + (if Odoc_misc.is_optional label then + Odoc_misc.remove_option t + else + t + ) + ) + (if parent then ")" else ""); + iter ctype + | Types.Tcty_signature _ + | Types.Tcty_constr _ -> () + in + iter c.Odoc_class.cl_type; + Buffer.contents b + +let bool_of_private = function + | Asttypes.Private -> true + | _ -> false + +let string_of_type t = + let module M = Odoc_type in + "type "^ + (String.concat "" + (List.map + (fun (p, co, cn) -> + (string_of_variance t (co, cn))^ + (Odoc_print.string_of_type_expr p)^" " + ) + t.M.ty_parameters + ) + )^ + let priv = bool_of_private (t.M.ty_private) in + (Name.simple t.M.ty_name)^" "^ + (match t.M.ty_manifest with + None -> "" + | Some typ -> + "= " ^ (if priv then "private " else "" ) ^ + (Odoc_print.string_of_type_expr typ)^" " + )^ + (match t.M.ty_kind with + M.Type_abstract -> + "" + | M.Type_variant l -> + "="^(if priv then " private" else "")^"\n"^ + (String.concat "" + (List.map + (fun cons -> + " | "^cons.M.vc_name^ + (match cons.M.vc_args with + [] -> "" + | l -> + " of "^(String.concat " * " + (List.map (fun t -> "("^(Odoc_print.string_of_type_expr t)^")") l)) + )^ + (match cons.M.vc_text with + None -> + "" + | Some t -> + "(* "^(Odoc_misc.string_of_text t)^" *)" + )^"\n" + ) + l + ) + ) + | M.Type_record l -> + "= "^(if priv then "private " else "")^"{\n"^ + (String.concat "" + (List.map + (fun record -> + " "^(if record.M.rf_mutable then "mutable " else "")^ + record.M.rf_name^" : "^(Odoc_print.string_of_type_expr record.M.rf_type)^";"^ + (match record.M.rf_text with + None -> + "" + | Some t -> + "(* "^(Odoc_misc.string_of_text t)^" *)" + )^"\n" + ) + l + ) + )^ + "}\n" + )^ + (match t.M.ty_info with + None -> "" + | Some info -> Odoc_misc.string_of_info info) + +let string_of_exception e = + let module M = Odoc_exception in + "exception "^(Name.simple e.M.ex_name)^ + (match e.M.ex_args with + [] -> "" + | _ ->" : "^ + (String.concat " -> " + (List.map (fun t -> "("^(Odoc_print.string_of_type_expr t)^")") e.M.ex_args) + ) + )^ + (match e.M.ex_alias with + None -> "" + | Some ea -> + " = "^ + (match ea.M.ea_ex with + None -> ea.M.ea_name + | Some e2 -> e2.M.ex_name + ) + )^"\n"^ + (match e.M.ex_info with + None -> "" + | Some i -> Odoc_misc.string_of_info i) + +let string_of_value v = + let module M = Odoc_value in + "val "^(Name.simple v.M.val_name)^" : "^ + (Odoc_print.string_of_type_expr v.M.val_type)^"\n"^ + (match v.M.val_info with + None -> "" + | Some i -> Odoc_misc.string_of_info i) + +let string_of_attribute a = + let module M = Odoc_value in + "val "^ + (if a.M.att_virtual then "virtual " else "")^ + (if a.M.att_mutable then Odoc_messages.mutab^" " else "")^ + (Name.simple a.M.att_value.M.val_name)^" : "^ + (Odoc_print.string_of_type_expr a.M.att_value.M.val_type)^"\n"^ + (match a.M.att_value.M.val_info with + None -> "" + | Some i -> Odoc_misc.string_of_info i) + +let string_of_method m = + let module M = Odoc_value in + "method "^ + (if m.M.met_private then Odoc_messages.privat^" " else "")^ + (Name.simple m.M.met_value.M.val_name)^" : "^ + (Odoc_print.string_of_type_expr m.M.met_value.M.val_type)^"\n"^ + (match m.M.met_value.M.val_info with + None -> "" + | Some i -> Odoc_misc.string_of_info i) + +(* eof $Id$ *) diff --git a/ocaml-binary-annot/ocamldoc/odoc_str.mli b/ocaml-binary-annot/ocamldoc/odoc_str.mli new file mode 100644 index 0000000000..5d68c6d234 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_str.mli @@ -0,0 +1,51 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** The functions to get a string from different kinds of elements (types, modules, ...). *) + +(** @return the variance string for the given type and (covariant, contravariant) information. *) +val string_of_variance : Odoc_type.t_type -> (bool * bool) -> string + +(** This function returns a string to represent the given list of types, + with a given separator. + @param par can be used to force the addition or not of parentheses around the returned string. +*) +val string_of_type_list : ?par: bool -> string -> Types.type_expr list -> string + +(** This function returns a string to represent the list of type parameters + for the given type. *) +val string_of_type_param_list : Odoc_type.t_type -> string + +(** This function returns a string to represent the given list of + type parameters of a class or class type, + with a given separator. *) +val string_of_class_type_param_list : Types.type_expr list -> string + +(** @return a string to describe the given type. *) +val string_of_type : Odoc_type.t_type -> string + +(** @return a string to display the parameters of the given class, + in the same form as the compiler. *) +val string_of_class_params : Odoc_class.t_class -> string + +(** @return a string to describe the given exception. *) +val string_of_exception : Odoc_exception.t_exception -> string + +(** @return a string to describe the given value. *) +val string_of_value : Odoc_value.t_value -> string + +(** @return a string to describe the given attribute. *) +val string_of_attribute : Odoc_value.t_attribute -> string + +(** @return a string to describe the given method. *) +val string_of_method : Odoc_value.t_method -> string diff --git a/ocaml-binary-annot/ocamldoc/odoc_test.ml b/ocaml-binary-annot/ocamldoc/odoc_test.ml new file mode 100644 index 0000000000..7b455f45bf --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_test.ml @@ -0,0 +1,118 @@ +(***********************************************************************) +(* OCamldoc *) +(* *) +(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2004 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Custom generator to perform test on ocamldoc. *) + +open Odoc_info +open Odoc_info.Module +open Odoc_info.Type + +type test_kind = + Types_display + +let p = Format.fprintf + +module Generator = +struct +class string_gen = + object(self) + inherit Odoc_info.Scan.scanner + + val mutable test_kinds = [] + val mutable fmt = Format.str_formatter + + method must_display_types = List.mem Types_display test_kinds + + method set_test_kinds_from_module m = + test_kinds <- List.fold_left + (fun acc (s, _) -> + match s with + "test_types_display" -> Types_display :: acc + | _ -> acc + ) + [] + ( + match m.m_info with + None -> [] + | Some i -> i.i_custom + ) + method! scan_type t = + match test_kinds with + [] -> () + | _ -> + p fmt "# type %s:\n" t.ty_name; + if self#must_display_types then + ( + p fmt "# manifest (Odoc_info.string_of_type_expr):\n<[%s]>\n" + (match t.ty_manifest with + None -> "None" + | Some e -> Odoc_info.string_of_type_expr e + ); + ); + + + method! scan_module_pre m = + p fmt "#\n# module %s:\n" m.m_name ; + if self#must_display_types then + ( + p fmt "# Odoc_info.string_of_module_type:\n<[%s]>\n" + (Odoc_info.string_of_module_type m.m_type); + p fmt "# Odoc_info.string_of_module_type ~complete: true :\n<[%s]>\n" + (Odoc_info.string_of_module_type ~complete: true m.m_type); + ); + true + + method! scan_module_type_pre m = + p fmt "#\n# module type %s:\n" m.mt_name ; + if self#must_display_types then + ( + p fmt "# Odoc_info.string_of_module_type:\n<[%s]>\n" + (match m.mt_type with + None -> "None" + | Some t -> Odoc_info.string_of_module_type t + ); + p fmt "# Odoc_info.string_of_module_type ~complete: true :\n<[%s]>\n" + (match m.mt_type with + None -> "None" + | Some t -> Odoc_info.string_of_module_type ~complete: true t + ); + ); + true + + method generate (module_list: Odoc_info.Module.t_module list) = + let oc = open_out !Odoc_info.Global.out_file in + fmt <- Format.formatter_of_out_channel oc; + ( + try + List.iter + (fun m -> + self#set_test_kinds_from_module m; + self#scan_module_list [m]; + ) + module_list + with + e -> + prerr_endline (Printexc.to_string e) + ); + Format.pp_print_flush fmt (); + close_out oc + end + + class generator = + let g = new string_gen in + object + method generate = g#generate + end +end;; + +let _ = Odoc_args.set_generator (Odoc_gen.Other (module Generator : Odoc_gen.Base)) diff --git a/ocaml-binary-annot/ocamldoc/odoc_texi.ml b/ocaml-binary-annot/ocamldoc/odoc_texi.ml new file mode 100644 index 0000000000..30ac53ce77 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_texi.ml @@ -0,0 +1,1244 @@ +(***********************************************************************) +(* OCamldoc *) +(* *) +(* Olivier Andrieu, base sur du code de Maxence Guesdon *) +(* *) +(* 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. *) +(***********************************************************************) + +(* $Id$ *) + +(** Generation of Texinfo documentation. *) + +open Odoc_info +open Parameter +open Value +open Type +open Exception +open Class +open Module + +let esc_8bits = ref false + +let info_section = ref "Objective Caml" + +let info_entry = ref [] + +(** {2 Some small helper functions} *) + +let puts_nl chan s = + output_string chan s ; + output_char chan '\n' +let puts chan s = + output_string chan s +let nl chan = + output_char chan '\n' + +let is = function + | None -> false + | Some _ -> true + +let pad_to n s = + let len = String.length s in + if len < n + then + let s' = String.make n ' ' in + String.blit s 0 s' 0 len ; s' + else s + +let indent nb_sp s = + let c = ref 0 in + let len = pred (String.length s) in + for i = 0 to len do if s.[i] = '\n' then incr c done ; + let s' = String.make (succ len + (succ !c) * nb_sp ) ' ' in + c := nb_sp ; + for i = 0 to len do + s'.[!c] <- s.[i] ; + if s.[i] = '\n' then c := !c + nb_sp ; + incr c + done ; + s' + +type subparts = [ + | `Module of Odoc_info.Module.t_module + | `Module_type of Odoc_info.Module.t_module_type + | `Class of Odoc_info.Class.t_class + | `Class_type of Odoc_info.Class.t_class_type + ] + +type menu_data = [ + | subparts + | `Blank + | `Comment of string + | `Texi of string + | `Index of string +] list + +let nothing = Verbatim "" + +let module_subparts = + let rec iter acc = function + | [] -> List.rev acc + (* skip aliases *) + | Element_module { m_kind = Module_alias _ } :: n -> + iter acc n + | Element_module_type { mt_kind = Some (Module_type_alias _) } :: n -> + iter acc n + (* keep modules, module types, classes and class types *) + | Element_module m :: n -> + iter (`Module m :: acc) n + | Element_module_type mt :: n -> + iter (`Module_type mt :: acc) n + | Element_class c :: n -> + iter (`Class c :: acc) n + | Element_class_type ct :: n -> + iter (`Class_type ct :: acc) n + (* forget the rest *) + | _ :: n -> iter acc n + in + iter [] + +type indices = [ + | `Type + | `Exception + | `Value + | `Class_att + | `Method + | `Class + | `Class_type + | `Module + | `Module_type +] + +let indices = function + | `Type -> "ty" + | `Exception -> "ex" + | `Value -> "va" + | `Class_att -> "ca" + | `Method -> "me" + | `Class -> "cl" + | `Class_type -> "ct" + | `Module -> "mo" + | `Module_type -> "mt" + +let indices_names = [ + "Types" , "ty" ; + "Exceptions" , "ex" ; + "Values" , "va" ; + "Class attributes", "ca" ; + "Methods" , "me" ; + "Classes" , "cl" ; + "Class types" , "ct" ; + "Modules" , "mo" ; + "Module types" , "mt" ; ] + + + +(** Module for generating various Texinfo things (menus, xrefs, ...) *) +module Texi = +struct + (** Associations of strings to subsitute in Texinfo code. *) + let subst_strings = [ + (Str.regexp "@", "@@") ; + (Str.regexp "{", "@{") ; + (Str.regexp "}", "@}") ; + (Str.regexp "\\.\\.\\.", "@dots{}") ; + ] @ + (if !esc_8bits + then [ + (Str.regexp "à", "@`a") ; + (Str.regexp "â", "@^a") ; + (Str.regexp "é", "@'e") ; + (Str.regexp "è", "@`e") ; + (Str.regexp "ê", "@^e") ; + (Str.regexp "ë", "@\"e") ; + (Str.regexp "ç", "@,{c}") ; + (Str.regexp "ô", "@^o") ; + (Str.regexp "ö", "@\"o") ; + (Str.regexp "î", "@^i") ; + (Str.regexp "ï", "@\"i") ; + (Str.regexp "ù", "@`u") ; + (Str.regexp "û", "@^u") ; + (Str.regexp "æ", "@ae{}" ) ; + (Str.regexp "Æ", "@AE{}" ) ; + (Str.regexp "ß", "@ss{}" ) ; + (Str.regexp "©", "@copyright{}" ) ; + ] + else []) + + (** Escape the strings which would clash with Texinfo syntax. *) + let escape s = + List.fold_left + (fun acc (p, r) -> Str.global_replace p r acc) + s subst_strings + + (** Removes dots (no good for a node name). *) + let fix_nodename s = + Str.global_replace (Str.regexp "\\.") "/" (escape s) + + (** Generates a Texinfo menu. *) + let generate_menu chan subpart_list = + if subpart_list <> [] + then begin + let menu_line part_qual name = + let sname = Name.simple name in + if sname = name + then ( + puts chan (pad_to 35 + ("* " ^ sname ^ ":: ")) ; + puts_nl chan part_qual ) + else ( + puts chan (pad_to 35 + ("* " ^ sname ^ ": " ^ (fix_nodename name) ^ ". " )) ; + puts_nl chan part_qual ) + in + puts_nl chan "@menu" ; + List.iter + (function + | `Module { m_name = name } -> + menu_line Odoc_messages.modul name + | `Module_type { mt_name = name } -> + menu_line Odoc_messages.module_type name + | `Class { cl_name = name } -> + menu_line Odoc_messages.clas name + | `Class_type { clt_name = name } -> + menu_line Odoc_messages.class_type name + | `Blank -> nl chan + | `Comment c -> puts_nl chan (escape c) + | `Texi t -> puts_nl chan t + | `Index ind -> Printf.fprintf chan "* %s::\n" ind) + subpart_list ; + puts_nl chan "@end menu" + end + + (** cross reference to node [name] *) + let xref ?xname name = + "@xref{" ^ (fix_nodename name) ^ + (match xname with | None -> "" | Some s -> "," ^ s) ^ + "}." + + (** enclose the string between [\@ifinfo] tags *) + let ifinfo s = + String.concat "\n" + [ "@ifinfo" ; s ; "@end ifinfo" ; "" ] + + (** [install-info] information *) + let dirsection sec = + "@dircategory " ^ (escape sec) + + let direntry ent = + [ "@direntry" ] @ + (List.map escape ent) @ + [ "@end direntry" ] +end + + + + + +(** {2 Generation of Texinfo code} *) + +(** This class generates Texinfo code from text structures *) +class text = + object(self) + + (** Associations between a title number and texinfo code. *) + val titles = [ + 1, "@chapter " ; + 2, "@section " ; + 3, "@subsection " ; + 4, "@subsubsection " ; + ] + + val fallback_title = + "@unnumberedsubsubsec " + + val headings = [ + 1, "@majorheading " ; + 2, "@heading " ; + 3, "@subheading " ; + 4, "@subsubheading " ; + ] + + val fallback_heading = + "@subsubheading " + + method escape = + Texi.escape + + (** this method is not used here but is virtual + in a class we will inherit later *) + method label ?(no_ : bool option) (_ : string) : string = + failwith "gni" + + (** Return the Texinfo code corresponding to the [text] parameter.*) + method texi_of_text t = + String.concat "" + (List.map self#texi_of_text_element t) + + + (** {3 Conversion methods} + [texi_of_????] converts a [text_element] to a Texinfo string. *) + + (** Return the Texinfo code for the [text_element] in parameter. *) + method texi_of_text_element = function + | Verbatim s | Latex s -> self#texi_of_Verbatim s + | Raw s -> self#texi_of_Raw s + | Code s -> self#texi_of_Code s + | CodePre s -> self#texi_of_CodePre s + | Bold t -> self#texi_of_Bold t + | Italic t -> self#texi_of_Italic t + | Emphasize t -> self#texi_of_Emphasize t + | Center t -> self#texi_of_Center t + | Left t -> self#texi_of_Left t + | Right t -> self#texi_of_Right t + | List tl -> self#texi_of_List tl + | Enum tl -> self#texi_of_Enum tl + | Newline -> self#texi_of_Newline + | Block t -> self#texi_of_Block t + | Title (n, _, t) -> self#texi_of_Title n t + | Link (s, t) -> self#texi_of_Link s t + | Ref (name, kind, _) ->self#texi_of_Ref name kind + | Superscript t -> self#texi_of_Superscript t + | Subscript t -> self#texi_of_Subscript t + | Odoc_info.Module_list _ -> "" + | Odoc_info.Index_list -> "" + | Odoc_info.Custom (s,t) -> self#texi_of_custom_text s t + | Odoc_info.Target (target, code) -> self#texi_of_Target ~target ~code + + method texi_of_custom_text s t = "" + + method texi_of_Target ~target ~code = + if String.lowercase target = "texi" then code else "" + + method texi_of_Verbatim s = s + method texi_of_Raw s = self#escape s + method texi_of_Code s = "@code{" ^ (self#escape s) ^ "}" + method texi_of_CodePre s = + String.concat "\n" + [ "" ; "@example" ; self#escape s ; "@end example" ; "" ] + method texi_of_Bold t = "@strong{" ^ (self#texi_of_text t) ^ "}" + method texi_of_Italic t = "@i{" ^ (self#texi_of_text t) ^ "}" + method texi_of_Emphasize t = "@emph{" ^ (self#texi_of_text t) ^ "}" + method texi_of_Center t = + let sl = Str.split (Str.regexp "\n") (self#texi_of_text t) in + String.concat "" + ((List.map (fun s -> "\n@center "^s) sl) @ [ "\n" ]) + method texi_of_Left t = + String.concat "\n" + [ "" ; "@flushleft" ; self#texi_of_text t ; "@end flushleft" ; "" ] + method texi_of_Right t = + String.concat "\n" + [ "" ; "@flushright" ; self#texi_of_text t ; "@end flushright"; "" ] + method texi_of_List tl = + String.concat "\n" + ( [ "" ; "@itemize" ] @ + (List.map (fun t -> "@item\n" ^ (self#texi_of_text t)) tl) @ + [ "@end itemize"; "" ] ) + method texi_of_Enum tl = + String.concat "\n" + ( [ "" ; "@enumerate" ] @ + (List.map (fun t -> "@item\n" ^ (self#texi_of_text t)) tl) @ + [ "@end enumerate"; "" ] ) + method texi_of_Newline = "\n" + method texi_of_Block t = + String.concat "\n" + [ "@format" ; self#texi_of_text t ; "@end format" ; "" ] + method texi_of_Title n t = + let t_begin = + try List.assoc n titles + with Not_found -> fallback_title in + t_begin ^ (self#texi_of_text t) ^ "\n" + method texi_of_Link s t = + String.concat "" + [ "@uref{" ; s ; "," ; self#texi_of_text t ; "}" ] + method texi_of_Ref name kind = + let xname = + match kind with + | Some RK_module -> + Odoc_messages.modul ^ " " ^ (Name.simple name) + | Some RK_module_type -> + Odoc_messages.module_type ^ " " ^ (Name.simple name) + | Some RK_class -> + Odoc_messages.clas ^ " " ^ (Name.simple name) + | Some RK_class_type -> + Odoc_messages.class_type ^ " " ^ (Name.simple name) + | _ -> "" + in + if xname = "" then self#escape name else Texi.xref ~xname name + method texi_of_Superscript t = + "^@{" ^ (self#texi_of_text t) ^ "@}" + method texi_of_Subscript t = + "_@{" ^ (self#texi_of_text t) ^ "@}" + + method heading n t = + let f = + try List.assoc n headings + with Not_found -> fallback_heading + in + f ^ (self#texi_of_text t) ^ "\n" + + method fixedblock t = + Block ( ( Verbatim "@t{" :: t ) @ [ Verbatim "}" ] ) + + end + +exception Aliased_node + +module Generator = +struct + +(** This class is used to create objects which can generate a simple + Texinfo documentation. *) +class texi = + object (self) + inherit text as to_texi + inherit Odoc_to_text.to_text as to_text + + (** {3 Small helper stuff.} *) + + val maxdepth = 4 + + val bullet = Verbatim " @bullet{} " + val minus = Verbatim " @minus{} " + val linebreak = Verbatim "@*\n" + + val mutable indices_to_build = [ `Module ] + + (** Keep a set of nodes we create. If we try to create one + a second time, that means it is some kind of alias, so + don't do it, just link to the previous one *) + val node_tbl = Hashtbl.create 37 + + method node depth name = + if Hashtbl.mem node_tbl name + then raise Aliased_node ; + Hashtbl.add node_tbl name () ; + if depth <= maxdepth + then Verbatim ("@node " ^ (Texi.fix_nodename name) ^ ",\n") + else nothing + + method index (ind : indices) ent = + Verbatim + (if !Global.with_index + then (assert(List.mem ind indices_to_build) ; + String.concat "" + [ "@" ; indices ind ; "index " ; + Texi.escape (Name.simple ent) ; "\n" ]) + else "") + + + (** Two hacks to fix linebreaks in the descriptions.*) + method private fix_linebreaks = + let re = Str.regexp "\n[ \t]*" in + fun t -> + List.map + (function + | Newline -> Raw "\n" + | Raw s -> Raw (Str.global_replace re "\n" s) + | List tel -> List (List.map self#fix_linebreaks tel) + | Enum tel -> Enum (List.map self#fix_linebreaks tel) + | te -> te) t + + method private soft_fix_linebreaks = + let re = Str.regexp "\n[ \t]*" in + fun ind t -> + let rep = String.make (succ ind) ' ' in + rep.[0] <- '\n' ; + List.map + (function + | Raw s -> Raw (Str.global_replace re rep s) + | te -> te) t + + (** {3 [text] values generation} + Generates [text] values out of description parts. + Redefines some of methods of {! Odoc_to_text.to_text}. *) + + method text_of_desc = function + | None -> [] + | Some [ Raw "" ] -> [] + | Some t -> (self#fix_linebreaks t) @ [ Newline ] + + method text_of_sees_opt see_l = + List.concat + (List.map + (function + | (See_url s, t) -> + [ linebreak ; Bold [ Raw Odoc_messages.see_also ] ; + Raw " " ; Link (s, t) ; Newline ] + | (See_file s, t) + | (See_doc s, t) -> + [ linebreak ; Bold [ Raw Odoc_messages.see_also ] ; + Raw " " ; Raw s ] @ t @ [ Newline ]) + see_l) + + method text_of_before l = + List.flatten + (List.map + (fun x -> linebreak :: (to_text#text_of_before [x])) l) + + method text_of_params params_list = + List.concat + (List.map + (fun (s, t) -> + [ linebreak ; + Bold [ Raw Odoc_messages.parameters ] ; + Raw " " ; Raw s ; Raw ": " ] @ t @ [ Newline ] ) + params_list) + + method! text_of_raised_exceptions = function + | [] -> [] + | (s, t) :: [] -> + [ linebreak ; + Bold [ Raw Odoc_messages.raises ] ; + Raw " " ; Code s ; Raw " " ] + @ t @ [ Newline ] + | l -> + [ linebreak ; + Bold [ Raw Odoc_messages.raises ] ; + Raw " :" ; + List + (List.map + (fun (ex, desc) ->(Code ex) :: (Raw " ") :: desc ) l ) ; + Newline ] + + method! text_of_return_opt = function + | None -> [] + | Some t -> + (Bold [Raw Odoc_messages.returns ]) :: Raw " " :: t @ [ Newline ] + + method! text_of_custom c_l = + List.flatten + (List.rev + (List.fold_left + (fun acc -> fun (tag, text) -> + try + let f = List.assoc tag tag_functions in + ( linebreak :: (f text) @ [ Newline ] ) :: acc + with + Not_found -> + Odoc_info.warning (Odoc_messages.tag_not_handled tag) ; + acc + ) [] c_l)) + + method! text_of_info ?(block=false) = function + | None -> [] + | Some info -> + let t = + List.concat + [ ( match info.i_deprecated with + | None -> [] + | Some t -> + (Raw (Odoc_messages.deprecated ^ " ")) :: + (self#fix_linebreaks t) + @ [ Newline ; Newline ] ) ; + self#text_of_desc info.i_desc ; + if info.i_authors <> [] + then ( linebreak :: + self#text_of_author_list info.i_authors ) + else [] ; + if is info.i_version + then ( linebreak :: + self#text_of_version_opt info.i_version ) + else [] ; + self#text_of_sees_opt info.i_sees ; + self#text_of_before info.i_before ; + if is info.i_since + then ( linebreak :: + self#text_of_since_opt info.i_since ) + else [] ; + self#text_of_params info.i_params ; + self#text_of_raised_exceptions info.i_raised_exceptions ; + if is info.i_return_value + then ( linebreak :: + self#text_of_return_opt info.i_return_value ) + else [] ; + self#text_of_custom info.i_custom ; + ] in + if block + then [ Block t ] + else (t @ [ Newline ] ) + + method texi_of_info i = + self#texi_of_text (self#text_of_info i) + + (** {3 Conversion of [module_elements] into Texinfo strings} + The following functions convert [module_elements] and their + description to [text] values then to Texinfo strings using the + functions above. *) + + method text_el_of_type_expr m_name typ = + Raw (indent 5 + (self#relative_idents m_name + (Odoc_info.string_of_type_expr typ))) + + method! text_of_short_type_expr m_name typ = + [ Raw (self#normal_type m_name typ) ] + + (** Return Texinfo code for a value. *) + method texi_of_value v = + Odoc_info.reset_type_names () ; + let t = [ self#fixedblock + [ Newline ; minus ; + Raw ("val " ^ (Name.simple v.val_name) ^ " :\n") ; + self#text_el_of_type_expr + (Name.father v.val_name) v.val_type ] ; + self#index `Value v.val_name ; Newline ] @ + (self#text_of_info v.val_info) in + self#texi_of_text t + + + (** Return Texinfo code for a class attribute. *) + method texi_of_attribute a = + Odoc_info.reset_type_names () ; + let t = [ self#fixedblock + [ Newline ; minus ; + Raw "val " ; + Raw (if a.att_virtual then "virtual " else "") ; + Raw (if a.att_mutable then "mutable " else "") ; + Raw (Name.simple a.att_value.val_name) ; + Raw " :\n" ; + self#text_el_of_type_expr + (Name.father a.att_value.val_name) + a.att_value.val_type ] ; + self#index `Class_att a.att_value.val_name ; Newline ] @ + (self#text_of_info a.att_value.val_info) in + self#texi_of_text t + + + (** Return Texinfo code for a class method. *) + method texi_of_method m = + Odoc_info.reset_type_names () ; + let t = [ self#fixedblock + [ Newline ; minus ; Raw "method " ; + Raw (if m.met_private then "private " else "") ; + Raw (if m.met_virtual then "virtual " else "") ; + Raw (Name.simple m.met_value.val_name) ; + Raw " :\n" ; + self#text_el_of_type_expr + (Name.father m.met_value.val_name) + m.met_value.val_type ] ; + self#index `Method m.met_value.val_name ; Newline ] @ + (self#text_of_info m.met_value.val_info) in + self#texi_of_text t + + + method string_of_type_parameters t = + let f (tp, co, cn) = + Printf.sprintf "%s%s" + (Odoc_info.string_of_variance t (co, cn)) + (Odoc_info.string_of_type_expr tp) + in + match t.ty_parameters with + | [] -> "" + | [ (tp, co, cn) ] -> + (f (tp, co, cn))^" " + | l -> + Printf.sprintf "(%s) " + (String.concat ", " (List.map f l)) + + method string_of_type_args = function + | [] -> "" + | args -> " of " ^ (Odoc_info.string_of_type_list " * " args) + + (** Return Texinfo code for a type. *) + method texi_of_type ty = + Odoc_info.reset_type_names () ; + let t = + [ self#fixedblock ( + [ Newline ; minus ; Raw "type " ; + Raw (self#string_of_type_parameters ty) ; + Raw (Name.simple ty.ty_name) ] @ + let priv = ty.ty_private = Asttypes.Private in + ( match ty.ty_manifest with + | None -> [] + | Some typ -> + (Raw " = ") :: + (Raw (if priv then "private " else "")) :: + (self#text_of_short_type_expr (Name.father ty.ty_name) typ) ) @ + ( + match ty.ty_kind with + | Type_abstract -> [ Newline ] + | Type_variant l -> + (Raw (" ="^(if priv then " private" else "")^"\n")) :: + (List.flatten + (List.map + (fun constr -> + (Raw (" | " ^ constr.vc_name)) :: + (Raw (self#string_of_type_args constr.vc_args)) :: + (match constr.vc_text with + | None -> [ Newline ] + | Some t -> + ((Raw (indent 5 "\n(* ")) :: (self#soft_fix_linebreaks 8 t)) @ + [ Raw " *)" ; Newline ] + ) ) l ) ) + | Type_record l -> + (Raw (" = "^(if priv then "private " else "")^"{\n")) :: + (List.flatten + (List.map + (fun r -> + [ Raw (" " ^ r.rf_name ^ " : ") ] @ + (self#text_of_short_type_expr + (Name.father r.rf_name) + r.rf_type) @ + [ Raw " ;" ] @ + (match r.rf_text with + | None -> [ Newline ] + | Some t -> + ((Raw (indent 5 "\n(* ")) :: (self#soft_fix_linebreaks 8 t)) @ + [ Raw " *)" ; Newline ] ) ) + l ) ) + @ [ Raw " }" ] + ) ) ; + self#index `Type ty.ty_name ; Newline ] @ + (self#text_of_info ty.ty_info) in + self#texi_of_text t + + (** Return Texinfo code for an exception. *) + method texi_of_exception e = + Odoc_info.reset_type_names () ; + let t = + [ self#fixedblock + ( [ Newline ; minus ; Raw "exception " ; + Raw (Name.simple e.ex_name) ; + Raw (self#string_of_type_args e.ex_args) ] @ + (match e.ex_alias with + | None -> [] + | Some ea -> [ Raw " = " ; Raw + ( match ea.ea_ex with + | None -> ea.ea_name + | Some e -> e.ex_name ) ; ] + ) ) ; + self#index `Exception e.ex_name ; Newline ] @ + (self#text_of_info e.ex_info) in + self#texi_of_text t + + + (** Return the Texinfo code for the given module. *) + method texi_of_module m = + let is_alias = function + | { m_kind = Module_alias _ } -> true + | _ -> false in + let is_alias_there = function + | { m_kind = Module_alias { ma_module = None } } -> false + | _ -> true in + let resolve_alias_name = function + | { m_kind = Module_alias { ma_name = name } } -> name + | { m_name = name } -> name in + let t = + [ [ self#fixedblock + [ Newline ; minus ; Raw "module " ; + Raw (Name.simple m.m_name) ; + Raw (if is_alias m + then " = " ^ (resolve_alias_name m) + else "" ) ] ] ; + ( if is_alias_there m + then [ Ref (resolve_alias_name m, Some RK_module, None) ; + Newline ; ] + else [] ) ; + ( if is_alias m + then [ self#index `Module m.m_name ; Newline ] + else [ Newline ] ) ; + self#text_of_info m.m_info ] + in + self#texi_of_text (List.flatten t) + + (** Return the Texinfo code for the given module type. *) + method texi_of_module_type mt = + let is_alias = function + | { mt_kind = Some (Module_type_alias _) } -> true + | _ -> false in + let is_alias_there = function + | { mt_kind = Some (Module_type_alias { mta_module = None }) } -> false + | _ -> true in + let resolve_alias_name = function + | { mt_kind = Some (Module_type_alias { mta_name = name }) } -> name + | { mt_name = name } -> name in + let t = + [ [ self#fixedblock + [ Newline ; minus ; Raw "module type " ; + Raw (Name.simple mt.mt_name) ; + Raw (if is_alias mt + then " = " ^ (resolve_alias_name mt) + else "" ) ] ] ; + ( if is_alias_there mt + then [ Ref (resolve_alias_name mt, Some RK_module_type, None) ; + Newline ; ] + else [] ) ; + ( if is_alias mt + then [ self#index `Module_type mt.mt_name ; Newline ] + else [ Newline ] ) ; + self#text_of_info mt.mt_info ] + in + self#texi_of_text (List.flatten t) + + (** Return the Texinfo code for the given included module. *) + method texi_of_included_module im = + let t = [ self#fixedblock + ( Newline :: minus :: (Raw "include ") :: + ( match im.im_module with + | None -> + [ Raw im.im_name ] + | Some (Mod { m_name = name }) -> + [ Raw name ; Raw "\n " ; + Ref (name, Some RK_module, None) ] + | Some (Modtype { mt_name = name }) -> + [ Raw name ; Raw "\n " ; + Ref (name, Some RK_module_type, None) ] + ) @ + [ Newline ] @ + (self#text_of_info im.im_info) + ) + ] + in + self#texi_of_text t + + (** Return the Texinfo code for the given class. *) + method texi_of_class c = + Odoc_info.reset_type_names () ; + let t = [ self#fixedblock + [ Newline ; minus ; Raw "class " ; + Raw (Name.simple c.cl_name) ] ; + Ref (c.cl_name, Some RK_class, None) ; Newline ; + Newline ] @ (self#text_of_info c.cl_info) in + self#texi_of_text t + + (** Return the Texinfo code for the given class type. *) + method texi_of_class_type ct = + Odoc_info.reset_type_names () ; + let t = [ self#fixedblock + [ Newline ; minus ; Raw "class type " ; + Raw (Name.simple ct.clt_name) ] ; + Ref (ct.clt_name, Some RK_class_type, None) ; Newline ; + Newline ] @ (self#text_of_info ct.clt_info) in + self#texi_of_text t + + (** Return the Texinfo code for the given class element. *) + method texi_of_class_element class_name class_ele = + match class_ele with + | Class_attribute att -> self#texi_of_attribute att + | Class_method met -> self#texi_of_method met + | Class_comment t -> self#texi_of_text t + + (** Return the Texinfo code for the given module element. *) + method texi_of_module_element module_name module_ele = + (match module_ele with + | Element_module m -> self#texi_of_module m + | Element_module_type mt -> self#texi_of_module_type mt + | Element_included_module im -> self#texi_of_included_module im + | Element_class c -> self#texi_of_class c + | Element_class_type ct -> self#texi_of_class_type ct + | Element_value v -> self#texi_of_value v + | Element_exception e -> self#texi_of_exception e + | Element_type t -> self#texi_of_type t + | Element_module_comment t -> + self#texi_of_text (Newline :: t @ [Newline]) + ) + + (** {3 Generating methods } + These methods write Texinfo code to an [out_channel] *) + + (** Generate the Texinfo code for the given list of inherited classes.*) + method generate_inheritance_info chanout inher_l = + let f inh = + match inh.ic_class with + | None -> (* we can't make the reference *) + (Code inh.ic_name) :: + (match inh.ic_text with + | None -> [] + | Some t -> Newline :: t) + | Some cct -> (* we can create the reference *) + let kind = + match cct with + | Cl _ -> Some RK_class + | Cltype _ -> Some RK_class_type in + (Code inh.ic_name) :: + (Ref (inh.ic_name, kind, None)) :: + ( match inh.ic_text with + | None -> [] + | Some t -> Newline :: t) + in + let text = [ + Bold [ Raw Odoc_messages.inherits ] ; + List (List.map f inher_l) ; Newline ] + in + puts chanout (self#texi_of_text text) + + + + (** Generate the Texinfo code for the inherited classes + of the given class. *) + method generate_class_inheritance_info chanout cl = + let rec iter_kind = function + | Class_structure ([], _) -> () + | Class_structure (l, _) -> + self#generate_inheritance_info chanout l + | Class_constraint (k, _) -> iter_kind k + | Class_apply _ + | Class_constr _ -> () + in + iter_kind cl.cl_kind + + + + (** Generate the Texinfo code for the inherited classes + of the given class type. *) + method generate_class_type_inheritance_info chanout clt = + match clt.clt_kind with + | Class_signature ([], _) -> + () + | Class_signature (l, _) -> + self#generate_inheritance_info chanout l + | Class_type _ -> + () + + (** Generate the Texinfo code for the given class, + in the given out channel. *) + method generate_for_class chanout c = + try + Odoc_info.reset_type_names () ; + let depth = Name.depth c.cl_name in + let title = [ + self#node depth c.cl_name ; + Title (depth, None, [ Raw (Odoc_messages.clas ^ " ") ; + Code c.cl_name ]) ; + self#index `Class c.cl_name ] in + puts chanout (self#texi_of_text title) ; + + if is c.cl_info + then begin + let descr = [ Title (succ depth, None, + [ Raw Odoc_messages.description ]) ] in + puts chanout (self#texi_of_text descr) ; + puts chanout (self#texi_of_info c.cl_info) + end ; + + let intf = [ Title (succ depth, None, + [ Raw Odoc_messages.interface]) ] in + puts chanout (self#texi_of_text intf); + self#generate_class_inheritance_info chanout c ; + List.iter + (fun ele -> puts chanout + (self#texi_of_class_element c.cl_name ele)) + (Class.class_elements ~trans:false c) + with Aliased_node -> () + + + (** Generate the Texinfo code for the given class type, + in the given out channel. *) + method generate_for_class_type chanout ct = + try + Odoc_info.reset_type_names () ; + let depth = Name.depth ct.clt_name in + let title = [ + self#node depth ct.clt_name ; + Title (depth, None, [ Raw (Odoc_messages.class_type ^ " ") ; + Code ct.clt_name ]) ; + self#index `Class_type ct.clt_name ] in + puts chanout (self#texi_of_text title) ; + + if is ct.clt_info + then begin + let descr = [ Title (succ depth, None, + [ Raw Odoc_messages.description ]) ] in + puts chanout (self#texi_of_text descr) ; + puts chanout (self#texi_of_info ct.clt_info) + end ; + + let intf = [ Title (succ depth, None, + [ Raw Odoc_messages.interface ]) ] in + puts chanout (self#texi_of_text intf) ; + self#generate_class_type_inheritance_info chanout ct; + List.iter + (fun ele -> puts chanout + (self#texi_of_class_element ct.clt_name ele)) + (Class.class_type_elements ~trans:false ct) + with Aliased_node -> () + + + (** Generate the Texinfo code for the given module type, + in the given out channel. *) + method generate_for_module_type chanout mt = + try + let depth = Name.depth mt.mt_name in + let title = [ + self#node depth mt.mt_name ; + Title (depth, None, [ Raw (Odoc_messages.module_type ^ " ") ; + Code mt.mt_name ]) ; + self#index `Module_type mt.mt_name ; Newline ] in + puts chanout (self#texi_of_text title) ; + + if is mt.mt_info + then begin + let descr = [ Title (succ depth, None, + [ Raw Odoc_messages.description ]) ] in + puts chanout (self#texi_of_text descr) ; + puts chanout (self#texi_of_info mt.mt_info) + end ; + + let mt_ele = Module.module_type_elements ~trans:true mt in + let subparts = module_subparts mt_ele in + if depth < maxdepth && subparts <> [] + then begin + let menu = Texi.ifinfo + ( self#heading (succ depth) [ Raw "Subparts" ]) in + puts chanout menu ; + Texi.generate_menu chanout (subparts :> menu_data) + end ; + + let intf = [ Title (succ depth, None, + [ Raw Odoc_messages.interface ]) ] in + puts chanout (self#texi_of_text intf) ; + List.iter + (fun ele -> puts chanout + (self#texi_of_module_element mt.mt_name ele)) + mt_ele ; + + (* create sub parts for modules, module types, classes and class types *) + List.iter + (function + | `Module m -> self#generate_for_module chanout m + | `Module_type mt -> self#generate_for_module_type chanout mt + | `Class c -> self#generate_for_class chanout c + | `Class_type ct -> self#generate_for_class_type chanout ct) + subparts + with Aliased_node -> () + + (** Generate the Texinfo code for the given module, + in the given out channel. *) + method generate_for_module chanout m = + try + Odoc_info.verbose ("Generate for module " ^ m.m_name) ; + let depth = Name.depth m.m_name in + let title = [ + self#node depth m.m_name ; + Title (depth, None, + if m.m_text_only then + [ Raw m.m_name ] + else + [ Raw (Odoc_messages.modul ^ " ") ; + Code m.m_name ] + ) ; + self#index `Module m.m_name ; Newline ] in + puts chanout (self#texi_of_text title) ; + + if is m.m_info + then begin + let descr = [ Title (succ depth, None, + [ Raw Odoc_messages.description ]) ] in + puts chanout (self#texi_of_text descr) ; + puts chanout (self#texi_of_info m.m_info) + end ; + + let m_ele = Module.module_elements ~trans:true m in + let subparts = module_subparts m_ele in + if depth < maxdepth && subparts <> [] + then begin + let menu = Texi.ifinfo + ( self#heading (succ depth) [ Raw "Subparts" ]) in + puts chanout menu ; + Texi.generate_menu chanout (subparts :> menu_data) + end ; + + let intf = [ Title (succ depth, None, + [ Raw Odoc_messages.interface]) ] in + puts chanout (self#texi_of_text intf) ; + + List.iter + (fun ele -> puts chanout + (self#texi_of_module_element m.m_name ele)) + m_ele ; + + (* create sub nodes for modules, module types, classes and class types *) + List.iter + (function + | `Module m -> self#generate_for_module chanout m + | `Module_type mt -> self#generate_for_module_type chanout mt + | `Class c -> self#generate_for_class chanout c + | `Class_type ct -> self#generate_for_class_type chanout ct ) + subparts + with Aliased_node -> () + + + (** Writes the header of the TeXinfo document. *) + method generate_texi_header chan texi_filename m_list = + let title = match !Global.title with + | None -> "" + | Some s -> self#escape s in + let filename = + if texi_filename <> "ocamldoc.texi" + then + let fn = Filename.basename texi_filename in + (if Filename.check_suffix fn ".texi" + then Filename.chop_suffix fn ".texi" + else fn) ^ ".info" + else + if title <> "" + then title ^ ".info" + else "doc.info" + in + (* write a standard Texinfo header *) + List.iter + (puts_nl chan) + (List.flatten + [ [ "\\input texinfo @c -*-texinfo-*-" ; + "@c %**start of header" ; + "@setfilename " ^ filename ; + "@settitle " ^ title ; + "@c %**end of header" ; ] ; + + (if !Global.with_index then + List.map + (fun ind -> + "@defcodeindex " ^ (indices ind)) + indices_to_build + else []) ; + + [ Texi.dirsection !info_section ] ; + + Texi.direntry + (if !info_entry <> [] + then !info_entry + else [ Printf.sprintf "* %s: (%s)." + title + (Filename.chop_suffix filename ".info") ]) ; + + [ "@ifinfo" ; + "This file was generated by Ocamldoc using the Texinfo generator." ; + "@end ifinfo" ; + + "@c no titlepage." ; + + "@node Top, , , (dir)" ; + "@top "^ title ; ] + ] ) ; + + (* insert the intro file *) + begin + match !Odoc_info.Global.intro_file with + | None when title <> "" -> + puts_nl chan "@ifinfo" ; + puts_nl chan ("Documentation for " ^ title) ; + puts_nl chan "@end ifinfo" + | None -> + puts_nl chan "@c no title given" + | Some f -> + nl chan ; + puts_nl chan + (self#texi_of_info + (Some (Odoc_info.info_of_comment_file m_list f))) + end ; + + (* write a top menu *) + Texi.generate_menu chan + ((List.map (fun m -> `Module m) m_list) @ + (if !Global.with_index then + let indices_names_to_build = List.map indices indices_to_build in + List.rev + (List.fold_left + (fun acc -> + function (longname, shortname) + when List.mem shortname indices_names_to_build -> + (`Index (longname ^ " index")) :: acc + | _ -> acc) + [ `Comment "Indices :" ; `Blank ] + indices_names ) + else [] )) + + + (** Writes the trailer of the TeXinfo document. *) + method generate_texi_trailer chan = + nl chan ; + if !Global.with_index + then + let indices_names_to_build = List.map indices indices_to_build in + List.iter (puts_nl chan) + (List.flatten + (List.map + (fun (longname, shortname) -> + if List.mem shortname indices_names_to_build + then [ "@node " ^ longname ^ " index," ; + "@unnumbered " ^ longname ^ " index" ; + "@printindex " ^ shortname ; ] + else []) + indices_names )) ; + if !Global.with_toc + then puts_nl chan "@contents" ; + puts_nl chan "@bye" + + + method do_index it = + if not (List.mem it indices_to_build) + then indices_to_build <- it :: indices_to_build + + (** Scan the whole module information to know which indices need to be build *) + method scan_for_index : subparts -> unit = function + | `Module m -> + let m_ele = Module.module_elements ~trans:true m in + List.iter self#scan_for_index_in_mod m_ele + | `Module_type mt -> + let m_ele = Module.module_type_elements ~trans:true mt in + List.iter self#scan_for_index_in_mod m_ele + | `Class c -> + let c_ele = Class.class_elements ~trans:true c in + List.iter self#scan_for_index_in_class c_ele + | `Class_type ct -> + let c_ele = Class.class_type_elements ~trans:true ct in + List.iter self#scan_for_index_in_class c_ele + + method scan_for_index_in_mod = function + (* no recursion *) + | Element_value _ -> self#do_index `Value + | Element_exception _ -> self#do_index `Exception + | Element_type _ -> self#do_index `Type + | Element_included_module _ + | Element_module_comment _ -> () + (* recursion *) + | Element_module m -> self#do_index `Module ; + self#scan_for_index (`Module m) + | Element_module_type mt -> self#do_index `Module_type ; + self#scan_for_index (`Module_type mt) + | Element_class c -> self#do_index `Class ; + self#scan_for_index (`Class c) + | Element_class_type ct -> self#do_index `Class_type ; + self#scan_for_index (`Class_type ct) + + method scan_for_index_in_class = function + | Class_attribute _ -> self#do_index `Class_att + | Class_method _ -> self#do_index `Method + | Class_comment _ -> () + + + (** Generate the Texinfo file from a module list, + in the {!Odoc_info.Global.out_file} file. *) + method generate module_list = + Hashtbl.clear node_tbl ; + let filename = + if !Global.out_file = Odoc_messages.default_out_file + then "ocamldoc.texi" + else !Global.out_file in + if !Global.with_index + then List.iter self#scan_for_index + (List.map (fun m -> `Module m) module_list) ; + try + let chanout = open_out + (Filename.concat !Global.target_dir filename) in + if !Global.with_header + then self#generate_texi_header chanout filename module_list ; + List.iter + (self#generate_for_module chanout) + module_list ; + if !Global.with_trailer + then self#generate_texi_trailer chanout ; + close_out chanout + with + | Failure s + | Sys_error s -> + prerr_endline s ; + incr Odoc_info.errors + end +end + +module type Texi_generator = module type of Generator diff --git a/ocaml-binary-annot/ocamldoc/odoc_text.ml b/ocaml-binary-annot/ocamldoc/odoc_text.ml new file mode 100644 index 0000000000..b50a2dbd17 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_text.ml @@ -0,0 +1,164 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +exception Text_syntax of int * int * string (* line, char, string *) + +open Odoc_types + +module Texter = + struct + (* builds a text structure from a string. *) + let text_of_string s = + let lexbuf = Lexing.from_string s in + try + Odoc_text_lexer.init (); + Odoc_text_parser.main Odoc_text_lexer.main lexbuf + with + _ -> + raise (Text_syntax (!Odoc_text_lexer.line_number, + !Odoc_text_lexer.char_number, + s) + ) + + let count s c = + let count = ref 0 in + for i = 0 to String.length s - 1 do + if s.[i] = c then incr count + done; + !count + + let escape_n s c n = + let remain = ref n in + let len = String.length s in + let b = Buffer.create (len + n) in + for i = 0 to len - 1 do + if s.[i] = c && !remain > 0 then + ( + Printf.bprintf b "\\%c" c; + decr remain + ) + else + Buffer.add_char b s.[i] + done; + Buffer.contents b + + let escape_code s = + let open_brackets = count s '[' in + let close_brackets = count s ']' in + if open_brackets > close_brackets then + escape_n s '[' (open_brackets - close_brackets) + else + if close_brackets > open_brackets then + escape_n s ']' (close_brackets - open_brackets) + else + s + + let escape_raw s = + let len = String.length s in + let b = Buffer.create len in + for i = 0 to len - 1 do + match s.[i] with + '[' | ']' | '{' | '}' -> + Printf.bprintf b "\\%c" s.[i] + | c -> + Buffer.add_char b c + done; + Buffer.contents b + + let p = Printf.bprintf + + let rec p_text b t = + List.iter (p_text_element b) t + + and p_list b l = + List.iter + (fun t -> p b "{- " ; p_text b t ; p b "}\n") + l + + and p_text_element b = function + | Raw s -> p b "%s" (escape_raw s) + | Code s -> p b "[%s]" (escape_code s) + | CodePre s -> p b "{[%s]}" s + | Verbatim s -> p b "{v %s v}" s + | Bold t -> p b "{b " ; p_text b t ; p b "}" + | Italic t -> p b "{i " ; p_text b t ; p b "}" + | Emphasize t -> p b "{e " ; p_text b t ; p b "}" + | Center t -> p b "{C " ; p_text b t ; p b "}" + | Left t -> p b "{L " ; p_text b t ; p b "}" + | Right t -> p b "{R " ; p_text b t ; p b "}" + | List l -> p b "{ul\n"; p_list b l; p b "}" + | Enum l -> p b "{ol\n"; p_list b l; p b "}" + | Newline -> p b "\n" + | Block t -> p_text b t + | Title (n, l_opt, t) -> + p b "{%d%s " + n + (match l_opt with + None -> "" + | Some s -> ":"^s + ); + p_text b t ; + p b "}" + | Latex s -> p b "{%% %s%%}" s + | Link (s,t) -> + p b "{{:%s}" s; + p_text b t ; + p b "}" + | Ref (name, kind_opt, text_opt) -> + begin + p b "%s{!%s%s}" + (match text_opt with None -> "" | Some _ -> "{") + (match kind_opt with + None -> "" + | Some k -> + let s = + match k with + RK_module -> "module" + | RK_module_type -> "modtype" + | RK_class -> "class" + | RK_class_type -> "classtype" + | RK_value -> "val" + | RK_type -> "type" + | RK_exception -> "exception" + | RK_attribute -> "attribute" + | RK_method -> "method" + | RK_section _ -> "section" + in + s^":" + ) + name; + match text_opt with + None -> () + | Some t -> p_text b t; p b "}" + end + | Superscript t -> p b "{^" ; p_text b t ; p b "}" + | Subscript t -> p b "{_" ; p_text b t ; p b "}" + | Module_list l -> + p b "{!modules:"; + List.iter (fun s -> p b " %s" s) l; + p b "}" + | Index_list -> + p b "{!indexlist}" + | Custom (s,t) -> + p b "{%s " s; + p_text b t; + p b "}" + | Target (target, code) -> + p b "{%%%s: %s}" target (escape_raw code) + + let string_of_text s = + let b = Buffer.create 256 in + p_text b s; + Buffer.contents b + + end diff --git a/ocaml-binary-annot/ocamldoc/odoc_text.mli b/ocaml-binary-annot/ocamldoc/odoc_text.mli new file mode 100644 index 0000000000..f4f8e911e4 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_text.mli @@ -0,0 +1,24 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** A module with a function to parse strings to obtain a [Odoc_types.text] value. *) + +(** Syntax error in a text. *) +exception Text_syntax of int * int * string (* line, char, string *) + +(** Transformation of strings to text structures. *) +module Texter : + sig + val text_of_string : string -> Odoc_types.text + val string_of_text : Odoc_types.text -> string + end diff --git a/ocaml-binary-annot/ocamldoc/odoc_text_lexer.mll b/ocaml-binary-annot/ocamldoc/odoc_text_lexer.mll new file mode 100644 index 0000000000..f229f08a66 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_text_lexer.mll @@ -0,0 +1,798 @@ +{ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** The lexer for string to build text structures. *) + +open Lexing +open Odoc_text_parser + +let line_number = ref 0 +let char_number = ref 0 + +let string_buffer = Buffer.create 32 + +(** Fonction de remise à zéro de la chaine de caractères tampon *) +let reset_string_buffer () = Buffer.reset string_buffer + +(** Fonction d'ajout d'un caractère dans la chaine de caractères tampon *) +let ajout_char_string = Buffer.add_char string_buffer + +(** Add a string to the buffer. *) +let ajout_string = Buffer.add_string string_buffer + +let lecture_string () = Buffer.contents string_buffer + + +(** the variable which will contain the description string. + Is initialized when we encounter the start of a special comment. *) + +let description = ref "" + +let blank = "[ \013\009\012]" + + +let print_DEBUG s = print_string s; print_newline () + +(** this flag indicates whether we're in a string between begin_code and end_code tokens, to + remember the number of open '[' and handle ']' correctly. *) +let open_brackets = ref 0 + +(** this flag indicates if we're in verbatim mode or not, to handle any special expression + like a string when we're in verbatim mode.*) +let verb_mode = ref false + +(** this flag indicates if we're in "target format" mode or not, to handle any special expression + like a string when we're in this mode.*) +let target_mode = ref false + +(** this flag indicates if we're in shortcut list mode or not, to handle end_shortcut_list correctly.*) +let shortcut_list_mode = ref false + +(** this flag indicates if we're in an element reference. *) +let ele_ref_mode = ref false + +(** this flag indicates if we're in a preformatted code string. *) +let code_pre_mode = ref false + +let init () = + open_brackets := 0; + verb_mode := false; + target_mode := false; + shortcut_list_mode := false; + ele_ref_mode := false ; + code_pre_mode := false ; + line_number := 0 ; + char_number := 0 + +let incr_cpts lexbuf = + let s = Lexing.lexeme lexbuf in + let l = Str.split_delim (Str.regexp_string "\n") s in + match List.rev l with + [] -> () (* should not occur *) + | [s2] -> (* no newline *) + char_number := !char_number + (String.length s2) + | s2 :: _ -> + line_number := !line_number + ((List.length l) - 1) ; + char_number := String.length s2 + +} + +(** html marks, to use as alternative possible special strings *) + +let html_bold = "<"('b'|'B')">" +let html_end_bold = "</"('b'|'B')">" +let html_italic = "<"('i'|'I')">" +let html_end_italic = "</"('i'|'I')">" +let html_title = "<"('h'|'H')(['0'-'9'])+">" +let html_end_title = "</"('h'|'H')(['0'-'9'])+">" +let html_list = "<"('u'|'U')('l'|'L')">" +let html_end_list = "</"('u'|'U')('l'|'L')">" +let html_enum = "<"('o'|'O')('l'|'L')">" +let html_end_enum = "</"('o'|'O')('l'|'L')">" +let html_item = "<"('l'|'L')('i'|'I')">" +let html_end_item = "</"('l'|'L')('i'|'I')">" +let html_code = "<"('c'|'C')('o'|'O')('d'|'D')('e'|'E')">" +let html_end_code = "</"('c'|'C')('o'|'O')('d'|'D')('e'|'E')">" +let html_center = "<"('c'|'C')('e'|'E')('n'|'N')('t'|'T')('e'|'E')('r'|'R')">" +let html_end_center = "</"('c'|'C')('e'|'E')('n'|'N')('t'|'T')('e'|'E')('r'|'R')">" +let html_left = "<"('l'|'L')('e'|'E')('f'|'F')('t'|'T')">" +let html_end_left = "</"('l'|'L')('e'|'E')('f'|'F')('t'|'T')">" +let html_right = "<"('r'|'R')('i'|'I')('g'|'G')('h'|'H')('t'|'T')">" +let html_end_right = "</"('r'|'R')('i'|'I')('g'|'G')('h'|'H')('t'|'T')">" + + +let blank = [' ' '\013' '\009' '\012'] +let blank_nl = [' ' '\013' '\009' '\012' '\010'] +let label = ['a'-'z']+['a'-'z' 'A'-'Z' '0'-'9' '_']* + +(** special strings *) + +let end = "}" + | html_end_bold + | html_end_italic + | html_end_title + | html_end_list + | html_end_enum + | html_end_item + | html_end_center +let begin_title = + ("{" ['0'-'9']+(":"label)? blank_nl) + | html_title + +let begin_bold = "{b"blank_nl | html_bold +let begin_emp = "{e"blank_nl +let begin_center = "{C"blank_nl | html_center +let begin_left = "{L"blank_nl +let begin_right = "{R"blank_nl +let begin_italic = "{i"blank_nl | html_italic +let begin_list = "{ul"blank_nl? | html_list +let begin_enum = "{ol"blank_nl? | html_enum +let begin_item = "{li"blank_nl | "{- " | html_item +let begin_link = "{{:" +let begin_target = "{%"['a'-'z''A'-'Z''0'-'9''-''_']+":"blank_nl? +let begin_latex = "{%"blank_nl +let end_target = "%}" +let begin_code = "[" | html_code +let end_code = "]" | html_end_code +let begin_code_pre = "{[" +let end_code_pre = "]}" +let begin_verb = "{v"blank_nl +let end_verb = blank_nl"v}" + +let begin_ele_ref = "{!"blank_nl | "{!" +let begin_val_ref = "{!val:"blank_nl | "{!val:" +let begin_typ_ref = "{!type:"blank_nl | "{!type:" +let begin_exc_ref = "{!exception:"blank_nl | "{!exception:" +let begin_mod_ref = "{!module:"blank_nl | "{!module:" +let begin_modt_ref = "{!modtype:"blank_nl | "{!modtype:" +let begin_cla_ref = "{!class:"blank_nl | "{!class:" +let begin_clt_ref = "{!classtype:"blank_nl | "{!classtype:" +let begin_att_ref = "{!attribute:"blank_nl | "{!attribute:" +let begin_met_ref = "{!method:"blank_nl | "{!method:" +let begin_sec_ref = "{!section:"blank_nl | "{!section:" +let begin_mod_list_ref = "{!modules:"blank_nl | "{!modules:" +let index_list = "{!indexlist}" +let begin_custom = "{"['a'-'z''A'-'Z']['a'-'z''A'-'Z''0'-'9']* +let begin_superscript = "{^"blank_nl | "{^" +let begin_subscript = "{_"blank_nl | "{_" + +let shortcut_list_item = '\n'blank*"- " +let shortcut_enum_item = '\n'blank*"+ " +let end_shortcut_list = '\n'(blank*'\n')+ + +rule main = parse +| "\\{" +| "\\}" +| "\\[" +| "\\]" + { + incr_cpts lexbuf ; + let s = Lexing.lexeme lexbuf in + Char (String.sub s 1 1) + } + +| end + { + print_DEBUG "end"; + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or + (!open_brackets >= 1) then + Char (Lexing.lexeme lexbuf) + else + let _ = + if !ele_ref_mode then + ele_ref_mode := false + in + END + } +| begin_title + { + print_DEBUG "begin_title"; + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + let s = Lexing.lexeme lexbuf in + try + (* chech if the "{..." or html_title mark was used. *) + if s.[0] = '<' then + let (n, l) = (2, (String.length s - 3)) in + let s2 = String.sub s n l in + Title (int_of_string s2, None) + else + let (n, l) = (1, (String.length s - 2)) in + let s2 = String.sub s n l in + try + let i = String.index s2 ':' in + let s_n = String.sub s2 0 i in + let s_label = String.sub s2 (i+1) (l-i-1) in + Title (int_of_string s_n, Some s_label) + with + Not_found -> + Title (int_of_string s2, None) + with + _ -> + Title (1, None) + } +| begin_bold + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + BOLD + } +| begin_italic + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + ITALIC + } +| begin_link + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + LINK + } +| begin_emp + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + EMP + } +| begin_superscript + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + SUPERSCRIPT + } +| begin_subscript + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + SUBSCRIPT + } +| begin_center + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + CENTER + } +| begin_left + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + LEFT + } +| begin_right + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode + or (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + RIGHT + } +| begin_list + { + print_DEBUG "LIST"; + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + LIST + } +| begin_enum + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + ENUM + } +| begin_item + { + print_DEBUG "ITEM"; + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + ITEM + } +| begin_target + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + ( + let s = Lexing.lexeme lexbuf in + let fmt = + let p1 = String.index s '%' in + let p2 = String.index s ':' in + String.sub s (p1 + 1) (p2 - p1 - 1) + in + target_mode := true; + Target fmt + ) + } +| begin_latex + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + ( + target_mode := true; + LATEX + ) + } +| end_target + { + incr_cpts lexbuf ; + if !verb_mode or (!open_brackets >= 1) or !code_pre_mode or + !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + ( + target_mode := false; + END_TARGET + ) + } +| begin_code end_code + { + incr_cpts lexbuf ; + Char (Lexing.lexeme lexbuf) + } + +| begin_code + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + if !open_brackets <= 0 then + ( + open_brackets := 1; + CODE + ) + else + ( + incr open_brackets; + Char (Lexing.lexeme lexbuf) + ) + } +| end_code + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + if !open_brackets > 1 then + ( + decr open_brackets; + Char "]" + ) + else + ( + open_brackets := 0; + END_CODE + ) + } + +| begin_code_pre end_code_pre + { + incr_cpts lexbuf ; + Char (Lexing.lexeme lexbuf) + } + +| begin_code_pre + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + ( + code_pre_mode := true; + CODE_PRE + ) + } +| end_code_pre + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + if !open_brackets >= 1 then + ( + lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; + lexbuf.Lexing.lex_curr_p <- + { lexbuf.Lexing.lex_curr_p with + pos_cnum = lexbuf.Lexing.lex_curr_p.pos_cnum - 1 + } ; + decr char_number ; + if !open_brackets > 1 then + ( + decr open_brackets; + Char "]" + ) + else + ( + open_brackets := 0; + END_CODE + ) + ) + else + if !code_pre_mode then + ( + code_pre_mode := false; + END_CODE_PRE + ) + else + Char (Lexing.lexeme lexbuf) + } + +| begin_ele_ref end + { + incr_cpts lexbuf ; + Char (Lexing.lexeme lexbuf) + } + +| begin_ele_ref + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then + Char (Lexing.lexeme lexbuf) + else + if not !ele_ref_mode then + ( + ele_ref_mode := true; + ELE_REF + ) + else + ( + Char (Lexing.lexeme lexbuf) + ) + } + + +| begin_val_ref + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then + Char (Lexing.lexeme lexbuf) + else + if not !ele_ref_mode then + ( + ele_ref_mode := true; + VAL_REF + ) + else + ( + Char (Lexing.lexeme lexbuf) + ) + } + +| begin_typ_ref + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then + Char (Lexing.lexeme lexbuf) + else + if not !ele_ref_mode then + ( + ele_ref_mode := true; + TYP_REF + ) + else + ( + Char (Lexing.lexeme lexbuf) + ) + } + +| begin_exc_ref + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then + Char (Lexing.lexeme lexbuf) + else + if not !ele_ref_mode then + ( + ele_ref_mode := true; + EXC_REF + ) + else + ( + Char (Lexing.lexeme lexbuf) + ) + } + +| begin_mod_ref + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then + Char (Lexing.lexeme lexbuf) + else + if not !ele_ref_mode then + ( + ele_ref_mode := true; + MOD_REF + ) + else + ( + Char (Lexing.lexeme lexbuf) + ) + } + +| begin_modt_ref + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then + Char (Lexing.lexeme lexbuf) + else + if not !ele_ref_mode then + ( + ele_ref_mode := true; + MODT_REF + ) + else + ( + Char (Lexing.lexeme lexbuf) + ) + } + +| begin_cla_ref + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then + Char (Lexing.lexeme lexbuf) + else + if not !ele_ref_mode then + ( + ele_ref_mode := true; + CLA_REF + ) + else + ( + Char (Lexing.lexeme lexbuf) + ) + } + +| begin_clt_ref + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then + Char (Lexing.lexeme lexbuf) + else + if not !ele_ref_mode then + ( + ele_ref_mode := true; + CLT_REF + ) + else + ( + Char (Lexing.lexeme lexbuf) + ) + } + +| begin_att_ref + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then + Char (Lexing.lexeme lexbuf) + else + if not !ele_ref_mode then + ( + ele_ref_mode := true; + ATT_REF + ) + else + ( + Char (Lexing.lexeme lexbuf) + ) + } + +| begin_met_ref + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then + Char (Lexing.lexeme lexbuf) + else + if not !ele_ref_mode then + ( + ele_ref_mode := true; + MET_REF + ) + else + ( + Char (Lexing.lexeme lexbuf) + ) + } + +| begin_sec_ref + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then + Char (Lexing.lexeme lexbuf) + else + if not !ele_ref_mode then + ( + ele_ref_mode := true; + SEC_REF + ) + else + ( + Char (Lexing.lexeme lexbuf) + ) + } + +| begin_mod_list_ref + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then + Char (Lexing.lexeme lexbuf) + else + if not !ele_ref_mode then + ( + ele_ref_mode := true; + MOD_LIST_REF + ) + else + ( + Char (Lexing.lexeme lexbuf) + ) + } + +| index_list + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then + Char (Lexing.lexeme lexbuf) + else + if not !ele_ref_mode then + INDEX_LIST + else + Char (Lexing.lexeme lexbuf) + } + +| begin_verb + { + incr_cpts lexbuf ; + if !target_mode or (!open_brackets >= 1) or !code_pre_mode or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + ( + verb_mode := true; + VERB + ) + } +| end_verb + { + incr_cpts lexbuf ; + if !target_mode or (!open_brackets >= 1) or !code_pre_mode or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + ( + verb_mode := false; + END_VERB + ) + } + +| shortcut_list_item + { + incr_cpts lexbuf ; + if !shortcut_list_mode then + ( + SHORTCUT_LIST_ITEM + ) + else + ( + shortcut_list_mode := true; + BEGIN_SHORTCUT_LIST_ITEM + ) + } + +| shortcut_enum_item + { + incr_cpts lexbuf ; + if !shortcut_list_mode then + SHORTCUT_ENUM_ITEM + else + ( + shortcut_list_mode := true; + BEGIN_SHORTCUT_ENUM_ITEM + ) + } +| end_shortcut_list + { + incr_cpts lexbuf ; + lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; + lexbuf.Lexing.lex_curr_p <- + { lexbuf.Lexing.lex_curr_p with + pos_cnum = lexbuf.Lexing.lex_curr_p.pos_cnum - 1 ; + } ; + decr line_number ; + if !shortcut_list_mode then + ( + shortcut_list_mode := false; + (* go back one char to re-use the last '\n', so we can + restart another shortcut-list with a single blank line, + and not two.*) + END_SHORTCUT_LIST + ) + else + if !target_mode or (!open_brackets >= 1) or !code_pre_mode or !ele_ref_mode or !verb_mode then + Char (Lexing.lexeme lexbuf) + else + BLANK_LINE + } + +| eof { EOF } + +| begin_custom + { + print_DEBUG "begin_custom"; + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + let s = Lexing.lexeme lexbuf in + let len = String.length s in + (* remove this starting '{' *) + let tag = Odoc_misc.no_blanks (String.sub s 1 (len - 1)) in + CUSTOM tag + } + +| "{" + { + incr_cpts lexbuf ; + if !target_mode or (!open_brackets >= 1) or !code_pre_mode or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + LBRACE + } +| _ + { + incr_cpts lexbuf ; + Char (Lexing.lexeme lexbuf) + } diff --git a/ocaml-binary-annot/ocamldoc/odoc_text_parser.mly b/ocaml-binary-annot/ocamldoc/odoc_text_parser.mly new file mode 100644 index 0000000000..478cfa074e --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_text_parser.mly @@ -0,0 +1,197 @@ +%{ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open Odoc_types + +let identchar = + "[A-Z a-z_\192-\214\216-\246\248-\255'0-9]" +let blank = "[ \010\013\009\012]" + +let remove_beginning_blanks s = + Str.global_replace (Str.regexp ("^"^blank^"+")) "" s + +let remove_trailing_blanks s = + Str.global_replace (Str.regexp (blank^"+$")) "" s + +let print_DEBUG s = print_string s; print_newline () +%} + +%token END +%token <int * string option> Title +%token BOLD +%token EMP +%token CENTER +%token LEFT +%token RIGHT +%token ITALIC +%token <string> CUSTOM +%token LIST +%token ENUM +%token ITEM +%token LINK +%token CODE +%token END_CODE +%token CODE_PRE +%token END_CODE_PRE +%token VERB +%token END_VERB +%token LATEX +%token <string> Target +%token END_TARGET +%token LBRACE + +%token ELE_REF +%token VAL_REF +%token TYP_REF +%token EXC_REF +%token MOD_REF +%token MODT_REF +%token CLA_REF +%token CLT_REF +%token ATT_REF +%token MET_REF +%token SEC_REF +%token MOD_LIST_REF +%token INDEX_LIST + +%token SUPERSCRIPT +%token SUBSCRIPT + +%token BEGIN_SHORTCUT_LIST_ITEM +%token BEGIN_SHORTCUT_ENUM_ITEM +%token SHORTCUT_LIST_ITEM +%token SHORTCUT_ENUM_ITEM +%token END_SHORTCUT_LIST + +%token BLANK_LINE + +%token EOF +%token <string> Char + +/* Start Symbols */ +%start main +%type <Odoc_types.text> main + +%% +main: + text EOF { $1 } +| EOF { [Raw ""] } +; + +text: + text_element_list { $1 } +; + +text_element_list: + text_element { [ $1 ] } +| text_element text_element_list { $1 :: $2 } +; + +ele_ref_kind: + ELE_REF { None } +| VAL_REF { Some RK_value } +| TYP_REF { Some RK_type } +| EXC_REF { Some RK_exception } +| MOD_REF { Some RK_module } +| MODT_REF { Some RK_module_type } +| CLA_REF { Some RK_class } +| CLT_REF { Some RK_class_type } +| ATT_REF { Some RK_attribute } +| MET_REF { Some RK_method } +| SEC_REF { Some (RK_section [])} +; + +text_element: + Title text END { let n, l_opt = $1 in Title (n, l_opt, $2) } +| BOLD text END { Bold $2 } +| ITALIC text END { Italic $2 } +| CUSTOM text END { Custom ($1, $2) } +| EMP text END { Emphasize $2 } +| SUPERSCRIPT text END { Superscript $2 } +| SUBSCRIPT text END { Subscript $2 } +| CENTER text END { Center $2 } +| LEFT text END { Left $2 } +| RIGHT text END { Right $2 } +| LIST list END { List $2 } +| ENUM list END { Enum $2 } +| CODE string END_CODE { Code $2 } +| CODE_PRE string END_CODE_PRE { CodePre $2 } +| ele_ref_kind string END { + let s2 = remove_beginning_blanks $2 in + let s3 = remove_trailing_blanks s2 in + Ref (s3, $1, None) + } +| LBRACE ele_ref_kind string END text END { + let s2 = remove_beginning_blanks $3 in + let s3 = remove_trailing_blanks s2 in + Ref (s3, $2, Some $5) + } + +| MOD_LIST_REF string END { + let s2 = remove_beginning_blanks $2 in + let s3 = remove_trailing_blanks s2 in + let l = Odoc_misc.split_with_blanks s3 in + Module_list l + } +| INDEX_LIST { Index_list } +| VERB string END_VERB { Verbatim $2 } +| LATEX string END_TARGET { Latex $2 } +| Target string END_TARGET { Target ($1, $2) } +| LINK string END text END { Link ($2, $4) } +| BLANK_LINE { Newline } +| BEGIN_SHORTCUT_LIST_ITEM shortcut_list END_SHORTCUT_LIST { List $2 } +| BEGIN_SHORTCUT_LIST_ITEM shortcut_list EOF { List $2 } +| BEGIN_SHORTCUT_ENUM_ITEM shortcut_enum END_SHORTCUT_LIST { Enum $2 } +| BEGIN_SHORTCUT_ENUM_ITEM shortcut_enum EOF { Enum $2 } +| string { Raw $1 } +; + +list: +| string { [] (* A VOIR : un test pour voir qu'il n'y a que des blancs *) } +| string list { $2 } +| list string { $1 } +| item { [ $1 ] } +| item list { $1 :: $2 } + +; + +item: + ITEM text END { $2 } +; + +shortcut_list: + text shortcut_list2 { $1 :: $2 } +| text { [ $1 ] } +; + +shortcut_list2: +| SHORTCUT_LIST_ITEM shortcut_list { $2 } +; + +shortcut_enum: + text shortcut_enum2 { $1 :: $2 } +| text { [ $1 ] } +; + +shortcut_enum2: +| SHORTCUT_ENUM_ITEM shortcut_enum { $2 } +; + + +string: + Char { $1 } +| Char string { $1^$2 } +; + +%% diff --git a/ocaml-binary-annot/ocamldoc/odoc_to_text.ml b/ocaml-binary-annot/ocamldoc/odoc_to_text.ml new file mode 100644 index 0000000000..591f81d613 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_to_text.ml @@ -0,0 +1,603 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Text generation. + + This module contains the class [to_text] with methods used to transform + information about elements to a [text] structure.*) + +open Odoc_info +open Exception +open Type +open Value +open Module +open Class +open Parameter + +(** A class used to get a [text] for info structures. *) +class virtual info = + object (self) + (** The list of pairs [(tag, f)] where [f] is a function taking + the [text] associated to [tag] and returning a [text]. + Add a pair here to handle a tag.*) + val mutable tag_functions = ([] : (string * (Odoc_info.text -> Odoc_info.text)) list) + + (** @return [etxt] value for an authors list. *) + method text_of_author_list l = + match l with + [] -> + [] + | _ -> + [ Bold [Raw (Odoc_messages.authors^": ")] ; + Raw (String.concat ", " l) ; + Newline + ] + + (** @return [text] value for the given optional version information.*) + method text_of_version_opt v_opt = + match v_opt with + None -> [] + | Some v -> [ Bold [Raw (Odoc_messages.version^": ")] ; + Raw v ; + Newline + ] + + (** @return [text] value for the given optional since information.*) + method text_of_since_opt s_opt = + match s_opt with + None -> [] + | Some s -> [ Bold [Raw (Odoc_messages.since^": ")] ; + Raw s ; + Newline + ] + + (** @return [text] value to represent the list of "before" information. *) + method text_of_before = function + [] -> [] + | l -> + let f (v, text) = + (Bold [Raw (Printf.sprintf "%s %s " Odoc_messages.before v) ]) :: + text @ + [Newline] + in + List.flatten (List.map f l) + + (** @return [text] value for the given list of raised exceptions.*) + method text_of_raised_exceptions l = + match l with + [] -> [] + | (s, t) :: [] -> + [ Bold [ Raw Odoc_messages.raises ] ; + Raw " " ; + Code s ; + Raw " " + ] + @ t + @ [ Newline ] + | _ -> + [ Bold [ Raw Odoc_messages.raises ] ; + Raw " " ; + List + (List.map + (fun (ex, desc) ->(Code ex) :: (Raw " ") :: desc ) + l + ) ; + Newline + ] + + (** Return [text] value for the given "see also" reference. *) + method text_of_see (see_ref, t) = + let t_ref = + match see_ref with + Odoc_info.See_url s -> [ Odoc_info.Link (s, t) ] + | Odoc_info.See_file s -> (Odoc_info.Code s) :: (Odoc_info.Raw " ") :: t + | Odoc_info.See_doc s -> (Odoc_info.Italic [Odoc_info.Raw s]) :: (Odoc_info.Raw " ") :: t + in + t_ref + + (** Return [text] value for the given list of "see also" references.*) + method text_of_sees l = + match l with + [] -> [] + | see :: [] -> + (Bold [ Raw Odoc_messages.see_also ]) :: + (Raw " ") :: + (self#text_of_see see) @ [ Newline ] + | _ -> + (Bold [ Raw Odoc_messages.see_also ]) :: + [ List + (List.map + (fun see -> self#text_of_see see) + l + ); + Newline + ] + + (** @return [text] value for the given optional return information.*) + method text_of_return_opt return_opt = + match return_opt with + None -> [] + | Some t -> (Bold [Raw (Odoc_messages.returns^" ")]) :: t @ [ Newline ] + + (** Return a [text] for the given list of custom tagged texts. *) + method text_of_custom l = + List.fold_left + (fun acc -> fun (tag, text) -> + try + let f = List.assoc tag tag_functions in + match acc with + [] -> f text + | _ -> acc @ (Newline :: (f text)) + with + Not_found -> + Odoc_info.warning (Odoc_messages.tag_not_handled tag) ; + acc + ) + [] + l + + (** @return [text] value for a description, except for the i_params field. *) + method text_of_info ?(block=true) info_opt = + match info_opt with + None -> + [] + | Some info -> + let t = + (match info.i_deprecated with + None -> [] + | Some t -> ( Italic [Raw (Odoc_messages.deprecated^" ")] ) :: t + ) @ + (match info.i_desc with + None -> [] + | Some t when t = [Odoc_info.Raw ""] -> [] + | Some t -> t @ [ Newline ] + ) @ + (self#text_of_author_list info.i_authors) @ + (self#text_of_version_opt info.i_version) @ + (self#text_of_before info.i_before) @ + (self#text_of_since_opt info.i_since) @ + (self#text_of_raised_exceptions info.i_raised_exceptions) @ + (self#text_of_return_opt info.i_return_value) @ + (self#text_of_sees info.i_sees) @ + (self#text_of_custom info.i_custom) + in + if block then + [Block t] + else + t + end + +(** This class defines methods to generate a [text] structure from elements. *) +class virtual to_text = + object (self) + inherit info + + method virtual label : ?no_: bool -> string -> string + + (** Take a string and return the string where fully qualified idents + have been replaced by idents relative to the given module name. + Also remove the "hidden modules".*) + method relative_idents m_name s = + let f str_t = + let match_s = Str.matched_string str_t in + let rel = Name.get_relative m_name match_s in + Odoc_info.apply_if_equal Odoc_info.use_hidden_modules match_s rel + in + let s2 = Str.global_substitute + (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)") + f + s + in + s2 + + (** Take a string and return the string where fully qualified idents + have been replaced by idents relative to the given module name. + Also remove the "hidden modules".*) + method relative_module_idents m_name s = + let f str_t = + let match_s = Str.matched_string str_t in + let rel = Name.get_relative m_name match_s in + Odoc_info.apply_if_equal Odoc_info.use_hidden_modules match_s rel + in + let s2 = Str.global_substitute + (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([A-Z][a-zA-Z_'0-9]*\\)") + f + s + in + s2 + + (** Get a string for a [Types.class_type] where all idents are relative. *) + method normal_class_type m_name t = + self#relative_idents m_name (Odoc_info.string_of_class_type t) + + (** Get a string for a [Types.module_type] where all idents are relative. *) + method normal_module_type ?code m_name t = + self#relative_module_idents m_name (Odoc_info.string_of_module_type ?code t) + + (** Get a string for a type where all idents are relative. *) + method normal_type m_name t = + self#relative_idents m_name (Odoc_info.string_of_type_expr t) + + (** Get a string for a list of types where all idents are relative. *) + method normal_type_list ?par m_name sep t = + self#relative_idents m_name (Odoc_info.string_of_type_list ?par sep t) + + (** Get a string for a list of class or class type type parameters + where all idents are relative. *) + method normal_class_type_param_list m_name t = + self#relative_idents m_name (Odoc_info.string_of_class_type_param_list t) + + (** Get a string for the parameters of a class (with arrows) where all idents are relative. *) + method normal_class_params m_name c = + let s = Odoc_info.string_of_class_params c in + self#relative_idents m_name + (Odoc_info.remove_ending_newline s) + + (** @return [text] value to represent a [Types.type_expr].*) + method text_of_type_expr module_name t = + let t = List.flatten + (List.map + (fun s -> [Code s ; Newline ]) + (Str.split (Str.regexp "\n") + (self#normal_type module_name t)) + ) + in + t + + (** Return [text] value for a given short [Types.type_expr].*) + method text_of_short_type_expr module_name t = + [ Code (self#normal_type module_name t) ] + + (** Return [text] value or the given list of [Types.type_expr], with + the given separator. *) + method text_of_type_expr_list module_name sep l = + [ Code (self#normal_type_list module_name sep l) ] + + (** Return [text] value or the given list of [Types.type_expr], + as type parameters of a class of class type. *) + method text_of_class_type_param_expr_list module_name l = + [ Code (self#normal_class_type_param_list module_name l) ] + + (** @return [text] value to represent parameters of a class (with arraows).*) + method text_of_class_params module_name c = + let t = Odoc_info.text_concat + [Newline] + (List.map + (fun s -> [Code s]) + (Str.split (Str.regexp "\n") + (self#normal_class_params module_name c)) + ) + in + t + + (** @return [text] value to represent a [Types.module_type]. *) + method text_of_module_type t = + let s = String.concat "\n" + (Str.split (Str.regexp "\n") (Odoc_info.string_of_module_type t)) + in + [ Code s ] + + (** @return [text] value for a value. *) + method text_of_value v = + let name = v.val_name in + let s_name = Name.simple name in + let s = + Format.fprintf Format.str_formatter "@[<hov 2>val %s :@ %s" + s_name + (self#normal_type (Name.father v.val_name) v.val_type); + Format.flush_str_formatter () + in + [ CodePre s ] @ + [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @ + (self#text_of_info v.val_info) + + (** @return [text] value for a class attribute. *) + method text_of_attribute a = + let s_name = Name.simple a.att_value.val_name in + let mod_name = Name.father a.att_value.val_name in + let s = + Format.fprintf Format.str_formatter "@[<hov 2>val %s%s%s :@ %s" + (if a.att_virtual then "virtual " else "") + (if a.att_mutable then "mutable " else "") + s_name + (self#normal_type mod_name a.att_value.val_type); + Format.flush_str_formatter () + in + (CodePre s) :: + [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @ + (self#text_of_info a.att_value.val_info) + + (** @return [text] value for a class method. *) + method text_of_method m = + let s_name = Name.simple m.met_value.val_name in + let mod_name = Name.father m.met_value.val_name in + let s = + Format.fprintf Format.str_formatter "@[<hov 2>method %s%s%s :@ %s" + (if m.met_private then "private " else "") + (if m.met_virtual then "virtual " else "") + s_name + (self#normal_type mod_name m.met_value.val_type); + Format.flush_str_formatter () + in + (CodePre s) :: + [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @ + (self#text_of_info m.met_value.val_info) + + + (** @return [text] value for an exception. *) + method text_of_exception e = + let s_name = Name.simple e.ex_name in + Format.fprintf Format.str_formatter "@[<hov 2>exception %s" s_name ; + (match e.ex_args with + [] -> () + | _ -> + Format.fprintf Format.str_formatter "@ of " + ); + let s = self#normal_type_list + ~par: false (Name.father e.ex_name) " * " e.ex_args + in + let s2 = + Format.fprintf Format.str_formatter "%s" s ; + (match e.ex_alias with + None -> () + | Some ea -> + Format.fprintf Format.str_formatter " = %s" + ( + match ea.ea_ex with + None -> ea.ea_name + | Some e -> e.ex_name + ) + ); + Format.flush_str_formatter () + in + [ CodePre s2 ] @ + [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @ + (self#text_of_info e.ex_info) + + (** Return [text] value for the description of a function parameter. *) + method text_of_parameter_description p = + match Parameter.names p with + [] -> [] + | name :: [] -> + ( + (* Only one name, no need for label for the description. *) + match Parameter.desc_by_name p name with + None -> [] + | Some t -> t + ) + | l -> + (* A list of names, we display those with a description. *) + let l2 = List.filter (fun n -> (Parameter.desc_by_name p n) <> None) l in + match l2 with + [] -> [] + | _ -> + [List + (List.map + (fun n -> + match Parameter.desc_by_name p n with + None -> [] (* should not occur *) + | Some t -> [Code (n^" ") ; Raw ": "] @ t + ) + l2 + ) + ] + + + (** Return [text] value for a list of parameters. *) + method text_of_parameter_list m_name l = + match l with + [] -> + [] + | _ -> + [ Bold [Raw Odoc_messages.parameters] ; + Raw ":" ; + List + (List.map + (fun p -> + (match Parameter.complete_name p with + "" -> Code "?" + | s -> Code s + ) :: + [Code " : "] @ + (self#text_of_short_type_expr m_name (Parameter.typ p)) @ + [Newline] @ + (self#text_of_parameter_description p) + ) + l + ) + ] + + (** Return [text] value for a list of module parameters. *) + method text_of_module_parameter_list l = + match l with + [] -> + [] + | _ -> + [ Newline ; + Bold [Raw Odoc_messages.parameters] ; + Raw ":" ; + List + (List.map + (fun (p, desc_opt) -> + [Code (p.mp_name^" : ")] @ + (self#text_of_module_type p.mp_type) @ + (match desc_opt with + None -> [] + | Some t -> (Raw " ") :: t) + ) + l + ) + ] + +(**/**) + + (** Return [text] value for the given [class_kind].*) + method text_of_class_kind father ckind = + match ckind with + Class_structure _ -> + [Code Odoc_messages.object_end] + + | Class_apply capp -> + [Code + ( + ( + match capp.capp_class with + None -> capp.capp_name + | Some cl -> cl.cl_name + )^ + " "^ + (String.concat " " + (List.map + (fun s -> "("^s^")") + capp.capp_params_code)) + ) + ] + + | Class_constr cco -> + ( + match cco.cco_type_parameters with + [] -> [] + | l -> + (Code "["):: + (self#text_of_type_expr_list father ", " l)@ + [Code "] "] + )@ + [Code ( + match cco.cco_class with + None -> cco.cco_name + | Some (Cl cl) -> Name.get_relative father cl.cl_name + | Some (Cltype (clt,_)) -> Name.get_relative father clt.clt_name + ) + ] + + | Class_constraint (ck, ctk) -> + [Code "( "] @ + (self#text_of_class_kind father ck) @ + [Code " : "] @ + (self#text_of_class_type_kind father ctk) @ + [Code " )"] + + + (** Return [text] value for the given [class_type_kind].*) + method text_of_class_type_kind father ctkind = + match ctkind with + Class_type cta -> + ( + match cta.cta_type_parameters with + [] -> [] + | l -> + (Code "[") :: + (self#text_of_class_type_param_expr_list father l) @ + [Code "] "] + ) @ + ( + match cta.cta_class with + None -> [ Code cta.cta_name ] + | Some (Cltype (clt, _)) -> + let rel = Name.get_relative father clt.clt_name in + [Code rel] + | Some (Cl cl) -> + let rel = Name.get_relative father cl.cl_name in + [Code rel] + ) + | Class_signature _ -> + [Code Odoc_messages.object_end] + + (** Return [text] value for a [module_kind]. *) + method text_of_module_kind ?(with_def_syntax=true) k = + match k with + Module_alias m_alias -> + (match m_alias.ma_module with + None -> + [Code ((if with_def_syntax then " = " else "")^m_alias.ma_name)] + | Some (Mod m) -> + [Code ((if with_def_syntax then " = " else "")^m.m_name)] + | Some (Modtype mt) -> + [Code ((if with_def_syntax then " = " else "")^mt.mt_name)] + ) + | Module_apply (k1, k2) -> + (if with_def_syntax then [Code " = "] else []) @ + (self#text_of_module_kind ~with_def_syntax: false k1) @ + [Code " ( "] @ + (self#text_of_module_kind ~with_def_syntax: false k2) @ + [Code " ) "] + + | Module_with (tk, code) -> + (if with_def_syntax then [Code " : "] else []) @ + (self#text_of_module_type_kind ~with_def_syntax: false tk) @ + [Code code] + + | Module_constraint (k, tk) -> + (if with_def_syntax then [Code " : "] else []) @ + [Code "( "] @ + (self#text_of_module_kind ~with_def_syntax: false k) @ + [Code " : "] @ + (self#text_of_module_type_kind ~with_def_syntax: false tk) @ + [Code " )"] + + | Module_struct _ -> + [Code ((if with_def_syntax then " : " else "")^ + Odoc_messages.struct_end^" ")] + + | Module_functor (p, k) -> + (if with_def_syntax then [Code " : "] else []) @ + [Code "functor ... "] @ + [Code " -> "] @ + (self#text_of_module_kind ~with_def_syntax: false k) + + | Module_typeof s -> + let code = Printf.sprintf "%smodule type of %s" + (if with_def_syntax then " : " else "") + s + in + [Code code] + | Module_unpack (code, _) -> + let code = Printf.sprintf "%s%s" + (if with_def_syntax then " : " else "") + code + in + [Code code] + + (** Return html code for a [module_type_kind].*) + method text_of_module_type_kind ?(with_def_syntax=true) tk = + match tk with + | Module_type_struct _ -> + [Code ((if with_def_syntax then " = " else "")^Odoc_messages.sig_end)] + + | Module_type_functor (p, k) -> + let t1 = + [Code ("("^p.mp_name^" : ")] @ + (self#text_of_module_type_kind p.mp_kind) @ + [Code ") -> "] + in + let t2 = self#text_of_module_type_kind ~with_def_syntax: false k in + (if with_def_syntax then [Code " = "] else []) @ t1 @ t2 + + | Module_type_with (tk2, code) -> + let t = self#text_of_module_type_kind ~with_def_syntax: false tk2 in + (if with_def_syntax then [Code " = "] else []) @ + t @ [Code code] + + | Module_type_alias mt_alias -> + [Code ((if with_def_syntax then " = " else "")^ + (match mt_alias.mta_module with + None -> mt_alias.mta_name + | Some mt -> mt.mt_name)) + ] + + | Odoc_module.Module_type_typeof s -> + let code = Printf.sprintf "%smodule type of %s" + (if with_def_syntax then " = " else "") s + in + [ Code code ] + end diff --git a/ocaml-binary-annot/ocamldoc/odoc_type.ml b/ocaml-binary-annot/ocamldoc/odoc_type.ml new file mode 100644 index 0000000000..9d19dc67d9 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_type.ml @@ -0,0 +1,55 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Representation and manipulation of a type, but not class nor module type.*) + +module Name = Odoc_name + +type private_flag = Asttypes.private_flag = + Private | Public + +(** Description of a variant type constructor. *) +type variant_constructor = { + vc_name : string ; + vc_args : Types.type_expr list ; (** arguments of the constructor *) + mutable vc_text : Odoc_types.text option ; (** optional user description *) + } + +(** Description of a record type field. *) +type record_field = { + rf_name : string ; + rf_mutable : bool ; (** true if mutable *) + rf_type : Types.type_expr ; + mutable rf_text : Odoc_types.text option ; (** optional user description *) + } + +(** The various kinds of type. *) +type type_kind = + Type_abstract + | Type_variant of variant_constructor list + (** constructors *) + | Type_record of record_field list + (** fields *) + +(** Representation of a type. *) +type t_type = { + ty_name : Name.t ; + mutable ty_info : Odoc_types.info option ; (** optional user information *) + ty_parameters : (Types.type_expr * bool * bool) list ; + (** type parameters: (type, covariant, contravariant) *) + ty_kind : type_kind ; + ty_private : private_flag; + ty_manifest : Types.type_expr option; (** type manifest *) + mutable ty_loc : Odoc_types.location ; + mutable ty_code : string option; + } diff --git a/ocaml-binary-annot/ocamldoc/odoc_types.ml b/ocaml-binary-annot/ocamldoc/odoc_types.ml new file mode 100644 index 0000000000..5c58afe165 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_types.ml @@ -0,0 +1,136 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +type ref_kind = + RK_module + | RK_module_type + | RK_class + | RK_class_type + | RK_value + | RK_type + | RK_exception + | RK_attribute + | RK_method + | RK_section of text + +and text_element = + | Raw of string + | Code of string + | CodePre of string + | Verbatim of string + | Bold of text + | Italic of text + | Emphasize of text + | Center of text + | Left of text + | Right of text + | List of text list + | Enum of text list + | Newline + | Block of text + | Title of int * string option * text + | Latex of string + | Link of string * text + | Ref of string * ref_kind option * text option + | Superscript of text + | Subscript of text + | Module_list of string list + | Index_list + | Custom of string * text + | Target of string * string + +and text = text_element list + +type see_ref = + See_url of string + | See_file of string + | See_doc of string + +type see = see_ref * text + +type param = (string * text) + +type raised_exception = (string * text) + +type info = { + i_desc : text option; + i_authors : string list; + i_version : string option; + i_sees : see list; + i_since : string option; + i_before : (string * text) list; + i_deprecated : text option; + i_params : param list; + i_raised_exceptions : raised_exception list; + i_return_value : text option ; + i_custom : (string * text) list ; + } + +let dummy_info = { + i_desc = None ; + i_authors = [] ; + i_version = None ; + i_sees = [] ; + i_since = None ; + i_before = [] ; + i_deprecated = None ; + i_params = [] ; + i_raised_exceptions = [] ; + i_return_value = None ; + i_custom = [] ; +} + +type location = { + loc_impl : (string * int) option ; + loc_inter : (string * int) option ; + } + +let dummy_loc = { loc_impl = None ; loc_inter = None } + +type merge_option = + | Merge_description + | Merge_author + | Merge_version + | Merge_see + | Merge_since + | Merge_deprecated + | Merge_param + | Merge_raised_exception + | Merge_return_value + | Merge_custom + +let all_merge_options = [ + Merge_description ; + Merge_author ; + Merge_version ; + Merge_see ; + Merge_since ; + Merge_deprecated ; + Merge_param ; + Merge_raised_exception ; + Merge_return_value ; + Merge_custom ; +] + +type magic = string + +let magic = Odoc_messages.magic + +type 'a dump = Dump of magic * 'a + +let make_dump a = Dump (magic, a) + +let open_dump = function + Dump (m, a) -> + if m = magic then a + else raise (Failure Odoc_messages.bad_magic_number) diff --git a/ocaml-binary-annot/ocamldoc/odoc_types.mli b/ocaml-binary-annot/ocamldoc/odoc_types.mli new file mode 100644 index 0000000000..639697f593 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_types.mli @@ -0,0 +1,136 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Types for the information collected in comments. *) + +(** The differents kinds of element references. *) +type ref_kind = + RK_module + | RK_module_type + | RK_class + | RK_class_type + | RK_value + | RK_type + | RK_exception + | RK_attribute + | RK_method + | RK_section of text + +and text_element = + | Raw of string (** Raw text. *) + | Code of string (** The string is source code. *) + | CodePre of string (** The string is pre-formatted source code. *) + | Verbatim of string (** String 'as is'. *) + | Bold of text (** Text in bold style. *) + | Italic of text (** Text in italic. *) + | Emphasize of text (** Emphasized text. *) + | Center of text (** Centered text. *) + | Left of text (** Left alignment. *) + | Right of text (** Right alignment. *) + | List of text list (** A list. *) + | Enum of text list (** An enumerated list. *) + | Newline (** To force a line break. *) + | Block of text (** Like html's block quote. *) + | Title of int * string option * text + (** Style number, optional label, and text. *) + | Latex of string (** A string for latex. *) + | Link of string * text (** A reference string and the link text. *) + | Ref of string * ref_kind option * text option + (** A reference to an element. Complete name and kind. An optional + text can be given to display this text instead of the element name.*) + | Superscript of text (** Superscripts. *) + | Subscript of text (** Subscripts. *) + | Module_list of string list + (** The table of the given modules with their abstract; *) + | Index_list (** The links to the various indexes (values, types, ...) *) + | Custom of string * text (** to extend \{foo syntax *) + | Target of string * string (** (target, code) : to specify code for a specific target format *) + +(** [text] is a list of text_elements. The order matters. *) +and text = text_element list + +(** The different forms of references in \@see tags. *) +type see_ref = + See_url of string + | See_file of string + | See_doc of string + +(** The information in a \@see tag. *) +type see = see_ref * text + +(** Parameter name and description. *) +type param = (string * text) + +(** Raised exception name and description. *) +type raised_exception = (string * text) + +(** Information in a special comment. *) +type info = { + i_desc : text option; (** The description text. *) + i_authors : string list; (** The list of authors in \@author tags. *) + i_version : string option; (** The string in the \@version tag. *) + i_sees : see list; (** The list of \@see tags. *) + i_since : string option; (** The string in the \@since tag. *) + i_before : (string * text) list; (** the version number and text in \@before tag *) + i_deprecated : text option; (** The of the \@deprecated tag. *) + i_params : param list; (** The list of parameter descriptions. *) + i_raised_exceptions : raised_exception list; (** The list of raised exceptions. *) + i_return_value : text option ; (** The description text of the return value. *) + i_custom : (string * text) list ; (** A text associated to a custom @-tag. *) + } + +(** An empty info structure. *) +val dummy_info : info + +(** Location of elements in implementation and interface files. *) +type location = { + loc_impl : (string * int) option ; (** implementation file name and position *) + loc_inter : (string * int) option ; (** interface file name and position *) + } + +(** A dummy location. *) +val dummy_loc : location + +(** The information to merge from two elements when they both have some information. *) +type merge_option = + | Merge_description (** Descriptions are concatenated. *) + | Merge_author (** Lists of authors are concatenated. *) + | Merge_version (** Versions are concatenated. *) + | Merge_see (** See references are concatenated. *) + | Merge_since (** Since information are concatenated. *) + | Merge_deprecated (** Deprecated information are concatenated. *) + | Merge_param (** Information on each parameter is concatenated, + and all parameters are kept. *) + | Merge_raised_exception (** Information on each raised_exception is concatenated, + and all raised exceptions are kept. *) + | Merge_return_value (** Information on return value are concatenated. *) + | Merge_custom (** Merge custom tags (all pairs (tag, text) are kept). *) + +(** The list with all merge options. *) +val all_merge_options : merge_option list + +(** Type of magic numbers. *) +type magic + +(** The magic number for the dumps of this version of ocamldoc. *) +val magic : magic + +(** A dump of a structure. *) +type 'a dump + +(** Create a dump structure. *) +val make_dump : 'a -> 'a dump + +(** Verify that a dump has the correct magic number + and return its content. *) +val open_dump : 'a dump -> 'a diff --git a/ocaml-binary-annot/ocamldoc/odoc_value.ml b/ocaml-binary-annot/ocamldoc/odoc_value.ml new file mode 100644 index 0000000000..a210f0851e --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_value.ml @@ -0,0 +1,144 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Representation and manipulation of values, class attributes and class methods. *) + +module Name = Odoc_name + +(** Types *) + +(** Representation of a value. *) +type t_value = { + val_name : Name.t ; + mutable val_info : Odoc_types.info option ; + val_type : Types.type_expr ; + val_recursive : bool ; + mutable val_parameters : Odoc_parameter.parameter list ; + mutable val_code : string option ; + mutable val_loc : Odoc_types.location ; + } + +(** Representation of a class attribute. *) +type t_attribute = { + att_value : t_value ; (** an attribute has almost all the same information + as a value *) + att_mutable : bool ; + att_virtual : bool ; + } + +(** Representation of a class method. *) +type t_method = { + met_value : t_value ; (** a method has almost all the same information + as a value *) + met_private : bool ; + met_virtual : bool ; + } + +(** Functions *) + +(** Returns the text associated to the given parameter name + in the given value, or None. *) +let value_parameter_text_by_name v name = + match v.val_info with + None -> None + | Some i -> + try + let t = List.assoc name i.Odoc_types.i_params in + Some t + with + Not_found -> + None + +(** Update the parameters text of a t_value, according to the val_info field. *) +let update_value_parameters_text v = + let f p = + Odoc_parameter.update_parameter_text (value_parameter_text_by_name v) p + in + List.iter f v.val_parameters + +(** Create a list of (parameter name, typ) from a type, according to the arrows. + [parameter_list_from_arrows t = [ a ; b ]] if t = a -> b -> c.*) +let parameter_list_from_arrows typ = + let rec iter t = + match t.Types.desc with + Types.Tarrow (l, t1, t2, _) -> + (l, t1) :: (iter t2) + | Types.Tlink texp + | Types.Tsubst texp -> + iter texp + | Types.Tpoly (texp, _) -> iter texp + | Types.Tvar + | Types.Ttuple _ + | Types.Tconstr _ + | Types.Tobject _ + | Types.Tfield _ + | Types.Tnil + | Types.Tunivar + | Types.Tpackage _ + | Types.Tvariant _ -> + [] + in + iter typ + +(** Create a list of parameters with dummy names "??" from a type list. + Used when we want to merge the parameters of a value, from the .ml + and the .mli file. In the .mli file we don't have parameter names + so there is nothing to merge. With this dummy list we can merge the + parameter names from the .ml and the type from the .mli file. *) +let dummy_parameter_list typ = + let normal_name s = + match s with + "" -> s + | _ -> + match s.[0] with + '?' -> String.sub s 1 ((String.length s) - 1) + | _ -> s + in + Printtyp.mark_loops typ; + let liste_param = parameter_list_from_arrows typ in + let rec iter (label, t) = + match t.Types.desc with + | Types.Ttuple l -> + if label = "" then + Odoc_parameter.Tuple + (List.map (fun t2 -> iter ("", t2)) l, t) + else + (* if there is a label, then we don't want to decompose the tuple *) + Odoc_parameter.Simple_name + { Odoc_parameter.sn_name = normal_name label ; + Odoc_parameter.sn_type = t ; + Odoc_parameter.sn_text = None } + | Types.Tlink t2 + | Types.Tsubst t2 -> + (iter (label, t2)) + + | _ -> + Odoc_parameter.Simple_name + { Odoc_parameter.sn_name = normal_name label ; + Odoc_parameter.sn_type = t ; + Odoc_parameter.sn_text = None } + in + List.map iter liste_param + +(** Return true if the value is a function, i.e. has a functional type.*) +let is_function v = + let rec f t = + match t.Types.desc with + Types.Tarrow _ -> + true + | Types.Tlink t -> + f t + | _ -> + false + in + f v.val_type diff --git a/ocaml-binary-annot/ocamldoc/remove_DEBUG b/ocaml-binary-annot/ocamldoc/remove_DEBUG new file mode 100755 index 0000000000..78b11e6128 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/remove_DEBUG @@ -0,0 +1,22 @@ +#!/bin/sh + +#(***********************************************************************) +#(* OCamldoc *) +#(* *) +#(* Damien Doligez, projet Moscova, INRIA Rocquencourt *) +#(* *) +#(* Copyright 2003 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. *) +#(* *) +#(***********************************************************************) + +# $Id$ + +# usage: remove_DEBUG <file> +# remove from <file> every line that contains the string "DEBUG", +# respecting the cpp # line annotation conventions + +echo "# 1 \"$1\"" +LC_ALL=C sed -e '/DEBUG/c\ +(* DEBUG statement removed *)' "$1" diff --git a/ocaml-binary-annot/ocamldoc/runocamldoc b/ocaml-binary-annot/ocamldoc/runocamldoc new file mode 100644 index 0000000000..a71d705ccd --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/runocamldoc @@ -0,0 +1,12 @@ +#!/bin/sh +# $Id$ + +case "$1" in + true) shift + exec ../boot/ocamlrun -I ../otherlibs/unix -I ../otherlibs/str \ + ./ocamldoc "$@" + ;; + *) shift + exec ./ocamldoc "$@" + ;; +esac |