diff options
64 files changed, 20023 insertions, 0 deletions
diff --git a/ocamldoc/Changes.txt b/ocamldoc/Changes.txt new file mode 100644 index 000000000..6ab6bbfb5 --- /dev/null +++ b/ocamldoc/Changes.txt @@ -0,0 +1,73 @@ +Next release : + - 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
\ No newline at end of file diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile new file mode 100644 index 000000000..8b5fba4b7 --- /dev/null +++ b/ocamldoc/Makefile @@ -0,0 +1,325 @@ +#(***********************************************************************) +#(* 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. *) +#(* *) +#(***********************************************************************) + +include ../config/Makefile + +# Various commands and dir +########################## +CAMLRUN=../boot/ocamlrun +OCAMLC = $(CAMLRUN) ../boot/ocamlc -I ../boot -warn-error A +OCAMLOPT = $(CAMLRUN) ../ocamlopt +OCAMLDEP = $(CAMLRUN) ../tools/ocamldep +OCAMLLEX = $(CAMLRUN) ../boot/ocamllex +OCAMLYACC= ../boot/ocamlyacc +OCAMLLIB = $(LIBDIR) +OCAMLBIN = $(BINDIR) +EXTRAC_CRC = $(CAMLRUN) ../otherlibs/dynlink/extract_crc + +OCAMLPP=-pp 'grep -v DEBUG' + +# For installation +############## +MKDIR=mkdir -p +CP=cp -f +OCAMLDOC=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_BINDIR=$(OCAMLBIN) + +INSTALL_MLIS=odoc_info.mli +INSTALL_CMIS=$(INSTALL_MLIS:.mli=.cmi) + +# Compilation +############# +OCAMLSRCDIR:=.. +INCLUDES= -I $(OCAMLSRCDIR)/parsing \ + -I $(OCAMLSRCDIR)/utils \ + -I $(OCAMLSRCDIR)/typing \ + -I $(OCAMLSRCDIR)/driver \ + -I $(OCAMLSRCDIR)/bytecomp \ + -I $(OCAMLSRCDIR)/tools \ + -I $(OCAMLSRCDIR)/stdlib \ + -I $(OCAMLSRCDIR)/otherlibs/str \ + -I $(OCAMLSRCDIR)/otherlibs/dynlink \ + -I $(OCAMLSRCDIR)/otherlibs/unix \ + -I $(OCAMLSRCDIR)/otherlibs/num \ + -I $(OCAMLSRCDIR)/otherlibs/graph \ + -I $(OCAMLSRCDIR)/toplevel/ \ + +COMPFLAGS=$(INCLUDES) +LINKFLAGS=$(INCLUDES) + +CMOFILES= 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_str.cmo\ + odoc_args.cmo\ + odoc_comments_global.cmo\ + odoc_parser.cmo\ + odoc_lexer.cmo\ + odoc_see_lexer.cmo\ + odoc_comments.cmo\ + odoc_env.cmo\ + odoc_merge.cmo\ + odoc_sig.cmo\ + odoc_ast.cmo\ + odoc_control.cmo\ + odoc_inherit.cmo\ + odoc_search.cmo\ + odoc_cross.cmo\ + odoc_dep.cmo\ + odoc_analyse.cmo\ + odoc_scan.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.cmo\ + odoc_dot.cmo\ + odoc_iso.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)/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/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): $(EXECMIFILES) $(EXECMOFILES) odoc_crc.cmo odoc.cmo + $(OCAMLC) -o $@ unix.cma str.cma dynlink.cma $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) odoc_crc.cmo odoc.cmo +$(OCAMLDOC_OPT): $(EXECMIFILES) $(EXECMXFILES) odoc_opt.cmx + $(OCAMLOPT) -o $@ unix.cmxa str.cmxa $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES) odoc_opt.cmx + +$(OCAMLDOC_LIBCMA): $(LIBCMIFILES) $(LIBCMOFILES) + $(OCAMLC) -a -o $@ $(LINKFLAGS) $(OCAMLCMOFILES) $(LIBCMOFILES) +$(OCAMLDOC_LIBCMXA): $(LIBCMIFILES) $(LIBCMXFILES) + $(OCAMLOPT) -a -o $@ $(LINKFLAGS) $(OCAMLCMXFILES) $(LIBCMXFILES) + +odoc_crc.ml: $(CMIFILES) + $(EXTRAC_CRC) $(INCLUDES)\ + Arg Arith_status Array Big_int Buffer Callback Char Digest Dynlink \ + Filename Format Gc Genlex Graphics Hashtbl \ + Lazy Lexing List Map Marshal Nat\ + Num Obj Oo Outcometree Parsing Pervasives Printexc\ + Printf Profiling Queue Random Ratio\ + Set Sort Stack Std_exit Str Stream\ + String Sys Topdirs Toploop Unix Weak\ + Printast \ + Ident \ + Tbl \ + Misc \ + Config \ + Clflags \ + Warnings \ + Ccomp \ + Linenum\ + Location\ + Longident \ + Syntaxerr \ + Parser \ + Lexer \ + Parse \ + Types \ + Path \ + Btype \ + Predef \ + Datarepr \ + Subst \ + Env \ + Ctype \ + Primitive \ + Oprint \ + Printtyp \ + Includecore \ + Typetexp \ + Parmatch \ + Typedtree \ + Typecore \ + Includeclass \ + Typedecl \ + Typeclass \ + Mtype \ + Includemod \ + Typemod \ + Lambda \ + Typeopt \ + Printlambda \ + Switch \ + Matching \ + Translobj \ + Translcore \ + Bytesections \ + Runtimedef \ + Symtable \ + Opcodes \ + Bytelink \ + Bytelibrarian \ + Translclass \ + Errors \ + Main_args \ + Asttypes \ + Depend \ + Odoc_global Odoc_args Odoc_info Odoc_messages Odoc_types\ + Odoc_misc Odoc_text_parser Odoc_text_lexer\ + Odoc_text Odoc_comments_global Odoc_parser\ + Odoc_lexer Odoc_comments Odoc_name Odoc_parameter\ + Odoc_value Odoc_type Odoc_exception Odoc_class\ + Odoc_module Odoc_str Odoc_args Odoc_env\ + Odoc_sig Odoc_ast Odoc_control Odoc_inherit\ + Odoc_search Odoc_cross Odoc_merge Odoc_analyse\ + Odoc_dag2html Odoc_ocamlhtml Odoc_html\ + Odoc_latex Odoc_man Odoc_iso Odoc_scan > $@ + +# generic rules : +################# + +.SUFFIXES: .mli .ml .cmi .cmo .cmx .mll .mly + +%.cmi:%.mli + $(OCAMLC) $(OCAMLPP) $(COMPFLAGS) -c $< + +%.cmo:%.ml + $(OCAMLC) $(OCAMLPP) $(COMPFLAGS) -c $< + +%.cmi %.cmo:%.ml + $(OCAMLC) $(OCAMLPP) $(COMPFLAGS) -c $< + +%.cmx %.o:%.ml + $(OCAMLOPT) $(OCAMLPP) $(COMPFLAGS) -c $< + +%.ml:%.mll + $(OCAMLLEX) $< + +%.mli %.ml:%.mly + $(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 + $(CP) $(OCAMLDOC) $(INSTALL_BINDIR) + $(CP) ocamldoc.sty ocamldoc.hva *.cmi $(GENERATORS) $(OCAMLDOC_LIBCMA) $(INSTALL_LIBDIR) + $(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) $(INSTALL_LIBDIR) + if test -f $(OCAMLDOC_OPT) ; then $(MAKE) installopt ; fi + +installopt: + 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) + $(CP) ocamldoc.sty 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 odoc odoc.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 odoc_crc.ml + +.depend depend:: + rm -f .depend + $(OCAMLYACC) odoc_text_parser.mly + $(OCAMLYACC) odoc_parser.mly + $(OCAMLLEX) odoc_text_lexer.mll + $(OCAMLLEX) odoc_lexer.mll + $(OCAMLDEP) $(INCLUDES) *.mll *.mly *.ml *.mli > .depend + +dummy: + +include .depend diff --git a/ocamldoc/ocamldoc.hva b/ocamldoc/ocamldoc.hva new file mode 100644 index 000000000..da700db5a --- /dev/null +++ b/ocamldoc/ocamldoc.hva @@ -0,0 +1,10 @@ +\usepackage{alltt} +\newenvironment{ocamldoccode}{\begin{alltt}}{\end{alltt}} +\newenvironment{ocamldocdescription}{\begin{quote}}{\end{quote}} +\newenvironment{ocamldoccomment}{\begin{quote}}{\end{quote}} +\newcommand\textbar{|} +\newcommand\textbackslash{\\} +\newcommand\textasciicircum{\^{}} +\newcommand\sharp{#} + + diff --git a/ocamldoc/ocamldoc.sty b/ocamldoc/ocamldoc.sty new file mode 100644 index 000000000..008a7975b --- /dev/null +++ b/ocamldoc/ocamldoc.sty @@ -0,0 +1,57 @@ +%% 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 + \@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} + +\endinput + diff --git a/ocamldoc/odoc.ml b/ocamldoc/odoc.ml new file mode 100644 index 000000000..cca5eea0e --- /dev/null +++ b/ocamldoc/odoc.ml @@ -0,0 +1,126 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + +(** Main module for bytecode. *) + +open Config +open Clflags +open Misc +open Format +open Typedtree + +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 (cmo_or_cma_opt, paths) = + let rec iter (f_opt, inc) = function + [] | _ :: [] -> (f_opt, inc) + | "-g" :: file :: q when + ((Filename.check_suffix file "cmo") or + (Filename.check_suffix file "cma")) & + (f_opt = None) -> + iter (Some file, inc) q + | "-i" :: dir :: q -> + iter (f_opt, inc @ [dir]) q + | _ :: q -> + iter (f_opt, inc) q + in + iter (None, []) arg_list + +let _ = print_DEBUG "Fin analyse des arguments pour le dynamic load" + +let _ = + match cmo_or_cma_opt with + None -> + () + | Some file -> + (* initializations for dynamic loading *) + Dynlink.init (); + Dynlink.allow_unsafe_modules true; + try + Dynlink.add_available_units Odoc_crc.crc_unit_list ; + let _ = Dynlink.loadfile file in + () + 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 -> + prerr_endline (Odoc_messages.load_file_error file s); + exit 1 + +let _ = print_DEBUG "Fin du chargement dynamique éventuel" + +let default_html_generator = new Odoc_html.html +let default_latex_generator = new Odoc_latex.latex +let default_man_generator = new Odoc_man.man +let default_iso_generator = new Odoc_iso.iso +let default_dot_generator = new Odoc_dot.dot +let _ = Odoc_args.parse + (default_html_generator :> Odoc_args.doc_generator) + (default_latex_generator :> Odoc_args.doc_generator) + (default_man_generator :> Odoc_args.doc_generator) + (default_iso_generator :> Odoc_args.doc_generator) + (default_dot_generator :> Odoc_args.doc_generator) + + +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_args.load + ) + +let modules = Odoc_analyse.analyse_files ~init: loaded_modules !Odoc_args.files + +let _ = + match !Odoc_args.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.doc_generator with + None -> + () + | Some gen -> + Odoc_info.verbose Odoc_messages.generating_doc; + gen#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/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml new file mode 100644 index 000000000..5b552fc64 --- /dev/null +++ b/ocamldoc/odoc_analyse.ml @@ -0,0 +1,452 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + +(** 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 () = + let dirs = + if !Clflags.thread_safe then + Filename.concat Config.standard_library "threads" :: !Clflags.include_dirs + else + !Clflags.include_dirs in + load_path := "" :: List.rev (Config.standard_library :: 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; + parse_fun (Lexing.from_channel ic) + 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 + let inputfile = preprocess sourcefile in + let env = initial_env () in + let cmi_file = (Filename.chop_extension sourcefile)^".cmi" in + try + let _ = Sys.command ("cp "^cmi_file^" /tmp") in + + let parsetree = parse_file inputfile Parse.implementation ast_impl_magic_number in + let typedtree = Typemod.type_implementation sourcefile prefixname modulename env parsetree in + let _ = Sys.command ("mv "^"/tmp/"^(Filename.basename cmi_file)^" "^cmi_file) in + (Some (parsetree, typedtree), inputfile) + with + e -> + let _ = Sys.command ("mv "^"/tmp/"^(Filename.basename cmi_file)^" "^cmi_file) in + 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 + 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. Besisdes, this + differences only concern code generation (i believe).*) +let process_error exn = + let report ppf = function + | Lexer.Error(err, start, stop) -> + Location.print ppf {Location.loc_start = start; + Location.loc_end = stop; + Location.loc_ghost = false}; + Lexer.report_error ppf err + | Syntaxerr.Error err -> + Syntaxerr.report_error ppf err + | Env.Error err -> + Env.report_error ppf err + | Ctype.Tags(l, l') -> fprintf ppf + "In this program,@ variant constructors@ `%s and `%s@ \ + have the same hash value." l l' + | Typecore.Error(loc, err) -> + Location.print ppf loc; Typecore.report_error ppf err + | Typetexp.Error(loc, err) -> + Location.print ppf loc; Typetexp.report_error ppf err + | Typedecl.Error(loc, err) -> + Location.print ppf loc; Typedecl.report_error ppf err + | Includemod.Error err -> + Includemod.report_error ppf err + | Typemod.Error(loc, err) -> + Location.print ppf loc; Typemod.report_error ppf err + | Translcore.Error(loc, err) -> + Location.print ppf loc; Translcore.report_error ppf err + | Sys_error msg -> + fprintf ppf "I/O error: %s" msg + | Typeclass.Error(loc, err) -> + Location.print ppf loc; Typeclass.report_error ppf err + | Translclass.Error(loc, err) -> + Location.print ppf loc; Translclass.report_error ppf err + | Warnings.Errors (n) -> + fprintf ppf "@.Error: %d error-enabled warnings occurred." n + | x -> + fprintf ppf "@]"; + fprintf ppf "Compilation error. Use the OCaml compiler to get more details." + 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_args.verbose then + ( + print_string (Odoc_messages.analysing sourcefile) ; + print_newline (); + ); + if Filename.check_suffix sourcefile "ml" then + ( + try + let (parsetree_typedtree_opt, input_file) = process_implementation_file ppf sourcefile in + match parsetree_typedtree_opt with + None -> + None + | Some (parsetree, typedtree) -> + let file_module = Ast_analyser.analyse_typed_tree sourcefile !Location.input_name parsetree typedtree in + + file_module.Odoc_module.m_top_deps <- Odoc_dep.impl_dependencies parsetree ; + + if !Odoc_args.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 + ) + else + if Filename.check_suffix sourcefile "mli" then + ( + try + let (ast, signat, input_file) = process_interface_file ppf sourcefile in + let file_module = Sig_analyser.analyse_signature sourcefile !Location.input_name ast signat in + + file_module.Odoc_module.m_top_deps <- Odoc_dep.intf_dependencies ast ; + + if !Odoc_args.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 + ) + else + ( + raise (Failure (Odoc_messages.unknown_extension sourcefile)) + ) + +(** Remove the class elements after the stop special comment. *) +let rec remove_class_elements_after_stop eles = + match eles with + [] -> [] + | ele :: q -> + match ele with + Odoc_class.Class_comment [ Odoc_types.Raw "/*" ] -> [] + | Odoc_class.Class_attribute _ + | Odoc_class.Class_method _ + | Odoc_class.Class_comment _ -> ele :: (remove_class_elements_after_stop q) + +(** Remove the class elements after the stop special comment in a class kind. *) +let rec remove_class_elements_after_stop_in_class_kind k = + match k with + Odoc_class.Class_structure (inher, l) -> + Odoc_class.Class_structure (inher, remove_class_elements_after_stop l) + | Odoc_class.Class_apply _ -> k + | Odoc_class.Class_constr _ -> k + | Odoc_class.Class_constraint (k1, ctk) -> + Odoc_class.Class_constraint (remove_class_elements_after_stop_in_class_kind k1, + remove_class_elements_after_stop_in_class_type_kind ctk) + +(** Remove the class elements after the stop special comment in a class type kind. *) +and remove_class_elements_after_stop_in_class_type_kind tk = + match tk with + Odoc_class.Class_signature (inher, l) -> + Odoc_class.Class_signature (inher, remove_class_elements_after_stop l) + | Odoc_class.Class_type _ -> tk + + +(** Remove the module elements after the stop special comment. *) +let rec remove_module_elements_after_stop eles = + let f = remove_module_elements_after_stop in + match eles with + [] -> [] + | ele :: q -> + match ele with + Odoc_module.Element_module_comment [ Odoc_types.Raw "/*" ] -> [] + | Odoc_module.Element_module_comment _ -> + ele :: (f q) + | Odoc_module.Element_module m -> + m.Odoc_module.m_kind <- remove_module_elements_after_stop_in_module_kind m.Odoc_module.m_kind ; + (Odoc_module.Element_module m) :: (f q) + | Odoc_module.Element_module_type mt -> + mt.Odoc_module.mt_kind <- Odoc_misc.apply_opt + remove_module_elements_after_stop_in_module_type_kind mt.Odoc_module.mt_kind ; + (Odoc_module.Element_module_type mt) :: (f q) + | Odoc_module.Element_included_module _ -> + ele :: (f q) + | Odoc_module.Element_class c -> + c.Odoc_class.cl_kind <- remove_class_elements_after_stop_in_class_kind c.Odoc_class.cl_kind ; + (Odoc_module.Element_class c) :: (f q) + | Odoc_module.Element_class_type ct -> + ct.Odoc_class.clt_kind <- remove_class_elements_after_stop_in_class_type_kind ct.Odoc_class.clt_kind ; + (Odoc_module.Element_class_type ct) :: (f q) + | Odoc_module.Element_value _ + | Odoc_module.Element_exception _ + | Odoc_module.Element_type _ -> + ele :: (f q) + + +(** Remove the module elements after the stop special comment, in the given module kind. *) +and remove_module_elements_after_stop_in_module_kind k = + match k with + | Odoc_module.Module_struct l -> Odoc_module.Module_struct (remove_module_elements_after_stop l) + | Odoc_module.Module_alias _ -> k + | Odoc_module.Module_functor (params, k2) -> + Odoc_module.Module_functor (params, remove_module_elements_after_stop_in_module_kind k2) + | Odoc_module.Module_apply (k1, k2) -> + Odoc_module.Module_apply (remove_module_elements_after_stop_in_module_kind k1, + remove_module_elements_after_stop_in_module_kind k2) + | Odoc_module.Module_with (mtkind, s) -> + Odoc_module.Module_with (remove_module_elements_after_stop_in_module_type_kind mtkind, s) + | Odoc_module.Module_constraint (k2, mtkind) -> + Odoc_module.Module_constraint (remove_module_elements_after_stop_in_module_kind k2, + remove_module_elements_after_stop_in_module_type_kind mtkind) + +(** Remove the module elements after the stop special comment, in the given module type kind. *) +and remove_module_elements_after_stop_in_module_type_kind tk = + match tk with + | Odoc_module.Module_type_struct l -> Odoc_module.Module_type_struct (remove_module_elements_after_stop l) + | Odoc_module.Module_type_functor (params, tk2) -> + Odoc_module.Module_type_functor (params, remove_module_elements_after_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_after_stop_in_module_type_kind tk2, s) + + +(** Remove elements after the stop special comment. *) +let remove_elements_after_stop module_list = + List.map + (fun m -> + m.Odoc_module.m_kind <- remove_module_elements_after_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 after the stop special comments, if needed. *) + let modules = + if !Odoc_args.no_stop then + modules_pre + else + remove_elements_after_stop modules_pre + in + + + if !Odoc_args.verbose then + ( + print_string Odoc_messages.merging; + print_newline () + ); + let merged_modules = Odoc_merge.merge !Odoc_args.merge_options modules in + if !Odoc_args.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_args.verbose then + ( + print_string Odoc_messages.cross_referencing; + print_newline () + ); + let _ = Odoc_cross.associate modules_list in + + if !Odoc_args.verbose then + ( + print_string Odoc_messages.ok; + print_newline (); + ); + + if !Odoc_args.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 + output_value chanout modules; + close_out chanout + with + Sys_error s -> + raise (Failure s) + +let load_modules file = + try + let chanin = open_in_bin file in + let (l : Odoc_module.t_module list) = input_value chanin in + close_in chanin ; + l + with + Sys_error s -> + raise (Failure s) + + diff --git a/ocamldoc/odoc_analyse.mli b/ocamldoc/odoc_analyse.mli new file mode 100644 index 000000000..845b1c4d8 --- /dev/null +++ b/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. *) +(* *) +(***********************************************************************) + + +(** 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 -> + string 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/ocamldoc/odoc_args.ml b/ocamldoc/odoc_args.ml new file mode 100644 index 000000000..1309d3a1b --- /dev/null +++ b/ocamldoc/odoc_args.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. *) +(* *) +(***********************************************************************) + + +(** Command-line arguments. *) +open Clflags + +let include_dirs = Clflags.include_dirs + +class type doc_generator = + object + method generate : Odoc_module.t_module list -> unit + end + +let doc_generator = ref (None : doc_generator option) + +let merge_options = ref ([] : Odoc_types.merge_option list) + +let iso_type_options = ref ([] : Odoc_types.iso_check list) +let iso_val_options = ref ([] : Odoc_types.iso_check list) +let iso_exception_options = ref ([] : Odoc_types.iso_check list) +let iso_class_options = ref ([] : Odoc_types.iso_check list) +let iso_module_options = ref ([] : Odoc_types.iso_check list) + +let dot_file = ref Odoc_messages.default_dot_file + +let dot_include_all = ref false + +let dot_types = ref false + +let dot_reduce = ref false + +let dot_colors = ref Odoc_messages.default_dot_colors + +(** 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 = [ + (Odoc_messages.merge_description, [Odoc_types.Merge_description]) ; + (Odoc_messages.merge_author, [Odoc_types.Merge_author]) ; + (Odoc_messages.merge_version, [Odoc_types.Merge_version]) ; + (Odoc_messages.merge_see, [Odoc_types.Merge_see]) ; + (Odoc_messages.merge_since, [Odoc_types.Merge_since]) ; + (Odoc_messages.merge_deprecated, [Odoc_types.Merge_deprecated]) ; + (Odoc_messages.merge_param, [Odoc_types.Merge_param]) ; + (Odoc_messages.merge_raised_exception, [Odoc_types.Merge_raised_exception]) ; + (Odoc_messages.merge_return_value, [Odoc_types.Merge_return_value]) ; + (Odoc_messages.merge_custom, [Odoc_types.Merge_custom]) ; + (Odoc_messages.merge_all, Odoc_types.all_merge_options) + ] + in + analyse_option_string l s + +(** Analysis of a string defining the iso checks to perform. + Return the list of checks specified.*) +let analyse_iso_checks s = + let l = [ + (Odoc_messages.iso_description, [Odoc_types.Has_description]) ; + (Odoc_messages.iso_author, [Odoc_types.Has_author]) ; + (Odoc_messages.iso_since, [Odoc_types.Has_since]) ; + (Odoc_messages.iso_version, [Odoc_types.Has_version]) ; + (Odoc_messages.iso_return, [Odoc_types.Has_return]) ; + (Odoc_messages.iso_params, [Odoc_types.Has_params]) ; + (Odoc_messages.iso_fields_described, [Odoc_types.Has_fields_decribed]) ; + (Odoc_messages.iso_constructors_described, [Odoc_types.Has_constructors_decribed]) ; + (Odoc_messages.iso_all, Odoc_types.all_iso_checks) + ] + in + analyse_option_string l s + + +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 + +let verbose = ref false + +(** 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 title = ref (None : string option) + +let with_parameter_list = ref false + +let hidden_modules = ref ([] : string list) + +let target_dir = ref Filename.current_dir_name + +let css_style = ref None + +let index_only = ref false + +let colorize_code = ref false + +let with_header = ref true + +let with_trailer = ref true + +let separate_files = ref false + +let latex_titles = ref [ + 1, "section" ; + 2, "subsection" ; + 3, "subsubsection" ; + 4, "paragraph" ; + 5, "subparagraph" ; +] + +let with_toc = ref true + +let files = ref [] + +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 + latex_titles := List.remove_assoc n !latex_titles ; + latex_titles := (n, command) :: !latex_titles + with + Not_found + | Invalid_argument _ -> + incr Odoc_global.errors ; + prerr_endline (Odoc_messages.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' -> hidden_modules := name :: !hidden_modules + | _ -> + incr Odoc_global.errors; + prerr_endline (Odoc_messages.not_a_module_name name) + ) + l + +let set_doc_generator (dg_opt : doc_generator option) = doc_generator := dg_opt + +(** The default html generator. Initialized in the parse function, to be used during the command line analysis.*) +let default_html_generator = ref (None : doc_generator option) + +(** The default latex generator. Initialized in the parse function, to be used during the command line analysis.*) +let default_latex_generator = ref (None : doc_generator option) + +(** The default man pages generator. Initialized in the parse function, to be used during the command line analysis.*) +let default_man_generator = ref (None : doc_generator option) + +(** The default iso check generator. Initialized in the parse function, to be used during the command line analysis.*) +let default_iso_generator = ref (None : doc_generator option) + +(** The default dot generator. Initialized in the parse function, to be used during the command line analysis.*) +let default_dot_generator = ref (None : doc_generator option) + +(** The default option list *) +let options = ref [ + "-version", Arg.Unit (fun () -> print_string Odoc_messages.message_version ; print_newline () ; exit 0) , Odoc_messages.option_version ; + "-v", Arg.Unit (fun () -> verbose := true), Odoc_messages.verbose_mode ; + "-I", Arg.String (fun s -> include_dirs := (Misc.expand_directory Config.standard_library s) :: !include_dirs), Odoc_messages.include_dirs ; + "-pp", Arg.String (fun s -> preprocessor := Some s), Odoc_messages.preprocess ; + "-rectypes", Arg.Set recursive_types, Odoc_messages.rectypes ; + "-nolabels", Arg.Unit (fun () -> classic := true), Odoc_messages.nolabels ; + "-warn-error", Arg.Set Odoc_global.warn_error, Odoc_messages.werr ; + "-d", Arg.String (fun s -> target_dir := s), Odoc_messages.target_dir ; + "-sort", Arg.Unit (fun () -> sort_modules := true), Odoc_messages.sort_modules ; + "-no-stop", Arg.Set no_stop, Odoc_messages.no_stop ; + "-no-custom-tags", Arg.Set no_custom_tags, Odoc_messages.no_custom_tags ; + "-stars", Arg.Set remove_stars, Odoc_messages.remove_stars ; + "-inv-merge-ml-mli", Arg.Set inverse_merge_ml_mli, Odoc_messages.inverse_merge_ml_mli ; + "-keep-code", Arg.Set keep_code, Odoc_messages.keep_code^"\n" ; + + "-dump", Arg.String (fun s -> dump := Some s), Odoc_messages.dump ; + "-load", Arg.String (fun s -> load := !load @ [s]), Odoc_messages.load^"\n" ; + + "-t", Arg.String (fun s -> title := Some s), Odoc_messages.option_title ; + "-hide", Arg.String add_hidden_modules, Odoc_messages.hide_modules ; + "-m", Arg.String (fun s -> merge_options := !merge_options @ (analyse_merge_options s)), Odoc_messages.merge_options^"\n" ; + +(* generators *) + "-html", Arg.Unit (fun () -> set_doc_generator !default_html_generator), Odoc_messages.generate_html ; + "-latex", Arg.Unit (fun () -> set_doc_generator !default_latex_generator), Odoc_messages.generate_latex ; + "-man", Arg.Unit (fun () -> set_doc_generator !default_man_generator), Odoc_messages.generate_man ; + "-iso", Arg.Unit (fun () -> set_doc_generator !default_iso_generator), Odoc_messages.generate_iso ; + "-dot", Arg.Unit (fun () -> set_doc_generator !default_dot_generator), Odoc_messages.generate_dot ; + "-g", Arg.String (fun s -> ()), Odoc_messages.load_file^"\n" ; + + +(* html only options *) + "-all-params", Arg.Set with_parameter_list, Odoc_messages.with_parameter_list ; + "-css-style", Arg.String (fun s -> css_style := Some s), Odoc_messages.css_style ; + "-index-only", Arg.Set index_only, Odoc_messages.index_only ; + "-colorize-code", Arg.Set colorize_code, Odoc_messages.colorize_code^"\n" ; + +(* latex only options *) + "-noheader", Arg.Unit (fun () -> with_header := false), Odoc_messages.no_header ; + "-notrailer", Arg.Unit (fun () -> with_trailer := false), Odoc_messages.no_trailer ; + "-sepfiles", Arg.Set separate_files, Odoc_messages.separate_files ; + "-latextitle", Arg.String f_latex_title, Odoc_messages.latex_title latex_titles ; + "-notoc", Arg.Unit (fun () -> with_toc := false), Odoc_messages.no_toc^"\n" ; + +(* iso only options *) + "-iso-val", Arg.String (fun s -> iso_val_options := analyse_iso_checks s), Odoc_messages.iso_val_met_att_options ; + "-iso-cl", Arg.String (fun s -> iso_class_options := analyse_iso_checks s), Odoc_messages.iso_class_options ; + "-iso-mod", Arg.String (fun s -> iso_module_options := analyse_iso_checks s), Odoc_messages.iso_module_options ; + "-iso-ex", Arg.String (fun s -> iso_exception_options := analyse_iso_checks s), Odoc_messages.iso_exception_options ; + "-iso-ty", Arg.String (fun s -> iso_type_options := analyse_iso_checks s), Odoc_messages.iso_type_options^"\n" ; + +(* dot only options *) + "-dot-file", Arg.String (fun s -> dot_file := s), Odoc_messages.dot_file ; + "-dot-colors", Arg.String (fun s -> dot_colors := Str.split (Str.regexp_string ",") s), Odoc_messages.dot_colors ; + "-dot-include-all", Arg.Set dot_include_all, Odoc_messages.dot_include_all ; + "-dot-types", Arg.Set dot_types, Odoc_messages.dot_types ; + "-dot-reduce", Arg.Set dot_reduce, Odoc_messages.dot_reduce ; + +] + +let add_option o = options := !options @ [o] + +let parse ~html_generator ~latex_generator ~man_generator ~iso_generator ~dot_generator = + default_html_generator := Some html_generator ; + default_latex_generator := Some latex_generator ; + default_man_generator := Some man_generator ; + default_iso_generator := Some iso_generator ; + default_dot_generator := Some dot_generator ; + let _ = Arg.parse !options + (fun s -> files := !files @ [s]) + (Odoc_messages.usage^Odoc_messages.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.*) + hidden_modules := List.sort (fun a -> fun b -> - (compare a b)) !hidden_modules + + diff --git a/ocamldoc/odoc_args.mli b/ocamldoc/odoc_args.mli new file mode 100644 index 000000000..f66b8c662 --- /dev/null +++ b/ocamldoc/odoc_args.mli @@ -0,0 +1,142 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + +(** Analysis of the command line arguments. *) + +(** The include_dirs in the OCaml compiler. *) +val include_dirs : string list ref + +(** The class type of documentation generators. *) +class type doc_generator = + object method generate : Odoc_module.t_module list -> unit end + +(** The function to be used to create a generator. *) +val doc_generator : doc_generator option ref + +(** The merge options to be used. *) +val merge_options : Odoc_types.merge_option list ref + +(** The iso checks to perform on each type. *) +val iso_type_options : Odoc_types.iso_check list ref + +(** The iso checks to perform on each value / method / attribute. *) +val iso_val_options : Odoc_types.iso_check list ref + +(** The iso checks to perform on each exception. *) +val iso_exception_options : Odoc_types.iso_check list ref + +(** The iso checks to perform on each class and class type. *) +val iso_class_options : Odoc_types.iso_check list ref + +(** The iso checks to perform on each module and module type. *) +val iso_module_options : Odoc_types.iso_check 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 + +(** Verbose mode or not. *) +val verbose : bool 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 + +(** The optional title to use in the generated documentation. *) +val title : string option ref + +(** Flag to indicate whether we must display the complete list of parameters + for functions and methods. *) +val with_parameter_list : bool ref + +(** The list of module names to hide. *) +val hidden_modules : string list ref + +(** The directory where files have to be generated. *) +val target_dir : string ref + +(** An optional file to use where a CSS style is defined (for HTML). *) +val css_style : string option ref + +(** Generate only index files. (for HTML). *) +val index_only : bool ref + +(** To colorize code in HTML generated documentation pages, not code pages. *) +val colorize_code : bool ref + +(** The flag which indicates if we must generate a header (for LaTeX). *) +val with_header : bool ref + +(** The flag which indicates if we must generate a trailer (for LaTeX). *) +val with_trailer : bool ref + +(** The flag to indicate if we must generate one file per module (for LaTeX). *) +val separate_files : bool ref + +(** The list of pairs (title level, sectionning style). *) +val latex_titles : (int * string) list ref + +(** The flag which indicates if we must generate a table of contents (for LaTeX). *) +val with_toc : bool ref + +(** The file used byt the dot generator. *) +val dot_file : string ref + +(** Include all modules or only the ones on the command line, for the dot ouput. *) +val dot_include_all : bool ref + +(** Generate dependency graph for types. *) +val dot_types : bool ref + +(** Perform transitive reduction before dot output. *) +val dot_reduce : bool ref + +(** The colors used in the dot output. *) +val dot_colors : string list ref + +(** The files to be analysed. *) +val files : string list ref + +(** To set the documentation generator. *) +val set_doc_generator : doc_generator option -> unit + +(** Add an option specification. *) +val add_option : string * Arg.spec * string -> unit + +(** Parse the args. *) +val parse : + html_generator:doc_generator -> + latex_generator:doc_generator -> + man_generator:doc_generator -> + iso_generator:doc_generator -> + dot_generator:doc_generator -> + unit + diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml new file mode 100644 index 000000000..46dea6501 --- /dev/null +++ b/ocamldoc/odoc_ast.ml @@ -0,0 +1,1522 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + +(** 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. *) +module Typedtree_search = + struct + let search_module typedtree name = + let rec iter = function + [] -> raise Not_found + | (Typedtree.Tstr_module (ident, module_expr)) :: q when + (Name.from_ident ident) = name -> + module_expr + | _ :: q -> + iter q + in + iter typedtree + + let search_module_type typedtree name = + let rec iter = function + [] -> raise Not_found + | (Typedtree.Tstr_modtype (ident, module_type)) :: q when + (Name.from_ident ident) = name -> + module_type + | _ :: q -> + iter q + in + iter typedtree + + let search_exception typedtree name = + let rec iter = function + [] -> raise Not_found + | (Typedtree.Tstr_exception (ident, excep_decl)) :: q when + (Name.from_ident ident) = name -> + excep_decl + | _ :: q -> + iter q + in + iter typedtree + + let search_exception_rebind typedtree name = + let rec iter = function + [] -> raise Not_found + | (Typedtree.Tstr_exn_rebind (ident, p)) :: q when + (Name.from_ident ident) = name -> + p + | _ :: q -> + iter q + in + iter typedtree + + let search_type_declaration typedtree name = + let rec iter = function + [] -> raise Not_found + | (Typedtree.Tstr_type ident_type_decl_list) :: q -> + ( + try + snd (List.find + (fun (id, _) -> Name.from_ident id = name) + ident_type_decl_list) + with + Not_found -> + iter q + ) + | _ :: q -> + iter q + in + iter typedtree + + let search_class_exp typedtree name = + let rec iter = function + [] -> raise Not_found + | (Typedtree.Tstr_class info_list) :: q -> + ( + try + let (_,_,_,ce) = (List.find + (fun (id, _, _, class_expr) -> Name.from_ident id = name) + info_list) + in + (* We look for the type artificially created for the class, + to get the list of type parameters. *) + try + let type_decl = search_type_declaration typedtree name in + (ce, type_decl.Types.type_params) + with + Not_found -> + (ce, []) + with + Not_found -> + iter q + ) + | _ :: q -> + iter q + in + iter typedtree + + let search_class_type_declaration typedtree name = + let rec iter = function + [] -> raise Not_found + | (Typedtree.Tstr_cltype info_list) :: q -> + ( + try + let (_, cltype_decl) = (List.find + (fun (id, clty_d) -> Name.from_ident id = name) + info_list) + in + cltype_decl + with + Not_found -> + iter q + ) + | _ :: q -> + iter q + in + iter typedtree + + let search_value typedtree name = + let rec iter_pat = 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 + in + let pred (pat, _) = + match iter_pat pat.Typedtree.pat_desc with + | Some n when n = name -> true + | _ -> false + in + let rec iter = function + [] -> + raise Not_found + | item :: q -> + match item with + Tstr_value (_, pat_exp_list) -> + ( + try + List.find pred pat_exp_list + with + Not_found -> + iter q + ) + | _ -> + iter q + in + iter typedtree + + let search_primitive typedtree name = + let rec iter = function + [] -> + raise Not_found + | item :: q -> + match item with + Tstr_primitive (ident, val_desc) -> + ( + if Name.from_ident ident = name then + val_desc.Types.val_type + else + iter q + ) + | _ -> + iter q + in + iter typedtree + + 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, exp) :: q + when Name.from_ident ident = name -> + exp.Typedtree.exp_type + | _ :: q -> + iter q + in + iter cls.Typedtree.cl_field + + 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 prarameter 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 *) + 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 paramčtre optionnel avec valeur par défaut."; + (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 loc.Location.loc_end) ; + val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start) ; 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 loc.Location.loc_end) ; + val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start) ; 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 converts a Types.type_kind into a Odoc_type.type_kind, + by analysing the comment of each constructor/field, if any. + @param pos_start is the start position of the type definition. + @param pos_end is the end position of the type definition. + @param pos_limit is the position of the last character which can be + used for a comment, for the variant types, where [pos_end] is not enough + since we can have comments after this position. + @return the type kind and the position of the last used character, + that is the end position of the last character of the comment + for the last constructor, if the type is a variant. If the type is + not a variant, then the last position is the [pos_end] parameter. + *) + let tt_get_type_kind env pos_start pos_end pos_limit type_kind = + match type_kind with + Types.Type_abstract -> + (Odoc_type.Type_abstract, pos_end) + + | Types.Type_variant l (*(string * type_expr list) list*) -> + let rec f acc last_pos l = + match l with + [] -> + (acc, last_pos) + | (constructor_name, type_expr_list) :: q -> + (* we don't have location info, so we try to + get it by searching for regexp "constructor_name(blank)*(of)?" from the + last location. *) + let loc_start = + try Str.search_forward (Str.regexp (constructor_name^blank^"*\\(of\\)?")) !file last_pos + with + Not_found -> + print_DEBUG3 (constructor_name^blank^"*\\(of\\)? n'a rien donné."); + last_pos + in + let loc_end = + match q with + [] -> pos_limit + | (constructor_name2, type_expr_list2) :: _ -> + try Str.search_forward (Str.regexp ("|"^blank^"*"^constructor_name2^blank^"*\\(of\\)?")) !file loc_start + with + Not_found -> + print_DEBUG3 (blank^"+|"^constructor_name2^blank^"*\\(of\\)? n'a rien donné."); + loc_start + in + (* get the comment *) + let s = get_string_of_file loc_start loc_end in + let (len, info_opt) = My_ir.just_after_special !file_name s in + let new_acc = + acc @ [ + { + vc_name = constructor_name ; + vc_args = List.map (Odoc_env.subst_type env) type_expr_list ; + vc_text = + (match info_opt with + None -> + print_DEBUG3 ("Pas de description pour le constructeur "^constructor_name); + None + | Some d -> + d.Odoc_types.i_desc) + } + ] + in + f new_acc (loc_start + len) q + in + let (l_cons, new_last_pos) = f [] pos_start l in + (Odoc_type.Type_variant l_cons, new_last_pos) + + | Types.Type_record (l, _) -> + (*(string * mutable_flag * type_expr) list * record_representation *) + let rec f acc last_pos l = + match l with + [] -> + acc + | (field_name, mutable_flag, type_expr) :: q -> + (* we don't have location info, so we try to + get it by searching for regexp "(mutable)?blank*field_name(blank)*:" from the + last location. *) + let loc_start = + ( + let regexp = "\\(mutable\\)?"^blank^"*"^field_name^blank^"*:" in + try + Str.search_forward (Str.regexp regexp) !file last_pos + with Not_found -> + print_DEBUG3 (regexp^" n'a rien donné."); + last_pos + ) + in + let loc_end = + match q with + [] -> pos_end + | (field_name2, mutable_flag2, type_expr2) :: _ -> + let regexp = "\\(mutable\\)?"^blank^"*"^field_name2^blank^"*:" in + try + Str.search_forward (Str.regexp regexp) !file loc_start + with Not_found -> + print_DEBUG3 (regexp^" n'a rien donné."); + loc_start + in + (* get the comment *) + let s = get_string_of_file loc_start loc_end in + let (len, info_opt) = My_ir.just_after_special !file_name s in + let new_acc = + acc @ [ + { + rf_name = field_name ; + rf_mutable = mutable_flag = Mutable ; + rf_type = Odoc_env.subst_type env type_expr ; + rf_text = + (match info_opt with + None -> + print_DEBUG3 ("Pas de description pour le champ "^field_name); + None + | Some d -> + d.Odoc_types.i_desc) + } + ] + in + f new_acc (loc_start + len) q + in + (Odoc_type.Type_record (f [] pos_start l), pos_end) + + + (** 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 + 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 *) + raise (Failure "") + | (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 paramčtre optionnel avec valeur par défaut."; + (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 = + 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 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 + q + + | (Parsetree.Pcf_val (label, mutable_flag, expression, 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 in + let type_exp = + try 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 loc.Location.loc_end) ; + val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start) ; loc_inter = None } ; + } ; + att_mutable = mutable_flag = Asttypes.Mutable ; + } + in + iter acc_inher (acc_fields @ ele_comments @ [ Class_attribute att ]) loc.Location.loc_end 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 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 loc.Location.loc_end) ; + val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start) ; 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 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 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 loc.Location.loc_end) ; + val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start) ; 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 q + + | Parsetree.Pcf_cstr (_, _, loc) :: q -> + (* don't give a $*%@ ! *) + iter acc_inher acc_fields loc.Location.loc_end q + + | Parsetree.Pcf_let (_, _, loc) :: q -> + (* don't give a $*%@ ! *) + iter acc_inher acc_fields loc.Location.loc_end q + + | (Parsetree.Pcf_init exp) :: q -> + iter acc_inher acc_fields exp.Parsetree.pexp_loc.Location.loc_end 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 = + 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 + p_class_structure + tt_class_structure + 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 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 + e.exp_loc.Location.loc_end) + 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 + + | (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 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 + 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 = + 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 in + let type_parameters = tt_type_params in + let virt = p_class_decl.Parsetree.pci_virt = Asttypes.Virtual in + let cltype = 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 + 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 _ -> + 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 ; + } + ] + | _ -> + 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) :: (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) + + (** 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 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 + in + let pos_limit2 = + match q with + [] -> pos_limit + | item2 :: _ -> item2.Parsetree.pstr_loc.Location.loc_start + 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 + in + ele_comments @ elements @ (iter new_env (item.Parsetree.pstr_loc.Location.loc_end + 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 = + 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 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 typedtree 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 + 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 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 typedtree 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 loc.Location.loc_end) ; + val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start) ; 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 in + let loc_end = type_decl.Parsetree.ptype_loc.Location.loc_end in + let pos_limit2 = + match q with + [] -> pos_limit + | (_, td) :: _ -> td.Parsetree.ptype_loc.Location.loc_start + in + let tt_type_decl = + try Typedtree_search.search_type_declaration typedtree 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, last_pos2) = tt_get_type_kind + new_env + loc_start + loc_end + pos_limit2 + tt_type_decl.Types.type_kind + in + let t = + { + ty_name = complete_name ; + ty_info = com_opt ; + ty_parameters = List.map + (Odoc_env.subst_type new_env) + tt_type_decl.Types.type_params ; + ty_kind = kind ; + 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 } ; + } + in + let (maybe_more, eles) = f (last_pos2 -loc_end) last_pos2 q in + (maybe_more, ele_comments @ ((Element_type t) :: eles)) + in + let (maybe_more, eles) = f ~first: true 0 loc.Location.loc_start 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 typedtree 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 = 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) ; loc_inter = 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 typedtree 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) ; loc_inter = 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 typedtree name in + let new_module = analyse_module + env + current_module_name + name + comment_opt + module_expr + tt_module_expr + 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 *) + Some (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_modtype (name, modtype) -> + let complete_name = Name.concat current_module_name name in + let tt_module_type = + try Typedtree_search.search_module_type typedtree 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) ; 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 typedtree 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 + in + let last_pos2 = class_decl.Parsetree.pci_loc.Location.loc_end in + let new_class = analyse_class + new_env + current_module_name + com_opt + class_decl + tt_type_params + tt_class_exp + in + ele_comments @ ((Element_class new_class) :: (f last_pos2 q)) + in + (0, new_env, f ~first: true loc.Location.loc_start 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 typedtree 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 + 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 + in + let last_pos2 = class_type_decl.Parsetree.pci_loc.Location.loc_end in + let new_ele = + Element_class_type + { + clt_name = complete_name ; + clt_info = com_opt ; + clt_type = 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) ; + loc_inter = None } ; + } + in + ele_comments @ (new_ele :: (f last_pos2 q)) + in + (0, new_env, f ~first: true loc.Location.loc_start 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 ; + } + 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 in + let pos_end = p_module_expr.Parsetree.pmod_loc.Location.loc_end in + let modtype = tt_module_expr.Typedtree.mod_type in + let m_base = + { + m_name = complete_name ; + m_type = Some tt_module_expr.Typedtree.mod_type ; + 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 = [] ; + } + 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 (_, _, p_module_expr2), + Typedtree.Tmod_functor (ident, mtyp, tt_module_expr2)) -> + let param = + { + mp_name = Name.from_ident ident ; + mp_type = Odoc_env.subst_module_type env mtyp ; + } + in + let dummy_complete_name = Name.concat "__" param.mp_name in + 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 = + match m_base2.m_kind with + Module_functor (params, k) -> Module_functor (param :: params, m_base2.m_kind) + | k -> Module_functor ([param], k) + in + { m_base with m_kind = kind } + + | (Parsetree.Pmod_apply (p_module_expr1, p_module_expr2), + 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, _)) -> + (* we create the module with p_module_expr2 and tt_module_expr2 + but we change its type according to the constraint. + A VOIR : est-ce que c'est bien ? + *) + 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 + { + m_base with + m_type = Some tt_modtype ; + m_kind = Module_constraint (m_base2.m_kind, + mtkind) + +(* Module_type_alias { mta_name = "Not analyzed" ; + mta_module = None }) +*) + } + + | _ -> + 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 + let kind = Module_struct + (analyse_structure Odoc_env.empty mod_name len (String.length !file) parsetree tree_structure) + in + let m = + { + m_name = mod_name ; + m_type = None ; + 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 = [] ; + } + in + m + end + + + diff --git a/ocamldoc/odoc_ast.mli b/ocamldoc/odoc_ast.mli new file mode 100644 index 000000000..b4561b9a9 --- /dev/null +++ b/ocamldoc/odoc_ast.mli @@ -0,0 +1,105 @@ +(***********************************************************************) +(* 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 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 + (** This function returns the [Typedtree.module_expr] associated to the given module name, + in the given typed tree. + @raise Not_found if the module was not found.*) + val search_module : + Typedtree.structure_item list -> string -> Typedtree.module_expr + + (** This function returns the [Types.module_type] associated to the given module type name, + in the given typed tree. + @raise Not_found if the module type was not found.*) + val search_module_type : + Typedtree.structure_item list -> string -> Types.module_type + + (** This function returns the [Types.exception_declaration] associated to the given exception name, + in the given typed tree. + @raise Not_found if the exception was not found.*) + val search_exception : + Typedtree.structure_item list -> string -> Types.exception_declaration + + (** This function returns the [Path.t] associated to the given exception rebind name, + in the given typed tree. + @raise Not_found if the exception rebind was not found.*) + val search_exception_rebind : + Typedtree.structure_item list -> string -> Path.t + + (** This function returns the [Typedtree.type_declaration] associated to the given type name, + in the given typed tree. + @raise Not_found if the type was not found. *) + val search_type_declaration : + Typedtree.structure_item list -> string -> Types.type_declaration + + (** This function returns the [Typedtree.class_expr] and type parameters + associated to the given class name, in the given typed tree. + @raise Not_found if the class was not found. *) + val search_class_exp : + Typedtree.structure_item list -> 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 typed tree. + @raise Not_found if the class type was not found. *) + val search_class_type_declaration : + Typedtree.structure_item list -> string -> Types.cltype_declaration + + (** This function returns the couple (pat, exp) for the given value name, in the + given typed tree. + @raise Not found if no value matches the name.*) + val search_value : + Typedtree.structure_item list -> + string -> Typedtree.pattern * Typedtree.expression + + (** This function returns the [type_expr] for the given primitive name, in the + given typed tree. + @raise Not found if no value matches the name.*) + val search_primitive : + Typedtree.structure_item list -> 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/ocamldoc/odoc_class.ml b/ocamldoc/odoc_class.ml new file mode 100644 index 000000000..1826eaddb --- /dev/null +++ b/ocamldoc/odoc_class.ml @@ -0,0 +1,250 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + +(** 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 exprssions *) + } + +and class_constr = { + cco_name : Name.t ; (** The complete name of the applied class *) + mutable cco_class : t_class option; (** The associated t_class 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 c when trans -> class_elements ~trans: trans c + | _ -> [] + ) + 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 + + diff --git a/ocamldoc/odoc_comments.ml b/ocamldoc/odoc_comments.ml new file mode 100644 index 000000000..b1192bcbd --- /dev/null +++ b/ocamldoc/odoc_comments.ml @@ -0,0 +1,306 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + +(** 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_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 + let pos = Str.search_forward (Str.regexp_string "(**") s 0 in + if blank_line (String.sub s 0 pos) 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, then the + last special comments must be associated to the element. *) + if blank_line_outside_simple file + (String.sub s len ((String.length s) - len)) + then + (None, special_coms) + else + match List.rev special_coms with + [] -> + (None, []) + | h :: q -> + (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) diff --git a/ocamldoc/odoc_comments.mli b/ocamldoc/odoc_comments.mli new file mode 100644 index 000000000..50e891cdc --- /dev/null +++ b/ocamldoc/odoc_comments.mli @@ -0,0 +1,56 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + +(** 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 diff --git a/ocamldoc/odoc_comments_global.ml b/ocamldoc/odoc_comments_global.ml new file mode 100644 index 000000000..e2149bcef --- /dev/null +++ b/ocamldoc/odoc_comments_global.ml @@ -0,0 +1,46 @@ +(***********************************************************************) +(* 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 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 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; + deprecated := None; + params := []; + raised_exceptions := []; + return_value := None ; + customs := [] + diff --git a/ocamldoc/odoc_comments_global.mli b/ocamldoc/odoc_comments_global.mli new file mode 100644 index 000000000..69116d55d --- /dev/null +++ b/ocamldoc/odoc_comments_global.mli @@ -0,0 +1,46 @@ +(***********************************************************************) +(* 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 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 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/ocamldoc/odoc_control.ml b/ocamldoc/odoc_control.ml new file mode 100644 index 000000000..7519a782e --- /dev/null +++ b/ocamldoc/odoc_control.ml @@ -0,0 +1,13 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + + diff --git a/ocamldoc/odoc_cross.ml b/ocamldoc/odoc_cross.ml new file mode 100644 index 000000000..895a2e2c3 --- /dev/null +++ b/ocamldoc/odoc_cross.ml @@ -0,0 +1,735 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + +(** 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 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) + +let rec build_alias_list (acc_m, acc_mt, acc_ex) = function + [] -> + (acc_m, acc_mt, acc_ex) + | (Odoc_search.Res_module m) :: q -> + let new_acc_m = + match m.m_kind with + Module_alias ma -> (m.m_name, ma.ma_name) :: acc_m + | _ -> acc_m + in + build_alias_list (new_acc_m, acc_mt, acc_ex) q + | (Odoc_search.Res_module_type mt) :: q -> + let new_acc_mt = + match mt.mt_kind with + Some (Module_type_alias mta) -> (mt.mt_name, mta.mta_name) :: acc_mt + | _ -> acc_mt + in + build_alias_list (acc_m, new_acc_mt, acc_ex) q + | (Odoc_search.Res_exception e) :: q -> + let new_acc_ex = + match e.ex_alias with + None -> acc_ex + | Some ea -> (e.ex_name, ea.ea_name) :: acc_ex + in + build_alias_list (acc_m, acc_mt, new_acc_ex) q + | _ :: q -> + build_alias_list (acc_m, acc_mt, acc_ex) q + + + +(** Couples of module name aliases. *) +let module_aliases = ref [] ;; +(** Couples of module type name aliases. *) +let module_type_aliases = ref [] ;; +(** Couples of exception name aliases. *) +let exception_aliases = ref [] ;; + +(** Retrieve the aliases for modules, module types and exceptions and put them in global variables. *) +let get_alias_names module_list = + let (alias_m, alias_mt, alias_ex) = + build_alias_list + ([], [], []) + (Search_alias.search module_list 0) + in + module_aliases := alias_m ; + module_type_aliases := alias_mt ; + exception_aliases := alias_ex + + +(** The module with lookup predicates. *) +module P_lookup = + struct + type t = Name.t + let p_module m name = (Name.prefix m.m_name name, m.m_name = (Name.name_alias name !module_aliases)) + let p_module_type mt name = (Name.prefix mt.mt_name name, mt.mt_name = (Name.name_alias name (!module_aliases @ !module_type_aliases))) + let p_class c name = (false, c.cl_name = (Name.name_alias name (!module_aliases @ !module_type_aliases))) + let p_class_type ct name = (false, ct.clt_name = (Name.name_alias name (!module_aliases @ !module_type_aliases))) + let p_value v name = false + let p_type t name = false + let p_exception e name = e.ex_name = (Name.name_alias name !exception_aliases) + let p_attribute a name = false + let p_method m name = false + let p_section s name = false + end + +(** The module used to search by a complete name.*) +module Search_by_complete_name = Odoc_search.Search (P_lookup) + +let rec lookup_module module_list name = + let l = List.filter + (fun res -> + match res with + Odoc_search.Res_module _ -> true + | _ -> false + ) + (Search_by_complete_name.search module_list name) + in + match l with + (Odoc_search.Res_module m) :: _ -> m + | _ -> raise Not_found + +let rec lookup_module_type module_list name = + let l = List.filter + (fun res -> + match res with + Odoc_search.Res_module_type _ -> true + | _ -> false + ) + (Search_by_complete_name.search module_list name) + in + match l with + (Odoc_search.Res_module_type mt) :: _ -> mt + | _ -> raise Not_found + +let rec lookup_class module_list name = + let l = List.filter + (fun res -> + match res with + Odoc_search.Res_class _ -> true + | _ -> false + ) + (Search_by_complete_name.search module_list name) + in + match l with + (Odoc_search.Res_class c) :: _ -> c + | _ -> raise Not_found + +let rec lookup_class_type module_list name = + let l = List.filter + (fun res -> + match res with + Odoc_search.Res_class_type _ -> true + | _ -> false + ) + (Search_by_complete_name.search module_list name) + in + match l with + (Odoc_search.Res_class_type ct) :: _ -> ct + | _ -> raise Not_found + +let rec lookup_exception module_list name = + let l = List.filter + (fun res -> + match res with + Odoc_search.Res_exception _ -> true + | _ -> false + ) + (Search_by_complete_name.search module_list name) + in + match l with + (Odoc_search.Res_exception e) :: _ -> e + | _ -> raise Not_found + +(** 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 module_list ma.ma_name)) + with Not_found -> + try Some (Modtype (lookup_module_type module_list 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 } + 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 -> + match mta.mta_module with + Some _ -> + (acc_b, acc_inc, acc_names) + | None -> + let mt_opt = + try Some (lookup_module_type module_list 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) + 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 module_list im.im_name)) + with Not_found -> + try Some (Modtype (lookup_module_type module_list 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 module_list 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 module_list ic.ic_name)) + with Not_found -> + try Some (Cltype (lookup_class_type module_list 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 module_list 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 module_list cco.cco_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 cco.cco_name = Odoc_messages.object_end then acc_names else (NF_c cco.cco_name) :: acc_names)) + | Some c -> + cco.cco_class <- Some 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 module_list ic.ic_name, [])) + with Not_found -> + try Some (Cl (lookup_class module_list 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 module_list cta.cta_name, [])) + with Not_found -> + try Some (Cl (lookup_class module_list 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 rec assoc_comments_text_elements module_list t_ele = + match t_ele with + | Raw _ + | Code _ + | CodePre _ + | Latex _ + | Verbatim _ + | Ref (_, Some _) -> t_ele + | Bold t -> Bold (assoc_comments_text module_list t) + | Italic t -> Italic (assoc_comments_text module_list t) + | Center t -> Center (assoc_comments_text module_list t) + | Left t -> Left (assoc_comments_text module_list t) + | Right t -> Right (assoc_comments_text module_list t) + | Emphasize t -> Emphasize (assoc_comments_text module_list t) + | List l -> List (List.map (assoc_comments_text module_list) l) + | Enum l -> Enum (List.map (assoc_comments_text module_list) l) + | Newline -> Newline + | Block t -> Block (assoc_comments_text module_list t) + | Superscript t -> Superscript (assoc_comments_text module_list t) + | Subscript t -> Subscript (assoc_comments_text module_list t) + | Title (n, l_opt, t) -> Title (n, l_opt, (assoc_comments_text module_list t)) + | Link (s, t) -> Link (s, (assoc_comments_text module_list t)) + | Ref (name, None) -> + let re = Str.regexp ("^"^(Str.quote name)^"$") in + let res = Odoc_search.Search_by_name.search module_list re in + match res with + [] -> + Odoc_messages.pwarning (Odoc_messages.cross_element_not_found name); + t_ele + | ele :: _ -> + let kind = + match ele with + Odoc_search.Res_module _ -> RK_module + | Odoc_search.Res_module_type _ -> RK_module_type + | Odoc_search.Res_class _ -> RK_class + | Odoc_search.Res_class_type _ -> RK_class_type + | Odoc_search.Res_value _ -> RK_value + | Odoc_search.Res_type _ -> RK_type + | Odoc_search.Res_exception _ -> RK_exception + | Odoc_search.Res_attribute _ -> RK_attribute + | Odoc_search.Res_method _ -> RK_method + | Odoc_search.Res_section _ -> RK_section + in + Ref (name, Some kind) + +and assoc_comments_text module_list text = + List.map (assoc_comments_text_elements module_list) text + +and assoc_comments_info module_list i = + let ft = assoc_comments_text 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 + } + + +let rec assoc_comments_module_element 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 module_list t) + +and assoc_comments_class_element 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 module_list t) + +and assoc_comments_module_kind module_list mk = + match mk with + | Module_struct eles -> + Module_struct (List.map (assoc_comments_module_element module_list) eles) + | Module_alias _ + | Module_functor _ -> + mk + | Module_apply (mk1, mk2) -> + Module_apply (assoc_comments_module_kind module_list mk1, + assoc_comments_module_kind module_list mk2) + | Module_with (mtk, s) -> + Module_with (assoc_comments_module_type_kind module_list mtk, s) + | Module_constraint (mk1, mtk) -> + Module_constraint (assoc_comments_module_kind module_list mk1, + assoc_comments_module_type_kind module_list mtk) + +and assoc_comments_module_type_kind module_list mtk = + match mtk with + | Module_type_struct eles -> + Module_type_struct (List.map (assoc_comments_module_element module_list) eles) + | Module_type_functor (params, mtk1) -> + Module_type_functor (params, assoc_comments_module_type_kind module_list mtk1) + | Module_type_alias _ -> + mtk + | Module_type_with (mtk1, s) -> + Module_type_with (assoc_comments_module_type_kind module_list mtk1, s) + +and assoc_comments_class_kind module_list ck = + match ck with + Class_structure (inher, eles) -> + let inher2 = + List.map + (fun ic -> { ic with + ic_text = ao (assoc_comments_text module_list) ic.ic_text }) + inher + in + Class_structure (inher2, List.map (assoc_comments_class_element module_list) eles) + + | Class_apply _ + | Class_constr _ -> ck + | Class_constraint (ck1, ctk) -> + Class_constraint (assoc_comments_class_kind module_list ck1, + assoc_comments_class_type_kind module_list ctk) + +and assoc_comments_class_type_kind module_list ctk = + match ctk with + Class_signature (inher, eles) -> + let inher2 = + List.map + (fun ic -> { ic with + ic_text = ao (assoc_comments_text module_list) ic.ic_text }) + inher + in + Class_signature (inher2, List.map (assoc_comments_class_element module_list) eles) + + | Class_type _ -> ctk + + +and assoc_comments_module module_list m = + m.m_info <- ao (assoc_comments_info module_list) m.m_info ; + m.m_kind <- assoc_comments_module_kind module_list m.m_kind ; + m + +and assoc_comments_module_type module_list mt = + mt.mt_info <- ao (assoc_comments_info module_list) mt.mt_info ; + mt.mt_kind <- ao (assoc_comments_module_type_kind module_list) mt.mt_kind ; + mt + +and assoc_comments_class module_list c = + c.cl_info <- ao (assoc_comments_info module_list) c.cl_info ; + c.cl_kind <- assoc_comments_class_kind module_list c.cl_kind ; + assoc_comments_parameter_list module_list c.cl_parameters; + c + +and assoc_comments_class_type module_list ct = + ct.clt_info <- ao (assoc_comments_info module_list) ct.clt_info ; + ct.clt_kind <- assoc_comments_class_type_kind module_list ct.clt_kind ; + ct + +and assoc_comments_parameter module_list p = + match p with + Simple_name sn -> + sn.sn_text <- ao (assoc_comments_text module_list) sn.sn_text + | Tuple (l, t) -> + List.iter (assoc_comments_parameter module_list) l + +and assoc_comments_parameter_list module_list pl = + List.iter (assoc_comments_parameter module_list) pl + +and assoc_comments_value module_list v = + v.val_info <- ao (assoc_comments_info module_list) v.val_info ; + assoc_comments_parameter_list module_list v.val_parameters; + v + +and assoc_comments_exception module_list e = + e.ex_info <- ao (assoc_comments_info module_list) e.ex_info ; + e + +and assoc_comments_type module_list t = + t.ty_info <- ao (assoc_comments_info 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 module_list) vc.vc_text) + vl + | Type_record fl -> + List.iter + (fun rf -> rf.rf_text <- ao (assoc_comments_text 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 _ = assoc_comments_value module_list m.met_value in + assoc_comments_parameter_list 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 ; + 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' 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_messages.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. *) + let _ = associate_type_of_elements_in_comments module_list in + () + diff --git a/ocamldoc/odoc_cross.mli b/ocamldoc/odoc_cross.mli new file mode 100644 index 000000000..d4c1d5ccc --- /dev/null +++ b/ocamldoc/odoc_cross.mli @@ -0,0 +1,16 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + +(** Cross-referencing. *) + +val associate : Odoc_module.t_module list -> unit + diff --git a/ocamldoc/odoc_dag2html.ml b/ocamldoc/odoc_dag2html.ml new file mode 100644 index 000000000..7ddf4d57c --- /dev/null +++ b/ocamldoc/odoc_dag2html.ml @@ -0,0 +1,1755 @@ +(***********************************************************************) +(* 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 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 jlast = Array.length t.table.(0) - 1 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 print_indi n = print_string n.valu in + 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/ocamldoc/odoc_dag2html.mli b/ocamldoc/odoc_dag2html.mli new file mode 100644 index 000000000..96d44affa --- /dev/null +++ b/ocamldoc/odoc_dag2html.mli @@ -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. *) +(* *) +(***********************************************************************) + + +(** 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/ocamldoc/odoc_dep.ml b/ocamldoc/odoc_dep.ml new file mode 100644 index 000000000..ad8d94f4c --- /dev/null +++ b/ocamldoc/odoc_dep.ml @@ -0,0 +1,223 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(** Top modules dependencies. *) + +module StrS = Depend.StringSet +module Module = Odoc_module +module Type = Odoc_type + +let dummy_loc = { + Location.loc_start = 0; + Location.loc_end = 1 ; + Location.loc_ghost = true +} + +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_misc.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_misc.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_misc.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/ocamldoc/odoc_dot.ml b/ocamldoc/odoc_dot.ml new file mode 100644 index 000000000..3fb0dd728 --- /dev/null +++ b/ocamldoc/odoc_dot.ml @@ -0,0 +1,130 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(** Definition of a class which outputs a dot file showing + top modules dependencies.*) + +module Name = Odoc_info.Name +module Module = Odoc_info.Module +module Type = Odoc_info.Type + +module F = Format + +(** 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 = !Odoc_args.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 -> + !Odoc_args.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 !Odoc_args.dot_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: !Odoc_args.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 !Odoc_args.dot_file in + let fmt = F.formatter_of_out_channel oc in + F.fprintf fmt "%s" self#header; + + if !Odoc_args.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_args.dot_file}. *) + method generate (modules_list : Odoc_info.Module.t_module list) = + if !Odoc_args.dot_types then + self#generate_types (Odoc_info.Search.types modules_list) + else + self#generate_modules modules_list + end diff --git a/ocamldoc/odoc_env.ml b/ocamldoc/odoc_env.ml new file mode 100644 index 000000000..d492af985 --- /dev/null +++ b/ocamldoc/odoc_env.ml @@ -0,0 +1,271 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + +(** 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 subst_type env t = +(** print_string "Odoc_env.subst_type"; + print_newline (); +*) + Printtyp.mark_loops t; + let rec iter deja_vu t = + let (new_desc, new_deja_vu) = + if List.memq t deja_vu then + (t.Types.desc, deja_vu) + else + let dv = t :: deja_vu in + match t.Types.desc with + | Types.Tvar -> + (Types.Tvar, dv) + + | Types.Tarrow (l, t1, t2, c) -> + let (t1', dv1) = iter dv t1 in + let (t2', dv2) = iter dv1 t2 in + (Types.Tarrow (l, t1', t2', c), dv2) + + | Types.Ttuple l -> + let (l', dv') = + List.fold_left + (fun (acc_t, acc_dv) -> fun t -> + let (new_t, new_dv) = iter acc_dv t in + (acc_t @ [new_t], new_dv) + ) + ([], dv) + l + in + (Types.Ttuple l', dv') + + | Types.Tconstr (p, [ty], a) when Path.same p Predef.path_option -> + let (ty', dv') = iter dv ty in + (Types.Tconstr (p, [ty'], a), dv') + + | Types.Tconstr (p, l, a) -> + let new_p = Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in + let (l', dv') = + List.fold_left + (fun (acc_t, acc_dv) -> fun t -> + let (new_t, new_dv) = iter acc_dv t in + (acc_t @ [new_t], new_dv) + ) + ([], dv) + l + in + (Types.Tconstr (new_p, l', a), dv') + + | Types.Tobject (t2, r) -> + (* A VOIR : descendre dans r ? *) + let (t2', dv') = iter dv t2 in + (Types.Tobject (t2', r), dv') + + | Types.Tfield (s, fk, t1, t2) -> + let (t1', dv1) = iter dv t1 in + let (t2', dv2) = iter dv1 t2 in + (Types.Tfield (s, fk, t1', t2'), dv2) + + | Types.Tnil -> + (Types.Tnil, dv) + + | Types.Tlink t2 -> + let (t2', dv') = iter dv t2 in + (Types.Tlink t2', dv') + + | Types.Tsubst t2 -> + let (t2', dv') = iter dv t2 in + (Types.Tsubst t2', dv') + + | Types.Tvariant rd -> + (* A VOIR : est-ce la peine de descendre dans rd ? *) + (Types.Tvariant rd, dv) + in + t.Types.desc <- new_desc; + (t, new_deja_vu) + in + let (res, _) = iter [] t in +(** print_string "Odoc_env.subst_type fini"; + print_newline (); +*) + res + +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 + + + diff --git a/ocamldoc/odoc_env.mli b/ocamldoc/odoc_env.mli new file mode 100644 index 000000000..99b292b57 --- /dev/null +++ b/ocamldoc/odoc_env.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. *) +(* *) +(***********************************************************************) + + +(** 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 diff --git a/ocamldoc/odoc_exception.ml b/ocamldoc/odoc_exception.ml new file mode 100644 index 000000000..b5b41bf93 --- /dev/null +++ b/ocamldoc/odoc_exception.ml @@ -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. *) +(* *) +(***********************************************************************) + + +(** 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 ; + } + diff --git a/ocamldoc/odoc_global.ml b/ocamldoc/odoc_global.ml new file mode 100644 index 000000000..ded9b715b --- /dev/null +++ b/ocamldoc/odoc_global.ml @@ -0,0 +1,15 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + +let errors = ref 0 + +let warn_error = ref false diff --git a/ocamldoc/odoc_global.mli b/ocamldoc/odoc_global.mli new file mode 100644 index 000000000..30158f95f --- /dev/null +++ b/ocamldoc/odoc_global.mli @@ -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. *) +(* *) +(***********************************************************************) + +(** Global variables. *) + +(** A counter for errors. *) +val errors : int ref + +(** Indicate if a warning is an error. *) +val warn_error : bool ref diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml new file mode 100644 index 000000000..3b066eb7a --- /dev/null +++ b/ocamldoc/odoc_html.ml @@ -0,0 +1,1962 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + +(** 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 + + +(** 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 html_file = name^".html" in + let html_frame_file = name^"-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 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^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 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 + +(** A class with a method to colorize a string which represents OCaml code. *) +class ocaml_code = + object(self) + method html_of_code ?(with_pre=true) code = + let html_code = Odoc_ocamlhtml.html_of_code ~with_pre: with_pre code in + html_code + end + + +(** Generation of html code from text structures. *) +class 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 + + (** Return the html code corresponding to the [text] parameter. *) + method html_of_text t = String.concat "" (List.map self#html_of_text_element t) + + (** Return the html code for the [text_element] in parameter. *) + method html_of_text_element te = + print_DEBUG "text::html_of_text_element"; + match te with + | Odoc_info.Raw s -> self#html_of_Raw s + | Odoc_info.Code s -> self#html_of_Code s + | Odoc_info.CodePre s -> self#html_of_CodePre s + | Odoc_info.Verbatim s -> self#html_of_Verbatim s + | Odoc_info.Bold t -> self#html_of_Bold t + | Odoc_info.Italic t -> self#html_of_Italic t + | Odoc_info.Emphasize t -> self#html_of_Emphasize t + | Odoc_info.Center t -> self#html_of_Center t + | Odoc_info.Left t -> self#html_of_Left t + | Odoc_info.Right t -> self#html_of_Right t + | Odoc_info.List tl -> self#html_of_List tl + | Odoc_info.Enum tl -> self#html_of_Enum tl + | Odoc_info.Newline -> self#html_of_Newline + | Odoc_info.Block t -> self#html_of_Block t + | Odoc_info.Title (n, l_opt, t) -> self#html_of_Title n l_opt t + | Odoc_info.Latex s -> self#html_of_Latex s + | Odoc_info.Link (s, t) -> self#html_of_Link s t + | Odoc_info.Ref (name, ref_opt) -> self#html_of_Ref name ref_opt + | Odoc_info.Superscript t -> self#html_of_Superscript t + | Odoc_info.Subscript t -> self#html_of_Subscript t + + method html_of_Raw s = self#escape s + + method html_of_Code s = + if !Odoc_args.colorize_code then + self#html_of_code ~with_pre: false s + else + "<code class=\""^Odoc_ocamlhtml.code_class^"\">"^(self#escape s)^"</code>" + + method html_of_CodePre s = + if !Odoc_args.colorize_code then + self#html_of_code s + else + "<pre><code class=\""^Odoc_ocamlhtml.code_class^"\">"^(self#escape s)^"</code></pre>" + + method html_of_Verbatim s = "<pre>"^(self#escape s)^"</pre>" + method html_of_Bold t = "<b>"^(self#html_of_text t)^"</b>" + method html_of_Italic t = "<i>"^(self#html_of_text t)^"</i>" + method html_of_Emphasize t = "<em>"^(self#html_of_text t)^"</em>" + method html_of_Center t = "<center>"^(self#html_of_text t)^"</center>" + method html_of_Left t = "<div align=left>"^(self#html_of_text t)^"</div>" + method html_of_Right t = "<div align=right>"^(self#html_of_text t)^"</div>" + + method html_of_List tl = + "<ul>\n"^ + (String.concat "" + (List.map (fun t -> "<li>"^(self#html_of_text t)^"</li>\n") tl))^ + "</ul>\n" + + method html_of_Enum tl = + "<OL>\n"^ + (String.concat "" + (List.map (fun t -> "<li>"^(self#html_of_text t)^"</li>\n") tl))^ + "</OL>\n" + + method html_of_Newline = "\n<p>\n" + + method html_of_Block t = + "<blockquote>\n"^(self#html_of_text t)^"</blockquote>\n" + + method html_of_Title n label_opt t = + let css_class = "title"^(string_of_int n) in + "<br>\n"^ + ( + match label_opt with + None -> "" + | Some l -> "<a name=\""^(Naming.label_target l)^"\"></a>" + )^ + "<table cellpadding=0 cellspacing=0 width=\"100%\">\n"^ + "<tr class=\""^css_class^"\"><td><div align=center>\n"^ + "<table><tr class=\""^css_class^"\">\n"^ + "<td width=\"100%\" align=center>\n"^ + "<span class=\""^css_class^"\">"^(self#html_of_text t)^"</span>\n"^ + "</td>\n</tr>\n</table>\n</div>\n</td>\n</tr>\n</table>\n" + + method html_of_Latex _ = "" + (* don't care about LaTeX stuff in HTML. *) + + method html_of_Link s t = + "<a href=\""^s^"\">"^(self#html_of_text t)^"</a>" + + method html_of_Ref name ref_opt = + match ref_opt with + None -> + self#html_of_text_element (Odoc_info.Code name) + | Some kind -> + let target = + 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 + | Odoc_info.RK_value -> Naming.complete_target Naming.mark_value name + | Odoc_info.RK_type -> Naming.complete_target Naming.mark_type name + | Odoc_info.RK_exception -> Naming.complete_target Naming.mark_exception name + | Odoc_info.RK_attribute -> Naming.complete_target Naming.mark_attribute name + | Odoc_info.RK_method -> Naming.complete_target Naming.mark_method name + | Odoc_info.RK_section -> Naming.complete_label_target name + in + "<a href=\""^target^"\">"^ + (self#html_of_text_element (Odoc_info.Code (Odoc_info.use_hidden_modules name)))^"</a>" + + method html_of_Superscript t = + "<sup class=\"superscript\">"^(self#html_of_text t)^"</sup>" + + method html_of_Subscript t = + "<sub class=\"subscript\">"^(self#html_of_text t)^"</sub>" + + 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 : Odoc_info.text -> string + + (** Return html for an author list. *) + method html_of_author_list l = + match l with + [] -> + "" + | _ -> + "<b>"^Odoc_messages.authors^": </b>"^ + (String.concat ", " l)^ + "<br>\n" + + (** Return html code for the given optional version information.*) + method html_of_version_opt v_opt = + match v_opt with + None -> "" + | Some v -> "<b>"^Odoc_messages.version^": </b>"^v^"<br>\n" + + (** Return html code for the given optional since information.*) + method html_of_since_opt s_opt = + match s_opt with + None -> "" + | Some s -> "<b>"^Odoc_messages.since^"</b> "^s^"<br>\n" + + (** Return html code for the given list of raised exceptions.*) + method html_of_raised_exceptions l = + match l with + [] -> "" + | (s, t) :: [] -> "<b>"^Odoc_messages.raises^"</b> <code>"^s^"</code> "^(self#html_of_text t)^"<br>\n" + | _ -> + "<b>"^Odoc_messages.raises^"</b><ul>"^ + (String.concat "" + (List.map + (fun (ex, desc) -> "<li><code>"^ex^"</code> "^(self#html_of_text desc)^"</li>\n") + l + ) + )^"</ul>\n" + + (** Return html code for the given "see also" reference. *) + method html_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 + self#html_of_text t_ref + + (** Return html code for the given list of "see also" references.*) + method html_of_sees l = + match l with + [] -> "" + | see :: [] -> "<b>"^Odoc_messages.see_also^"</b> "^(self#html_of_see see)^"<br>\n" + | _ -> + "<b>"^Odoc_messages.see_also^"</b><ul>"^ + (String.concat "" + (List.map + (fun see -> "<li>"^(self#html_of_see see)^"</li>\n") + l + ) + )^"</ul>\n" + + (** Return html code for the given optional return information.*) + method html_of_return_opt return_opt = + match return_opt with + None -> "" + | Some s -> "<b>"^Odoc_messages.returns^"</b> "^(self#html_of_text s)^"<br>\n" + + (** Return html code for the given list of custom tagged texts. *) + method html_of_custom 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; + Buffer.contents buf + + (** Return html code for a description, except for the [i_params] field. *) + method html_of_info info_opt = + match info_opt with + None -> + "" + | Some info -> + let module M = Odoc_info in + "<div class=\"info\">\n"^ + (match info.M.i_deprecated with + None -> "" + | Some d -> + "<span class=\"warning\">"^Odoc_messages.deprecated^"</span> "^ + (self#html_of_text d)^ + "<br>\n" + )^ + (match info.M.i_desc with + None -> "" + | Some d when d = [Odoc_info.Raw ""] -> "" + | Some d -> (self#html_of_text d)^"<br>\n" + )^ + (self#html_of_author_list info.M.i_authors)^ + (self#html_of_version_opt info.M.i_version)^ + (self#html_of_since_opt info.M.i_since)^ + (self#html_of_raised_exceptions info.M.i_raised_exceptions)^ + (self#html_of_return_opt info.M.i_return_value)^ + (self#html_of_sees info.M.i_sees)^ + (self#html_of_custom info.M.i_custom)^ + "</div>\n" + + (** Return html code for the first sentence of a description. *) + method html_of_info_first_sentence info_opt = + match info_opt with + None -> "" + | Some info -> + let module M = Odoc_info in + let dep = info.M.i_deprecated <> None in + "<div class=\"info\">\n"^ + (if dep then "<font color=\"#CCCCCC\">" else "") ^ + (match info.M.i_desc with + None -> "" + | Some d when d = [Odoc_info.Raw ""] -> "" + | Some d -> (self#html_of_text (Odoc_info.first_sentence_of_text d))^"\n" + )^ + (if dep then "</font>" else "") ^ + "</div>\n" + + end + + +(** A function used to create index files. + We must put it out of the html class because ocaml doesn't support + yet polymorphic methods :-( *) +let generate_elements_index + self_header self_inner_title self_html_of_info_first_sentence + elements name info target title simple_file = + try + let chanout = open_out (Filename.concat !Odoc_args.target_dir simple_file) in + output_string chanout + ( + "<html>\n"^ + (self_header (self_inner_title title)) ^ + "<body>\n"^ + "<center><h1>"^title^"</h1></center>\n"); + + let sorted_elements = List.sort + (fun e1 -> fun 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 + output_string chanout + ("<tr><td><a href=\""^(target e)^"\">"^simple_name^"</a> "^ + (if simple_name <> father_name then + "["^"<a href=\""^(fst (Naming.html_files father_name))^"\">"^father_name^"</a>]" + else + "" + )^ + "</td>\n"^ + "<td>"^(self_html_of_info_first_sentence (info e))^"</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 + output_string chanout ("<tr><td align=\"left\"><br>"^s^"</td></tr>\n"); + List.iter f_ele l + in + output_string chanout "<table>\n"; + List.iter f_group groups ; + output_string chanout "</table><br>\n" ; + output_string chanout "</body>\n</html>"; + close_out chanout + with + Sys_error s -> + raise (Failure s) + +(** A function used to generate a list of module/class files. + We must put it out of the html class because ocaml doesn't support + yet polymorphic methods :-( *) +let generate_elements 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 + +let opt = Odoc_info.apply_opt + +(** This class is used to create objects which can generate a simple html documentation. *) +class html = + object (self) + inherit text + inherit info + + (** 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 }" ; + ".string { color : Maroon }" ; + ".warning { color : Red ; font-weight : bold }" ; + ".info { margin-left : 3em; margin-right : 3em }" ; + ".code { color : black ; }" ; + ".title1 { font-size : 20pt ; background-color : #416DFF }" ; + ".title2 { font-size : 20pt ; background-color : #418DFF }" ; + ".title3 { font-size : 20pt ; background-color : #41ADFF }" ; + ".title4 { font-size : 20pt ; background-color : #41CDFF }" ; + ".title5 { font-size : 20pt ; background-color : #41EDFF }" ; + ".title6 { font-size : 20pt ; background-color : #41FFFF }" ; +(* + ".title1 { font-size : 20pt ; background-color : #AAFF44 }" ; + ".title2 { font-size : 20pt ; background-color : #AAFF66 }" ; + ".title3 { font-size : 20pt ; background-color : #AAFF99 }" ; + ".title4 { font-size : 20pt ; background-color : #AAFFCC }" ; + ".title5 { font-size : 20pt ; background-color : #AAFFFF }" ; + ".title6 { font-size : 20pt ; background-color : #DDFF44 }" ; +*) + "body { background-color : White }" ; + "tr { background-color : White }" ; + ] + + (** 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 = [] + + (** 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 = [] + + (** 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 = [] + + (** The main file. *) + val mutable index = "index.html" + (** The file for the index of values. *) + val mutable index_values = "index_values.html" + (** The file for the index of types. *) + val mutable index_types = "index_types.html" + (** The file for the index of exceptions. *) + val mutable index_exceptions = "index_exceptions.html" + (** The file for the index of attributes. *) + val mutable index_attributes = "index_attributes.html" + (** The file for the index of methods. *) + val mutable index_methods = "index_methods.html" + (** The file for the index of classes. *) + val mutable index_classes = "index_classes.html" + (** The file for the index of class types. *) + val mutable index_class_types = "index_class_types.html" + (** The file for the index of modules. *) + val mutable index_modules = "index_modules.html" + (** The file for the index of module types. *) + val mutable index_module_types = "index_module_types.html" + + + (** The list of attributes. Filled in the generate method. *) + val mutable list_attributes = [] + (** The list of methods. Filled in the generate method. *) + val mutable list_methods = [] + (** The list of values. Filled in the generate method. *) + val mutable list_values = [] + (** The list of exceptions. Filled in the generate method. *) + val mutable list_exceptions = [] + (** The list of types. Filled in the generate method. *) + val mutable list_types = [] + (** The list of modules. Filled in the generate method. *) + val mutable list_modules = [] + (** The list of module types. Filled in the generate method. *) + val mutable list_module_types = [] + (** The list of classes. Filled in the generate method. *) + val mutable list_classes = [] + (** The list of class types. Filled in the generate method. *) + val mutable list_class_types = [] + + (** The header of pages. Must be prepared by the [prepare_header] method.*) + val mutable header = fun ?(nav=None) -> fun _ -> "" + + (** Init the style. *) + method init_style = + (match !Odoc_args.css_style with + None -> + let default_style = String.concat "\n" default_style_options in + ( + try + let chanout = open_out (Filename.concat !Odoc_args.target_dir style_file) in + output_string chanout default_style ; + flush chanout ; + close_out chanout + 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 !Odoc_args.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 header ?nav title = header ?nav title + + (** A function to build the header of pages. *) + method prepare_header module_list = + let f ?(nav=None) t = + let link_if_not_empty l m url = + match l with + [] -> "" + | _ -> "<link title=\""^m^"\" rel=Appendix href=\""^url^"\">\n" + in + "<head>\n"^ + style^ + "<link rel=\"Start\" href=\""^index^"\">\n"^ + ( + match nav with + None -> "" + | Some (pre_opt, post_opt, name) -> + (match pre_opt with + None -> "" + | Some name -> + "<link rel=\"previous\" href=\""^(fst (Naming.html_files name))^"\">\n" + )^ + (match post_opt with + None -> "" + | Some name -> + "<link rel=\"next\" href=\""^(fst (Naming.html_files name))^"\">\n" + )^ + ( + let father = Name.father name in + let href = if father = "" then index else fst (Naming.html_files father) in + "<link rel=\"Up\" href=\""^href^"\">\n" + ) + )^ + (link_if_not_empty list_types Odoc_messages.index_of_types index_types)^ + (link_if_not_empty list_exceptions Odoc_messages.index_of_exceptions index_exceptions)^ + (link_if_not_empty list_values Odoc_messages.index_of_values index_values)^ + (link_if_not_empty list_attributes Odoc_messages.index_of_attributes index_attributes)^ + (link_if_not_empty list_methods Odoc_messages.index_of_methods index_methods)^ + (link_if_not_empty list_classes Odoc_messages.index_of_classes index_classes)^ + (link_if_not_empty list_class_types Odoc_messages.index_of_class_types index_class_types)^ + (link_if_not_empty list_modules Odoc_messages.index_of_modules index_modules)^ + (link_if_not_empty list_module_types Odoc_messages.index_of_module_types index_module_types)^ + (String.concat "\n" + (List.map + (fun m -> + let html_file = fst (Naming.html_files m.m_name) in + "<link title=\""^m.m_name^"\" rel=\"Chapter\" href=\""^html_file^"\">\n" + ) + module_list + ) + )^ + "<title>"^ + t^ + "</title>\n</head>\n" + in + header <- f + + (** Html code for navigation bar. + @param pre optional name for optinal previous module/class + @param post optional name for optinal next module/class + @param name name of current module/class *) + method navbar pre post name = + "<div class=\"navbar\">"^ + (match pre with + None -> "" + | Some name -> + "<a href=\""^(fst (Naming.html_files name))^"\">"^Odoc_messages.previous^"</a>\n" + )^ + " "^ + ( + let father = Name.father name in + let href = if father = "" then index else fst (Naming.html_files father) in + "<a href=\""^href^"\">"^Odoc_messages.up^"</a>\n" + )^ + " "^ + (match post with + None -> "" + | Some name -> + "<a href=\""^(fst (Naming.html_files name))^"\">"^Odoc_messages.next^"</a>\n" + )^ + "</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 html_code = self#html_of_code code in + output_string chanout ("<html>"^(self#header (self#inner_title in_title))^"<body>\n"); + output_string chanout html_code; + output_string chanout "</body></html>"; + 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 + if List.mem match_s known_types_names then + "<a href=\""^(Naming.complete_target Naming.mark_type match_s)^"\">"^ + (Odoc_info.apply_if_equal + Odoc_info.use_hidden_modules + match_s + (Name.get_relative m_name match_s) + )^"</a>" + else + if List.mem match_s known_classes_names then + let (html_file, _) = Naming.html_files match_s in + "<a href=\""^html_file^"\">"^ + (Odoc_info.apply_if_equal + Odoc_info.use_hidden_modules + match_s + (Name.get_relative m_name match_s) + )^"</a>" + else + 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 + + (** 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 + if List.mem match_s known_modules_names then + let (html_file, _) = Naming.html_files match_s in + "<a href=\""^html_file^"\">"^(Name.get_relative m_name match_s)^"</a>" + else + 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 + + (** Return html code to display a [Types.type_expr].*) + method html_of_type_expr m_name t = + let s = String.concat "\n" + (Str.split (Str.regexp "\n") (Odoc_info.string_of_type_expr t)) + in + let s2 = Str.global_replace (Str.regexp "\n") "<br> " s in + "<code class=\"type\">"^(self#create_fully_qualified_idents_links m_name s2)^"</code>" + + (** Return html code to display a [Types.type_expr list].*) + method html_of_type_expr_list m_name sep l = + print_DEBUG "html#html_of_type_expr_list"; + let s = Odoc_info.string_of_type_list sep l in + print_DEBUG "html#html_of_type_expr_list: 1"; + let s2 = Str.global_replace (Str.regexp "\n") "<br> " s in + print_DEBUG "html#html_of_type_expr_list: 2"; + "<code class=\"type\">"^(self#create_fully_qualified_idents_links m_name s2)^"</code>" + + (** Return html code to display a [Types.module_type]. *) + method html_of_module_type m_name t = + let s = String.concat "\n" + (Str.split (Str.regexp "\n") (Odoc_info.string_of_module_type t)) + in + let s2 = Str.global_replace (Str.regexp "\n") "<br> " s in + "<code class=\"type\">"^(self#create_fully_qualified_module_idents_links m_name s2)^"</code>" + + (** Generate a file containing the module type in the given file name. *) + method output_module_type in_title file mtyp = + let s = String.concat "\n" + (Str.split (Str.regexp "\n") (Odoc_info.string_of_module_type 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 = String.concat "\n" + (Str.split (Str.regexp "\n") (Odoc_info.string_of_class_type ctyp)) + in + self#output_code in_title file s + + + (** Return html code for a value. *) + method html_of_value v = + Odoc_info.reset_type_names (); + "<pre>"^(self#keyword "val")^" "^ + (* html mark *) + "<a name=\""^(Naming.value_target v)^"\"></a>"^ + (match v.val_code with + None -> 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 !Odoc_args.target_dir file) c; + "<a href=\""^file^"\">"^(Name.simple v.val_name)^"</a>" + )^" : "^ + (self#html_of_type_expr (Name.father v.val_name) v.val_type)^"</pre>"^ + (self#html_of_info v.val_info)^ + (if !Odoc_args.with_parameter_list then + self#html_of_parameter_list (Name.father v.val_name) v.val_parameters + else + self#html_of_described_parameter_list (Name.father v.val_name) v.val_parameters + ) + + (** Return html code for an exception. *) + method html_of_exception e = + Odoc_info.reset_type_names (); + "<pre>"^(self#keyword "exception")^" "^ + (* html mark *) + "<a name=\""^(Naming.exception_target e)^"\"></a>"^ + (Name.simple e.ex_name)^ + (match e.ex_args with + [] -> "" + | _ -> + " "^(self#keyword "of")^" "^ + (self#html_of_type_expr_list (Name.father e.ex_name) " * " e.ex_args) + )^ + (match e.ex_alias with + None -> "" + | Some ea -> " = "^ + ( + match ea.ea_ex with + None -> ea.ea_name + | Some e -> "<a href=\""^(Naming.complete_exception_target e)^"\">"^e.ex_name^"</a>" + ) + )^ + "</pre>\n"^ + (self#html_of_info e.ex_info) + + (** Return html code for a type. *) + method html_of_type t = + Odoc_info.reset_type_names (); + let father = Name.father t.ty_name in + "<br><code>"^(self#keyword "type")^" "^ + (* html mark *) + "<a name=\""^(Naming.type_target t)^"\"></a>"^ + (match t.ty_parameters with + [] -> "" + | tp :: [] -> (self#html_of_type_expr father tp)^" " + | l -> "("^(self#html_of_type_expr_list father ", " l)^") " + )^ + (Name.simple t.ty_name)^" "^ + (match t.ty_manifest with None -> "" | Some typ -> "= "^(self#html_of_type_expr father typ)^" ")^ + (match t.ty_kind with + Type_abstract -> "</code>" + | Type_variant l -> + "=<br>"^ + "</code><table border=\"0\" cellpadding=\"1\">\n"^ + (String.concat "\n" + (List.map + (fun constr -> + "<tr>\n"^ + "<td align=\"left\" valign=\"top\" >\n"^ + "<code>"^ + (self#keyword "|")^ + "</code></td>\n"^ + "<td align=\"left\" valign=\"top\" >\n"^ + "<code>"^ + (self#constructor constr.vc_name)^ + (match constr.vc_args with + [] -> "" + | l -> + " "^(self#keyword "of")^" "^ + (self#html_of_type_expr_list father " * " l) + )^ + "</code></td>\n"^ + (match constr.vc_text with + None -> "" + | Some t -> + "<td align=\"left\" valign=\"top\" >"^ + "<code>"^ + "(*"^ + "</code></td>"^ + "<td align=\"left\" valign=\"top\" >"^ + "<code>"^ + (self#html_of_text t)^ + "</code></td>"^ + "<td align=\"left\" valign=\"bottom\" >"^ + "<code>"^ + "*)"^ + "</code></td>" + )^ + "\n</tr>" + ) + l + ) + )^ + "</table>\n" + + | Type_record l -> + "= {<br>"^ + "</code><table border=\"0\" cellpadding=\"1\">\n"^ + (String.concat "\n" + (List.map + (fun r -> + "<tr>\n"^ + "<td align=\"left\" valign=\"top\" >\n"^ + "<code> </code>"^ + "</td>\n"^ + "<td align=\"left\" valign=\"top\" >\n"^ + "<code>"^(if r.rf_mutable then self#keyword "mutable " else "")^ + r.rf_name^" : "^(self#html_of_type_expr father r.rf_type)^";"^ + "</code></td>\n"^ + (match r.rf_text with + None -> "" + | Some t -> + "<td align=\"left\" valign=\"top\" >"^ + "<code>"^ + "(*"^ + "</code></td>"^ + "<td align=\"left\" valign=\"top\" >"^ + "<code>"^ + (self#html_of_text t)^ + "</code></td>"^ + "<td align=\"left\" valign=\"bottom\" >"^ + "<code>"^ + "*)"^ + "</code></td>" + )^ + "\n</tr>" + ) + l + ) + )^ + "</table>\n"^ + "}\n" + )^"\n"^ + (self#html_of_info t.ty_info)^ + "<br>\n" + + (** Return html code for a class attribute. *) + method html_of_attribute a = + let module_name = Name.father (Name.father a.att_value.val_name) in + "<pre>"^(self#keyword "val")^" "^ + (* html mark *) + "<a name=\""^(Naming.attribute_target a)^"\"></a>"^ + (if a.att_mutable then (self#keyword Odoc_messages.mutab)^" " else "")^ + (match a.att_value.val_code with + None -> 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 !Odoc_args.target_dir file) c; + "<a href=\""^file^"\">"^(Name.simple a.att_value.val_name)^"</a>" + )^" : "^ + (self#html_of_type_expr module_name a.att_value.val_type)^"</pre>"^ + (self#html_of_info a.att_value.val_info) + + (** Return html code for a class method. *) + method html_of_method m = + let module_name = Name.father (Name.father m.met_value.val_name) in + "<pre>"^(self#keyword "method")^" "^ + (* html mark *) + "<a name=\""^(Naming.method_target m)^"\"></a>"^ + (if m.met_private then (self#keyword "private")^" " else "")^ + (if m.met_virtual then (self#keyword "virtual")^" " else "")^ + (match m.met_value.val_code with + None -> 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 !Odoc_args.target_dir file) c; + "<a href=\""^file^"\">"^(Name.simple m.met_value.val_name)^"</a>" + )^" : "^ + (self#html_of_type_expr module_name m.met_value.val_type)^"</pre>"^ + (self#html_of_info m.met_value.val_info)^ + (if !Odoc_args.with_parameter_list then + self#html_of_parameter_list module_name m.met_value.val_parameters + else + self#html_of_described_parameter_list module_name m.met_value.val_parameters + ) + + (** Return html code for the description of a function parameter. *) + method html_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 -> self#html_of_text 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 + String.concat "<br>\n" + (List.map + (fun n -> + match Parameter.desc_by_name p n with + None -> "" + | Some t -> "<code>"^n^"</code> : "^(self#html_of_text t) + ) + l2 + ) + + (** Return html code for a list of parameters. *) + method html_of_parameter_list m_name l = + match l with + [] -> + "" + | _ -> + "<div class=\"info\">"^ + "<table border=\"0\" cellpadding=\"3\" width=\"100%\">\n"^ + "<tr>\n"^ + "<td align=\"left\" valign=\"top\" width=\"1%\"><b>"^Odoc_messages.parameters^": </b></td>\n"^ + "<td>\n"^ + "<table border=\"0\" cellpadding=\"5\" cellspacing=\"0\">\n"^ + (String.concat "" + (List.map + (fun p -> + "<tr>\n"^ + "<td align=\"center\" valign=\"top\" width=\"15%\">\n"^ + "<code>"^ + (match Parameter.complete_name p with + "" -> "?" + | s -> s + )^"</code></td>\n"^ + "<td align=\"center\" valign=\"top\">:</td>\n"^ + "<td>"^(self#html_of_type_expr m_name (Parameter.typ p))^"<br>\n"^ + (self#html_of_parameter_description p)^"\n"^ + "</tr>\n" + ) + l + ) + )^"</table>\n"^ + "</td>\n"^ + "</tr>\n"^ + "</table></div>\n" + + (** Return html code for the parameters which have a name and description. *) + method html_of_described_parameter_list 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 = + "<div class=\"info\"><code>"^(Parameter.complete_name p)^"</code> : "^ + (self#html_of_parameter_description p)^"</div>\n" + in + match l2 with + [] -> "" + | _ -> "<br>"^(String.concat "" (List.map f l2)) + + (** Return html code for a list of module parameters. *) + method html_of_module_parameter_list m_name l = + match l with + [] -> + "" + | _ -> + "<table border=\"0\" cellpadding=\"3\" width=\"100%\">\n"^ + "<tr>\n"^ + "<td align=\"left\" valign=\"top\" width=\"1%\"><b>"^Odoc_messages.parameters^": </b></td>\n"^ + "<td>\n"^ + "<table border=\"0\" cellpadding=\"5\" cellspacing=\"0\">\n"^ + (String.concat "" + (List.map + (fun (p, desc_opt) -> + "<tr>\n"^ + "<td align=\"center\" valign=\"top\" width=\"15%\">\n"^ + "<code>"^p.mp_name^"</code></td>\n"^ + "<td align=\"center\" valign=\"top\">:</td>\n"^ + "<td>"^(self#html_of_module_type m_name p.mp_type)^"\n"^ + (match desc_opt with + None -> "" + | Some t -> "<br>"^(self#html_of_text t))^ + "\n"^ + "</tr>\n" + ) + l + ) + )^"</table>\n"^ + "</td>\n"^ + "</tr>\n"^ + "</table>\n" + + (** Return html code for a [module_kind]. *) + method html_of_module_kind ?(with_def_syntax=true) k = + match k with + Module_alias m_alias -> + (match m_alias.ma_module with + None -> + (if with_def_syntax then " = " else "")^ + m_alias.ma_name + | Some (Mod m) -> + let (html_file,_) = Naming.html_files m.m_name in + (if with_def_syntax then " = " else "")^ + "<a href=\""^html_file^"\">"^m.m_name^"</a>" + | Some (Modtype mt) -> + let (html_file,_) = Naming.html_files mt.mt_name in + (if with_def_syntax then " : " else "")^ + "<a href=\""^html_file^"\">"^mt.mt_name^"</a>" + ) + | Module_apply (k1, k2) -> + (if with_def_syntax then " = " else "")^ + (self#html_of_module_kind ~with_def_syntax: false k1)^ + " ( "^(self#html_of_module_kind ~with_def_syntax: false k2)^" ) " + + | Module_with (tk, code) -> + (if with_def_syntax then " : " else "")^ + (self#html_of_module_type_kind ~with_def_syntax: false tk)^ + (self#html_of_code ~with_pre: false code) + + | Module_constraint (k, tk) -> + (if with_def_syntax then " = " else "")^ + "( "^(self#html_of_module_kind ~with_def_syntax: false k)^" : "^ + (self#html_of_module_type_kind ~with_def_syntax: false tk)^" )" + + | Module_struct _ -> + (if with_def_syntax then " = " else "")^ + (self#html_of_code ~with_pre: false (Odoc_messages.struct_end^" ")) + + | Module_functor (_, k) -> + (if with_def_syntax then " = " else "")^ + (self#html_of_code ~with_pre: false "functor ... ")^ + " -> "^(self#html_of_module_kind ~with_def_syntax: false k) + + (** Return html code for a [module_type_kind]. *) + method html_of_module_type_kind ?(with_def_syntax=true) tk = + match tk with + | Module_type_struct _ -> + (if with_def_syntax then " : " else "")^ + (self#html_of_code ~with_pre: false Odoc_messages.sig_end) + + | Module_type_functor (params, k) -> + let f p = "("^p.mp_name^" : "^(self#html_of_module_type "" p.mp_type)^") -> " in + let s1 = String.concat "" (List.map f params) in + let s2 = self#html_of_module_type_kind ~with_def_syntax: false k in + (if with_def_syntax then " : " else "")^s1^s2 + + | Module_type_with (tk2, code) -> + let s = self#html_of_module_type_kind ~with_def_syntax: false tk2 in + (if with_def_syntax then " : " else "")^ + s^(self#html_of_code ~with_pre: false code) + + | Module_type_alias mt_alias -> + (if with_def_syntax then " : " else "")^ + (match mt_alias.mta_module with + None -> + mt_alias.mta_name + | Some mt -> + let (html_file,_) = Naming.html_files mt.mt_name in + "<a href=\""^html_file^"\">"^mt.mt_name^"</a>" + ) + + (** Return html code for a module. *) + method html_of_module ?(info=true) ?(complete=true) ?(with_link=true) m = + let (html_file, _) = Naming.html_files m.m_name in + let s1 = + "<pre>"^(self#keyword "module")^" "^ + ( + if with_link then + "<a href=\""^html_file^"\">"^(Name.simple m.m_name)^"</a>" + else + Name.simple m.m_name + )^ + (self#html_of_module_kind m.m_kind)^ + "</pre>" + in + let s2 = + if info then + (if complete then self#html_of_info else self#html_of_info_first_sentence) m.m_info + else + "" + in + s1^s2 + + (** Return html code for a module type. *) + method html_of_modtype ?(info=true) ?(complete=true) ?(with_link=true) mt = + let (html_file, _) = Naming.html_files mt.mt_name in + "<pre>"^(self#keyword "module type")^" "^ + ( + if with_link then + "<a href=\""^html_file^"\">"^(Name.simple mt.mt_name)^"</a>" + else + Name.simple mt.mt_name + )^ + (match mt.mt_kind with + | Some tk -> self#html_of_module_type_kind tk + | None -> "" + )^ + "</pre>"^ + (if info then + (if complete then self#html_of_info else self#html_of_info_first_sentence) mt.mt_info + else + "" + ) + + (** Return html code for an included module. *) + method html_of_included_module im = + "<pre>"^(self#keyword "include")^" "^ + ( + match im.im_module with + None -> + 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 + "<a href=\""^file^"\">"^(Name.simple name)^"</a>" + )^ + "</pre>\n" + + (** Return html code for the given [class_kind].*) + method html_of_class_kind father ?(with_def_syntax=true) ckind = + print_DEBUG "html#html_of_class_kind"; + match ckind with + Class_structure _ -> + (if with_def_syntax then " = " else "")^ + (self#html_of_code ~with_pre: false Odoc_messages.object_end) + + | Class_apply capp -> + (if with_def_syntax then " = " else "")^ + ( + match capp.capp_class with + None -> capp.capp_name + | Some cl -> + let (html_file, _) = Naming.html_files cl.cl_name in + "<a href=\""^html_file^"\">"^cl.cl_name^"</a>" + )^ + " "^ + (String.concat " " + (List.map + (fun s -> self#html_of_code ~with_pre: false ("("^s^")")) + capp.capp_params_code)) + + | Class_constr cco -> + (if with_def_syntax then " = " else "")^ + ( + match cco.cco_type_parameters with + [] -> "" + | l -> "["^(self#html_of_type_expr_list father ", " l)^"] " + )^ + ( + match cco.cco_class with + None -> cco.cco_name + | Some cl -> + let (html_file, _) = Naming.html_files cl.cl_name in + "<a href=\""^html_file^"\">"^cl.cl_name^"</a> " + ) + | Class_constraint (ck, ctk) -> + (if with_def_syntax then " = " else "")^ + "( "^(self#html_of_class_kind father ~with_def_syntax: false ck)^ + " : "^ + (self#html_of_class_type_kind father ctk)^ + " )" + + (** Return html code for the given [class_type_kind].*) + method html_of_class_type_kind father ?def_syntax ctkind = + match ctkind with + Class_type cta -> + (match def_syntax with + None -> "" + | Some s -> " "^s^" ")^ + ( + match cta.cta_type_parameters with + [] -> "" + | l -> "["^(self#html_of_type_expr_list father ", " l)^"] " + )^ + ( + match cta.cta_class with + None -> + if cta.cta_name = Odoc_messages.object_end then + self#html_of_code ~with_pre: false cta.cta_name + else + cta.cta_name + | Some (Cltype (clt, _)) -> + let (html_file, _) = Naming.html_files clt.clt_name in + "<a href=\""^html_file^"\">"^clt.clt_name^"</a>" + | Some (Cl cl) -> + let (html_file, _) = Naming.html_files cl.cl_name in + "<a href=\""^html_file^"\">"^cl.cl_name^"</a>" + ) + | Class_signature _ -> + (match def_syntax with + None -> "" + | Some s -> " "^s^" ")^ + (self#html_of_code ~with_pre: false Odoc_messages.object_end) + + (** Return html code for a class. *) + method html_of_class ?(complete=true) ?(with_link=true) c = + Odoc_info.reset_type_names (); + let (html_file, _) = Naming.html_files c.cl_name in + "<pre>"^(self#keyword "class")^" "^ + (* we add a html tag, the same as for a type so we can + go directly here when the class name is used as a type name *) + "<a name=\""^(Naming.type_target + { ty_name = c.cl_name ; + ty_info = None ; ty_parameters = [] ; + ty_kind = Type_abstract ; ty_manifest = None ; + ty_loc = Odoc_info.dummy_loc })^ + "\"></a>"^ + (print_DEBUG "html#html_of_class : virtual or not" ; "")^ + (if c.cl_virtual then (self#keyword "virtual")^" " else "")^ + ( + match c.cl_type_parameters with + [] -> "" + | l -> "["^(self#html_of_type_expr_list (Name.father c.cl_name) ", " l)^"] " + )^ + (print_DEBUG "html#html_of_class : with link or not" ; "")^ + ( + if with_link then + "<a href=\""^html_file^"\">"^(Name.simple c.cl_name)^"</a>" + else + Name.simple c.cl_name + )^ + (match c.cl_parameters with [] -> "" | _ -> " ... ")^ + (print_DEBUG "html#html_of_class : class kind" ; "")^ + (self#html_of_class_kind (Name.father c.cl_name) c.cl_kind)^ + "</pre>"^ + (print_DEBUG "html#html_of_class : info" ; "")^ + ((if complete then self#html_of_info else self#html_of_info_first_sentence) c.cl_info) + + (** Return html code for a class type. *) + method html_of_class_type ?(complete=true) ?(with_link=true) ct = + Odoc_info.reset_type_names (); + let (html_file, _) = Naming.html_files ct.clt_name in + "<pre>"^(self#keyword "class type")^" "^ + (* we add a html tag, the same as for a type so we can + go directly here when the class type name is used as a type name *) + "<a name=\""^(Naming.type_target + { ty_name = ct.clt_name ; + ty_info = None ; ty_parameters = [] ; + ty_kind = Type_abstract ; ty_manifest = None ; + ty_loc = Odoc_info.dummy_loc })^ + "\"></a>"^ + (if ct.clt_virtual then (self#keyword "virtual")^" " else "")^ + ( + match ct.clt_type_parameters with + [] -> "" + | l -> "["^(self#html_of_type_expr_list (Name.father ct.clt_name) ", " l)^"] " + )^ + ( + if with_link then + "<a href=\""^html_file^"\">"^(Name.simple ct.clt_name)^"</a>" + else + Name.simple ct.clt_name + )^ + (self#html_of_class_type_kind (Name.father ct.clt_name) ~def_syntax: ":" ct.clt_kind)^ + "</pre>"^ + ((if complete then self#html_of_info else self#html_of_info_first_sentence) 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 } + + (** Return html code for a module comment.*) + method html_of_module_comment text = + "<br>\n"^(self#html_of_text text)^"<br><br>\n" +(* + (* 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, [Odoc_info.Raw s])) :: q + | _ -> text + in + self#html_of_text text2 +*) + + (** Return html code for a class comment.*) + method html_of_class_comment 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 text2 + + (** Generate html 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 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 + let html = self#html_of_text text in + output_string chanout html + + (** Generate html code for the inherited classes of the given class. *) + method generate_class_inheritance_info chanout cl = + let rec iter_kind k = + match k with + Class_structure ([], _) -> + () + | Class_structure (l, _) -> + self#generate_inheritance_info chanout 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 chanout clt = + match clt.clt_kind with + Class_signature ([], _) -> + () + | Class_signature (l, _) -> + self#generate_inheritance_info chanout l + | Class_type _ -> + () + + (** 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 !Odoc_args.target_dir html_file) in + let pre_name = opt (fun c -> c.cl_name) pre in + let post_name = opt (fun c -> c.cl_name) post in + output_string chanout + ("<html>\n"^ + (self#header + ~nav: (Some (pre_name, post_name, cl.cl_name)) + (self#inner_title cl.cl_name) + )^ + "<body>\n"^ + (self#navbar pre_name post_name cl.cl_name)^ + "<center><h1>"^Odoc_messages.clas^" "^ + (if cl.cl_virtual then "virtual " else "")^ + "<a href=\""^type_file^"\">"^cl.cl_name^"</a>"^ + "</h1></center>\n"^ + "<br>\n"^ + (self#html_of_class ~with_link: false cl) + ); + (* parameters *) + output_string chanout (self#html_of_parameter_list (Name.father cl.cl_name) cl.cl_parameters); + (* class inheritance *) + self#generate_class_inheritance_info chanout cl; + (* a horizontal line *) + output_string chanout "<hr width=\"100%\">\n"; + (* the various elements *) + List.iter + (fun element -> + match element with + Class_attribute a -> + output_string chanout (self#html_of_attribute a) + | Class_method m -> + output_string chanout (self#html_of_method m) + | Class_comment t -> + output_string chanout (self#html_of_class_comment t) + ) + (Class.class_elements cl); + output_string chanout "</html>"; + close_out chanout; + + (* generate the file with the complete class type *) + self#output_class_type + cl.cl_name + (Filename.concat !Odoc_args.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 !Odoc_args.target_dir html_file) in + let pre_name = opt (fun ct -> ct.clt_name) pre in + let post_name = opt (fun ct -> ct.clt_name) post in + output_string chanout + ("<html>\n"^ + (self#header + ~nav: (Some (pre_name, post_name, clt.clt_name)) + (self#inner_title clt.clt_name) + )^ + "<body>\n"^ + (self#navbar pre_name post_name clt.clt_name)^ + "<center><h1>"^Odoc_messages.class_type^" "^ + (if clt.clt_virtual then "virtual " else "")^ + "<a href=\""^type_file^"\">"^clt.clt_name^"</a>"^ + "</h1></center>\n"^ + "<br>\n"^ + (self#html_of_class_type ~with_link: false clt) + ); + (* class inheritance *) + self#generate_class_type_inheritance_info chanout clt; + (* a horizontal line *) + output_string chanout "<hr width=\"100%\">\n"; + (* the various elements *) + List.iter + (fun element -> + match element with + Class_attribute a -> + output_string chanout (self#html_of_attribute a) + | Class_method m -> + output_string chanout (self#html_of_method m) + | Class_comment t -> + output_string chanout (self#html_of_class_comment t) + ) + (Class.class_type_elements clt); + output_string chanout "</html>"; + close_out chanout; + + (* generate the file with the complete class type *) + self#output_class_type + clt.clt_name + (Filename.concat !Odoc_args.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 !Odoc_args.target_dir html_file) in + let pre_name = opt (fun mt -> mt.mt_name) pre in + let post_name = opt (fun mt -> mt.mt_name) post in + output_string chanout + ("<html>\n"^ + (self#header + ~nav: (Some (pre_name, post_name, mt.mt_name)) + (self#inner_title mt.mt_name) + )^ + "<body>\n"^ + (self#navbar pre_name post_name mt.mt_name)^ + "<center><h1>"^Odoc_messages.module_type^ + " "^ + (match mt.mt_type with + Some _ -> "<a href=\""^type_file^"\">"^mt.mt_name^"</a>" + | None-> mt.mt_name + )^ + "</h1></center>\n"^ + "<br>\n"^ + (self#html_of_modtype ~with_link: false mt) + ); + (* parameters for functors *) + output_string chanout (self#html_of_module_parameter_list "" (Module.module_type_parameters mt)); + (* a horizontal line *) + output_string chanout "<hr width=\"100%\">\n"; + (* module elements *) + List.iter + (fun ele -> + match ele with + Element_module m -> + output_string chanout (self#html_of_module ~complete: false m) + | Element_module_type mt -> + output_string chanout (self#html_of_modtype ~complete: false mt) + | Element_included_module im -> + output_string chanout (self#html_of_included_module im) + | Element_class c -> + output_string chanout (self#html_of_class ~complete: false c) + | Element_class_type ct -> + output_string chanout (self#html_of_class_type ~complete: false ct) + | Element_value v -> + output_string chanout (self#html_of_value v) + | Element_exception e -> + output_string chanout (self#html_of_exception e) + | Element_type t -> + output_string chanout (self#html_of_type t) + | Element_module_comment text -> + output_string chanout (self#html_of_module_comment text) + ) + (Module.module_type_elements mt); + + output_string chanout "</html>"; + close_out chanout; + + (* generate html files for submodules *) + generate_elements self#generate_for_module (Module.module_type_modules mt); + (* generate html files for module types *) + generate_elements self#generate_for_module_type (Module.module_type_module_types mt); + (* generate html files for classes *) + generate_elements self#generate_for_class (Module.module_type_classes mt); + (* generate html files for class types *) + 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 !Odoc_args.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 chanout = open_out (Filename.concat !Odoc_args.target_dir html_file) in + let pre_name = opt (fun m -> m.m_name) pre in + let post_name = opt (fun m -> m.m_name) post in + output_string chanout + ("<html>\n"^ + (self#header + ~nav: (Some (pre_name, post_name, modu.m_name)) + (self#inner_title modu.m_name) + ) ^ + "<body>\n"^ + (self#navbar pre_name post_name modu.m_name)^ + "<center><h1>"^(if Module.module_is_functor modu then Odoc_messages.functo else Odoc_messages.modul)^ + " "^ + (match modu.m_type with + Some _ -> "<a href=\""^type_file^"\">"^modu.m_name^"</a>" + | None-> modu.m_name + )^ + "</h1></center>\n"^ + "<br>\n"^ + (self#html_of_module ~with_link: false modu) + ); + (* parameters for functors *) + output_string chanout (self#html_of_module_parameter_list "" (Module.module_parameters modu)); + (* a horizontal line *) + output_string chanout "<hr width=\"100%\">\n"; + (* module elements *) + List.iter + (fun ele -> + print_DEBUG "html#generate_for_module : ele ->"; + match ele with + Element_module m -> + output_string chanout (self#html_of_module ~complete: false m) + | Element_module_type mt -> + output_string chanout (self#html_of_modtype ~complete: false mt) + | Element_included_module im -> + output_string chanout (self#html_of_included_module im) + | Element_class c -> + output_string chanout (self#html_of_class ~complete: false c) + | Element_class_type ct -> + output_string chanout (self#html_of_class_type ~complete: false ct) + | Element_value v -> + output_string chanout (self#html_of_value v) + | Element_exception e -> + output_string chanout (self#html_of_exception e) + | Element_type t -> + output_string chanout (self#html_of_type t) + | Element_module_comment text -> + output_string chanout (self#html_of_module_comment text) + ) + (Module.module_elements modu); + + output_string chanout "</html>"; + close_out chanout; + + (* generate html files for submodules *) + generate_elements self#generate_for_module (Module.module_modules modu); + (* generate html files for module types *) + generate_elements self#generate_for_module_type (Module.module_module_types modu); + (* generate html files for classes *) + generate_elements self#generate_for_class (Module.module_classes modu); + (* generate html files for class types *) + generate_elements self#generate_for_class_type (Module.module_class_types modu); + + (* generate the file with the complete module type *) + ( + match modu.m_type with + None -> () + | Some mty -> self#output_module_type + modu.m_name + (Filename.concat !Odoc_args.target_dir type_file) + mty + ) + with + Sys_error s -> + raise (Failure s) + + (** Generate the [index.html] file corresponding to the given module list. + @raise Failure if an error occurs.*) + method generate_index module_list = + try + let title = match !Odoc_args.title with None -> "" | Some t -> self#escape t in + let index_if_not_empty l url m = + match l with + [] -> "" + | _ -> "<a href=\""^url^"\">"^m^"</a><br>\n" + in + let chanout = open_out (Filename.concat !Odoc_args.target_dir index) in + output_string chanout + ( + "<html>\n"^ + (self#header self#title) ^ + "<body>\n"^ + "<center><h1>"^title^"</h1></center>\n"^ + (index_if_not_empty list_types index_types Odoc_messages.index_of_types)^ + (index_if_not_empty list_exceptions index_exceptions Odoc_messages.index_of_exceptions)^ + (index_if_not_empty list_values index_values Odoc_messages.index_of_values)^ + (index_if_not_empty list_attributes index_attributes Odoc_messages.index_of_attributes)^ + (index_if_not_empty list_methods index_methods Odoc_messages.index_of_methods)^ + (index_if_not_empty list_classes index_classes Odoc_messages.index_of_classes)^ + (index_if_not_empty list_class_types index_class_types Odoc_messages.index_of_class_types)^ + (index_if_not_empty list_modules index_modules Odoc_messages.index_of_modules)^ + (index_if_not_empty list_module_types index_module_types Odoc_messages.index_of_module_types)^ + "<br>\n"^ + "<table border=\"0\">\n"^ + (String.concat "" + (List.map + (fun m -> + let (html, _) = Naming.html_files m.m_name in + "<tr><td><a href=\""^html^"\">"^m.m_name^"</a></td>"^ + "<td>"^(self#html_of_info_first_sentence m.m_info)^"</td></tr>\n") + module_list + ) + )^ + "</table>\n"^ + "</body>\n"^ + "</html>" + ); + 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 = + generate_elements_index + self#header + self#inner_title + self#html_of_info_first_sentence + list_values + (fun v -> v.val_name) + (fun v -> v.val_info) + Naming.complete_value_target + Odoc_messages.index_of_values + index_values + + (** Generate the exceptions index in the file [index_exceptions.html]. *) + method generate_exceptions_index module_list = + generate_elements_index + self#header + self#inner_title + self#html_of_info_first_sentence + list_exceptions + (fun e -> e.ex_name) + (fun e -> e.ex_info) + Naming.complete_exception_target + Odoc_messages.index_of_exceptions + index_exceptions + + (** Generate the types index in the file [index_types.html]. *) + method generate_types_index module_list = + generate_elements_index + self#header + self#inner_title + self#html_of_info_first_sentence + list_types + (fun t -> t.ty_name) + (fun t -> t.ty_info) + Naming.complete_type_target + Odoc_messages.index_of_types + index_types + + (** Generate the attributes index in the file [index_attributes.html]. *) + method generate_attributes_index module_list = + generate_elements_index + self#header + self#inner_title + self#html_of_info_first_sentence + 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 + index_attributes + + (** Generate the methods index in the file [index_methods.html]. *) + method generate_methods_index module_list = + generate_elements_index + self#header + self#inner_title + self#html_of_info_first_sentence + 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 + index_methods + + (** Generate the classes index in the file [index_classes.html]. *) + method generate_classes_index module_list = + generate_elements_index + self#header + self#inner_title + self#html_of_info_first_sentence + 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 + index_classes + + (** Generate the class types index in the file [index_class_types.html]. *) + method generate_class_types_index module_list = + generate_elements_index + self#header + self#inner_title + self#html_of_info_first_sentence + 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 + index_class_types + + (** Generate the modules index in the file [index_modules.html]. *) + method generate_modules_index module_list = + generate_elements_index + self#header + self#inner_title + self#html_of_info_first_sentence + 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 + index_modules + + (** Generate the module types index in the file [index_module_types.html]. *) + method generate_module_types_index module_list = + let module_types = Odoc_info.Search.module_types module_list in + generate_elements_index + self#header + self#inner_title + self#html_of_info_first_sentence + 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 + index_module_types + + (** Generate all the html files from a module list. The main + file is [index.html]. *) + method generate module_list = + let sorted_module_list = Sort.list (fun m1 -> fun m2 -> m1.m_name < m2.m_name) module_list in + (* 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 sorted_module_list ; + (* Get the names of all known types. *) + let types = Odoc_info.Search.types module_list in + let type_names = List.map (fun t -> t.ty_name) types in + known_types_names <- type_names ; + (* 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 + let class_names = List.map (fun c -> c.cl_name) classes in + let class_type_names = List.map (fun ct -> ct.clt_name) class_types in + known_classes_names <- class_names @ class_type_names ; + (* 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 + let module_type_names = List.map (fun mt -> mt.mt_name) module_types in + let module_names = List.map (fun m -> m.m_name) modules in + known_modules_names <- module_type_names @ module_names ; + (* generate html for each module *) + if not !Odoc_args.index_only then + generate_elements self#generate_for_module sorted_module_list ; + + try + self#generate_index sorted_module_list; + self#generate_values_index sorted_module_list ; + self#generate_exceptions_index sorted_module_list ; + self#generate_types_index sorted_module_list ; + self#generate_attributes_index sorted_module_list ; + self#generate_methods_index sorted_module_list ; + self#generate_classes_index sorted_module_list ; + self#generate_class_types_index sorted_module_list ; + self#generate_modules_index sorted_module_list ; + self#generate_module_types_index sorted_module_list ; + with + Failure s -> + prerr_endline s ; + incr Odoc_info.errors + + initializer + Odoc_ocamlhtml.html_of_comment := + (fun s -> self#html_of_text (Odoc_text.Texter.text_of_string s)) + end + + + diff --git a/ocamldoc/odoc_info.ml b/ocamldoc/odoc_info.ml new file mode 100644 index 000000000..d52ff1704 --- /dev/null +++ b/ocamldoc/odoc_info.ml @@ -0,0 +1,212 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + +(** 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 + +type 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 + | Superscript of text + | Subscript of text + + +and text = text_element list + +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_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 } + +type iso_check = Odoc_types.iso_check = + | Has_description + | Has_author + | Has_since + | Has_version + | Has_return + | Has_params + | Has_fields_decribed + | Has_constructors_decribed + + +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_args.merge_options := merge_options; + Odoc_args.include_dirs := include_dirs; + Odoc_args.classic := not labels; + Odoc_args.sort_modules := sort_modules; + Odoc_args.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_names + +let string_of_type_expr t = Odoc_misc.string_of_type_expr t + +(** This function returns a string to represent the given list of types, + with a given separator. *) +let string_of_type_list sep type_list = Odoc_misc.string_of_type_list sep type_list + +let string_of_module_type t = Odoc_misc.string_of_module_type t + +let string_of_class_type t = Odoc_misc.string_of_class_type t + +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 create_index_lists = Odoc_misc.create_index_lists + +let use_hidden_modules n = + Odoc_name.hide_given_modules !Odoc_args.hidden_modules n + +let verbose s = + if !Odoc_args.verbose then + (print_string s ; print_newline ()) + else + () + +let warning s = Odoc_messages.pwarning s + +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 + +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 + + 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 diff --git a/ocamldoc/odoc_info.mli b/ocamldoc/odoc_info.mli new file mode 100644 index 000000000..318ff117e --- /dev/null +++ b/ocamldoc/odoc_info.mli @@ -0,0 +1,832 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(** 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 + +type 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 + (** A reference to an element. Complete name and kind. *) + | Superscript of text (** Superscripts. *) + | Subscript of text (** Subscripts. *) + +(** 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 + +(** 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 = 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_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 + +(** The kind of checks which can be performed on elements. *) +type iso_check = Odoc_types.iso_check = + | Has_description (** the element has an associated description *) + | Has_author (** the element's description has one or more \@author tag(s) *) + | Has_since (** the element's description has a \@since tag *) + | Has_version (** the element's description has a \@version tag *) + | Has_return (** the function's description has a \@return tag *) + | Has_params (** all the named parameters of the element has a description *) + | Has_fields_decribed (** all the fields of the type are described *) + | Has_constructors_decribed (** all the constructors of the type are described *) + +(** Representation of element names. *) +module Name : + sig + type t = Odoc_name.t + (** 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 value. *) + type parameter = param_info + + (** A module parameter is just a name and a module type.*) + type module_parameter = Odoc_parameter.module_parameter = + { + mp_name : string ; + mp_type : Types.module_type ; + } + + (** {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 ; + } + end + +(** Representation and manipulation of types.*) +module Type : + sig + (** 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 + | Type_record of record_field list + + (** 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 list ; (** Type parameters. *) + ty_kind : type_kind ; (** Type kind. *) + ty_manifest : Types.type_expr option; (** Type manifest. *) + mutable ty_loc : location ; + } + 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. *) + } + + (** 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 : t_class option; (** The associated t_class 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. *) + } + + 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. *) + } + + (** 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 (Parameter.module_parameter list) * module_kind + (** A functor, with {e all} its parameters 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. *) + + (** Representation of a module. *) + and t_module = Odoc_module.t_module = + { + m_name : Name.t ; (** Complete name of the module. *) + m_type : Types.module_type option ; + (** The type of the module. + It is [None] when we had only the .ml file and it is a top 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. *) + } + + 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 (Odoc_parameter.module_parameter list) * module_type_kind + (** A functor, with {e all} its parameters 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. *) + + (** 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. *) + 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 -> (Parameter.module_parameter * text option) 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 -> (Parameter.module_parameter * text option) list + + 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 -> + string 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 + +(** {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 + +(** This function returns a string representing a Types.type_expr. + It writes in and flushes [Format.str_formatter]. *) +val string_of_type_expr : Types.type_expr -> string + +(** This function returns a string to represent the given list of types, + with a given separator. It writes in and flushes [Format.str_formatter].*) +val string_of_type_list : string -> Types.type_expr list -> string + +(** This function returns a string representing a [Types.module_type]. *) +val string_of_module_type : Types.module_type -> string + +(** This function returns a string representing a [Types.class_type]. *) +val string_of_class_type : 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 : Odoc_types.text -> Odoc_types.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 : + Odoc_types.text -> Odoc_types.text * Odoc_types.text + +(** 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 + +(** 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 + +(** 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 + +(** 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 + + (** 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 overriden. 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 overriden. 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 overriden. 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 overriden. 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 diff --git a/ocamldoc/odoc_inherit.ml b/ocamldoc/odoc_inherit.ml new file mode 100644 index 000000000..7519a782e --- /dev/null +++ b/ocamldoc/odoc_inherit.ml @@ -0,0 +1,13 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + + diff --git a/ocamldoc/odoc_iso.ml b/ocamldoc/odoc_iso.ml new file mode 100644 index 000000000..f9d5e64a5 --- /dev/null +++ b/ocamldoc/odoc_iso.ml @@ -0,0 +1,174 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(** A generator which performs some controls on the collected information. *) + +open Odoc_info.Value +open Odoc_info.Type +open Odoc_info.Exception +open Odoc_info.Class +open Odoc_info.Module + +open Odoc_info + +let (<@) e l = List.mem e l + +(** The generator class. *) +class iso = + object (self) + inherit Odoc_info.Scan.scanner + + method print_fail s = + incr Odoc_info.errors ; + print_string s ; print_newline () + + method check_info_error_messages = + [ + Has_author, self#check_authors, Odoc_messages.has_no_author ; + Has_since, self#check_since, Odoc_messages.has_no_since ; + Has_version, self#check_version, Odoc_messages.has_no_version ; + Has_return, self#check_return, Odoc_messages.has_no_return ; + ] + + method check_authors i = i.i_authors <> [] + method check_since i = i.i_since <> None + method check_version i = i.i_version <> None + method check_return i = i.i_return_value <> None + + method check_info prefix lchecks info_opt = + match info_opt with + None -> + if Has_description <@ lchecks then + self#print_fail (Odoc_messages.has_no_description prefix); + + List.iter + (fun (check, f, m) -> + if check <@ lchecks then + self#print_fail (m prefix) + else + () + ) + self#check_info_error_messages + + | Some i -> + List.iter + (fun (check, f, m) -> + if check <@ lchecks then + if not (f i) then + self#print_fail (m prefix) + else + () + ) + self#check_info_error_messages + + method check_params l = + let rec iter = function + | Parameter.Simple_name sn -> + (sn.Parameter.sn_text <> None) or + (sn.Parameter.sn_name = "") + | Parameter.Tuple (l, _) -> + List.for_all iter l + in + List.for_all iter l + + method check_type_fields l = + List.for_all (fun f -> f.rf_text <> None) l + + method check_type_constructors l = + List.for_all (fun c -> c.vc_text <> None) l + + method scan_value v = + let prefix = Odoc_messages.value_n v.val_name in + self#check_info + prefix + !Odoc_args.iso_val_options + v.val_info; + if Has_params <@ !Odoc_args.iso_val_options then + if not (self#check_params v.val_parameters) then + self#print_fail (Odoc_messages.has_not_all_params_described prefix) + + method scan_type t = + let prefix = Odoc_messages.type_n t.ty_name in + self#check_info + prefix + !Odoc_args.iso_type_options + t.ty_info; + match t.ty_kind with + Type.Type_record l when Has_fields_decribed <@ !Odoc_args.iso_type_options -> + if not (self#check_type_fields l) then + self#print_fail (Odoc_messages.has_not_all_fields_described prefix) + + | Type.Type_variant l when Has_constructors_decribed <@ !Odoc_args.iso_type_options -> + if not (self#check_type_constructors l) then + self#print_fail (Odoc_messages.has_not_all_cons_described prefix) + + | _ -> + () + + method scan_exception e = + self#check_info + (Odoc_messages.exception_n e.ex_name) + !Odoc_args.iso_exception_options + e.ex_info; + + method scan_attribute a = + self#check_info + (Odoc_messages.attribute_n a.att_value.val_name) + !Odoc_args.iso_val_options + a.att_value.val_info; + + method scan_method m = + let prefix= Odoc_messages.method_n m.met_value.val_name in + self#check_info + prefix + !Odoc_args.iso_val_options + m.met_value.val_info; + if Has_params <@ !Odoc_args.iso_val_options then + if not (self#check_params m.met_value.val_parameters) then + self#print_fail (Odoc_messages.has_not_all_params_described prefix) + + method scan_class_pre c = + let prefix = Odoc_messages.class_n c.cl_name in + self#check_info + prefix + !Odoc_args.iso_class_options + c.cl_info; + if Has_params <@ !Odoc_args.iso_class_options then + if not (self#check_params c.cl_parameters) then + self#print_fail (Odoc_messages.has_not_all_params_described prefix); + true + + method scan_class_type_pre ct = + self#check_info + (Odoc_messages.class_type_n ct.clt_name) + !Odoc_args.iso_class_options + ct.clt_info; + true + + method scan_module_pre m = + let prefix = Odoc_messages.module_n m.m_name in + self#check_info + prefix + !Odoc_args.iso_module_options + m.m_info; + true + + method scan_module_type_pre mt = + let prefix = Odoc_messages.module_type_n mt.mt_name in + self#check_info + prefix + !Odoc_args.iso_module_options + mt.mt_info; + true + + method generate = self#scan_module_list + + end diff --git a/ocamldoc/odoc_latex.ml b/ocamldoc/odoc_latex.ml new file mode 100644 index 000000000..30566d5e5 --- /dev/null +++ b/ocamldoc/odoc_latex.ml @@ -0,0 +1,908 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + +(** 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 + + +(** 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 !Odoc_args.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. *) + method label ?(no_=true) name = + let s = + if no_ then + Str.global_replace (Str.regexp_string "_") "" name + else + name + in + List.fold_right + (fun (s, s2) -> fun acc -> Str.global_replace (Str.regexp_string s) s2 acc) + [ + "@", "\"@" ; + "!", "\"!" ; + "|", "\"|" ; + ] + s + + (** Return latex code for the label of a name. *) + method make_label name = + "\\label{"^(self#label name)^"}" + + (** Return latex code for the ref to a name. *) + method make_ref name = + "\\ref{"^(self#label name)^"}" + + (** Return the LaTeX code corresponding to the [text] parameter.*) + method latex_of_text t = String.concat "" (List.map self#latex_of_text_element t) + + (** Return the LaTeX code for the [text_element] in parameter. *) + method latex_of_text_element te = + match te with + | Odoc_info.Raw s -> self#latex_of_Raw s + | Odoc_info.Code s -> self#latex_of_Code s + | Odoc_info.CodePre s -> self#latex_of_CodePre s + | Odoc_info.Verbatim s -> self#latex_of_Verbatim s + | Odoc_info.Bold t -> self#latex_of_Bold t + | Odoc_info.Italic t -> self#latex_of_Italic t + | Odoc_info.Emphasize t -> self#latex_of_Emphasize t + | Odoc_info.Center t -> self#latex_of_Center t + | Odoc_info.Left t -> self#latex_of_Left t + | Odoc_info.Right t -> self#latex_of_Right t + | Odoc_info.List tl -> self#latex_of_List tl + | Odoc_info.Enum tl -> self#latex_of_Enum tl + | Odoc_info.Newline -> self#latex_of_Newline + | Odoc_info.Block t -> self#latex_of_Block t + | Odoc_info.Title (n, l_opt, t) -> self#latex_of_Title n l_opt t + | Odoc_info.Latex s -> self#latex_of_Latex s + | Odoc_info.Link (s, t) -> self#latex_of_Link s t + | Odoc_info.Ref (name, ref_opt) -> self#latex_of_Ref name ref_opt + | Odoc_info.Superscript t -> self#latex_of_Superscript t + | Odoc_info.Subscript t -> self#latex_of_Subscript t + + method latex_of_Raw s = self#escape s + + method latex_of_Code s = + let s2 = self#escape_code s in + let s3 = Str.global_replace (Str.regexp "\n") ("\\\\\n") s2 in + "{\\tt{"^s3^"}}" + + method latex_of_CodePre s = + "\n\\begin{ocamldoccode}\n"^(self#escape_simple s)^"\n\\end{ocamldoccode}\n" + + method latex_of_Verbatim s = "\\begin{verbatim}"^s^"\\end{verbatim}" + + method latex_of_Bold t = + let s = self#latex_of_text t in + "{\\bf "^s^"}" + + method latex_of_Italic t = + let s = self#latex_of_text t in + "{\\it "^s^"}" + + method latex_of_Emphasize t = + let s = self#latex_of_text t in + "{\\em "^s^"}" + + method latex_of_Center t = + let s = self#latex_of_text t in + "\\begin{center}\n"^s^"\\end{center}\n" + + method latex_of_Left t = + let s = self#latex_of_text t in + "\\begin{flushleft}\n"^s^"\\end{flushleft}\n" + + method latex_of_Right t = + let s = self#latex_of_text t in + "\\begin{flushright}\n"^s^"\\end{flushright}\n" + + method latex_of_List tl = + "\\begin{itemize}"^ + (String.concat "" + (List.map (fun t -> "\\item "^(self#latex_of_text t)^"\n") tl))^ + "\\end{itemize}\n" + + method latex_of_Enum tl = + "\\begin{enumerate}"^ + (String.concat "" + (List.map (fun t -> "\\item "^(self#latex_of_text t)^"\n") tl))^ + "\\end{enumerate}\n" + + method latex_of_Newline = "\n\n" + + method latex_of_Block t = + let s = self#latex_of_text t in + "\\begin{ocamldocdescription}\n"^s^"\n\\end{ocamldocdescription}\n" + + method latex_of_Title n label_opt t = + let s_title = self#latex_of_text t in + let s_title2 = self#section_style n s_title in + s_title2^ + (match label_opt with + None -> "" + | Some l -> self#make_label l) + + method latex_of_Latex s = s + + method latex_of_Link s t = + let s1 = "\\url{"^s^"} " in + let s2 = self#latex_of_text t in + s1^s2 + + method latex_of_Ref name ref_opt = + match ref_opt with + None -> + self#latex_of_text_element + (Odoc_info.Code (Odoc_info.use_hidden_modules name)) + | Some kind when kind = RK_section -> + self#latex_of_text_element (Latex ("["^(self#make_ref (Name.simple name))^"]")) + | Some kind -> + let target = + match kind with + Odoc_info.RK_module + | Odoc_info.RK_module_type + | Odoc_info.RK_class + | Odoc_info.RK_class_type + | Odoc_info.RK_value + | Odoc_info.RK_type + | Odoc_info.RK_exception + | Odoc_info.RK_attribute + | Odoc_info.RK_method -> name + | Odoc_info.RK_section -> assert false + in + (self#latex_of_text + [ + Odoc_info.Code (Odoc_info.use_hidden_modules name) ; + Latex ("["^(self#make_ref name)^"]") + ] + ) + + method latex_of_Superscript t = "$^{"^(self#latex_of_text t)^"}$" + + method latex_of_Subscript t = "$_{"^(self#latex_of_text t)^"}$" + + 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 : Odoc_info.text -> string + + (** 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 + + (** Return LaTeX code for a description, except for the [i_params] field. *) + method latex_of_info info_opt = + self#latex_of_text + (self#text_of_info ~block: false info_opt) + end + +(** 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. + *) + 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 + (first, rest) + + (** Return LaTeX code for a value. *) + method latex_of_value v = + Odoc_info.reset_type_names () ; + self#latex_of_text + ((Latex (self#make_label v.val_name)) :: + (to_text#text_of_value v)) + + (** Return LaTeX code for a class attribute. *) + method latex_of_attribute a = + self#latex_of_text + ((Latex (self#make_label a.att_value.val_name)) :: + (to_text#text_of_attribute a)) + + (** Return LaTeX code for a class method. *) + method latex_of_method m = + self#latex_of_text + ((Latex (self#make_label m.met_value.val_name)) :: + (to_text#text_of_method m)) + + (** Return LaTeX code for a type. *) + method latex_of_type t = + let s_name = Name.simple t.ty_name in + let text = + Odoc_info.reset_type_names () ; + let mod_name = Name.father t.ty_name in + let s_type1 = + Format.fprintf Format.str_formatter + "@[<hov 2>type "; + match t.ty_parameters with + [] -> Format.flush_str_formatter () + | [p] -> self#normal_type mod_name p + | l -> + Format.fprintf Format.str_formatter "(" ; + let s = self#normal_type_list mod_name ", " l in + s^")" + in + Format.fprintf Format.str_formatter + ("@[<hov 2>%s %s") + s_type1 + s_name; + let s_type2 = + match t.ty_manifest with + None -> Format.flush_str_formatter () + | Some typ -> + Format.fprintf Format.str_formatter " = "; + self#normal_type mod_name typ + in + let s_type3 = + Format.fprintf Format.str_formatter + ("%s %s") + s_type2 + (match t.ty_kind with + Type_abstract -> "" + | Type_variant _ -> "=" + | Type_record _ -> "= {" ) ; + Format.flush_str_formatter () + in + + let defs = + match t.ty_kind with + Type_abstract -> [] + | Type_variant l -> + (List.flatten + (List.map + (fun constr -> + let s_cons = + Format.fprintf Format.str_formatter + "@[<hov 6> | %s" + constr.vc_name; + match constr.vc_args with + [] -> Format.flush_str_formatter () + | l -> + Format.fprintf Format.str_formatter " %s@ " "of"; + self#normal_type_list mod_name " * " l + in + [ CodePre s_cons ] @ + (match constr.vc_text with + None -> [] + | Some t -> + [ Latex + ("\\begin{ocamldoccomment}\n"^ + (self#latex_of_text t)^ + "\n\\end{ocamldoccomment}\n") + ] + ) + ) + l + ) + ) + | Type_record l -> + (List.flatten + (List.map + (fun r -> + let s_field = + Format.fprintf Format.str_formatter + "@[<hov 6> %s%s :@ " + (if r.rf_mutable then "mutable " else "") + r.rf_name; + (self#normal_type mod_name r.rf_type)^" ;" + in + [ CodePre s_field ] @ + (match r.rf_text with + None -> [] + | Some t -> + [ Latex + ("\\begin{ocamldoccomment}\n"^ + (self#latex_of_text t)^ + "\n\\end{ocamldoccomment}\n") + ] + ) + ) + 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 + ((Latex (self#make_label t.ty_name)) :: text) + + (** Return LaTeX code for an exception. *) + method latex_of_exception e = + Odoc_info.reset_type_names () ; + self#latex_of_text + ((Latex (self#make_label e.ex_name)) :: + (to_text#text_of_exception e)) + + (** Return the LaTeX code for the given module. *) + method latex_of_module ?(with_link=true) m = + let t = + [Code "module "] @ + [Code (Name.simple m.m_name)] @ + (self#text_of_module_kind m.m_kind) @ + ( + if with_link + then [Odoc_info.Latex ("\\\n["^(self#make_ref m.m_name)^"]")] + else [] + ) + in + self#latex_of_text t + + (** Return the LaTeX code for the given module type. *) + method latex_of_module_type ?(with_link=true) mt = + let t = + [Code "module type "] @ + [Code (Name.simple mt.mt_name)] @ + (match mt.mt_kind with + None -> [] + | Some k -> self#text_of_module_type_kind k + ) @ + ( + if with_link + then [Odoc_info.Latex ("\\\n["^(self#make_ref mt.mt_name)^"]")] + else [] + ) + in + self#latex_of_text t + + (** Return the LaTeX code for the given included module. *) + method latex_of_included_module im = + (self#latex_of_text [ Code "include module " ; + Code + (match im.im_module with + None -> im.im_name + | Some (Mod m) -> m.m_name + | Some (Modtype mt) -> mt.mt_name) + ] ) + + (** Return a well-formatted code string for the given [class_kind]. + This method uses [Format.str_formatter].*) + method pre_of_class_kind father acc ?(with_def_syntax=true) ckind = + let p = Format.fprintf in + let f = Format.str_formatter in + p f "%s%s" acc (if with_def_syntax then " = " else ""); + match ckind with + Class_structure _ -> + p f "%s" Odoc_messages.object_end ; + Format.flush_str_formatter () + + | Class_apply capp -> + p f "%s" + (match capp.capp_class with + None -> capp.capp_name + | Some cl -> cl.cl_name + ); + List.iter + (fun s -> p f " (%s)" s) + capp.capp_params_code; + Format.flush_str_formatter () + + | Class_constr cco -> + (match cco.cco_type_parameters with + [] -> () + | l -> + p f "["; + let s = self#normal_type_list father ", " l in + p f "%s] " s + ); + p f "%s" + (match cco.cco_class with + None -> cco.cco_name + | Some cl -> cl.cl_name + ); + Format.flush_str_formatter () + + | Class_constraint (ck, ctk) -> + p f "(" ; + let s = self#pre_of_class_kind father + (Format.flush_str_formatter ()) + ~with_def_syntax: false ck + in + p f "%s : " s; + let s2 = self#pre_of_class_type_kind father + (Format.flush_str_formatter ()) + ctk + in + p f "%s)" s2 ; + Format.flush_str_formatter () + + (** Return well-formatted string for the given [class_type_kind]. + This method uses [Format.str_formatter].*) + method pre_of_class_type_kind father acc ?def_syntax ctkind = + let p = Format.fprintf in + let f = Format.str_formatter in + p f "%s%s" acc + (match def_syntax with + None -> "" + | Some s -> " "^s^" "); + match ctkind with + Class_type cta -> + ( + match cta.cta_type_parameters with + [] -> () + | l -> + p f "[" ; + let s = self#normal_type_list father ", " l in + p f "%s] " s + ); + p f "%s" + ( + match cta.cta_class with + None -> cta.cta_name + | Some (Cltype (clt, _)) -> clt.clt_name + | Some (Cl cl) -> cl.cl_name + ); + Format.flush_str_formatter () + + | Class_signature _ -> + p f "%s" Odoc_messages.object_end ; + Format.flush_str_formatter () + + + (** Return the LaTeX code for the given class. *) + method latex_of_class ?(with_link=true) c = + Odoc_info.reset_type_names () ; + let father = Name.father c.cl_name in + let t = + let s = + Format.fprintf Format.str_formatter "class %s" + (if c.cl_virtual then "virtual " else ""); + ( + match c.cl_type_parameters with + [] -> () + | l -> + Format.fprintf Format.str_formatter "[" ; + let s1 = self#normal_type_list father ", " l in + Format.fprintf Format.str_formatter "%s] " s1 + ); + Format.fprintf Format.str_formatter "%s%s" + (Name.simple c.cl_name) + (match c.cl_parameters with [] -> "" | _ -> " ..."); + Format.flush_str_formatter () + in + (CodePre (self#pre_of_class_kind father s c.cl_kind)) :: + ( + if with_link + then [Odoc_info.Latex (" ["^(self#make_ref c.cl_name)^"]")] + else [] + ) + in + self#latex_of_text t + + (** Return the LaTeX code for the given class type. *) + method latex_of_class_type ?(with_link=true) ct = + Odoc_info.reset_type_names () ; + let father = Name.father ct.clt_name in + let t = + let s = + Format.fprintf Format.str_formatter "class type %s" + (if ct.clt_virtual then "virtual " else ""); + ( + match ct.clt_type_parameters with + [] -> () + | l -> + Format.fprintf Format.str_formatter "[" ; + let s1 = self#normal_type_list father ", " l in + Format.fprintf Format.str_formatter "%s] " s1 + ); + Format.fprintf Format.str_formatter "%s" (Name.simple ct.clt_name); + Format.flush_str_formatter () + in + (CodePre (self#pre_of_class_type_kind father s ~def_syntax: "=" ct.clt_kind)) :: + ( + if with_link + then [Odoc_info.Latex (" ["^(self#make_ref ct.clt_name)^"]")] + else [] + ) + in + self#latex_of_text t + + (** Return the LaTeX code for the given class element. *) + method latex_of_class_element class_name class_ele = + (self#latex_of_text [Newline])^ + ( + match class_ele with + Class_attribute att -> self#latex_of_attribute att + | Class_method met -> self#latex_of_method met + | Class_comment t -> + match t with + | [] -> "" + | (Title (_,_,_)) :: _ -> self#latex_of_text t + | _ -> self#latex_of_text [ Title ((Name.depth class_name) + 2, None, t) ] + ) + + (** Return the LaTeX code for the given module element. *) + method latex_of_module_element module_name module_ele = + (self#latex_of_text [Newline])^ + ( + match module_ele with + Element_module m -> self#latex_of_module m + | Element_module_type mt -> self#latex_of_module_type mt + | Element_included_module im -> self#latex_of_included_module im + | Element_class c -> self#latex_of_class c + | Element_class_type ct -> self#latex_of_class_type ct + | Element_value v -> self#latex_of_value v + | Element_exception e -> self#latex_of_exception e + | Element_type t -> self#latex_of_type t + | Element_module_comment t -> self#latex_of_text t + ) + + (** Generate the LaTeX 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 *) + (Odoc_info.Code inh.ic_name) :: + (match inh.ic_text with + None -> [] + | Some t -> Newline :: t + ) + | Some _ -> + (* we can create the reference *) + (Odoc_info.Code inh.ic_name) :: + (Odoc_info.Latex (" ["^(self#make_ref inh.ic_name)^"]")) :: + (match inh.ic_text with + None -> [] + | Some t -> Newline :: t + ) + in + let text = [ + Odoc_info.Bold [Odoc_info.Raw Odoc_messages.inherits ]; + Odoc_info.List (List.map f inher_l) + ] + in + let s = self#latex_of_text text in + output_string chanout s + + (** Generate the LaTeX code for the inherited classes of the given class. *) + method generate_class_inheritance_info chanout cl = + let rec iter_kind k = + match k with + 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 LaTeX 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 LaTeX code for the given class, in the given out channel. *) + method generate_for_class chanout c = + Odoc_info.reset_type_names () ; + let depth = Name.depth c.cl_name in + let (first_t, rest_t) = self#first_and_rest_of_info c.cl_info in + let text = [ Title (depth, None, [ Raw (Odoc_messages.clas^" ") ; Code c.cl_name ] @ + (match first_t with + [] -> [] + | t -> (Raw " : ") :: t)) ; + Latex (self#make_label c.cl_name) ; + ] + in + output_string chanout (self#latex_of_text text); + output_string chanout ((self#latex_of_class ~with_link: false c)^"\n\n") ; + let s_name = Name.simple c.cl_name in + output_string chanout + (self#latex_of_text [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")]); + output_string chanout (self#latex_of_text rest_t) ; + (* parameters *) + output_string chanout + (self#latex_of_text (self#text_of_parameter_list (Name.father c.cl_name) c.cl_parameters)); + + output_string chanout (self#latex_of_text [ Newline ] ); + output_string chanout ("\\vspace{0.5cm}\n\n"); + self#generate_class_inheritance_info chanout c; + + List.iter + (fun ele -> output_string chanout ((self#latex_of_class_element c.cl_name ele)^"\\vspace{0.1cm}\n\n")) + (Class.class_elements ~trans: false c) + + (** Generate the LaTeX code for the given class type, in the given out channel. *) + method generate_for_class_type chanout ct = + Odoc_info.reset_type_names () ; + let depth = Name.depth ct.clt_name in + let (first_t, rest_t) = self#first_and_rest_of_info ct.clt_info in + let text = [ Title (depth, None, [ Raw (Odoc_messages.class_type^" ") ; Code ct.clt_name ] @ + (match first_t with + [] -> [] + | t -> (Raw " : ") :: t)) ; + Latex (self#make_label ct.clt_name) ; + ] + in + + output_string chanout (self#latex_of_text text); + output_string chanout ((self#latex_of_class_type ~with_link: false ct)^"\n\n") ; + let s_name = Name.simple ct.clt_name in + output_string chanout + (self#latex_of_text [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")]); + output_string chanout ((self#latex_of_text rest_t)) ; + output_string chanout (self#latex_of_text [ Newline]) ; + output_string chanout ("\\vspace{0.5cm}\n\n"); + self#generate_class_type_inheritance_info chanout ct; + + List.iter + (fun ele -> output_string chanout ((self#latex_of_class_element ct.clt_name ele)^"\\vspace{0.1cm}\n\n")) + (Class.class_type_elements ~trans: false ct) + + (** Generate the LaTeX code for the given module type, in the given out channel. *) + method generate_for_module_type chanout mt = + let depth = Name.depth mt.mt_name in + let (first_t, rest_t) = self#first_and_rest_of_info mt.mt_info in + let text = [ Title (depth, None, + [ Raw (Odoc_messages.module_type^" ") ; Code mt.mt_name ] @ + (match first_t with + [] -> [] + | t -> (Raw " : ") :: t)) ; + Latex (self#make_label mt.mt_name) ; + ] + in + output_string chanout (self#latex_of_text text); + if depth > 1 then + output_string chanout ((self#latex_of_module_type ~with_link: false mt)^"\n\n"); + let s_name = Name.simple mt.mt_name in + output_string chanout + (self#latex_of_text [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")]); + output_string chanout (self#latex_of_text rest_t) ; + (* parameters *) + output_string chanout + (self#latex_of_text + (self#text_of_module_parameter_list + (Module.module_type_parameters mt))); + + output_string chanout (self#latex_of_text [ Newline ] ); + output_string chanout ("\\vspace{0.5cm}\n\n"); + List.iter + (fun ele -> output_string chanout ((self#latex_of_module_element mt.mt_name ele)^"\\vspace{0.1cm}\n\n")) + (Module.module_type_elements ~trans: false mt); + (* create sub parts for modules, module types, classes and class types *) + let rec iter ele = + match ele with + Element_module m -> self#generate_for_module chanout m + | Element_module_type mt -> self#generate_for_module_type chanout mt + | Element_class c -> self#generate_for_class chanout c + | Element_class_type ct -> self#generate_for_class_type chanout ct + | _ -> () + in + List.iter iter (Module.module_type_elements ~trans: false mt) + + (** Generate the LaTeX code for the given module, in the given out channel. *) + method generate_for_module chanout m = + let depth = Name.depth m.m_name in + let (first_t, rest_t) = self#first_and_rest_of_info m.m_info in + let text = [ Title (depth, None, + [ Raw (Odoc_messages.modul^" ") ; Code m.m_name ] @ + (match first_t with + [] -> [] + | t -> (Raw " : ") :: t)) ; + Latex (self#make_label m.m_name) ; + ] + in + output_string chanout (self#latex_of_text text); + if depth > 1 then + output_string chanout ((self#latex_of_module ~with_link: false m)^"\n\n"); + let s_name = Name.simple m.m_name in + output_string chanout + (self#latex_of_text [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")]); + output_string chanout (self#latex_of_text rest_t) ; + (* parameters *) + output_string chanout + (self#latex_of_text + (self#text_of_module_parameter_list + (Module.module_parameters m))); + + output_string chanout (self#latex_of_text [ Newline ]) ; + output_string chanout ("\\vspace{0.5cm}\n\n"); + List.iter + (fun ele -> output_string chanout ((self#latex_of_module_element m.m_name ele)^"\\vspace{0.1cm}\n\n")) + (Module.module_elements ~trans: false m); + (* create sub parts for modules, module types, classes and class types *) + let rec iter ele = + match ele with + Element_module m -> self#generate_for_module chanout m + | Element_module_type mt -> self#generate_for_module_type chanout mt + | Element_class c -> self#generate_for_class chanout c + | Element_class_type ct -> self#generate_for_class_type chanout ct + | _ -> () + in + List.iter iter (Module.module_elements ~trans: false m) + + (** Return the header of the TeX document. *) + method latex_header = + "\\documentclass[11pt]{article} \n"^ + "\\usepackage[latin1]{inputenc} \n"^ + "\\usepackage[T1]{fontenc} \n"^ + "\\usepackage{fullpage} \n"^ + "\\usepackage{url} \n"^ + "\\usepackage{ocamldoc}\n"^ + ( + match !Odoc_args.title with + None -> "" + | Some s -> "\\title{"^(self#escape s)^"}\n" + )^ + "\\begin{document}\n"^ + (match !Odoc_args.title with None -> "" | Some _ -> "\\maketitle\n")^ + (if !Odoc_args.with_toc then "\\tableofcontents\n" else "") + + (** Generate the [doc.tex] LaTeX file from a module list. *) + method generate module_list = + if !Odoc_args.separate_files then + ( + let f m = + try + let chanout = + open_out ((Filename.concat !Odoc_args.target_dir (Name.simple m.m_name))^".tex") + in + self#generate_for_module chanout m ; + 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 (Filename.concat !Odoc_args.target_dir "doc.tex") in + let _ = if !Odoc_args.with_header then output_string chanout self#latex_header else () in + List.iter + (fun m -> if !Odoc_args.separate_files then + output_string chanout ("\\input{"^((Name.simple m.m_name))^".tex}\n") + else + self#generate_for_module chanout m + ) + module_list ; + let _ = if !Odoc_args.with_trailer then output_string chanout "\\end{document}" else () in + close_out chanout + with + Failure s + | Sys_error s -> + prerr_endline s ; + incr Odoc_info.errors + end diff --git a/ocamldoc/odoc_lexer.mll b/ocamldoc/odoc_lexer.mll new file mode 100644 index 000000000..3d34f2789 --- /dev/null +++ b/ocamldoc/odoc_lexer.mll @@ -0,0 +1,407 @@ +{ +(***********************************************************************) +(* 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 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_args.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_abs_pos <- lexbuf.Lexing.lex_abs_pos - len; + lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - len; + lexbuf.Lexing.lex_last_pos <- lexbuf.Lexing.lex_last_pos - 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_args.remove_stars then + remove_stars !description + else + !description + in + let remain = lecture_string () in + let remain2 = + if !Odoc_args.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 + | "deprecated" -> + T_DEPRECATED + | "raise" -> + T_RAISES + | "return" -> + T_RETURN + | s -> + if !Odoc_args.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 s2 = remove_blanks s in + print_DEBUG2 ("Desc "^s2); + Desc s2 + } + | 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/ocamldoc/odoc_man.ml b/ocamldoc/odoc_man.ml new file mode 100644 index 000000000..d295559d3 --- /dev/null +++ b/ocamldoc/odoc_man.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. *) +(* *) +(***********************************************************************) + + +(** The man pages generator. *) +open Odoc_info +open Parameter +open Value +open Type +open Exception +open Class +open Module +open Search + + +(** 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 : Odoc_info.text -> string + + (** Groff string for an author list. *) + method man_of_author_list l = + match l with + [] -> + "" + | _ -> + ".B \""^Odoc_messages.authors^"\"\n:\n"^ + (String.concat ", " l)^ + "\n.sp\n" + + (** Groff string for the given optional version information.*) + method man_of_version_opt v_opt = + match v_opt with + None -> "" + | Some v -> ".B \""^Odoc_messages.version^"\"\n:\n"^v^"\n.sp\n" + + (** Groff string for the given optional since information.*) + method man_of_since_opt s_opt = + match s_opt with + None -> "" + | Some s -> ".B \""^Odoc_messages.since^"\"\n"^s^"\n.sp\n" + + (** Groff string for the given list of raised exceptions.*) + method man_of_raised_exceptions l = + match l with + [] -> "" + | (s, t) :: [] -> ".B \""^Odoc_messages.raises^" "^s^"\"\n"^(self#man_of_text t)^"\n.sp\n" + | _ -> + ".B \""^Odoc_messages.raises^"\"\n"^ + (String.concat "" + (List.map + (fun (ex, desc) -> ".TP\n.B \""^ex^"\"\n"^(self#man_of_text desc)^"\n") + l + ) + )^"\n.sp\n" + + (** Groff string for the given "see also" reference. *) + method man_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 + self#man_of_text t_ref + + (** Groff string for the given list of "see also" references.*) + method man_of_sees l = + match l with + [] -> "" + | see :: [] -> ".B \""^Odoc_messages.see_also^"\"\n"^(self#man_of_see see)^"\n.sp\n" + | _ -> + ".B \""^Odoc_messages.see_also^"\"\n"^ + (String.concat "" + (List.map + (fun see -> ".TP\n \"\"\n"^(self#man_of_see see)^"\n") + l + ) + )^"\n.sp\n" + + (** Groff string for the given optional return information.*) + method man_of_return_opt return_opt = + match return_opt with + None -> "" + | Some s -> ".B "^Odoc_messages.returns^"\n"^(self#man_of_text s)^"\n.sp\n" + + (** Return man code for the given list of custom tagged texts. *) + method man_of_custom 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; + Buffer.contents buf + + (** Return the groff string to display an optional info structure. *) + method man_of_info info_opt = + match info_opt with + None -> + "" + | Some info -> + let module M = Odoc_info in + (match info.M.i_deprecated with + None -> "" + | Some d -> ".B \""^Odoc_messages.deprecated^"\"\n"^(self#man_of_text d)^"\n.sp\n")^ + (match info.M.i_desc with + None -> "" + | Some d when d = [Odoc_info.Raw ""] -> "" + | Some d -> (self#man_of_text d)^"\n.sp\n" + )^ + (self#man_of_author_list info.M.i_authors)^ + (self#man_of_version_opt info.M.i_version)^ + (self#man_of_since_opt info.M.i_since)^ + (self#man_of_raised_exceptions info.M.i_raised_exceptions)^ + (self#man_of_return_opt info.M.i_return_value)^ + (self#man_of_sees info.M.i_sees)^ + (self#man_of_custom info.M.i_custom) + end + +(** This class is used to create objects which can generate a simple html documentation. *) +class man = + object (self) + inherit info + + (** Get a file name from a module or class complete name. *) + method file_name name = name^".man" + + (** Escape special sequences of characters in a string. *) + method escape (s : string) = s + + (** Open a file for output. Add the target directory.*) + method open_out file = + let f = Filename.concat !Odoc_args.target_dir file in + open_out f + + (** Return the groff string for a text, without correction of blanks. *) + method private man_of_text2 t = String.concat "" (List.map self#man_of_text_element t) + + (** Return the groff string for a text, with blanks corrected. *) + method man_of_text t = + let s = self#man_of_text2 t in + let s2 = Str.global_replace (Str.regexp "\n[ ]*") "\n" s in + Str.global_replace (Str.regexp "\n\n") "\n" s2 + + (** Return the groff string for a text element. *) + method man_of_text_element te = + match te with + | Odoc_info.Raw s -> s + | Odoc_info.Code s -> + let s2 = "\n.B "^(Str.global_replace (Str.regexp "\n") "\n.B " (self#escape s))^"\n" in + s2 + | Odoc_info.CodePre s -> + let s2 = "\n.B "^(Str.global_replace (Str.regexp "\n") "\n.B " (self#escape s))^"\n" in + s2 + | Odoc_info.Verbatim s -> 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 t + | Odoc_info.List tl -> + (String.concat "" + (List.map + (fun t -> ".TP\n \"\"\n"^(self#man_of_text2 t)^"\n") + tl + ) + )^"\n" + | Odoc_info.Enum tl -> + (String.concat "" + (List.map + (fun t -> ".TP\n \"\"\n"^(self#man_of_text2 t)^"\n") + tl + ) + )^"\n" + | Odoc_info.Newline -> + "\n.sp\n" + | Odoc_info.Block t -> + "\n.sp\n"^(self#man_of_text2 t)^"\n.sp\n" + | Odoc_info.Title (n, l_opt, t) -> + self#man_of_text2 [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 t + | Odoc_info.Ref (name, _) -> + self#man_of_text_element + (Odoc_info.Code (Odoc_info.use_hidden_modules name)) + | Odoc_info.Superscript t -> + "^{"^(self#man_of_text2 t) + | Odoc_info.Subscript t -> + "_{"^(self#man_of_text2 t) + + (** Groff string to display code. *) + method man_of_code s = self#man_of_text [ 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 + + (** Groff string to display a [Types.type_expr].*) + method man_of_type_expr m_name t = + let s = String.concat "\n" + (Str.split (Str.regexp "\n") (Odoc_misc.string_of_type_expr t)) + in + let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in + "\n.B "^(self#relative_idents m_name s2)^"\n" + + (** Groff string to display a [Types.type_expr list].*) + method man_of_type_expr_list m_name sep l = + let s = Odoc_misc.string_of_type_list sep l in + let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in + "\n.B "^(self#relative_idents m_name s2)^"\n" + + (** Groff string to display a [Types.module_type]. *) + method man_of_module_type m_name t = + let s = String.concat "\n" + (Str.split (Str.regexp "\n") (Odoc_misc.string_of_module_type t)) + in + let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in + "\n.B "^(self#relative_idents m_name s2)^"\n" + + (** Groff string code for a value. *) + method man_of_value v = + Odoc_info.reset_type_names () ; + "\n.I val "^(Name.simple v.val_name)^" \n: "^ + (self#man_of_type_expr (Name.father v.val_name) v.val_type)^ + ".sp\n"^ + (self#man_of_info v.val_info)^ + "\n.sp\n" + + (** Groff string code for an exception. *) + method man_of_exception e = + Odoc_info.reset_type_names () ; + "\n.I exception "^(Name.simple e.ex_name)^" \n"^ + (match e.ex_args with + [] -> "" + | _ -> + ".B of "^ + (self#man_of_type_expr_list (Name.father e.ex_name) " * " e.ex_args) + )^ + (match e.ex_alias with + None -> "" + | Some ea -> " = "^ + ( + match ea.ea_ex with + None -> ea.ea_name + | Some e -> e.ex_name + ) + )^ + "\n.sp\n"^ + (self#man_of_info e.ex_info)^ + "\n.sp\n" + + (** Groff string for a type. *) + method man_of_type t = + Odoc_info.reset_type_names () ; + let father = Name.father t.ty_name in + ".I type "^ + (match t.ty_parameters with + [] -> "" + | tp :: [] -> (Odoc_misc.string_of_type_expr tp) + | l -> + (self#man_of_type_expr_list father ", " l) + )^ + (match t.ty_parameters with [] -> "" | _ -> ".I ")^(Name.simple t.ty_name)^" \n"^ + (match t.ty_manifest with None -> "" | Some typ -> "= "^(self#man_of_type_expr father typ))^ + (match t.ty_kind with + Type_abstract -> + "" + | Type_variant l -> + "=\n "^ + (String.concat "" + (List.map + (fun constr -> + "| "^constr.vc_name^ + (match constr.vc_args, constr.vc_text with + [], None -> "\n " + | [], (Some t) -> " (* "^(self#man_of_text t)^" *)\n " + | l, None -> + "\n.B of "^(self#man_of_type_expr_list father " * " l)^" " + | l, (Some t) -> + "\n.B of "^(self#man_of_type_expr_list father " * " l)^ + ".I \" \"\n"^ + "(* "^(self#man_of_text t)^" *)\n " + ) + ) + l + ) + ) + | Type_record l -> + "= {"^ + (String.concat "" + (List.map + (fun r -> + (if r.rf_mutable then "\n\n.B mutable \n" else "\n ")^ + r.rf_name^" : "^(self#man_of_type_expr father r.rf_type)^";"^ + (match r.rf_text with + None -> + "" + | Some t -> + " (* "^(self#man_of_text t)^" *) " + )^"" + ) + l + ) + )^ + "\n }\n" + )^ + "\n.sp\n"^(self#man_of_info t.ty_info)^ + "\n.sp\n" + + (** Groff string for a class attribute. *) + method man_of_attribute a = + ".I val "^ + (if a.att_mutable then Odoc_messages.mutab^" " else "")^ + (Name.simple a.att_value.val_name)^" : "^ + (self#man_of_type_expr (Name.father a.att_value.val_name) a.att_value.val_type)^ + "\n.sp\n"^(self#man_of_info a.att_value.val_info)^ + "\n.sp\n" + + (** Groff string for a class method. *) + method man_of_method m = + ".I method "^ + (if m.met_private then "private " else "")^ + (if m.met_virtual then "virtual " else "")^ + (Name.simple m.met_value.val_name)^" : "^ + (self#man_of_type_expr (Name.father m.met_value.val_name) m.met_value.val_type)^ + "\n.sp\n"^(self#man_of_info m.met_value.val_info)^ + "\n.sp\n" + + (** Groff for a list of parameters. *) + method man_of_parameter_list m_name l = + match l with + [] -> + "" + | _ -> + "\n.B "^Odoc_messages.parameters^": \n"^ + (String.concat "" + (List.map + (fun p -> + ".TP\n"^ + "\""^(Parameter.complete_name p)^"\"\n"^ + (self#man_of_type_expr m_name (Parameter.typ p))^"\n"^ + (self#man_of_parameter_description p)^"\n" + ) + l + ) + )^"\n" + + (** Groff for the description of a function parameter. *) + method man_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 -> "\n "^(self#man_of_text t) + ) + | l -> + (* A list of names, we display those with a description. *) + String.concat "" + (List.map + (fun n -> + match Parameter.desc_by_name p n with + None -> "" + | Some t -> (self#man_of_code (n^" : "))^(self#man_of_text t) + ) + l + ) + + (** Groff string for a list of module parameters. *) + method man_of_module_parameter_list m_name l = + match l with + [] -> + "" + | _ -> + ".B \""^Odoc_messages.parameters^":\"\n"^ + (String.concat "" + (List.map + (fun (p, desc_opt) -> + ".TP\n"^ + "\""^p.mp_name^"\"\n"^ + (self#man_of_module_type m_name p.mp_type)^"\n"^ + (match desc_opt with + None -> "" + | Some t -> self#man_of_text t)^ + "\n" + ) + l + ) + )^"\n\n" + + (** Groff string for a [class_kind]. *) + method man_of_class_kind ?(with_def_syntax=true) ckind = + match ckind with + Class_structure _ -> + (if with_def_syntax then " = " else "")^ + (self#man_of_code Odoc_messages.object_end) + + | Class_apply capp -> + (if with_def_syntax then " = " else "")^ + ( + match capp.capp_class with + None -> capp.capp_name + | Some cl -> cl.cl_name + )^ + " "^ + (String.concat " " + (List.map + (fun s -> self#man_of_code ("("^s^")")) + capp.capp_params_code)) + + | Class_constr cco -> + (if with_def_syntax then " = " else "")^ + ( + match cco.cco_type_parameters with + [] -> "" + | l -> "["^(Odoc_misc.string_of_type_list ", " l)^"] " + )^ + ( + match cco.cco_class with + None -> cco.cco_name + | Some cl -> cl.cl_name^" " + ) + | Class_constraint (ck, ctk) -> + (if with_def_syntax then " = " else "")^ + "( "^(self#man_of_class_kind ~with_def_syntax: false ck)^ + " : "^ + (self#man_of_class_type_kind ctk)^ + " )" + + (** Groff string for the given [class_type_kind].*) + method man_of_class_type_kind ?def_syntax ctkind = + match ctkind with + Class_type cta -> + (match def_syntax with + None -> "" + | Some s -> " "^s^" ")^ + ( + match cta.cta_class with + None -> cta.cta_name + | Some (Cltype (clt, _)) -> clt.clt_name + | Some (Cl cl) -> cl.cl_name + ) + | Class_signature _ -> + (match def_syntax with + None -> "" + | Some s -> " "^s^" ")^ + (self#man_of_code Odoc_messages.object_end) + + (** Groff string for a [module_kind]. *) + method man_of_module_kind ?(with_def_syntax=true) k = + match k with + Module_alias m_alias -> + (match m_alias.ma_module with + None -> + (if with_def_syntax then " = " else "")^ + m_alias.ma_name + | Some (Mod m) -> + (if with_def_syntax then " = " else "")^m.m_name + | Some (Modtype mt) -> + (if with_def_syntax then " : " else "")^mt.mt_name + ) + | Module_apply (k1, k2) -> + (if with_def_syntax then " = " else "")^ + (self#man_of_module_kind ~with_def_syntax: false k1)^ + " ( "^(self#man_of_module_kind ~with_def_syntax: false k2)^" ) " + + | Module_with (tk, code) -> + (if with_def_syntax then " : " else "")^ + (self#man_of_module_type_kind ~with_def_syntax: false tk)^ + (self#man_of_code code) + + | Module_constraint (k, tk) -> + (if with_def_syntax then " = " else "")^ + "( "^(self#man_of_module_kind ~with_def_syntax: false k)^" : "^ + (self#man_of_module_type_kind ~with_def_syntax: false tk)^" )" + + | Module_struct _ -> + (if with_def_syntax then " = " else "")^ + (self#man_of_code (Odoc_messages.struct_end^" ")) + + | Module_functor _ -> + (if with_def_syntax then " = " else "")^ + (self#man_of_code "functor ... ") + + (** Groff string for a [module_type_kind]. *) + method man_of_module_type_kind ?(with_def_syntax=true) tk = + match tk with + | Module_type_struct _ -> + (if with_def_syntax then " : " else "")^ + (self#man_of_code Odoc_messages.sig_end) + + | Module_type_functor (params, k) -> + let f p = "("^p.mp_name^" : "^(self#man_of_module_type "" p.mp_type)^") -> " in + let s1 = String.concat "" (List.map f params) in + let s2 = self#man_of_module_type_kind ~with_def_syntax: false k in + (if with_def_syntax then " : " else "")^s1^s2 + + | Module_type_with (tk2, code) -> (* we don't want to print nested with's *) + let s = self#man_of_module_type_kind ~with_def_syntax: false tk2 in + (if with_def_syntax then " : " else "")^ + s^(self#man_of_code code) + + | Module_type_alias mt_alias -> + (if with_def_syntax then " : " else "")^ + (match mt_alias.mta_module with + None -> + mt_alias.mta_name + | Some mt -> + mt.mt_name + ) + + (** Groff string for a class. *) + method man_of_class c = + Odoc_info.reset_type_names () ; + ".I class "^ + (if c.cl_virtual then "virtual " else "")^ + ( + match c.cl_type_parameters with + [] -> "" + | l -> "["^(Odoc_misc.string_of_type_list ", " l)^".I ] " + )^ + (Name.simple c.cl_name)^ + (match c.cl_parameters with [] -> "" | _ -> " ... ")^ + (self#man_of_class_kind c.cl_kind)^ + "\n.sp\n"^(self#man_of_info c.cl_info)^"\n.sp\n" + + (** Groff string for a class type. *) + method man_of_class_type ct = + Odoc_info.reset_type_names () ; + ".I class type "^ + (if ct.clt_virtual then "virtual " else "")^ + ( + match ct.clt_type_parameters with + [] -> "" + | l -> "["^(Odoc_misc.string_of_type_list ", " l)^".I ] " + )^ + (Name.simple ct.clt_name)^ + (self#man_of_class_type_kind ~def_syntax: ":" ct.clt_kind)^ + "\n.sp\n"^(self#man_of_info ct.clt_info)^"\n.sp\n" + + (** Groff string for a module. *) + method man_of_module m = + ".I module "^(Name.simple m.m_name)^ + (self#man_of_module_kind m.m_kind)^ + "\n.sp\n"^(self#man_of_info m.m_info)^"\n.sp\n" + + (** Groff string for a module type. *) + method man_of_modtype mt = + ".I module type "^(Name.simple mt.mt_name)^ + (match mt.mt_kind with None -> "" | Some k -> self#man_of_module_type_kind k)^ + "\n.sp\n"^(self#man_of_info mt.mt_info)^"\n.sp\n" + + (** Groff string for a module comment.*) + method man_of_module_comment text = + "\n.pp\n"^ + (self#man_of_text [Code ("=== "^(Odoc_misc.string_of_text text)^" ===")])^ + "\n.pp\n" + + (** Groff string for a class comment.*) + method man_of_class_comment text = + "\n.pp\n"^ + (self#man_of_text [Code ("=== "^(Odoc_misc.string_of_text text)^" ===")])^ + "\n.pp\n" + + (** Groff string for an included module. *) + method man_of_included_module m_name im = + ".I include "^ + ( + match im.im_module with + None -> im.im_name + | Some mmt -> + let name = + match mmt with + Mod m -> m.m_name + | Modtype mt -> mt.mt_name + in + self#relative_idents m_name name + )^ + "\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 + output_string chanout + (".TH \""^Odoc_messages.clas^"\" "^ + cl.cl_name^" "^ + "\""^(Odoc_misc.string_of_date ~hour: false date)^"\" "^ + "Odoc "^ + "\""^(match !Odoc_args.title with Some t -> t | None -> "")^"\n"); + + output_string chanout + ( + ".SH "^Odoc_messages.clas^"\n"^ + Odoc_messages.clas^" "^cl.cl_name^"\n"^ + ".SH "^Odoc_messages.documentation^"\n"^ + ".sp\n"^ + Odoc_messages.clas^"\n"^ + (if cl.cl_virtual then ".B virtual \n" else "")^ + ".B \""^(Name.simple cl.cl_name)^"\"\n"^ + (self#man_of_class_kind cl.cl_kind )^ + "\n.sp\n"^ + (self#man_of_info cl.cl_info)^"\n"^ + ".sp\n" + ); + + (* parameters *) + output_string chanout + (self#man_of_parameter_list "" cl.cl_parameters); + (* a large blank *) + output_string chanout "\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 -> + output_string chanout (self#man_of_attribute a) + | Class_method m -> + output_string chanout (self#man_of_method m) + | Class_comment t -> + output_string chanout (self#man_of_class_comment t) + ) + (Class.class_elements cl); + + 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 + output_string chanout + (".TH \""^Odoc_messages.class_type^"\" "^ + ct.clt_name^" "^ + "\""^(Odoc_misc.string_of_date ~hour: false date)^"\" "^ + "Odoc "^ + "\""^(match !Odoc_args.title with Some t -> t | None -> "")^"\n"); + + output_string chanout + ( + ".SH "^Odoc_messages.class_type^"\n"^ + Odoc_messages.class_type^" "^ct.clt_name^"\n"^ + ".SH "^Odoc_messages.documentation^"\n"^ + ".sp\n"^ + Odoc_messages.class_type^"\n"^ + (if ct.clt_virtual then ".B virtual \n" else "")^ + ".B \""^(Name.simple ct.clt_name)^"\"\n"^ + (self#man_of_class_type_kind ~def_syntax: ":" ct.clt_kind )^ + "\n.sp\n"^ + (self#man_of_info ct.clt_info)^"\n"^ + ".sp\n" + ); + (* a large blank *) + output_string chanout "\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 -> + output_string chanout (self#man_of_attribute a) + | Class_method m -> + output_string chanout (self#man_of_method m) + | Class_comment t -> + output_string chanout (self#man_of_class_comment t) + ) + (Class.class_type_elements ct); + + 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 + output_string chanout + (".TH \""^Odoc_messages.module_type^"\" "^ + mt.mt_name^" "^ + "\""^(Odoc_misc.string_of_date ~hour: false date)^"\" "^ + "Odoc "^ + "\""^(match !Odoc_args.title with Some t -> t | None -> "")^"\n"); + + output_string chanout + ( + ".SH "^Odoc_messages.module_type^"\n"^ + Odoc_messages.module_type^" "^mt.mt_name^"\n"^ + ".SH "^Odoc_messages.documentation^"\n"^ + ".sp\n"^ + Odoc_messages.module_type^"\n"^ + ".BI \""^(Name.simple mt.mt_name)^"\"\n"^ + (match mt.mt_kind with None -> "" | Some k -> self#man_of_module_type_kind k)^ + "\n.sp\n"^ + (self#man_of_info mt.mt_info)^"\n"^ + ".sp\n" + ); + + (* parameters for functors *) + output_string chanout + (self#man_of_module_parameter_list "" (Module.module_type_parameters mt)); + (* a large blank *) + output_string chanout "\n.sp\n.sp\n"; + + (* module elements *) + List.iter + (fun ele -> + match ele with + Element_module m -> + output_string chanout (self#man_of_module m) + | Element_module_type mt -> + output_string chanout (self#man_of_modtype mt) + | Element_included_module im -> + output_string chanout (self#man_of_included_module mt.mt_name im) + | Element_class c -> + output_string chanout (self#man_of_class c) + | Element_class_type ct -> + output_string chanout (self#man_of_class_type ct) + | Element_value v -> + output_string chanout (self#man_of_value v) + | Element_exception e -> + output_string chanout (self#man_of_exception e) + | Element_type t -> + output_string chanout (self#man_of_type t) + | Element_module_comment text -> + output_string chanout (self#man_of_module_comment text) + ) + (Module.module_type_elements mt); + + 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 + output_string chanout + (".TH \""^Odoc_messages.modul^"\" "^ + m.m_name^" "^ + "\""^(Odoc_misc.string_of_date ~hour: false date)^"\" "^ + "Odoc "^ + "\""^(match !Odoc_args.title with Some t -> t | None -> "")^"\n"); + + output_string chanout + ( + ".SH "^Odoc_messages.modul^"\n"^ + Odoc_messages.modul^" "^m.m_name^"\n"^ + ".SH "^Odoc_messages.documentation^"\n"^ + ".sp\n"^ + Odoc_messages.modul^"\n"^ + ".BI \""^(Name.simple m.m_name)^"\"\n"^ + (self#man_of_module_kind m.m_kind)^ + "\n.sp\n"^ + (self#man_of_info m.m_info)^"\n"^ + ".sp\n" + ); + + (* parameters for functors *) + output_string chanout + (self#man_of_module_parameter_list "" (Module.module_parameters m)); + (* a large blank *) + output_string chanout "\n.sp\n.sp\n"; + + (* module elements *) + List.iter + (fun ele -> + match ele with + Element_module m -> + output_string chanout (self#man_of_module m) + | Element_module_type mt -> + output_string chanout (self#man_of_modtype mt) + | Element_included_module im -> + output_string chanout (self#man_of_included_module m.m_name im) + | Element_class c -> + output_string chanout (self#man_of_class c) + | Element_class_type ct -> + output_string chanout (self#man_of_class_type ct) + | Element_value v -> + output_string chanout (self#man_of_value v) + | Element_exception e -> + output_string chanout (self#man_of_exception e) + | Element_type t -> + output_string chanout (self#man_of_type t) + | Element_module_comment text -> + output_string chanout (self#man_of_module_comment text) + ) + (Module.module_elements m); + + 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 s -> 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 + output_string chanout + (".TH \""^name^"\" "^ + "man "^ + "\""^(Odoc_misc.string_of_date ~hour: false date)^"\" "^ + "Odoc "^ + "\""^(match !Odoc_args.title with Some t -> t | None -> "")^"\n"); + + let f ele = + match ele with + Res_value v -> + output_string chanout + ("\n.SH "^Odoc_messages.modul^" "^(Name.father v.val_name)^"\n"^ + (self#man_of_value v)) + | Res_type t -> + output_string chanout + ("\n.SH "^Odoc_messages.modul^" "^(Name.father t.ty_name)^"\n"^ + (self#man_of_type t)) + | Res_exception e -> + output_string chanout + ("\n.SH "^Odoc_messages.modul^" "^(Name.father e.ex_name)^"\n"^ + (self#man_of_exception e)) + | Res_attribute a -> + output_string chanout + ("\n.SH "^Odoc_messages.clas^" "^(Name.father a.att_value.val_name)^"\n"^ + (self#man_of_attribute a)) + | Res_method m -> + output_string chanout + ("\n.SH "^Odoc_messages.clas^" "^(Name.father m.met_value.val_name)^"\n"^ + (self#man_of_method m)) + | Res_class c -> + output_string chanout + ("\n.SH "^Odoc_messages.modul^" "^(Name.father c.cl_name)^"\n"^ + (self#man_of_class c)) + | Res_class_type ct -> + output_string chanout + ("\n.SH "^Odoc_messages.modul^" "^(Name.father ct.clt_name)^"\n"^ + (self#man_of_class_type ct)) + | _ -> + (* normalement on ne peut pas avoir de module ici. *) + () + in + List.iter f l; + 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 -> + self#generate_for_group l + in + List.iter f groups + end diff --git a/ocamldoc/odoc_merge.ml b/ocamldoc/odoc_merge.ml new file mode 100644 index 000000000..aa01c77d3 --- /dev/null +++ b/ocamldoc/odoc_merge.ml @@ -0,0 +1,935 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + +(** 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 + +(** 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_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_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 } ; + 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_args.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_args.inverse_merge_ml_mli then + () + else + raise (Failure (Odoc_messages.different_types mli.ty_name)) + in + List.iter f l1 + + | _ -> + if !Odoc_args.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_args.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_args.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_args.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_args.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 } ; + 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 + ( + 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_args.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 } ; + (* More dependencies in the .ml file. *) + mli.m_top_deps <- ml.m_top_deps ; + (* 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 } ; + 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 + ( + 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_args.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_args.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_args.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_args.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/ocamldoc/odoc_merge.mli b/ocamldoc/odoc_merge.mli new file mode 100644 index 000000000..44e89ee61 --- /dev/null +++ b/ocamldoc/odoc_merge.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. *) +(* *) +(***********************************************************************) + + +(** Merge of information from [.ml] and [.mli] for a module.*) + +(** 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/ocamldoc/odoc_messages.ml b/ocamldoc/odoc_messages.ml new file mode 100644 index 000000000..3a05e1603 --- /dev/null +++ b/ocamldoc/odoc_messages.ml @@ -0,0 +1,292 @@ +(***********************************************************************) +(* 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 messages of the application. *) + +let ok = "Ok" +let software = "OCamldoc" +let version = "3.04-Pre4" +let message_version = software^" "^version + +(** Messages for command line *) + +let usage = "Usage : "^(Sys.argv.(0))^" [options] <files>\n" +let options_are = "Options are :" +let option_version = " Print version and exit" +let latex_only = "(LaTeX only)" +let html_only = "(HTML only)" +let iso_only = "(ISO only)" +let verbose_mode = " verbose mode" +let include_dirs = "<dir> Add <dir> to the list of include directories" +let rectypes = " Allow arbitrary recursive types" +let preprocess = "<command> Pipe sources through preprocessor <command>" +let load_file = "<file.cm[o|a]> Load file defining a new documentation generator" +let nolabels = " Ignore non-optional labels in types" +let werr = "Treat ocamldoc warnings as errors" +let target_dir = "<dir> Generate files in directory <dir>, rather than in current directory" +let dump = "<file> Dump collected information into <file>" +let load = "<file> Load information from <file> ; may be used several times" +let css_style = "<file> Use content of <file> as CSS style definition "^html_only +let index_only = " Generate index files only "^html_only +let colorize_code = "Colorize code even in documentation pages "^html_only +let generate_html = " Generate HTML documentation" +let generate_latex = " Generate LaTeX documentation" +let generate_man = " Generate man pages" +let generate_iso = " Generate boring check report" + +let generate_dot = " Generate dot code of top modules dependencies" +let default_dot_file = "dep.dot" +let dot_file = "<file> Set the file to use to output the dot code "^ + "(default is "^default_dot_file^")" +let dot_include_all = " include all modules in the dot output,\n"^ + " not only the modules given on the command line" +let dot_types = " generate 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> use colors c1,c1,...,cn in the dot output\n"^ + " (default list is "^(String.concat "," default_dot_colors)^")" +let dot_reduce = " perform a transitive reduction on the selected dependency graph before the dot output\n" + +let option_title = "<title> use <title> as title for the generated documentation" +let with_parameter_list = " display the complete list of parameters for functions and methods "^html_only +let hide_modules = " <M1,M2.M3,...> Hide the given complete module names in generated doc" +let no_header = " Suppress header in generated documentation "^latex_only +let no_trailer = " Suppress trailer in generated documentation "^latex_only +let separate_files = " Generate one file per toplevel module "^latex_only +let latex_title ref_titles = + "n,style associate {n } to the given sectionning style\n"^ + " (e.g. 'section') in the latex output "^latex_only^"\n"^ + " Default sectionning is:\n"^ + (String.concat "\n" + (List.map (fun (n,t) -> Printf.sprintf " %d -> %s" n t) !ref_titles)) + +let no_toc = " Do not generate table of contents "^latex_only +let sort_modules = " Sort the list of top modules before generating the documentation" +let no_stop = " Do not stop at (**/**) comments" +let no_custom_tags = " Do not allow custom @-tags" +let remove_stars = " Remove beginning blanks of comment lines, until the first '*'" +let keep_code = " Always keep code when available" +let inverse_merge_ml_mli = "Inverse implementations and interfaces when merging" +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 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 "^(String.make 1 c)^" "^m) + "" + l + +let merge_options = + "<options> specify merge options between .mli and .ml\n"^ + 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 ] + ) + +let iso_description = 'd', "description is mandatory" +let iso_author = 'a', "author information is mandatory" +let iso_since = 's', "@since tag is mandatory" +let iso_version = 'v', "@version tag is mandatory" +let iso_return = 'r', "@return tag is mandatory" +let iso_params = 'p', "all named parameters must be described" +let iso_fields_described = 'f', "All fields of a record type must be described" +let iso_constructors_described = 'c', "All constructors of a type must be described" +let iso_all = 'A', "all iso checks" +let iso_base_option_list = [ iso_description ; iso_author ; iso_version ; iso_since ; iso_all ] +let iso_type_options = + "<options> specify iso checks to perform on each type "^iso_only^"\n"^ + options_can_be^ + (string_of_options_list ([iso_fields_described ; iso_constructors_described] @ iso_base_option_list)) +let iso_val_met_att_options = + "<options> specify iso checks to perform on each value, method or attribute "^iso_only^"\n"^ + options_can_be^ + (string_of_options_list (iso_params :: iso_return :: iso_base_option_list )) +let iso_exception_options = + "<options> specify iso checks to perform on each exception "^iso_only^"\n"^ + options_can_be^ + (string_of_options_list iso_base_option_list) +let iso_class_options = + "<options> specify iso checks to perform on each class and class type "^iso_only^"\n"^ + options_can_be^ + (string_of_options_list (iso_params :: iso_base_option_list)) +let iso_module_options = + "<options> specify iso checks to perform on each module and module type "^iso_only^"\n"^ + options_can_be^ + (string_of_options_list iso_base_option_list) + + +(** Error and warning messages *) + +let warning = "Warning" +let pwarning s = + prerr_endline (warning^": "^s); + if !Odoc_global.warn_error then incr Odoc_global.errors + +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^"\n" +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 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 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 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 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^"..." + +(** 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 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" + +(** iso report messages *) + +let has_no_description n = n^" has no description." +let has_no_author n = n^" has no author." +let has_no_since n = n^" has no @since tag." +let has_no_version n = n^" has no @version tag." +let has_no_return n = n^" has no @return tag." +let has_not_all_params_described n = n^" has not all its parameters described." +let has_not_all_fields_described n = n^" has not all its fields described." +let has_not_all_cons_described n = n^" has not all its constructors described." + +let value_n n = "Value "^n +let type_n n = "Type "^n +let exception_n n = "Exception "^n +let attribute_n n = "Attribute "^n +let method_n n = "Method "^n +let class_n n = "Class "^n +let class_type_n n = "Class type "^n +let module_n n = "Module "^n +let module_type_n n = "Module type "^n diff --git a/ocamldoc/odoc_misc.ml b/ocamldoc/odoc_misc.ml new file mode 100644 index 000000000..c2e739117 --- /dev/null +++ b/ocamldoc/odoc_misc.ml @@ -0,0 +1,342 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + + +let input_file_as_string nom = + let chanin = open_in nom in + let buf = Buffer.create 80 in + let rec iter () = + try + Buffer.add_string buf ((input_line chanin)^"\n"); + iter () + with + End_of_file -> () + in + iter (); + close_in chanin; + let len = Buffer.length buf in + if len <= 1 then + Buffer.contents buf + else + (String.sub (Buffer.contents buf) 0 (len - 1)) + +let string_of_longident li = String.concat "." (Longident.flatten li) + +let string_of_type_expr t = + Printtyp.mark_loops t; + Printtyp.type_scheme_max ~b_reset_names: false Format.str_formatter t; + let s = Format.flush_str_formatter () in + s + +let string_of_type_list sep type_list = + 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.Tobject _ + | Types.Tfield _ | Types.Tnil | Types.Tvariant _ -> false + in + let print_one_type t = + Printtyp.mark_loops t; + if need_parent t then + ( + Format.fprintf Format.str_formatter "(" ; + Printtyp.type_scheme_max ~b_reset_names: false Format.str_formatter t; + Format.fprintf Format.str_formatter ")" + ) + else + Printtyp.type_scheme_max ~b_reset_names: false Format.str_formatter t + in + begin match type_list with + [] -> () + | [ty] -> print_one_type ty + | ty :: tyl -> + Format.fprintf Format.str_formatter "@[<hov 2>"; + print_one_type ty; + List.iter + (fun t -> Format.fprintf Format.str_formatter "@,%s" sep; print_one_type t) + tyl; + Format.fprintf Format.str_formatter "@]" + end; + Format.flush_str_formatter() + +let string_of_module_type t = + Printtyp.modtype Format.str_formatter t; + let s = Format.flush_str_formatter () in + s + +let string_of_class_type t = + Printtyp.class_type Format.str_formatter t; + let s = Format.flush_str_formatter () in + s + +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, _) -> + iter (Odoc_types.Code name) + | Odoc_types.Superscript t -> + "^{"^(string_of_text t)^"}" + | Odoc_types.Subscript t -> + "^{"^(string_of_text t)^"}" + 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 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 _ -> (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 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 diff --git a/ocamldoc/odoc_misc.mli b/ocamldoc/odoc_misc.mli new file mode 100644 index 000000000..c54481cf6 --- /dev/null +++ b/ocamldoc/odoc_misc.mli @@ -0,0 +1,90 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + +(** Miscelaneous functions *) + +(** This function returns a file in the form of one string.*) +val input_file_as_string : string -> string + +(** This function creates a string from a Longident.t .*) +val string_of_longident : Longident.t -> string + +(** 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 to represent the given list of types, + with a given separator. It writes in and flushes [Format.str_formatter].*) +val string_of_type_list : string -> Types.type_expr list -> string + +(** This function returns a string representing a [Types.module_type]. *) +val string_of_module_type : Types.module_type -> string + +(** This function returns a string representing a [Types.class_type]. *) +val string_of_class_type : Types.class_type -> 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 + +(** 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 diff --git a/ocamldoc/odoc_module.ml b/ocamldoc/odoc_module.ml new file mode 100644 index 000000000..45c5fd222 --- /dev/null +++ b/ocamldoc/odoc_module.ml @@ -0,0 +1,505 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + +(** 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 *) + } + +and module_alias = { + ma_name : Name.t ; + mutable ma_module : mmt option ; (** the real module or module type if we could associate it *) + } + +(** 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 (Odoc_parameter.module_parameter list) * module_kind + | Module_apply of module_kind * module_kind + | Module_with of module_type_kind * string + | Module_constraint of module_kind * module_type_kind + +(** Representation of a module. *) +and t_module = { + m_name : Name.t ; + m_type : Types.module_type option ; + (** It is [None] when we had only the .ml file and it is a top module. *) + 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. *) + } + +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 (Odoc_parameter.module_parameter list) * 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 *) + +(** Representation of a module type. *) +and t_module_type = { + mt_name : Name.t ; + mutable mt_info : Odoc_types.info option ; + 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 -> l + | Module_alias ma -> + 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, _) -> iter_kind k + | Module_with (tk,_) -> + 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) -> + (* A VOIR : utiliser k ou tk ? *) + module_elements ~trans: trans + { m_name = "" ; m_info = None ; m_type = None ; + m_is_interface = false ; m_file = "" ; m_kind = k ; + m_loc = Odoc_types.dummy_loc ; + m_top_deps = [] ; + } +(* + 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 + [] + 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 (params, _)) -> + ( + (* 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 -> + List.map (fun p -> (p, None)) params + | Some i -> + List.map + (fun p -> + try + let d = List.assoc p.Odoc_parameter.mp_name i.Odoc_types.i_params in + (p, Some d) + with + Not_found -> + (p, None) + ) + params + ) + | 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 _) -> + [] + | 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 = + match m.m_kind with + Module_functor (params, _) -> + ( + (* 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 -> + List.map (fun p -> (p, None)) params + | Some i -> + List.map + (fun p -> + try + let d = List.assoc p.Odoc_parameter.mp_name i.Odoc_types.i_params in + (p, Some d) + with + Not_found -> + (p, None) + ) + params + ) + | 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 _ -> + [] + +(** 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 _) + | 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 rec module_is_functor m = + match m.m_kind with + Module_functor _ -> true + | Module_alias ma -> + ( + match ma.ma_module with + None -> false + | Some (Mod mo) -> module_is_functor mo + | Some (Modtype mt) -> module_type_is_functor mt + ) + | _ -> false + + +(** 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/ocamldoc/odoc_name.ml b/ocamldoc/odoc_name.ml new file mode 100644 index 000000000..4ff0aa61a --- /dev/null +++ b/ocamldoc/odoc_name.ml @@ -0,0 +1,166 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + +(** Representation of element names. *) + +let infix_chars = [ '|' ; + '<' ; + '>' ; + '@' ; + '^' ; + '|' ; + '&' ; + '+' ; + '-' ; + '*' ; + '/' ; + '$' ; + '%' ; + '=' + ] + +type t = string + +let parens_if_infix name = + match name with + "" -> "" + | s -> + if List.mem s.[0] infix_chars then + "("^s^")" + else + s + +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 head n = + match Str.split (Str.regexp "\\.") n with + [] -> n + | h :: _ -> h + +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 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.print (Format.str_formatter) ident; + let s = Format.flush_str_formatter () in + (* the ident is of the form name/id ; we get the name only *) + try + List.hd (Str.split (Str.regexp "/") s) + with + _ -> + "" + +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 longident = String.concat "." (Longident.flatten longident) + +let name_alias name cpl_aliases = + let rec f n1 = function + [] -> raise Not_found + | (n2, n3) :: q -> + if n2 = n1 then + n3 + else + if prefix n2 n1 then + let ln2 = String.length n2 in + n3^(String.sub n1 ln2 ((String.length n1) - ln2)) + else + f n1 q + in + let rec iter n = + try iter (f n cpl_aliases) + with Not_found -> n + in + iter name diff --git a/ocamldoc/odoc_name.mli b/ocamldoc/odoc_name.mli new file mode 100644 index 000000000..6319b40e9 --- /dev/null +++ b/ocamldoc/odoc_name.mli @@ -0,0 +1,65 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + +(** 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 + +(** 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 a list of module names to hide and a name, + and return the name when the module name (or part of it) + was removedn, 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 + +(** This function takes a name and a list of name aliases and returns the name + after substitution using the aliases. *) +val name_alias : t -> (t * t) list -> t diff --git a/ocamldoc/odoc_ocamlhtml.mll b/ocamldoc/odoc_ocamlhtml.mll new file mode 100644 index 000000000..cff408ade --- /dev/null +++ b/ocamldoc/odoc_ocamlhtml.mll @@ -0,0 +1,538 @@ + +{ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(** 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 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>" + 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 + String.escaped s + +(** To translate escape sequences *) + +let char_for_backslash = + match Sys.os_type with + | "Unix" | "Win32" | "Cygwin" -> + begin function + | 'n' -> '\010' + | 'r' -> '\013' + | 'b' -> '\008' + | 't' -> '\009' + | c -> c + end + | "MacOS" -> + begin function + | 'n' -> '\013' + | 'r' -> '\010' + | 'b' -> '\008' + | 't' -> '\009' + | c -> c + end + | x -> fatal_error "Lexer: unknown system type" + +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) + +(** 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; + 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; + } + | "\"" + { reset_string_buffer(); + string_start_pos := Lexing.lexeme_start lexbuf; + store_comment_char '"'; + begin try string lexbuf + 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 '\''; + 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 '\''; + store_comment_char '\\'; + store_comment_char(char_for_decimal_code lexbuf 1); + 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'] + { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1)); + string lexbuf } + | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] + { store_string_char(char_for_decimal_code lexbuf 1); + 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 ?(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 = "<span class=\""^code_class^"\"><code>" in + let ending = "</code></span>" 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 ; + + html + +} diff --git a/ocamldoc/odoc_opt.ml b/ocamldoc/odoc_opt.ml new file mode 100644 index 000000000..6f90ce307 --- /dev/null +++ b/ocamldoc/odoc_opt.ml @@ -0,0 +1,80 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + +(** Main module for native version.*) + +open Config +open Clflags +open Misc +open Format +open Typedtree + + + +let html_generator = new Odoc_html.html +let default_latex_generator = new Odoc_latex.latex +let default_man_generator = new Odoc_man.man +let default_iso_generator = new Odoc_iso.iso +let default_dot_generator = new Odoc_dot.dot +let _ = Odoc_args.parse + (html_generator :> Odoc_args.doc_generator) + (default_latex_generator :> Odoc_args.doc_generator) + (default_man_generator :> Odoc_args.doc_generator) + (default_iso_generator :> Odoc_args.doc_generator) + (default_dot_generator :> Odoc_args.doc_generator) + +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_args.load + ) + +let modules = Odoc_analyse.analyse_files ~init: loaded_modules !Odoc_args.files + +let _ = + match !Odoc_args.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.doc_generator with + None -> + () + | Some gen -> + Odoc_info.verbose Odoc_messages.generating_doc; + gen#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/ocamldoc/odoc_parameter.ml b/ocamldoc/odoc_parameter.ml new file mode 100644 index 000000000..adf035d3d --- /dev/null +++ b/ocamldoc/odoc_parameter.ml @@ -0,0 +1,130 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + +(** Representation and manipulation of method / function / class parameters, + and module 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 value. *) +type parameter = param_info + +(** A module parameter is just a name and a module type.*) +type module_parameter = { + mp_name : string ; + mp_type : Types.module_type ; + } + + +(** 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 p = + match p 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 p = + match p 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 p 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 [] p in + List.assoc name l + + +(** acces to the list of names ; only one for a simple parameter, or + a list for tuples. *) +let names p = + 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 [] p + +(** access to the type of a specific name. + @raise Not_found if no type is associated to the given name. *) +let type_by_name p 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 [] p 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/ocamldoc/odoc_parser.mly b/ocamldoc/odoc_parser.mly new file mode 100644 index 000000000..4603ed3a6 --- /dev/null +++ b/ocamldoc/odoc_parser.mly @@ -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. *) +(* *) +(***********************************************************************) + +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_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 { () } +| 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 } +; +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/ocamldoc/odoc_scan.ml b/ocamldoc/odoc_scan.ml new file mode 100644 index 000000000..2750c0368 --- /dev/null +++ b/ocamldoc/odoc_scan.ml @@ -0,0 +1,154 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(** 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 overriden. 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 overriden. 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 overriden. 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 overriden. 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/ocamldoc/odoc_search.ml b/ocamldoc/odoc_search.ml new file mode 100644 index 000000000..00d4199b9 --- /dev/null +++ b/ocamldoc/odoc_search.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. *) +(* *) +(***********************************************************************) + + +(** 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 + +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 s v = if P.p_section s v then [Res_section s] 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.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.Title (n, l_opt, t) -> + (match l_opt with + None -> [] + | Some s -> search_section (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 diff --git a/ocamldoc/odoc_search.mli b/ocamldoc/odoc_search.mli new file mode 100644 index 000000000..b2add68b4 --- /dev/null +++ b/ocamldoc/odoc_search.mli @@ -0,0 +1,157 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + +(** 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 + +(** 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 : 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 : 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 diff --git a/ocamldoc/odoc_see_lexer.mll b/ocamldoc/odoc_see_lexer.mll new file mode 100644 index 000000000..2fa6a5314 --- /dev/null +++ b/ocamldoc/odoc_see_lexer.mll @@ -0,0 +1,100 @@ +{ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +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/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml new file mode 100644 index 000000000..51b8f66ef --- /dev/null +++ b/ocamldoc/odoc_sig.ml @@ -0,0 +1,1240 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + +(** 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 + let search_value signat name = + let rec iter sig_item_list = + match sig_item_list with + [] -> + raise Not_found + | (Types.Tsig_value (ident, val_desc)) :: q -> + if Ident.name ident = name then + val_desc.Types.val_type + else + iter q + | _ :: q -> + iter q + in + iter signat + + let search_exception signat name = + let rec iter sig_item_list = + match sig_item_list with + [] -> + raise Not_found + | (Types.Tsig_exception (ident, type_expr_list)) :: q -> + if Ident.name ident = name then + type_expr_list + else + iter q + | _ :: q -> + iter q + in + iter signat + + let search_type signat name = + let rec iter sig_item_list = + match sig_item_list with + [] -> + raise Not_found + | (Types.Tsig_type (ident, type_decl)) :: q -> + if Ident.name ident = name then + type_decl + else + iter q + | _ :: q -> + iter q + in + iter signat + + let search_class signat name = + let rec iter sig_item_list = + match sig_item_list with + [] -> + raise Not_found + | (Types.Tsig_class (ident, class_decl)) :: q -> + if Ident.name ident = name then + class_decl + else + iter q + | _ :: q -> + iter q + in + iter signat + + let search_class_type signat name = + let rec iter sig_item_list = + match sig_item_list with + [] -> + raise Not_found + | (Types.Tsig_cltype (ident, cltype_decl)) :: q -> + if Ident.name ident = name then + cltype_decl + else + iter q + | _ :: q -> + iter q + in + iter signat + + let search_module signat name = + let rec iter sig_item_list = + match sig_item_list with + [] -> + raise Not_found + | (Types.Tsig_module (ident, module_type)) :: q -> + if Ident.name ident = name then + module_type + else + iter q + | _ :: q -> + iter q + in + iter signat + + let search_module_type signat name = + let rec iter sig_item_list = + match sig_item_list with + [] -> + raise Not_found + | (Types.Tsig_modtype (ident, Types.Tmodtype_manifest module_type)) :: q -> + if Ident.name ident = name then + Some module_type + else + iter q + | (Types.Tsig_modtype (ident, Types.Tmodtype_abstract)) :: q -> + if Ident.name ident = name then + None + else + iter q + | _ :: q -> + iter q + in + iter signat + + 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) + + (** This function merge two optional info structures. *) + let merge_infos = Odoc_merge.merge_info_opt Odoc_types.all_merge_options + + (** 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_start] and [pos_end] are the first and last char of the complete type definition.*) + let name_comment_from_type_kind pos_start pos_end pos_limit tk = + match tk with + Parsetree.Ptype_abstract -> + (0, []) + | Parsetree.Ptype_variant cons_core_type_list_list -> + (*of (string * core_type list) list *) + let rec f acc last_pos cons_core_type_list_list = + match cons_core_type_list_list with + [] -> + (0, acc) + | (name, core_type_list) :: [] -> + let pos = Str.search_forward (Str.regexp_string name) !file last_pos in + let s = get_string_of_file pos_end 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) :: (name2, core_type_list2) :: q -> + match (List.rev core_type_list, core_type_list2) with + ([], []) -> + let pos = Str.search_forward (Str.regexp_string name) !file last_pos in + let pos' = pos + (String.length name) in + let pos2 = Str.search_forward (Str.regexp_string name2) !file pos' in + let s = get_string_of_file pos' pos2 in + let (_,comment_opt) = My_ir.just_after_special !file_name s in + f (acc @ [name, comment_opt]) pos2 ((name2, core_type_list2) :: q) + + | ([], (ct2 :: _)) -> + let pos = Str.search_forward (Str.regexp_string name) !file last_pos in + let pos' = pos + (String.length name) in + let pos2 = ct2.Parsetree.ptyp_loc.Location.loc_start in + let pos2' = Str.search_backward (Str.regexp_string name2) !file pos2 in + let s = get_string_of_file pos' pos2' in + let (_,comment_opt) = My_ir.just_after_special !file_name s in + f (acc @ [name, comment_opt]) pos2' ((name2, core_type_list2) :: q) + + | ((ct :: _), _) -> + let pos = ct.Parsetree.ptyp_loc.Location.loc_end in + let pos2 = Str.search_forward (Str.regexp_string name2) !file pos in + let s = get_string_of_file pos pos2 in + let (_,comment_opt) = My_ir.just_after_special !file_name s in + let new_pos_end = + match comment_opt with + None -> ct.Parsetree.ptyp_loc.Location.loc_end + | Some _ -> Str.search_forward (Str.regexp "*)") !file pos + in + f (acc @ [name, comment_opt]) new_pos_end ((name2, core_type_list2) :: q) + in + f [] pos_start 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) :: [] -> + let pos = ct.Parsetree.ptyp_loc.Location.loc_end 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) :: ((name2,_,ct2) as ele2) :: q -> + let pos = ct.Parsetree.ptyp_loc.Location.loc_end in + let pos2 = ct2.Parsetree.ptyp_loc.Location.loc_start 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) + + (** 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.*) + 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 = + print_DEBUG "Types.Tcty_signature class_signature"; + let f_DEBUG var (mutable_flag, type_exp) = print_DEBUG var in + Types.Vars.iter f_DEBUG class_signature.Types.cty_vars; + print_DEBUG ("Type de la classe "^current_class_name^" : "); + print_DEBUG (Odoc_misc.string_of_type_expr class_signature.Types.cty_self); + 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 + | Parsetree.Pctf_inher class_type -> + class_type.Parsetree.pcty_loc.Location.loc_start + 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) }; + } ; + 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 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, _, 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 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)} ; + } ; + att_mutable = mutable_flag = Asttypes.Mutable ; + } + in + let pos_limit2 = get_pos_limit2 q in + let pos_end = loc.Location.loc_end 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 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 + 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 in + let (met, maybe_more) = get_method name comment_opt private_flag loc q in + let (inher_l, eles) = f (loc.Location.loc_end + 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 in + let (inher_l, eles) = f loc.Location.loc_end 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 + in + let pos_limit2 = get_pos_limit2 q in + let pos_end = loc.Location.loc_end 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 = + (* 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 + in + let (maybe_more, new_env, elements) = analyse_signature_item_desc + acc_env + signat + current_module_name + ele.Parsetree.psig_loc.Location.loc_start + ele.Parsetree.psig_loc.Location.loc_end + (match q with + [] -> pos_limit + | ele2 :: _ -> ele2.Parsetree.psig_loc.Location.loc_start + ) + assoc_com + ele.Parsetree.psig_desc + in + f (acc_eles @ (ele_comments @ elements)) + new_env + (ele.Parsetree.psig_loc.Location.loc_end + 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 *) + 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 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 = Signature_search.search_value signat 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 = Signature_search.search_exception signat 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) } + } + 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 + in + let pos_limit2 = + match q with + [] -> pos_limit + | (_, td) :: _ -> td.Parsetree.ptype_loc.Location.loc_start + in + let (maybe_more, name_comment_list) = + name_comment_from_type_kind + type_decl.Parsetree.ptype_loc.Location.loc_start + type_decl.Parsetree.ptype_loc.Location.loc_end + 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 = Signature_search.search_type signat 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 + (* 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.map (Odoc_env.subst_type new_env) sig_type_decl.Types.type_params ; + ty_kind = type_kind ; + 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,type_decl.Parsetree.ptype_loc.Location.loc_start) + }; + } + in + let new_end = type_decl.Parsetree.ptype_loc.Location.loc_end + maybe_more 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 signat 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 new_module = + { + m_name = complete_name ; + m_type = Some 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 = [] ; + } + 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 *) + Some (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_modtype (name, Parsetree.Pmodtype_abstract) -> + let sig_mtype = + try Signature_search.search_module_type signat name + with Not_found -> + raise (Failure (Odoc_messages.module_type_not_found current_module_name name)) + in + let complete_name = Name.concat current_module_name name 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 = None ; + 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 + (maybe_more, new_env, [ Element_module_type mt ]) + + | Parsetree.Psig_modtype (name, Parsetree.Pmodtype_manifest module_type) -> + let complete_name = Name.concat current_module_name name in + let sig_mtype_opt = + try Signature_search.search_module_type signat name + with Not_found -> + raise (Failure (Odoc_messages.module_type_not_found current_module_name name)) + in + let module_type_kind = + match sig_mtype_opt 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_opt ; + 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_opt 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 + in + let im = + { + im_name = Odoc_env.full_module_or_module_type_name env (f module_type.Parsetree.pmty_desc) ; + im_module = None ; + } + 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 + in + let pos_end = class_desc.Parsetree.pci_loc.Location.loc_end in + let pos_limit2 = + match q with + [] -> pos_limit + | cd :: _ -> cd.Parsetree.pci_loc.Location.loc_start + in + let name = class_desc.Parsetree.pci_name in + let complete_name = Name.concat current_module_name name in + let sig_class_decl = Signature_search.search_class signat 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 + class_desc.Parsetree.pci_expr + sig_class_type + in + let new_class = + { + cl_name = complete_name ; + cl_info = assoc_com ; + cl_type = 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 + in + let pos_end = ct_decl.Parsetree.pci_loc.Location.loc_end in + let pos_limit2 = + match q with + [] -> pos_limit + | ct_decl2 :: _ -> ct_decl2.Parsetree.pci_loc.Location.loc_start + in + let name = ct_decl.Parsetree.pci_name in + let complete_name = Name.concat current_module_name name in + let sig_cltype_decl = Signature_search.search_class_type signat 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 + ct_decl.Parsetree.pci_expr + sig_class_type + in + let ct = + { + clt_name = complete_name ; + clt_info = assoc_com ; + clt_type = 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 in + let pos_end = module_type.Parsetree.pmty_loc.Location.loc_end 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 (_,_, module_type2) -> + ( + match sig_module_type with + Types.Tmty_functor (ident, param_module_type, body_module_type) -> + let param = + { + mp_name = Name.from_ident ident ; + mp_type = Odoc_env.subst_module_type env param_module_type ; + } + in + ( + match analyse_module_type_kind env current_module_name module_type2 body_module_type with + Module_type_functor (params, k) -> + Module_type_functor (param :: params, k) + | k -> + 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 in + let loc_end = module_type.Parsetree.pmty_loc.Location.loc_end 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) + ) + + (** 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 (*of Longident.t*) -> + let name = + match sig_module_type with + Types.Tmty_ident path -> Name.from_path path + | _ -> + Name.from_longident longident + in + Module_alias { ma_name = Odoc_env.full_module_or_module_type_name env name ; + ma_module = None } + + | 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 + module_type.Parsetree.pmty_loc.Location.loc_end + signature + ) + | _ -> + (* if we're here something's wrong *) + raise (Failure "Parsetree.Pmty_signature signature but not Types.Tmty_signature signat") + ) + | Parsetree.Pmty_functor (_,_,module_type2) (* of string * module_type * module_type *) -> + ( + match sig_module_type with + Types.Tmty_functor (ident, param_module_type, body_module_type) -> + let param = + { + mp_name = Name.from_ident ident ; + mp_type = Odoc_env.subst_module_type env param_module_type ; + } + in + ( + match analyse_module_kind env current_module_name module_type2 body_module_type with + Module_functor (params, k) -> + Module_functor (param :: params, k) + | k -> + 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 in + let loc_end = module_type.Parsetree.pmty_loc.Location.loc_end 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) + ) + + (** 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 k = + Class_constr + { + cco_name = Odoc_env.full_class_name env (Name.from_path p) ; + 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) -> + print_DEBUG "Types.Tcty_signature class_signature"; + let f_DEBUG var (mutable_flag, type_exp) = print_DEBUG var in + Types.Vars.iter f_DEBUG class_signature.Types.cty_vars; + print_DEBUG ("Type de la classe "^current_class_name^" : "); + print_DEBUG (Odoc_misc.string_of_type_expr class_signature.Types.cty_self); + (* 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 + 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. A VOIR : 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 = 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) -> + print_DEBUG "Types.Tcty_signature class_signature"; + let f_DEBUG var (mutable_flag, type_exp) = print_DEBUG var in + Types.Vars.iter f_DEBUG class_signature.Types.cty_vars; + print_DEBUG ("Type de la classe "^current_class_name^" : "); + print_DEBUG (Odoc_misc.string_of_type_expr class_signature.Types.cty_self); + (* 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 + 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 m = + { + m_name = mod_name ; + m_type = Some (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 = [] ; + } + in + + print_DEBUG "Eléments du module:"; + let f e = + let s = + match e with + Element_module m -> "module "^m.m_name + | Element_module_type mt -> "module type "^mt.mt_name + | Element_included_module im -> "included module "^im.im_name + | Element_class c -> "class "^c.cl_name + | Element_class_type ct -> "class type "^ct.clt_name + | Element_value v -> "value "^v.val_name + | Element_exception e -> "exception "^e.ex_name + | Element_type t -> "type "^t.ty_name + | Element_module_comment t -> Odoc_misc.string_of_text t + in + print_DEBUG s; + () + in + List.iter f elements; + + m + + end diff --git a/ocamldoc/odoc_sig.mli b/ocamldoc/odoc_sig.mli new file mode 100644 index 000000000..2718b9343 --- /dev/null +++ b/ocamldoc/odoc_sig.mli @@ -0,0 +1,154 @@ +(***********************************************************************) +(* 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 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 + (** 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 : Types.signature_item list -> string -> Types.type_expr + + (** This function returns the type expression list for the exception whose name is given, + in the given signature. + @raise Not_found if error.*) + val search_exception : + Types.signature_item list -> string -> Types.exception_declaration + + (** This function returns the Types.type_declaration for the type whose name is given, + in the given signature. + @raise Not_found if error.*) + val search_type : + Types.signature_item list -> string -> Types.type_declaration + + (** This function returns the Types.class_declaration for the class whose name is given, + in the given signature. + @raise Not_found if error.*) + val search_class : + Types.signature_item list -> string -> Types.class_declaration + + (** This function returns the Types.cltype_declaration for the class type whose name is given, + in the given signature. + @raise Not_found if error.*) + val search_class_type : + Types.signature_item list -> string -> Types.cltype_declaration + + (** This function returns the Types.module_type for the module whose name is given, + in the given signature. + @raise Not_found if error.*) + val search_module : + Types.signature_item list -> string -> Types.module_type + + (** This function returns the optional Types.module_type for the module type whose name is given, + in the given signature. + @raise Not_found if error.*) + val search_module_type : + Types.signature_item list -> 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) + + (** 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/ocamldoc/odoc_str.ml b/ocamldoc/odoc_str.ml new file mode 100644 index 000000000..434ae72f5 --- /dev/null +++ b/ocamldoc/odoc_str.ml @@ -0,0 +1,128 @@ +(***********************************************************************) +(* 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 functions to get a string from different kinds of elements (types, modules, ...). *) + +module Name = Odoc_name + +let string_of_type t = + let module M = Odoc_type in + "type "^ + (String.concat "" + (List.map + (fun p -> (Odoc_misc.string_of_type_expr p)^" ") + t.M.ty_parameters + ) + )^ + (Name.simple t.M.ty_name)^" "^ + (match t.M.ty_manifest with + None -> "" + | Some typ -> "= "^(Odoc_misc.string_of_type_expr typ)^" " + )^ + (match t.M.ty_kind with + M.Type_abstract -> + "" + | M.Type_variant l -> + "=\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_misc.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 -> + "= {\n"^ + (String.concat "" + (List.map + (fun record -> + " "^(if record.M.rf_mutable then "mutable " else "")^ + record.M.rf_name^" : "^(Odoc_misc.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_misc.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_misc.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_mutable then Odoc_messages.mutab^" " else "")^ + (Name.simple a.M.att_value.M.val_name)^" : "^ + (Odoc_misc.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_misc.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) diff --git a/ocamldoc/odoc_str.mli b/ocamldoc/odoc_str.mli new file mode 100644 index 000000000..711de7e6a --- /dev/null +++ b/ocamldoc/odoc_str.mli @@ -0,0 +1,28 @@ +(***********************************************************************) +(* 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 functions to get a string from different kinds of elements (types, modules, ...). *) + +(** @return a string to describe the given type. *) +val string_of_type : Odoc_type.t_type -> 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/ocamldoc/odoc_text.ml b/ocamldoc/odoc_text.ml new file mode 100644 index 000000000..5a712e5b4 --- /dev/null +++ b/ocamldoc/odoc_text.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. *) +(* *) +(***********************************************************************) + + +exception Text_syntax of int * int * string (* line, char, string *) + +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) + ) + end + diff --git a/ocamldoc/odoc_text.mli b/ocamldoc/odoc_text.mli new file mode 100644 index 000000000..5b18a413a --- /dev/null +++ b/ocamldoc/odoc_text.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. *) +(* *) +(***********************************************************************) + + +(** 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 end diff --git a/ocamldoc/odoc_text_lexer.mll b/ocamldoc/odoc_text_lexer.mll new file mode 100644 index 000000000..54b7db057 --- /dev/null +++ b/ocamldoc/odoc_text_lexer.mll @@ -0,0 +1,521 @@ +{ +(***********************************************************************) +(* 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 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 latex mode or not, to handle any special expression + like a string when we're in latex mode.*) +let latex_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; + latex_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" | html_list +let begin_enum = "{ol" | html_enum +let begin_item = "{li"blank_nl | "{- " | html_item +let begin_link = "{{:" +let begin_latex = "{%"blank_nl +let end_latex = "%}" +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_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 + { + incr_cpts lexbuf ; + if !verb_mode or !latex_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 + { + incr_cpts lexbuf ; + if !verb_mode or !latex_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 !latex_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 !latex_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 !latex_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 !latex_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 !latex_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 !latex_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 !latex_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 !latex_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 !latex_mode or !code_pre_mode + or (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + RIGHT + } +| begin_list + { + incr_cpts lexbuf ; + if !verb_mode or !latex_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 !latex_mode or !code_pre_mode or + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + ENUM + } +| begin_item + { + incr_cpts lexbuf ; + if !verb_mode or !latex_mode or !code_pre_mode or + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + ITEM + } +| begin_latex + { + incr_cpts lexbuf ; + if !verb_mode or !latex_mode or !code_pre_mode or + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + ( + latex_mode := true; + LATEX + ) + } +| end_latex + { + incr_cpts lexbuf ; + if !verb_mode or (!open_brackets >= 1) or !code_pre_mode or + !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + ( + latex_mode := false; + END_LATEX + ) + } +| begin_code end_code + { + incr_cpts lexbuf ; + Char (Lexing.lexeme lexbuf) + } + +| begin_code + { + incr_cpts lexbuf ; + if !verb_mode or !latex_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 !latex_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 !latex_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 !latex_mode or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + 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 !latex_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_verb + { + incr_cpts lexbuf ; + if !latex_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 !latex_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_abs_pos <- lexbuf.Lexing.lex_abs_pos - 1; + lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; + lexbuf.Lexing.lex_last_pos <- lexbuf.Lexing.lex_last_pos - 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 + BLANK_LINE + } + +| eof { EOF } + +| "{" + { + incr_cpts lexbuf ; + if !latex_mode or (!open_brackets >= 1) or !code_pre_mode or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) + else + ERROR + } +| _ + { + incr_cpts lexbuf ; + Char (Lexing.lexeme lexbuf) + } + + diff --git a/ocamldoc/odoc_text_parser.mly b/ocamldoc/odoc_text_parser.mly new file mode 100644 index 000000000..4524e69a7 --- /dev/null +++ b/ocamldoc/odoc_text_parser.mly @@ -0,0 +1,150 @@ +%{ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +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 ERROR +%token END +%token <int * string option> Title +%token BOLD +%token EMP +%token CENTER +%token LEFT +%token RIGHT +%token ITALIC +%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 END_LATEX +%token ELE_REF +%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 } +; + +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 } +| 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 string END { + let s2 = remove_beginning_blanks $2 in + let s3 = remove_trailing_blanks s2 in + Ref (s3, None) + } +| VERB string END_VERB { Verbatim $2 } +| LATEX string END_LATEX { Latex $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/ocamldoc/odoc_to_text.ml b/ocamldoc/odoc_to_text.ml new file mode 100644 index 000000000..d59a5bf1e --- /dev/null +++ b/ocamldoc/odoc_to_text.ml @@ -0,0 +1,516 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + +(** 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 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 -> ( 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_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 + + (** 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 m_name sep t = + (self#relative_idents m_name (Odoc_info.string_of_type_list sep t)) + + (** @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 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 s_name = Name.simple v.val_name in + Format.fprintf Format.str_formatter "@[<hov 2>val %s :@ " + s_name; + let s = + (self#normal_type (Name.father v.val_name) v.val_type) + 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 + Format.fprintf Format.str_formatter "@[<hov 2>val %s%s :@ " + (if a.att_mutable then "mutable " else "") + s_name; + let mod_name = Name.father a.att_value.val_name in + let s = self#normal_type mod_name a.att_value.val_type 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 + Format.fprintf Format.str_formatter "@[<hov 2>method %s%s%s :@ " + (if m.met_private then "private " else "") + (if m.met_virtual then "virtual " else "") + s_name ; + let mod_name = Name.father m.met_value.val_name in + let s = self#normal_type mod_name m.met_value.val_type 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 (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 -> t) + ) + l + ) + ] + + (** Return [text] value for the given [class_kind].*) + method text_of_class_kind father ?(with_def_syntax=true) ckind = + match ckind with + Class_structure _ -> + [Code ((if with_def_syntax then " = " else "")^ + Odoc_messages.object_end) + ] + + | Class_apply capp -> + [Code + ((if with_def_syntax then " = " else "")^ + ( + 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 -> + (if with_def_syntax then [Code " = "] else [])@ + ( + 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.cl_name + ) + ] + + | Class_constraint (ck, ctk) -> + (if with_def_syntax then [Code " = "] else [])@ + [Code "( "] @ + (self#text_of_class_kind father ~with_def_syntax: false 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 ?def_syntax ctkind = + match ctkind with + Class_type cta -> + (match def_syntax with + None -> [] + | Some s -> [Code (" "^s^" ")] + ) @ + ( + match cta.cta_type_parameters with + [] -> [] + | l -> + (Code "[") :: + (self#text_of_type_expr_list father ", " l) @ + [Code "] "] + ) @ + ( + match cta.cta_class with + None -> [ Code cta.cta_name ] + | Some (Cltype (clt, _)) -> [Code clt.clt_name] + | Some (Cl cl) -> [Code cl.cl_name] + ) + | Class_signature _ -> + (match def_syntax with + None -> [] + | Some s -> [Code (" "^s^" ")] + ) @ + [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 (_, k) -> + (if with_def_syntax then [Code " : "] else []) @ + [Code "functor ... "] @ + [Code " -> "] @ + (self#text_of_module_kind ~with_def_syntax: false k) + + (** 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 (params, k) -> + let f p = + [Code ("("^p.mp_name^" : ")] @ + (self#text_of_module_type p.mp_type) @ + [Code ") -> "] + in + let t1 = List.flatten (List.map f params) 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)) + ] + + end diff --git a/ocamldoc/odoc_type.ml b/ocamldoc/odoc_type.ml new file mode 100644 index 000000000..2887cd56a --- /dev/null +++ b/ocamldoc/odoc_type.ml @@ -0,0 +1,47 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + +(** Representation and manipulation of a type, but not class nor module type.*) + +module Name = Odoc_name + +(** 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 + | Type_record of record_field list + +(** 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 list ; (** type parameters *) + ty_kind : type_kind ; + ty_manifest : Types.type_expr option; (** type manifest *) + mutable ty_loc : Odoc_types.location ; + } + diff --git a/ocamldoc/odoc_types.ml b/ocamldoc/odoc_types.ml new file mode 100644 index 000000000..8680c9930 --- /dev/null +++ b/ocamldoc/odoc_types.ml @@ -0,0 +1,157 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + +(** 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 + +type 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 + (** A reference to an element. Complete name and kind. *) + | Superscript of text (** Superscripts. *) + | Subscript of text (** Subscripts. *) + +(** [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_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. *) +let dummy_info = { + i_desc = None ; + i_authors = [] ; + i_version = None ; + i_sees = [] ; + i_since = None ; + i_deprecated = None ; + i_params = [] ; + i_raised_exceptions = [] ; + i_return_value = None ; + i_custom = [] ; +} + +(** 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. *) +let dummy_loc = { loc_impl = None ; loc_inter = None } + +(** 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. *) +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 ; +] + +(** The kind of checks which can be performed on elements. *) +type iso_check = + | Has_description (** the element has an associated description *) + | Has_author (** the element's description has one or more \@author tag(s) *) + | Has_since (** the element's description has a \@since tag *) + | Has_version (** the element's description has a \@version tag *) + | Has_return (** the function's description has a \@return tag *) + | Has_params (** all the named parameters of the element has a description *) + | Has_fields_decribed (** all the fields of the type are described *) + | Has_constructors_decribed (** all the constructors of the type are described *) + +(** The list of all checks. *) +let all_iso_checks = [ + Has_description ; + Has_author ; + Has_since ; + Has_version ; + Has_return ; + Has_params ; + Has_fields_decribed ; + Has_constructors_decribed ; +] diff --git a/ocamldoc/odoc_value.ml b/ocamldoc/odoc_value.ml new file mode 100644 index 000000000..6c5e71637 --- /dev/null +++ b/ocamldoc/odoc_value.ml @@ -0,0 +1,132 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + + +(** 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 ; + } + +(** 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 label + in the given value, or None. *) +let value_parameter_text_by_name v label = + match v.val_info with + None -> None + | Some i -> + try + let t = List.assoc label 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) + | _ -> + [] + 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 (normal_name 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 + + |