diff options
148 files changed, 10758 insertions, 10756 deletions
diff --git a/README.win32 b/README.win32 index ee9670acf..30645cf21 100644 --- a/README.win32 +++ b/README.win32 @@ -56,7 +56,7 @@ supported out of the box, without additional software. The native-code compiler (ocamlopt) requires Visual C++ and the Microsoft assembler MASM version 6.11 or later. MASM can be downloaded for free from Microsoft's Web site; for directions, see - http://www.easystreet.com/~jkirwan/pctools.html + http://www.easystreet.com/~jkirwan/pctools.html or http://www2.dgsys.com/~raymoon/faq/masm.html or the comp.lang.asm.x86 FAQ. @@ -96,14 +96,14 @@ You will need the following software components to perform the recompilation: To recompile, start a Cygwin shell and change to the top-level directory of the OCaml distribution. Then, do - cp config/m-nt.h config/m.h - cp config/s-nt.h config/s.h - cp config/Makefile.msvc config/Makefile + cp config/m-nt.h config/m.h + cp config/s-nt.h config/s.h + cp config/Makefile.msvc config/Makefile Then, edit config/Makefile as needed, following the comments in this file. Normally, the only variables that need to be changed are - PREFIX where to install everything - TK_ROOT where TCL/TK was installed + PREFIX where to install everything + TK_ROOT where TCL/TK was installed Finally, use "make -f Makefile.nt" to build the system, e.g. @@ -149,7 +149,7 @@ runs without any additional tools. The native-code compiler (ocamlopt), as well as static linking of Caml bytecode with C code (ocamlc -custom), require either the MinGW development tools, which is free software available at - http://www.mingw.org/ + http://www.mingw.org/ or the Cygwin development tools (also free software), available at http://sources.redhat.com/cygwin/ @@ -174,14 +174,14 @@ Start a Cygwin shell and unpack the source distribution (ocaml-X.YZ.tar.gz) with "tar xzf". Change to the top-level directory of the OCaml distribution. Then, do - cp config/m-nt.h config/m.h - cp config/s-nt.h config/s.h - cp config/Makefile.mingw config/Makefile + cp config/m-nt.h config/m.h + cp config/s-nt.h config/s.h + cp config/Makefile.mingw config/Makefile Then, edit config/Makefile as needed, following the comments in this file. Normally, the only variables that need to be changed are - PREFIX where to install everything - TK_ROOT where TCL/TK was installed + PREFIX where to install everything + TK_ROOT where TCL/TK was installed Finally, use "make -f Makefile.nt" to build the system, e.g. diff --git a/byterun/extern.c b/byterun/extern.c index 9298c8a40..5204361e1 100644 --- a/byterun/extern.c +++ b/byterun/extern.c @@ -335,8 +335,8 @@ static void extern_rec(value v) unsigned long sz_32, sz_64; char * ident = Custom_ops_val(v)->identifier; void (*serialize)(value v, unsigned long * wsize_32, - unsigned long * wsize_64) - = Custom_ops_val(v)->serialize; + unsigned long * wsize_64) + = Custom_ops_val(v)->serialize; if (serialize == NULL) failwith("output_value: abstract value"); Write(CODE_CUSTOM); writeblock(ident, strlen(ident) + 1); diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c index 17775c3ab..aa9830c9b 100644 --- a/byterun/minor_gc.c +++ b/byterun/minor_gc.c @@ -98,12 +98,12 @@ void oldify_one (value v, value *p) Field (result, 0) = field0; Field (result, 1) = oldify_todo_list; /* Add this block */ oldify_todo_list = v; /* to the "to do" list. */ - }else{ + }else{ Assert (sz == 1); p = &Field (result, 0); - v = field0; + v = field0; goto tail_call; - } + } }else if (tag >= No_scan_tag){ sz = Wosize_hd (hd); result = alloc_shr (sz, tag); diff --git a/camlp4/CHANGES b/camlp4/CHANGES index 7b25a65a0..038cc06b5 100644 --- a/camlp4/CHANGES +++ b/camlp4/CHANGES @@ -643,7 +643,7 @@ Camlp4 Version 0.6: * Added option -where: "camlp4 -where" prints the name of the standard library directory of Camlp4 and exit. So, the ocaml toplevel and the compiler can use the option: - -I `camlp4 -where` + -I `camlp4 -where` * Added option -nolib to not search for objects files in the installed library directory of Camlp4. diff --git a/camlp4/compile/compile.sh b/camlp4/compile/compile.sh index 88a06cf5f..780fea0c2 100755 --- a/camlp4/compile/compile.sh +++ b/camlp4/compile/compile.sh @@ -4,15 +4,15 @@ ARGS= FILES= ENTRIES= while test "" != "$1"; do - case $1 in + case $1 in -e) shift; if test "$ENTRIES" != ""; then ENTRIES="$ENTRIES; "; fi ENTRIES="$ENTRIES$1";; - *.ml*) FILES="$FILES $1";; - *) ARGS="$ARGS $1";; - esac - shift + *.ml*) FILES="$FILES $1";; + *) ARGS="$ARGS $1";; + esac + shift done cat $FILES | sed -e 's/Pcaml.parse_i.*$//' > tmp.ml diff --git a/camlp4/config/configure_batch b/camlp4/config/configure_batch index 9e6bd6c3c..29753041f 100755 --- a/camlp4/config/configure_batch +++ b/camlp4/config/configure_batch @@ -58,10 +58,10 @@ touch Makefile.cnf for i in utils parsing otherlibs/dynlink; do if test ! -d "$ocaml_top/$i"; then - echo "Bad value $ocaml_top for option -ocaml-top" + echo "Bad value $ocaml_top for option -ocaml-top" echo "There is no directory $ocaml_top/$i" - echo "Configuration script failed" - exit 1 + echo "Configuration script failed" + exit 1 fi done diff --git a/camlp4/etc/mkcamlp4.sh.tpl b/camlp4/etc/mkcamlp4.sh.tpl index 2fd04ae8c..5780f2ce8 100755 --- a/camlp4/etc/mkcamlp4.sh.tpl +++ b/camlp4/etc/mkcamlp4.sh.tpl @@ -11,14 +11,14 @@ while test "" != "$1"; do case $1 in -I) INCL="$INCL -I $2"; shift;; *) - j=`basename $1 .cmi` - if test "$j.cmi" = "$1"; then - first="`expr "$j" : '\(.\)' | tr 'a-z' 'A-Z'`" - rest="`expr "$j" : '.\(.*\)'`" - INTERFACES="$INTERFACES $first$rest" - else - OPTS="$OPTS $1" - fi;; + j=`basename $1 .cmi` + if test "$j.cmi" = "$1"; then + first="`expr "$j" : '\(.\)' | tr 'a-z' 'A-Z'`" + rest="`expr "$j" : '.\(.*\)'`" + INTERFACES="$INTERFACES $first$rest" + else + OPTS="$OPTS $1" + fi;; esac shift done diff --git a/camlp4/etc/pa_sml.ml b/camlp4/etc/pa_sml.ml index 642ab6739..5b1aac915 100644 --- a/camlp4/etc/pa_sml.ml +++ b/camlp4/etc/pa_sml.ml @@ -779,7 +779,7 @@ EXTEND | Left x2 -> <:module_expr< $x1$ (struct $list:x2$ end) >> | Right x2 -> <:module_expr< $x1$ $x2$ >> ] | "let"; x1 = strdecs; "in"; x2 = module_expr; "end" -> - not_impl loc "str 4" + not_impl loc "str 4" | x1 = module_expr; ":"; x2 = module_type -> not_impl loc "str 5" | x1 = module_expr; x2 = ":>"; x3 = module_type -> not_impl loc "str 6" ] ] diff --git a/camlp4/tools/apply.sh b/camlp4/tools/apply.sh index 4b13b1540..f208c1e4f 100755 --- a/camlp4/tools/apply.sh +++ b/camlp4/tools/apply.sh @@ -4,23 +4,23 @@ ARGS1= FILE= while test "" != "$1"; do - case $1 in - *.ml*) FILE=$1;; - *) ARGS1="$ARGS1 $1";; - esac - shift + case $1 in + *.ml*) FILE=$1;; + *) ARGS1="$ARGS1 $1";; + esac + shift done head -1 $FILE >/dev/null || exit 1 set - `head -1 $FILE` if test "$2" = "camlp4r" -o "$2" = "camlp4"; then - COMM="../boot/$2 -nolib -I ../boot -I ../etc" - shift; shift - ARGS2=`echo $* | sed -e "s/[()*]//g"` + COMM="../boot/$2 -nolib -I ../boot -I ../etc" + shift; shift + ARGS2=`echo $* | sed -e "s/[()*]//g"` else - COMM="../boot/camlp4 -nolib -I ../boot -I ../etc pa_o.cmo" - ARGS2= + COMM="../boot/camlp4 -nolib -I ../boot -I ../etc pa_o.cmo" + ARGS2= fi OTOP=../.. diff --git a/camlp4/tools/camlp4_comm.sh b/camlp4/tools/camlp4_comm.sh index 05ab4c3e4..d23a01cc5 100755 --- a/camlp4/tools/camlp4_comm.sh +++ b/camlp4/tools/camlp4_comm.sh @@ -4,32 +4,32 @@ ARGS1= FILE= while test "" != "$1"; do - case $1 in - *.ml*) FILE=$1;; - *) ARGS1="$ARGS1 $1";; - esac - shift + case $1 in + *.ml*) FILE=$1;; + *) ARGS1="$ARGS1 $1";; + esac + shift done head -1 $FILE >/dev/null || exit 1 set - `head -1 $FILE` if test "$2" = "camlp4r" -o "$2" = "camlp4"; then - COMM="ocamlrun$EXE ../boot/$2$EXE -nolib -I ../boot" + COMM="ocamlrun$EXE ../boot/$2$EXE -nolib -I ../boot" if test "`basename $OTOP`" != "ocaml_stuff"; then COMM="$OTOP/boot/$COMM" fi - shift; shift - ARGS2=`echo $* | sed -e "s/[()*]//g"` -# ARGS1="$ARGS1 -verbose" - echo $COMM $ARGS2 $ARGS1 $FILE - $COMM $ARGS2 $ARGS1 $FILE + shift; shift + ARGS2=`echo $* | sed -e "s/[()*]//g"` +# ARGS1="$ARGS1 -verbose" + echo $COMM $ARGS2 $ARGS1 $FILE + $COMM $ARGS2 $ARGS1 $FILE else - if test "`basename $FILE .mli`.mli" = "$FILE"; then - OFILE=`basename $FILE .mli`.ppi - else - OFILE=`basename $FILE .ml`.ppo - fi - echo cp $FILE $OFILE - cp $FILE $OFILE + if test "`basename $FILE .mli`.mli" = "$FILE"; then + OFILE=`basename $FILE .mli`.ppi + else + OFILE=`basename $FILE .ml`.ppo + fi + echo cp $FILE $OFILE + cp $FILE $OFILE fi diff --git a/camlp4/tools/conv.sh b/camlp4/tools/conv.sh index b9bd4dabe..98ba728f5 100755 --- a/camlp4/tools/conv.sh +++ b/camlp4/tools/conv.sh @@ -4,19 +4,19 @@ DIR=`expr "$0" : "\(.*\)/.*" "|" "."` INCL= FILE= while test "" != "$1"; do - case $1 in - -I) INCL="$INCL -I $2"; shift;; - *) FILE=$1;; - esac - shift + case $1 in + -I) INCL="$INCL -I $2"; shift;; + *) FILE=$1;; + esac + shift done set - `head -1 $FILE` if test "$2" = "camlp4r" -o "$2" = "camlp4"; then - COMM="$OTOP/boot/ocamlrun $DIR/../boot/$2 -nolib -I $DIR/../boot $INCL $DIR/../etc/pr_o.cmo" - shift; shift - ARGS=`echo $* | sed -e "s/[()*]//g"` - $COMM $ARGS -ss $FILE + COMM="$OTOP/boot/ocamlrun $DIR/../boot/$2 -nolib -I $DIR/../boot $INCL $DIR/../etc/pr_o.cmo" + shift; shift + ARGS=`echo $* | sed -e "s/[()*]//g"` + $COMM $ARGS -ss $FILE else - cat $FILE + cat $FILE fi @@ -88,7 +88,7 @@ while : ; do -tklibs*|--tklibs*) tk_libs=$2; shift;; -tk-no-x11|--tk-no-x11) - tk_x11=no;; + tk_x11=no;; -binutils*|--binutils*) binutils_dir=$2; shift;; -verbose|--verbose) @@ -467,13 +467,13 @@ if test $withsharedlibs = "yes"; then byteccrpath="-Wl,-rpath," mksharedlibrpath="-Wl,-rpath," fi - shared_libraries_supported=true;; + shared_libraries_supported=true;; *) sharedcccompopts="-KPIC" byteccrpath="-R" mksharedlibrpath="-R" - mksharedlib="/usr/ccs/bin/ld -G -o" - shared_libraries_supported=true;; + mksharedlib="/usr/ccs/bin/ld -G -o" + shared_libraries_supported=true;; esac;; mips*-*-irix[56]*) case "$bytecc" in @@ -1134,7 +1134,7 @@ for dir in \ /usr/unsupported/lib \ /usr/athena/lib \ /usr/lpp/Xamples/lib \ - /lib/usr/lib/X11 \ + /lib/usr/lib/X11 \ \ /usr/openwin/lib \ /usr/openwin/share/lib \ diff --git a/emacs/inf-caml.el b/emacs/inf-caml.el index b3f768578..f24a7a71f 100644 --- a/emacs/inf-caml.el +++ b/emacs/inf-caml.el @@ -113,8 +113,8 @@ be sent from another buffer in Caml mode. Input and output via buffer `*inferior-caml*'." (interactive (list (if (not (comint-check-proc inferior-caml-buffer-name)) - (read-from-minibuffer "Caml toplevel to run: " - inferior-caml-program)))) + (read-from-minibuffer "Caml toplevel to run: " + inferior-caml-program)))) (caml-run-process-if-needed cmd) (switch-to-buffer-other-window inferior-caml-buffer-name)) @@ -250,15 +250,15 @@ should lies." (cond ((re-search-forward " *Characters \\([01-9][01-9]*\\)-\\([1-9][01-9]*\\):\n[^W]" (point-max) t) - (setq beg (string-to-int (caml-match-string 1))) + (setq beg (string-to-int (caml-match-string 1))) (setq end (string-to-int (caml-match-string 2))) (switch-to-buffer buf) - (goto-char orig) - (forward-byte end) - (setq end (point)) - (goto-char orig) - (forward-byte beg) - (setq beg (point)) + (goto-char orig) + (forward-byte end) + (setq end (point)) + (goto-char orig) + (forward-byte beg) + (setq beg (point)) (setq err beg) ) ((looking-at diff --git a/lex/Makefile b/lex/Makefile index 8a1c58cbb..1b8e59f90 100644 --- a/lex/Makefile +++ b/lex/Makefile @@ -38,6 +38,7 @@ ocamllex.opt: $(OBJS:.cmo=.cmx) clean:: rm -f ocamllex ocamllex.opt rm -f *.cmo *.cmi *.cmx *.o + rm -f parser.output parser.ml parser.mli: parser.mly $(CAMLYACC) $(YACCFLAGS) parser.mly diff --git a/ocamldoc/odoc.ml b/ocamldoc/odoc.ml index dba04f6e2..04bdedfd3 100644 --- a/ocamldoc/odoc.ml +++ b/ocamldoc/odoc.ml @@ -26,14 +26,14 @@ 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 + ((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 + iter (f_opt, inc @ [dir]) q | _ :: q -> - iter (f_opt, inc) q + iter (f_opt, inc) q in iter (None, []) arg_list @@ -48,19 +48,19 @@ let _ = Dynlink.init (); Dynlink.allow_unsafe_modules true; try - Dynlink.add_available_units Odoc_crc.crc_unit_list ; - let _ = Dynlink.loadfile file in - () + 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 + 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" @@ -81,15 +81,15 @@ 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_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 ) @@ -102,8 +102,8 @@ let _ = | Some f -> try Odoc_analyse.dump_modules f modules with Failure s -> - prerr_endline s ; - incr Odoc_global.errors + prerr_endline s ; + incr Odoc_global.errors let _ = match !Odoc_args.doc_generator with diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml index c0d0faf7a..071e7c192 100644 --- a/ocamldoc/odoc_analyse.ml +++ b/ocamldoc/odoc_analyse.ml @@ -118,16 +118,16 @@ let process_implementation_file ppf sourcefile = with e -> match e with - Syntaxerr.Error err -> - fprintf Format.err_formatter "@[%a@]@." + Syntaxerr.Error err -> + fprintf Format.err_formatter "@[%a@]@." Syntaxerr.report_error err; - None, inputfile + None, inputfile | Failure s -> - prerr_endline s; - incr Odoc_global.errors ; - None, inputfile + prerr_endline s; + incr Odoc_global.errors ; + None, inputfile | e -> - raise e + raise e (** Analysis of an interface file. Returns (Some signature) if no error occured, else None and an error message is printed.*) @@ -204,57 +204,57 @@ let process_file ppf sourcefile = try let (parsetree_typedtree_opt, input_file) = process_implementation_file ppf sourcefile in match parsetree_typedtree_opt with - None -> - None + None -> + None | Some (parsetree, typedtree) -> - let file_module = Ast_analyser.analyse_typed_tree sourcefile !Location.input_name parsetree typedtree in + 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 ; + 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 + 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 + prerr_endline s ; + incr Odoc_global.errors ; + None | e -> - process_error e ; - incr Odoc_global.errors ; - None + 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 + 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 + prerr_endline s; + incr Odoc_global.errors ; + None | e -> - process_error e ; - incr Odoc_global.errors ; - None + process_error e ; + incr Odoc_global.errors ; + None ) else ( @@ -267,10 +267,10 @@ let rec remove_class_elements_after_stop eles = [] -> [] | 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) + 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 = @@ -281,7 +281,7 @@ let rec remove_class_elements_after_stop_in_class_kind 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_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 = @@ -298,28 +298,28 @@ let rec remove_module_elements_after_stop eles = [] -> [] | 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_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) + 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) + 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) + 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) + ele :: (f q) (** Remove the module elements after the stop special comment, in the given module kind. *) @@ -331,12 +331,12 @@ and remove_module_elements_after_stop_in_module_kind k = 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) + 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_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 = @@ -364,17 +364,17 @@ let analyse_files ?(init=[]) files = 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 + 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 diff --git a/ocamldoc/odoc_analyse.mli b/ocamldoc/odoc_analyse.mli index 845b1c4d8..4b1254b8d 100644 --- a/ocamldoc/odoc_analyse.mli +++ b/ocamldoc/odoc_analyse.mli @@ -19,7 +19,7 @@ val analyse_files : ?init: Odoc_module.t_module list -> string list -> - Odoc_module.t_module list + Odoc_module.t_module list (** Dump of a list of modules into a file. @raise Failure if an error occurs.*) diff --git a/ocamldoc/odoc_args.ml b/ocamldoc/odoc_args.ml index b78f8bf12..fb3e159ec 100644 --- a/ocamldoc/odoc_args.ml +++ b/ocamldoc/odoc_args.ml @@ -45,9 +45,9 @@ let analyse_option_string l s = List.fold_left (fun acc -> fun ((c,_), v) -> if String.contains s c then - acc @ v + acc @ v else - acc) + acc) [] l @@ -152,13 +152,13 @@ let add_hidden_modules s = (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) + "" -> () + | _ -> + 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 @@ -265,10 +265,10 @@ let add_option o = let rec iter = function [] -> [o] | (s2,f,m) :: q -> - if s = s2 then - o :: q - else - (s2,f,m) :: (iter q) + if s = s2 then + o :: q + else + (s2,f,m) :: (iter q) in options := iter !options diff --git a/ocamldoc/odoc_args.mli b/ocamldoc/odoc_args.mli index de4948857..4f660854c 100644 --- a/ocamldoc/odoc_args.mli +++ b/ocamldoc/odoc_args.mli @@ -159,8 +159,8 @@ val add_option : string * Arg.spec * string -> unit val parse : html_generator:doc_generator -> latex_generator:doc_generator -> - texi_generator:doc_generator -> - man_generator:doc_generator -> - dot_generator:doc_generator -> - unit + texi_generator:doc_generator -> + man_generator:doc_generator -> + dot_generator:doc_generator -> + unit diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml index 466fc6e71..c10d771e6 100644 --- a/ocamldoc/odoc_ast.ml +++ b/ocamldoc/odoc_ast.ml @@ -43,15 +43,15 @@ let simple_blank = "[ \013\009\012]" module Typedtree_search = struct type ele = - | M of string - | MT of string - | T of string - | C of string - | CT of string - | E of string - | ER of string - | P of string - | IM of string + | M of string + | MT of string + | T of string + | C of string + | CT of string + | E of string + | ER of string + | P of string + | IM of string type tab = (ele, Typedtree.structure_item) Hashtbl.t type tab_values = (Odoc_module.Name.t, Typedtree.pattern * Typedtree.expression) Hashtbl.t @@ -65,45 +65,45 @@ module Typedtree_search = let add_to_hashes table table_values tt = match tt with | Typedtree.Tstr_module (ident, _) -> - Hashtbl.add table (M (Name.from_ident ident)) tt - | Typedtree.Tstr_modtype (ident, _) -> - Hashtbl.add table (MT (Name.from_ident ident)) tt - | Typedtree.Tstr_exception (ident, _) -> - Hashtbl.add table (E (Name.from_ident ident)) tt - | Typedtree.Tstr_exn_rebind (ident, _) -> - Hashtbl.add table (ER (Name.from_ident ident)) tt - | Typedtree.Tstr_type ident_type_decl_list -> - List.iter - (fun (id, e) -> - Hashtbl.add table (T (Name.from_ident id)) - (Typedtree.Tstr_type [(id,e)])) - ident_type_decl_list - | Typedtree.Tstr_class info_list -> - List.iter - (fun ((id,_,_,_) as ci) -> - Hashtbl.add table (C (Name.from_ident id)) - (Typedtree.Tstr_class [ci])) - info_list - | Typedtree.Tstr_cltype info_list -> - List.iter - (fun ((id,_) as ci) -> - Hashtbl.add table - (CT (Name.from_ident id)) - (Typedtree.Tstr_cltype [ci])) - info_list - | Typedtree.Tstr_value (_, pat_exp_list) -> - List.iter - (fun (pat,exp) -> - match iter_val_pattern pat.Typedtree.pat_desc with - None -> () - | Some n -> Hashtbl.add table_values n (pat,exp) - ) - pat_exp_list - | Typedtree.Tstr_primitive (ident, _) -> - Hashtbl.add table (P (Name.from_ident ident)) tt - | Typedtree.Tstr_open _ -> () - | Typedtree.Tstr_include _ -> () - | Typedtree.Tstr_eval _ -> () + Hashtbl.add table (M (Name.from_ident ident)) tt + | Typedtree.Tstr_modtype (ident, _) -> + Hashtbl.add table (MT (Name.from_ident ident)) tt + | Typedtree.Tstr_exception (ident, _) -> + Hashtbl.add table (E (Name.from_ident ident)) tt + | Typedtree.Tstr_exn_rebind (ident, _) -> + Hashtbl.add table (ER (Name.from_ident ident)) tt + | Typedtree.Tstr_type ident_type_decl_list -> + List.iter + (fun (id, e) -> + Hashtbl.add table (T (Name.from_ident id)) + (Typedtree.Tstr_type [(id,e)])) + ident_type_decl_list + | Typedtree.Tstr_class info_list -> + List.iter + (fun ((id,_,_,_) as ci) -> + Hashtbl.add table (C (Name.from_ident id)) + (Typedtree.Tstr_class [ci])) + info_list + | Typedtree.Tstr_cltype info_list -> + List.iter + (fun ((id,_) as ci) -> + Hashtbl.add table + (CT (Name.from_ident id)) + (Typedtree.Tstr_cltype [ci])) + info_list + | Typedtree.Tstr_value (_, pat_exp_list) -> + List.iter + (fun (pat,exp) -> + match iter_val_pattern pat.Typedtree.pat_desc with + None -> () + | Some n -> Hashtbl.add table_values n (pat,exp) + ) + pat_exp_list + | Typedtree.Tstr_primitive (ident, _) -> + Hashtbl.add table (P (Name.from_ident ident)) tt + | Typedtree.Tstr_open _ -> () + | Typedtree.Tstr_include _ -> () + | Typedtree.Tstr_eval _ -> () let tables typedtree = let t = Hashtbl.create 13 in @@ -113,8 +113,8 @@ module Typedtree_search = let search_module table name = match Hashtbl.find table (M name) with - (Typedtree.Tstr_module (_, module_expr)) -> module_expr - | _ -> assert false + (Typedtree.Tstr_module (_, module_expr)) -> module_expr + | _ -> assert false let search_module_type table name = match Hashtbl.find table (MT name) with @@ -129,69 +129,69 @@ module Typedtree_search = let search_exception_rebind table name = match Hashtbl.find table (ER name) with | (Typedtree.Tstr_exn_rebind (_, p)) -> p - | _ -> assert false + | _ -> assert false let search_type_declaration table name = match Hashtbl.find table (T name) with | (Typedtree.Tstr_type [(_,decl)]) -> decl - | _ -> assert false + | _ -> assert false let search_class_exp table name = match Hashtbl.find table (C name) with | (Typedtree.Tstr_class [(_,_,_,ce)]) -> - ( - try - let type_decl = search_type_declaration table name in - (ce, type_decl.Types.type_params) - with - Not_found -> - (ce, []) - ) - | _ -> assert false + ( + try + let type_decl = search_type_declaration table name in + (ce, type_decl.Types.type_params) + with + Not_found -> + (ce, []) + ) + | _ -> assert false let search_class_type_declaration table name = match Hashtbl.find table (CT name) with | (Typedtree.Tstr_cltype [(_,cltype_decl)]) -> cltype_decl - | _ -> assert false + | _ -> assert false let search_value table name = Hashtbl.find table name let search_primitive table name = match Hashtbl.find table (P name) with - Tstr_primitive (ident, val_desc) -> val_desc.Types.val_type - | _ -> assert false + Tstr_primitive (ident, val_desc) -> val_desc.Types.val_type + | _ -> assert false let get_nth_inherit_class_expr cls n = let rec iter cpt = function - | [] -> - raise Not_found - | Typedtree.Cf_inher (clexp, _, _) :: q -> - if n = cpt then clexp else iter (cpt+1) q - | _ :: q -> - iter cpt q + | [] -> + 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 + | [] -> + 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 + | [] -> + raise Not_found + | Typedtree.Cf_meth (label, exp) :: q when label = name -> + exp + | _ :: q -> + iter q in iter cls.Typedtree.cl_field end @@ -230,42 +230,42 @@ module Analyser = *) 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 - } - - | _ -> + 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 - } + Simple_name { sn_name = "()" ; + sn_text = None ; + sn_type = Odoc_env.subst_type env pat.pat_type + } in iter_pattern pat @@ -273,119 +273,119 @@ module Analyser = 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") + [] -> + (* 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 -> + | (pattern_param, exp) :: second_ele :: q -> (* implicit pattern matching -> anonymous parameter and no more parameter *) - (* A VOIR : le label ? *) - let parameter = Odoc_parameter.Tuple ([], Odoc_env.subst_type env pattern_param.pat_type) in - [ parameter ] + (* A VOIR : le label ? *) + let parameter = Odoc_parameter.Tuple ([], Odoc_env.subst_type env pattern_param.pat_type) in + [ parameter ] | (pattern_param, func_body) :: [] -> - let parameter = - tt_param_info_from_pattern - env - (Odoc_parameter.desc_from_info_opt current_comment_opt) - pattern_param + let parameter = + tt_param_info_from_pattern + env + (Odoc_parameter.desc_from_info_opt current_comment_opt) + pattern_param - in + 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 + 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) - | _ -> + 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 ] + [ p ] (** Analysis of a Tstr_value from the typedtree. Create and return a list of [t_value]. - @raise Failure if an error occurs.*) + @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)) -> + (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 ] - + 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 ] - + (* 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 *) - [] - + (* 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 *) - [] + (* something else, we don't care ? A VOIR *) + [] (** This function takes a Typedtree.class_expr and returns a string which can stand for the class name. The name can be "object ... end" if the class expression is not an ident or a class constraint or a class apply. *) let rec tt_name_of_class_expr clexp = match clexp.Typedtree.cl_desc with - 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_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 + | 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 + | _ -> Odoc_messages.object_end (** Analysis of a method expression to get the method parameters. @param first indicates if we're analysing the method for @@ -394,358 +394,358 @@ module Analyser = *) let rec tt_analyse_method_expression env current_method_name comment_opt ?(first=true) exp = match exp.Typedtree.exp_desc with - Typedtree.Texp_function (pat_exp_list, _) -> - ( - match pat_exp_list with - [] -> - (* it is not a function since there are no parameters *) - (* we can't get here normally *) - raise (Failure (Odoc_messages.bad_tree^" "^(Odoc_messages.method_without_param current_method_name))) - | l -> - match l with - [] -> - (* cas impossible, on l'a filtré avant *) - assert false - | (pattern_param, exp) :: second_ele :: q -> + Typedtree.Texp_function (pat_exp_list, _) -> + ( + match pat_exp_list with + [] -> + (* it is not a function since there are no parameters *) + (* we can't get here normally *) + raise (Failure (Odoc_messages.bad_tree^" "^(Odoc_messages.method_without_param current_method_name))) + | l -> + match l with + [] -> + (* cas impossible, on l'a filtré avant *) + assert false + | (pattern_param, exp) :: second_ele :: q -> (* implicit pattern matching -> anonymous parameter *) - (* Note : We can't match this pattern if it is the first call to the function. *) - let new_param = Simple_name - { sn_name = "??" ; sn_text = None; - sn_type = Odoc_env.subst_type env pattern_param.Typedtree.pat_type } - in - [ new_param ] - - | (pattern_param, body) :: [] -> - (* if this is the first call to the function, this is the first parameter and we skip it *) - if not first then - ( - let parameter = - tt_param_info_from_pattern - env - (Odoc_parameter.desc_from_info_opt comment_opt) - pattern_param - in + (* 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 - ) + 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 *) - [] + (* 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 + | [] -> + 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 + | (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. *) + (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 ; - } ) + 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) ) - + (* 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") - ) + 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) + (* 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 = + 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 *) - | _ -> + 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 ; - } ) + 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 + (* 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.") + 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 = @@ -756,24 +756,24 @@ module Analyser = let virt = p_class_decl.Parsetree.pci_virt = Asttypes.Virtual in let cltype = Odoc_env.subst_class_type env tt_class_exp.Typedtree.cl_type in let (parameters, kind) = analyse_class_kind - env - complete_name - comment_opt - pos_start - p_class_decl.Parsetree.pci_expr - tt_class_exp + 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 } ; - } + { + 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 @@ -781,26 +781,26 @@ module Analyser = 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_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 + 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 + 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 @@ -808,14 +808,14 @@ module Analyser = 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)) + | ([], _) -> + [] + | ((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) @@ -824,430 +824,430 @@ module Analyser = print_DEBUG "Odoc_ast:analyse_struture"; let (table, table_values) = Typedtree_search.tables typedtree in let rec iter env last_pos = function - [] -> - let s = get_string_of_file last_pos pos_limit in - let (_, ele_coms) = My_ir.all_special !file_name s in - let ele_comments = - List.fold_left - (fun acc -> fun sc -> - match sc.Odoc_types.i_desc with - None -> - acc - | Some t -> - acc @ [Element_module_comment t]) - [] - ele_coms - in - ele_comments - | item :: q -> - let (comment_opt, ele_comments) = - get_comments_in_module last_pos item.Parsetree.pstr_loc.Location.loc_start - 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 - table - table_values - in - ele_comments @ elements @ (iter new_env (item.Parsetree.pstr_loc.Location.loc_end + maybe_more) q) + [] -> + 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 + table + table_values + 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 - table table_values = + table table_values = print_DEBUG "Odoc_ast:analyse_struture_item"; match parsetree_item_desc with - Parsetree.Pstr_eval _ -> - (* don't care *) - (0, env, []) + Parsetree.Pstr_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 table_values name in - let (info_opt, ele_comments) = - (* we already have the optional comment for the first value. *) - if first then - (comment_opt, []) - else - get_comments_in_module - last_pos - pat.Parsetree.ppat_loc.Location.loc_start - 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) + (* 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 table_values name in + let (info_opt, ele_comments) = + (* we already have the optional comment for the first value. *) + if first then + (comment_opt, []) + else + get_comments_in_module + last_pos + pat.Parsetree.ppat_loc.Location.loc_start + 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 table name_pre in - let name = Name.parens_if_infix name_pre in - let complete_name = Name.concat current_module_name name in - let new_value = { - val_name = complete_name ; - val_info = comment_opt ; - val_type = Odoc_env.subst_type env typ ; - val_recursive = false ; - val_parameters = [] ; - val_code = Some (get_string_of_file loc.Location.loc_start 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]) + (* of string * value_description *) + print_DEBUG ("Parsetree.Pstr_primitive ("^name_pre^", ["^(String.concat ", " val_desc.Parsetree.pval_prim)^"]"); + let typ = Typedtree_search.search_primitive table name_pre in + let name = Name.parens_if_infix name_pre in + let complete_name = Name.concat current_module_name name in + let new_value = { + val_name = complete_name ; + val_info = comment_opt ; + val_type = Odoc_env.subst_type env typ ; + val_recursive = false ; + val_parameters = [] ; + val_code = Some (get_string_of_file loc.Location.loc_start 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 (maybe_more, name_comment_list) = - Sig.name_comment_from_type_kind - loc_start loc_end - pos_limit2 - type_decl.Parsetree.ptype_kind - in - let tt_type_decl = - try Typedtree_search.search_type_declaration table name - with Not_found -> raise (Failure (Odoc_messages.type_not_found_in_typedtree complete_name)) - in - let (com_opt, ele_comments) = (* the comment for the first type was already retrieved *) - if first then - (comment_opt , []) - else - get_comments_in_module last_pos loc_start - in - let kind = Sig.get_type_kind - new_env name_comment_list - tt_type_decl.Types.type_kind - in - let 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 new_end = 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 - t.ty_info <- Sig.merge_infos t.ty_info info_after_opt ; - let (maybe_more3, eles) = f (maybe_more + maybe_more2) (new_end + maybe_more2) q in - (maybe_more3, ele_comments @ ((Element_type t) :: eles)) - in - let (maybe_more, eles) = f ~first: true 0 loc.Location.loc_start name_typedecl_list in - (maybe_more, new_env, eles) + (* 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 (maybe_more, name_comment_list) = + Sig.name_comment_from_type_kind + loc_start loc_end + pos_limit2 + type_decl.Parsetree.ptype_kind + in + let tt_type_decl = + try Typedtree_search.search_type_declaration table name + with Not_found -> raise (Failure (Odoc_messages.type_not_found_in_typedtree complete_name)) + in + let (com_opt, ele_comments) = (* the comment for the first type was already retrieved *) + if first then + (comment_opt , []) + else + get_comments_in_module last_pos loc_start + in + let kind = Sig.get_type_kind + new_env name_comment_list + tt_type_decl.Types.type_kind + in + let 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 new_end = 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 + t.ty_info <- Sig.merge_infos t.ty_info info_after_opt ; + let (maybe_more3, eles) = f (maybe_more + maybe_more2) (new_end + maybe_more2) q in + (maybe_more3, ele_comments @ ((Element_type t) :: eles)) + in + let (maybe_more, eles) = f ~first: true 0 loc.Location.loc_start name_typedecl_list in + (maybe_more, new_env, eles) | Parsetree.Pstr_exception (name, excep_decl) -> - (* a new exception is defined *) - let complete_name = Name.concat current_module_name name in - (* we get the exception declaration in the typed tree *) - let tt_excep_decl = - try Typedtree_search.search_exception table name - with Not_found -> - raise (Failure (Odoc_messages.exception_not_found_in_typedtree complete_name)) - in - let new_env = Odoc_env.add_exception env complete_name in - let 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 ]) + (* a new exception is defined *) + let complete_name = Name.concat current_module_name name in + (* we get the exception declaration in the typed tree *) + let tt_excep_decl = + try Typedtree_search.search_exception table name + with Not_found -> + raise (Failure (Odoc_messages.exception_not_found_in_typedtree complete_name)) + in + let new_env = Odoc_env.add_exception env complete_name in + let 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 table name - with Not_found -> - raise (Failure (Odoc_messages.exception_not_found_in_typedtree complete_name)) - in - let new_env = Odoc_env.add_exception env complete_name in - let new_ex = - { - ex_name = complete_name ; - ex_info = comment_opt ; - ex_args = [] ; - ex_alias = Some { ea_name = (Odoc_env.full_exception_name env (Name.from_path tt_path)) ; - ea_ex = None ; } ; - ex_loc = { loc_impl = Some (!file_name, loc.Location.loc_start) ; loc_inter = None } ; - } - in - (0, new_env, [ Element_exception new_ex ]) + (* a new exception is defined *) + let complete_name = Name.concat current_module_name name in + (* we get the exception rebind in the typed tree *) + let tt_path = + try Typedtree_search.search_exception_rebind table name + with Not_found -> + raise (Failure (Odoc_messages.exception_not_found_in_typedtree complete_name)) + in + let new_env = Odoc_env.add_exception env complete_name in + let new_ex = + { + ex_name = complete_name ; + ex_info = comment_opt ; + ex_args = [] ; + ex_alias = Some { ea_name = (Odoc_env.full_exception_name env (Name.from_path tt_path)) ; + ea_ex = None ; } ; + ex_loc = { loc_impl = Some (!file_name, loc.Location.loc_start) ; 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 table 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 + ( + (* of string * module_expr *) + try + let tt_module_expr = Typedtree_search.search_module table 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 *) - 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)) - ) + 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 table name - with Not_found -> - raise (Failure (Odoc_messages.module_type_not_found_in_typedtree complete_name)) - in - let kind = Sig.analyse_module_type_kind env complete_name - modtype tt_module_type - in - let mt = - { - mt_name = complete_name ; - mt_info = comment_opt ; - mt_type = Some tt_module_type ; - mt_is_interface = false ; - mt_file = !file_name ; - mt_kind = Some kind ; - mt_loc = { loc_impl = Some (!file_name, loc.Location.loc_start) ; 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 + let complete_name = Name.concat current_module_name name in + let tt_module_type = + try Typedtree_search.search_module_type table name + with Not_found -> + raise (Failure (Odoc_messages.module_type_not_found_in_typedtree complete_name)) + in + let kind = Sig.analyse_module_type_kind env complete_name + modtype tt_module_type + in + let mt = + { + mt_name = complete_name ; + mt_info = comment_opt ; + mt_type = Some tt_module_type ; + mt_is_interface = false ; + mt_file = !file_name ; + mt_kind = Some kind ; + mt_loc = { loc_impl = Some (!file_name, loc.Location.loc_start) ; 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 ]) + 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) + (* A VOIR : enrichir l'environnement quand open ? *) + let ele_comments = match comment_opt with + None -> [] + | Some i -> + match i.i_desc with + None -> [] + | Some t -> [Element_module_comment t] + in + (0, env, ele_comments) | Parsetree.Pstr_class class_decl_list -> (* we start by extending the environment *) - let new_env = - List.fold_left - (fun acc_env -> fun class_decl -> - let complete_name = Name.concat current_module_name class_decl.Parsetree.pci_name in - Odoc_env.add_class acc_env complete_name - ) - env - class_decl_list - in - let rec f ?(first=false) last_pos class_decl_list = - match class_decl_list with - [] -> - [] - | class_decl :: q -> - let (tt_class_exp, tt_type_params) = - try Typedtree_search.search_class_exp table class_decl.Parsetree.pci_name - with Not_found -> - let complete_name = Name.concat current_module_name class_decl.Parsetree.pci_name in - raise (Failure (Odoc_messages.class_not_found_in_typedtree complete_name)) - in - let (com_opt, ele_comments) = - if first then - (comment_opt, []) - else - get_comments_in_module last_pos class_decl.Parsetree.pci_loc.Location.loc_start - 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) + let new_env = + List.fold_left + (fun acc_env -> fun class_decl -> + let complete_name = Name.concat current_module_name class_decl.Parsetree.pci_name in + Odoc_env.add_class acc_env complete_name + ) + env + class_decl_list + in + let rec f ?(first=false) last_pos class_decl_list = + match class_decl_list with + [] -> + [] + | class_decl :: q -> + let (tt_class_exp, tt_type_params) = + try Typedtree_search.search_class_exp table class_decl.Parsetree.pci_name + with Not_found -> + let complete_name = Name.concat current_module_name class_decl.Parsetree.pci_name in + raise (Failure (Odoc_messages.class_not_found_in_typedtree complete_name)) + in + let (com_opt, ele_comments) = + if first then + (comment_opt, []) + else + get_comments_in_module last_pos class_decl.Parsetree.pci_loc.Location.loc_start + 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 table name - with Not_found -> - raise (Failure (Odoc_messages.class_type_not_found_in_typedtree complete_name)) - in - let type_params = tt_cltype_declaration.Types.clty_params in - let kind = Sig.analyse_class_type_kind - new_env - complete_name - class_type_decl.Parsetree.pci_loc.Location.loc_start - 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 = Odoc_env.subst_class_type env tt_cltype_declaration.Types.clty_type ; - clt_type_parameters = List.map (Odoc_env.subst_type new_env) type_params ; - clt_virtual = virt ; - clt_kind = kind ; - clt_loc = { loc_impl = Some (!file_name, loc.Location.loc_start) ; - 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) + (* we start by extending the environment *) + let new_env = + List.fold_left + (fun acc_env -> fun class_type_decl -> + let complete_name = Name.concat current_module_name class_type_decl.Parsetree.pci_name in + Odoc_env.add_class_type acc_env complete_name + ) + env + class_type_decl_list + in + let rec f ?(first=false) last_pos class_type_decl_list = + match class_type_decl_list with + [] -> + [] + | class_type_decl :: q -> + let name = class_type_decl.Parsetree.pci_name in + let complete_name = Name.concat current_module_name name in + let virt = class_type_decl.Parsetree.pci_virt = Asttypes.Virtual in + let tt_cltype_declaration = + try Typedtree_search.search_class_type_declaration table name + with Not_found -> + raise (Failure (Odoc_messages.class_type_not_found_in_typedtree complete_name)) + in + let type_params = tt_cltype_declaration.Types.clty_params in + let kind = Sig.analyse_class_type_kind + new_env + complete_name + class_type_decl.Parsetree.pci_loc.Location.loc_start + 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 = Odoc_env.subst_class_type env tt_cltype_declaration.Types.clty_type ; + clt_type_parameters = List.map (Odoc_env.subst_type new_env) type_params ; + clt_virtual = virt ; + clt_kind = kind ; + clt_loc = { loc_impl = Some (!file_name, loc.Location.loc_start) ; + 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 ? *) + (* 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 = @@ -1256,124 +1256,124 @@ module Analyser = 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 = 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 = [] ; - } + { + m_name = complete_name ; + m_type = 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_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 } + 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 } + 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) } + 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 = tt_modtype ; - m_kind = Module_constraint (m_base2.m_kind, - mtkind) - -(* Module_type_alias { mta_name = "Not analyzed" ; - mta_module = None }) + 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 = 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.") + | _ -> + raise (Failure "analyse_module: parsetree and typedtree don't match.") let analyse_typed_tree source_file input_file - (parsetree : Parsetree.structure) (typedtree : typedtree) = + (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 + 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. *) @@ -1386,16 +1386,16 @@ module Analyser = let elements2 = replace_dummy_included_modules elements included_modules_from_tt in let kind = Module_struct elements2 in let m = - { - m_name = mod_name ; - m_type = Types.Tmty_signature [] ; - m_info = info_opt ; - m_is_interface = false ; - m_file = !file_name ; - m_kind = kind ; - m_loc = { loc_impl = Some (!file_name, 0) ; loc_inter = None } ; - m_top_deps = [] ; - } + { + m_name = mod_name ; + m_type = Types.Tmty_signature [] ; + m_info = info_opt ; + m_is_interface = false ; + m_file = !file_name ; + m_kind = kind ; + m_loc = { loc_impl = Some (!file_name, 0) ; loc_inter = None } ; + m_top_deps = [] ; + } in m end diff --git a/ocamldoc/odoc_ast.mli b/ocamldoc/odoc_ast.mli index 53d1105cb..458365b09 100644 --- a/ocamldoc/odoc_ast.mli +++ b/ocamldoc/odoc_ast.mli @@ -26,66 +26,66 @@ module Typedtree_search : val tables : Typedtree.structure_item list -> tab * tab_values (** This function returns the [Typedtree.module_expr] associated to the given module name, - in the given table. - @raise Not_found if the module was not found.*) + in the given table. + @raise Not_found if the module was not found.*) val search_module : tab -> string -> Typedtree.module_expr (** This function returns the [Types.module_type] associated to the given module type name, - in the given table. - @raise Not_found if the module type was not found.*) + in the given table. + @raise Not_found if the module type was not found.*) val search_module_type : tab -> string -> Types.module_type (** This function returns the [Types.exception_declaration] associated to the given exception name, - in the given table. - @raise Not_found if the exception was not found.*) + in the given table. + @raise Not_found if the exception was not found.*) val search_exception : tab -> string -> Types.exception_declaration (** This function returns the [Path.t] associated to the given exception rebind name, - in the table. - @raise Not_found if the exception rebind was not found.*) + in the table. + @raise Not_found if the exception rebind was not found.*) val search_exception_rebind : tab -> string -> Path.t (** This function returns the [Typedtree.type_declaration] associated to the given type name, - in the given table. - @raise Not_found if the type was not found. *) + in the given table. + @raise Not_found if the type was not found. *) val search_type_declaration : tab -> string -> Types.type_declaration (** This function returns the [Typedtree.class_expr] and type parameters - associated to the given class name, in the given table. - @raise Not_found if the class was not found. *) + associated to the given class name, in the given table. + @raise Not_found if the class was not found. *) val search_class_exp : tab -> string -> (Typedtree.class_expr * (Types.type_expr list)) (** This function returns the [Types.cltype_declaration] associated to the given class type name, - in the given table. - @raise Not_found if the class type was not found. *) + in the given table. + @raise Not_found if the class type was not found. *) val search_class_type_declaration : tab -> string -> Types.cltype_declaration (** This function returns the couple (pat, exp) for the given value name, in the - given table of values. - @raise Not found if no value matches the name.*) + given table of values. + @raise Not found if no value matches the name.*) val search_value : tab_values -> string -> Typedtree.pattern * Typedtree.expression (** This function returns the [type_expr] for the given primitive name, in the - given table. - @raise Not found if no value matches the name.*) + given table. + @raise Not found if no value matches the name.*) val search_primitive : tab -> string -> Types.type_expr (** This function returns the [Typedtree.class_expr] associated to - the n'th inherit in the given class structure of typed tree. - @raise Not_found if the class expression could not be found.*) + 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 + 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.*) + 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 + 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.*) + @raise Not_found if the class method could not be found.*) val search_method_expression : - Typedtree.class_structure -> string -> Typedtree.expression + Typedtree.class_structure -> string -> Typedtree.expression end (** The module which performs the analysis of a typed tree. @@ -95,9 +95,9 @@ 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.*) + 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 index 3992c387a..fc367765b 100644 --- a/ocamldoc/odoc_class.ml +++ b/ocamldoc/odoc_class.ml @@ -47,15 +47,15 @@ and class_constr = { and class_kind = Class_structure of inherited_class list * class_element list - (** an explicit class structure, used in implementation and interface *) + (** 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 *) + 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. *) + (** A class definition with a constraint. *) (** Representation of a class. *) and t_class = { @@ -100,11 +100,11 @@ let class_parameter_text_by_name cl label = None -> None | Some i -> try - let t = List.assoc label i.Odoc_types.i_params in - Some t + let t = List.assoc label i.Odoc_types.i_params in + Some t with - Not_found -> - None + Not_found -> + None (** Returns the list of elements of a t_class. *) let rec class_elements ?(trans=true) cl = @@ -112,29 +112,29 @@ let rec class_elements ?(trans=true) cl = match k with Class_structure (_, elements) -> elements | Class_constraint (c_kind, ct_kind) -> - iter_kind c_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 } + 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 - | _ -> [] - ) + ( + match capp.capp_class with + Some c when trans -> class_elements ~trans: trans c + | _ -> [] + ) | Class_constr cco -> - ( - match cco.cco_class with - Some (Cl c) when trans -> class_elements ~trans: trans c - | Some (Cltype (ct,_)) when trans -> class_type_elements ~trans: trans ct - | _ -> [] - ) + ( + match cco.cco_class with + Some (Cl c) when trans -> class_elements ~trans: trans c + | Some (Cltype (ct,_)) when trans -> class_type_elements ~trans: trans ct + | _ -> [] + ) in iter_kind cl.cl_kind @@ -154,10 +154,10 @@ let class_attributes ?(trans=true) cl = List.fold_left (fun acc -> fun ele -> match ele with - Class_attribute a -> - acc @ [ a ] + Class_attribute a -> + acc @ [ a ] | _ -> - acc + acc ) [] (class_elements ~trans cl) @@ -167,10 +167,10 @@ let class_methods ?(trans=true) cl = List.fold_left (fun acc -> fun ele -> match ele with - Class_method m -> - acc @ [ m ] + Class_method m -> + acc @ [ m ] | _ -> - acc + acc ) [] (class_elements ~trans cl) @@ -180,10 +180,10 @@ let class_comments ?(trans=true) cl = List.fold_left (fun acc -> fun ele -> match ele with - Class_comment t -> - acc @ [ t ] + Class_comment t -> + acc @ [ t ] | _ -> - acc + acc ) [] (class_elements ~trans cl) @@ -201,10 +201,10 @@ let class_type_attributes ?(trans=true) clt = List.fold_left (fun acc -> fun ele -> match ele with - Class_attribute a -> - acc @ [ a ] + Class_attribute a -> + acc @ [ a ] | _ -> - acc + acc ) [] (class_type_elements ~trans clt) @@ -214,10 +214,10 @@ let class_type_methods ?(trans=true) clt = List.fold_left (fun acc -> fun ele -> match ele with - Class_method m -> - acc @ [ m ] + Class_method m -> + acc @ [ m ] | _ -> - acc + acc ) [] (class_type_elements ~trans clt) @@ -227,10 +227,10 @@ let class_type_comments ?(trans=true) clt = List.fold_left (fun acc -> fun ele -> match ele with - Class_comment m -> - acc @ [ m ] + Class_comment m -> + acc @ [ m ] | _ -> - acc + acc ) [] (class_type_elements ~trans clt) @@ -242,10 +242,10 @@ let class_type_parameter_text_by_name clt label = None -> None | Some i -> try - let t = List.assoc label i.Odoc_types.i_params in - Some t + let t = List.assoc label i.Odoc_types.i_params in + Some t with - Not_found -> - None + Not_found -> + None - + diff --git a/ocamldoc/odoc_comments.ml b/ocamldoc/odoc_comments.ml index be3d17f9d..2b1d1f6fd 100644 --- a/ocamldoc/odoc_comments.ml +++ b/ocamldoc/odoc_comments.ml @@ -30,72 +30,72 @@ module Info_retriever = 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) + 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)) + | 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) + 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 @@ -103,36 +103,36 @@ module Info_retriever = 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 <> '*') && - ( + 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 + 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 - ) + false + with + Not_found -> + true + ) with - Not_found -> - false + 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 + let _ = Str.search_forward (Str.regexp ("['\n']"^simple_blank^"*['\n']")) s 0 in (* a blank line was before the comment *) - true + true with - Not_found -> - false - + Not_found -> + false + let retrieve_info_special file (s : string) = retrieve_info Odoc_lexer.main file s @@ -141,27 +141,27 @@ module Info_retriever = Odoc_lexer.comments_level := 0; let lexbuf = Lexing.from_string s in match Odoc_parser.main Odoc_lexer.simple lexbuf with - None -> - (0, None) + None -> + (0, None) | Some (desc, remain_opt) -> - (!Odoc_comments_global.nb_chars, Some Odoc_types.dummy_info) + (!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 + 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 @@ -171,72 +171,72 @@ module Info_retriever = 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) + (_, 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) + 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) + 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 + 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"); @@ -245,30 +245,30 @@ module Info_retriever = let just_after_special file s = print_DEBUG ("just_after_special: "^s); let res = match retrieve_info_special file s with - (_, None) -> - (0, None) - | (len, Some d) -> - (* we must not have a simple comment or a blank line before. *) - match retrieve_info_simple file (String.sub s 0 len) with - (_, None) -> - ( - try - (* if the special comment is the stop comment (**/**), - then we must not associate it. *) - let pos = Str.search_forward (Str.regexp_string "(**") s 0 in - if blank_line (String.sub s 0 pos) or - d.Odoc_types.i_desc = Some [Odoc_types.Raw "/*"] - then - (0, None) - else - (len, Some d) - with - Not_found -> - (* should not occur *) - (0, None) - ) - | (len2, Some d2) -> - (0, None) + (_, None) -> + (0, None) + | (len, Some d) -> + (* we must not have a simple comment or a blank line before. *) + match retrieve_info_simple file (String.sub s 0 len) with + (_, None) -> + ( + try + (* if the special comment is the stop comment (**/**), + then we must not associate it. *) + let pos = Str.search_forward (Str.regexp_string "(**") s 0 in + if blank_line (String.sub s 0 pos) or + d.Odoc_types.i_desc = Some [Odoc_types.Raw "/*"] + then + (0, None) + else + (len, Some d) + with + Not_found -> + (* should not occur *) + (0, None) + ) + | (len2, Some d2) -> + (0, None) in print_DEBUG ("just_after_special:end"); res @@ -279,32 +279,32 @@ module Info_retriever = let get_comments f_create_ele file s = let (assoc_com, ele_coms) = (* get the comments *) - let (len, special_coms) = all_special file s in - (* if there is no blank line after the special comments, and - if the last special comment is not the stop special comment, then the - last special comments must be associated to the element. *) - match List.rev special_coms with - [] -> - (None, []) - | h :: q -> - if (blank_line_outside_simple file - (String.sub s len ((String.length s) - len)) ) - or h.Odoc_types.i_desc = Some [Odoc_types.Raw "/*"] - then - (None, special_coms) - else - (Some h, List.rev q) + let (len, special_coms) = all_special file s in + (* if there is no blank line after the special comments, and + if the last special comment is not the stop special comment, then the + last special comments must be associated to the element. *) + match List.rev special_coms with + [] -> + (None, []) + | h :: q -> + if (blank_line_outside_simple file + (String.sub s len ((String.length s) - len)) ) + or h.Odoc_types.i_desc = Some [Odoc_types.Raw "/*"] + then + (None, special_coms) + else + (Some h, List.rev q) in let ele_comments = - List.fold_left - (fun acc -> fun sc -> - match sc.Odoc_types.i_desc with - None -> - acc - | Some t -> - acc @ [f_create_ele t]) - [] - ele_coms + 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 diff --git a/ocamldoc/odoc_comments.mli b/ocamldoc/odoc_comments.mli index 50e891cdc..349ccaf96 100644 --- a/ocamldoc/odoc_comments.mli +++ b/ocamldoc/odoc_comments.mli @@ -44,7 +44,7 @@ module Basic_info_retriever : [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 diff --git a/ocamldoc/odoc_cross.ml b/ocamldoc/odoc_cross.ml index d422ba7c0..dda37d8ea 100644 --- a/ocamldoc/odoc_cross.ml +++ b/ocamldoc/odoc_cross.ml @@ -32,13 +32,13 @@ module P_alias = let p_module m _ = (true, match m.m_kind with - Module_alias _ -> true + Module_alias _ -> true | _ -> false ) let p_module_type mt _ = (true, match mt.mt_kind with - Some (Module_type_alias _) -> true + Some (Module_type_alias _) -> true | _ -> false ) let p_class c _ = (false, false) @@ -59,23 +59,23 @@ 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 + 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 + 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 + 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 -> @@ -124,9 +124,9 @@ 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 + match res with + Odoc_search.Res_module _ -> true + | _ -> false ) (Search_by_complete_name.search module_list name) in @@ -137,9 +137,9 @@ let rec lookup_module module_list name = let rec lookup_module_type module_list name = let l = List.filter (fun res -> - match res with - Odoc_search.Res_module_type _ -> true - | _ -> false + match res with + Odoc_search.Res_module_type _ -> true + | _ -> false ) (Search_by_complete_name.search module_list name) in @@ -150,9 +150,9 @@ let rec lookup_module_type module_list name = let rec lookup_class module_list name = let l = List.filter (fun res -> - match res with - Odoc_search.Res_class _ -> true - | _ -> false + match res with + Odoc_search.Res_class _ -> true + | _ -> false ) (Search_by_complete_name.search module_list name) in @@ -163,9 +163,9 @@ let rec lookup_class module_list name = let rec lookup_class_type module_list name = let l = List.filter (fun res -> - match res with - Odoc_search.Res_class_type _ -> true - | _ -> false + match res with + Odoc_search.Res_class_type _ -> true + | _ -> false ) (Search_by_complete_name.search module_list name) in @@ -176,9 +176,9 @@ let rec lookup_class_type module_list name = let rec lookup_exception module_list name = let l = List.filter (fun res -> - match res with - Odoc_search.Res_exception _ -> true - | _ -> false + match res with + Odoc_search.Res_exception _ -> true + | _ -> false ) (Search_by_complete_name.search module_list name) in @@ -202,97 +202,97 @@ let rec associate_in_module module_list (acc_b_modif, acc_incomplete_top_module_ 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 - + 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) - ) + ( + 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 + 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 } - + 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 + 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 } + 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 + 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 + iter_kind (acc_b, acc_inc, acc_names) k | Module_type_with (k, _) -> - iter_kind (acc_b, acc_inc, acc_names) 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) + 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) @@ -304,50 +304,50 @@ and associate_in_module_element module_list m_name (acc_b_modif, acc_incomplete_ | 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) + 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) + 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) @@ -356,82 +356,82 @@ and associate_in_class module_list (acc_b_modif, acc_incomplete_top_module_names 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 + 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) - ) + ( + 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 -> - ( - let clt_opt = - try Some (lookup_class_type module_list cco.cco_name) - with Not_found -> None - in - match clt_opt with - None -> - (acc_b, (Name.head c.cl_name) :: acc_inc, - (* we don't want to output warning messages for "object ... end" classes not found *) - (if cco.cco_name = Odoc_messages.object_end then acc_names else (NF_cct cco.cco_name) :: acc_names)) - | Some ct -> - cco.cco_class <- Some (Cltype (ct, [])) ; - (true, acc_inc, acc_names) - ) - | Some c -> - cco.cco_class <- Some (Cl c) ; - (true, acc_inc, acc_names) - ) + ( + 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 -> + ( + let clt_opt = + try Some (lookup_class_type module_list cco.cco_name) + with Not_found -> None + in + match clt_opt with + None -> + (acc_b, (Name.head c.cl_name) :: acc_inc, + (* we don't want to output warning messages for "object ... end" classes not found *) + (if cco.cco_name = Odoc_messages.object_end then acc_names else (NF_cct cco.cco_name) :: acc_names)) + | Some ct -> + cco.cco_class <- Some (Cltype (ct, [])) ; + (true, acc_inc, acc_names) + ) + | Some c -> + cco.cco_class <- Some (Cl c) ; + (true, acc_inc, acc_names) + ) | Class_constraint (ckind, ctkind) -> - let (acc_b2, acc_inc2, acc_names2) = iter_kind (acc_b, acc_inc, acc_names) ckind in - associate_in_class_type module_list (acc_b2, acc_inc2, acc_names2) - { clt_name = "" ; clt_info = None ; - clt_type = c.cl_type ; (* should be ok *) - clt_type_parameters = [] ; - clt_virtual = false ; - clt_kind = ctkind ; - clt_loc = Odoc_types.dummy_loc } + 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 @@ -439,45 +439,45 @@ and associate_in_class_type module_list (acc_b_modif, acc_incomplete_top_module_ 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 + 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) - ) + ( + 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 @@ -500,8 +500,8 @@ let rec assoc_comments_text_elements module_list t_ele = | 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) + | 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) @@ -509,27 +509,27 @@ let rec assoc_comments_text_elements module_list t_ele = | 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) + 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 @@ -574,12 +574,12 @@ and assoc_comments_module_kind module_list mk = mk | Module_apply (mk1, mk2) -> Module_apply (assoc_comments_module_kind module_list mk1, - assoc_comments_module_kind module_list mk2) + 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) + assoc_comments_module_type_kind module_list mtk) and assoc_comments_module_type_kind module_list mtk = match mtk with @@ -596,10 +596,10 @@ 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 + 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) @@ -607,16 +607,16 @@ and assoc_comments_class_kind module_list ck = | Class_constr _ -> ck | Class_constraint (ck1, ctk) -> Class_constraint (assoc_comments_class_kind module_list ck1, - assoc_comments_class_type_kind module_list ctk) + 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 + 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) @@ -669,12 +669,12 @@ and assoc_comments_type module_list t = Type_abstract -> () | Type_variant vl -> List.iter - (fun vc -> vc.vc_text <- ao (assoc_comments_text module_list) vc.vc_text) - vl + (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 + (fun rf -> rf.rf_text <- ao (assoc_comments_text module_list) rf.rf_text) + fl ); t @@ -699,8 +699,8 @@ let associate 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 + 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) = @@ -708,8 +708,8 @@ let associate module_list = 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 + (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 *) @@ -725,23 +725,23 @@ let associate module_list = () | 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 + (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_dag2html.ml b/ocamldoc/odoc_dag2html.ml index 7ddf4d57c..4231bab00 100644 --- a/ocamldoc/odoc_dag2html.ml +++ b/ocamldoc/odoc_dag2html.ml @@ -1661,54 +1661,54 @@ let create_class_dag cl_list clt_list = 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 + (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 + | (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) + [] -> [] + | (name, _) :: q -> (name, n) :: (f (n+1) q) in f 0 distinct_classes in @@ -1716,24 +1716,24 @@ let create_class_dag cl_list clt_list = (* 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 - | _ -> - [] - ) - ); + (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 = [] } @@ -1743,7 +1743,7 @@ let create_class_dag cl_list clt_list = 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) + (List.filter (fun n -> List.mem i n.pare) l) in node.chil <- List.map (fun (name,_) -> List.assoc name liste_index) l2 in @@ -1752,4 +1752,4 @@ let create_class_dag cl_list clt_list = - + diff --git a/ocamldoc/odoc_dag2html.mli b/ocamldoc/odoc_dag2html.mli index 96d44affa..b66de064c 100644 --- a/ocamldoc/odoc_dag2html.mli +++ b/ocamldoc/odoc_dag2html.mli @@ -25,6 +25,6 @@ val html_of_dag : string dag -> string 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 + (Odoc_info.Name.t * Odoc_info.Class.cct option) dag diff --git a/ocamldoc/odoc_dep.ml b/ocamldoc/odoc_dep.ml index ad8d94f4c..c87423f21 100644 --- a/ocamldoc/odoc_dep.ml +++ b/ocamldoc/odoc_dep.ml @@ -49,50 +49,50 @@ module Dep = !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 *) + 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 + S.add + children + S.empty in { id = s; - near = S.remove s set ; - far = [] ; - reflex = List.mem s children ; + 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 [] + make_node s [] let rec trans_closure graph acc n = if S.mem n.id acc then - acc + 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) + (* 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) + (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 @@ -101,31 +101,31 @@ module Dep = 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; + (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 + node.near <- S.add node.id node.near else - () + () let kernel graph = (* compute transitive closure *) @@ -153,22 +153,22 @@ let type_deps t = 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 + (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 + (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 @@ -192,7 +192,7 @@ let kernel_deps_of_modules modules = (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) + 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, @@ -206,16 +206,16 @@ let deps_of_types ?(kernel=false) types = if kernel then ( let graph = List.map - (fun (t, names) -> Dep.make_node t.Type.ty_name names) - deps_pre + (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 + (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 diff --git a/ocamldoc/odoc_dot.ml b/ocamldoc/odoc_dot.ml index 55a900426..2a5366f47 100644 --- a/ocamldoc/odoc_dot.ml +++ b/ocamldoc/odoc_dot.ml @@ -42,40 +42,40 @@ class dot = method get_one_color = match colors with - [] -> None - | h :: q -> - colors <- q ; - Some h + [] -> 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 + 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 + 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 + 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 + (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 @@ -83,48 +83,48 @@ class dot = 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 + (self#print_one_dep fmt t.Type.ty_name) + l method generate_types types = try - let oc = open_out !Odoc_args.out_file in - let fmt = F.formatter_of_out_channel oc in - F.fprintf fmt "%s" self#header; - let graph = Odoc_info.Dep.deps_of_types - ~kernel: !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 + let oc = open_out !Odoc_args.out_file in + let fmt = F.formatter_of_out_channel oc in + F.fprintf fmt "%s" self#header; + let graph = Odoc_info.Dep.deps_of_types + ~kernel: !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) + Sys_error s -> + raise (Failure s) method generate_modules modules_list = try - modules <- modules_list ; - let oc = open_out !Odoc_args.out_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 + modules <- modules_list ; + let oc = open_out !Odoc_args.out_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) + Sys_error s -> + raise (Failure s) (** Generate the dot code in the file {!Odoc_args.out_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) + self#generate_types (Odoc_info.Search.types modules_list) else - self#generate_modules modules_list + self#generate_modules modules_list end diff --git a/ocamldoc/odoc_env.ml b/ocamldoc/odoc_env.ml index 4eb5cf02a..a9432a5af 100644 --- a/ocamldoc/odoc_env.ml +++ b/ocamldoc/odoc_env.ml @@ -54,24 +54,24 @@ let rec add_signature env root ?rel signat = | 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 } + 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 } + 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 @@ -183,19 +183,19 @@ let subst_type env t = Btype.iter_type_expr iter t; match t.Types.desc with | Types.Tconstr (p, [ty], a) when Path.same p Predef.path_option -> - () + () | Types.Tconstr (p, l, a) -> - let new_p = + let new_p = Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in - t.Types.desc <- Types.Tconstr (new_p, l, a) + t.Types.desc <- Types.Tconstr (new_p, l, a) | Types.Tobject (_, ({contents=Some(p,tyl)} as r)) -> - let new_p = + let new_p = Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in r := Some (new_p, tyl) | Types.Tvariant ({Types.row_name=Some(p, tyl)} as row) -> - let new_p = + let new_p = Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in - t.Types.desc <- + t.Types.desc <- Types.Tvariant {row with Types.row_name=Some(new_p, tyl)} | _ -> () @@ -209,12 +209,12 @@ 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 + 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 + t | Types.Tmty_functor (id, mt1, mt2) -> - Types.Tmty_functor (id, iter mt1, iter mt2) + Types.Tmty_functor (id, iter mt1, iter mt2) in iter t @@ -222,16 +222,16 @@ let subst_class_type env t = let rec iter t = match t with Types.Tcty_constr (p,texp_list,ct) -> - let new_p = Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in - let new_texp_list = List.map (subst_type env) texp_list in - let new_ct = iter ct in - Types.Tcty_constr (new_p, new_texp_list, new_ct) + let new_p = Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in + let new_texp_list = List.map (subst_type env) texp_list in + let new_ct = iter ct in + Types.Tcty_constr (new_p, new_texp_list, new_ct) | Types.Tcty_signature cs -> - (* on ne s'occupe pas des vals et methods *) - t + (* on ne s'occupe pas des vals et methods *) + t | Types.Tcty_fun (l, texp, ct) -> - let new_texp = subst_type env texp in - let new_ct = iter ct in - Types.Tcty_fun (l, new_texp, new_ct) + let new_texp = subst_type env texp in + let new_ct = iter ct in + Types.Tcty_fun (l, new_texp, new_ct) in iter t diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml index c5b610db9..995d77c9c 100644 --- a/ocamldoc/odoc_html.ml +++ b/ocamldoc/odoc_html.ml @@ -56,8 +56,8 @@ module Naming = 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 + 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) @@ -140,9 +140,9 @@ class text = let len = String.length s in let buf = Buffer.create len in for i = 0 to len - 1 do - match s.[i] with - 'a'..'z' | 'A'..'Z' | '0'..'9' -> Buffer.add_char buf s.[i] - | _ -> () + match s.[i] with + 'a'..'z' | 'A'..'Z' | '0'..'9' -> Buffer.add_char buf s.[i] + | _ -> () done; Buffer.contents buf @@ -151,12 +151,12 @@ class text = from the title level and the first sentence of the title.*) method create_title_label (n,label_opt,t) = match label_opt with - Some s -> s - | None -> - let t2 = Odoc_info.first_sentence_of_text t in - let s = Odoc_info.string_of_text t2 in - let s2 = self#keep_alpha_num s in - Printf.sprintf "%d%s" n s2 + Some s -> s + | None -> + let t2 = Odoc_info.first_sentence_of_text t in + let s = Odoc_info.string_of_text t2 in + let s2 = self#keep_alpha_num s in + Printf.sprintf "%d%s" n s2 (** Return the html code corresponding to the [text] parameter. *) method html_of_text t = String.concat "" (List.map self#html_of_text_element t) @@ -165,40 +165,40 @@ class text = 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 + | 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 + self#html_of_code ~with_pre: false s else - "<code class=\""^Odoc_ocamlhtml.code_class^"\">"^(self#escape s)^"</code>" + "<code class=\""^Odoc_ocamlhtml.code_class^"\">"^(self#escape s)^"</code>" method html_of_CodePre s = if !Odoc_args.colorize_code then - "<pre></pre>"^(self#html_of_code s)^"<pre></pre>" + "<pre></pre>"^(self#html_of_code s)^"<pre></pre>" else - "<pre><code class=\""^Odoc_ocamlhtml.code_class^"\">"^(self#escape s)^"</code></pre>" + "<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>" @@ -211,13 +211,13 @@ class text = method html_of_List tl = "<ul>\n"^ (String.concat "" - (List.map (fun t -> "<li>"^(self#html_of_text t)^"</li>\n") tl))^ + (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))^ + (List.map (fun t -> "<li>"^(self#html_of_text t)^"</li>\n") tl))^ "</OL>\n" method html_of_Newline = "\n<p>\n" @@ -242,26 +242,26 @@ class text = 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>" + 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>" @@ -285,132 +285,132 @@ class virtual info = (** 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" + "<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 -> "" + 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 -> "" + 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" + "<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 + 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" + "<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 -> "" + 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; + (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 -> - "" + 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" + 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. The titles and lists in this first sentence has been removed.*) method html_of_info_first_sentence info_opt = match info_opt with - None -> "" + 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.text_no_title_no_list - (Odoc_info.first_sentence_of_text d)))^"\n" - )^ - (if dep then "</font>" else "") ^ - "</div>\n" + 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.text_no_title_no_list + (Odoc_info.first_sentence_of_text d)))^"\n" + )^ + (if dep then "</font>" else "") ^ + "</div>\n" end @@ -427,29 +427,29 @@ class html = (** The default style options. *) val mutable default_style_options = ["a:visited {color : #416DFF; text-decoration : none; }" ; - "a:link {color : #416DFF; text-decoration : none;}" ; - "a:hover {color : Red; text-decoration : none; background-color: #5FFF88}" ; - "a:active {color : Red; text-decoration : underline; }" ; - ".keyword { font-weight : bold ; color : Red }" ; - ".keywordsign { color : #C04600 }" ; - ".superscript { font-size : 4 }" ; - ".subscript { font-size : 4 }" ; - ".comment { color : Green }" ; - ".constructor { color : Blue }" ; - ".type { color : #5C6585 }" ; - ".string { color : Maroon }" ; - ".warning { color : Red ; font-weight : bold }" ; - ".info { margin-left : 3em; margin-right : 3em }" ; - ".code { color : #465F91 ; }" ; - ".title1 { font-size : 20pt ; background-color : #909DFF }" ; - ".title2 { font-size : 20pt ; background-color : #90BDFF }" ; - ".title3 { font-size : 20pt ; background-color : #90DDFF }" ; - ".title4 { font-size : 20pt ; background-color : #90EDFF }" ; - ".title5 { font-size : 20pt ; background-color : #90FDFF }" ; - ".title6 { font-size : 20pt ; background-color : #C0FFFF }" ; - "body { background-color : White }" ; - "tr { background-color : White }" ; - ] + "a:link {color : #416DFF; text-decoration : none;}" ; + "a:hover {color : Red; text-decoration : none; background-color: #5FFF88}" ; + "a:active {color : Red; text-decoration : underline; }" ; + ".keyword { font-weight : bold ; color : Red }" ; + ".keywordsign { color : #C04600 }" ; + ".superscript { font-size : 4 }" ; + ".subscript { font-size : 4 }" ; + ".comment { color : Green }" ; + ".constructor { color : Blue }" ; + ".type { color : #5C6585 }" ; + ".string { color : Maroon }" ; + ".warning { color : Red ; font-weight : bold }" ; + ".info { margin-left : 3em; margin-right : 3em }" ; + ".code { color : #465F91 ; }" ; + ".title1 { font-size : 20pt ; background-color : #909DFF }" ; + ".title2 { font-size : 20pt ; background-color : #90BDFF }" ; + ".title3 { font-size : 20pt ; background-color : #90DDFF }" ; + ".title4 { font-size : 20pt ; background-color : #90EDFF }" ; + ".title5 { font-size : 20pt ; background-color : #90FDFF }" ; + ".title6 { font-size : 20pt ; background-color : #C0FFFF }" ; + "body { background-color : White }" ; + "tr { background-color : White }" ; + ] (** The style file for all pages. *) val mutable style_file = "style.css" @@ -519,21 +519,21 @@ class html = (** 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 ; - ) + 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_file <- f ); style <- "<link rel=\"stylesheet\" href=\""^style_file^"\" type=\"text/css\">\n" @@ -551,56 +551,56 @@ class html = (** A function to build the header of pages. *) method prepare_header module_list = let f ?(nav=None) ?(comments=[]) 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^"\">" - ) - module_list - ) - )^ - (self#html_sections_links comments)^ - "<title>"^ - t^ - "</title>\n</head>\n" + 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^"\">" + ) + module_list + ) + )^ + (self#html_sections_links comments)^ + "<title>"^ + t^ + "</title>\n</head>\n" in header <- f @@ -609,37 +609,37 @@ class html = method html_sections_links comments = let titles = List.flatten (List.map Odoc_info.get_titles_in_text comments) in let levels = - let rec iter acc l = - match l with - [] -> acc - | (n,_,_) :: q -> - if List.mem n acc - then iter acc q - else iter (n::acc) q - in - iter [] titles + let rec iter acc l = + match l with + [] -> acc + | (n,_,_) :: q -> + if List.mem n acc + then iter acc q + else iter (n::acc) q + in + iter [] titles in let sorted_levels = List.sort compare levels in let (section_level, subsection_level) = - match sorted_levels with - [] -> (None, None) - | [n] -> (Some n, None) - | n :: m :: _ -> (Some n, Some m) + match sorted_levels with + [] -> (None, None) + | [n] -> (Some n, None) + | n :: m :: _ -> (Some n, Some m) in let titles_per_level level_opt = - match level_opt with - None -> [] - | Some n -> List.filter (fun (m,_,_) -> m = n) titles + match level_opt with + None -> [] + | Some n -> List.filter (fun (m,_,_) -> m = n) titles in let section_titles = titles_per_level section_level in let subsection_titles = titles_per_level subsection_level in let create_lines s_rel titles = - List.map - (fun (n,lopt,t) -> - let s = Odoc_info.string_of_text t in - let label = self#create_title_label (n,lopt,t) in - Printf.sprintf "<link title=\"%s\" rel=\"%s\" href=\"#%s\">\n" s s_rel label) - titles + List.map + (fun (n,lopt,t) -> + let s = Odoc_info.string_of_text t in + let label = self#create_title_label (n,lopt,t) in + Printf.sprintf "<link title=\"%s\" rel=\"%s\" href=\"#%s\">\n" s s_rel label) + titles in let section_lines = create_lines "Section" section_titles in let subsection_lines = create_lines "Subsection" subsection_titles in @@ -652,9 +652,9 @@ class html = method navbar pre post name = "<div class=\"navbar\">"^ (match pre with - None -> "" + None -> "" | Some name -> - "<a href=\""^(fst (Naming.html_files name))^"\">"^Odoc_messages.previous^"</a>\n" + "<a href=\""^(fst (Naming.html_files name))^"\">"^Odoc_messages.previous^"</a>\n" )^ " "^ ( @@ -664,9 +664,9 @@ class html = )^ " "^ (match post with - None -> "" + None -> "" | Some name -> - "<a href=\""^(fst (Naming.html_files name))^"\">"^Odoc_messages.next^"</a>\n" + "<a href=\""^(fst (Naming.html_files name))^"\">"^Odoc_messages.next^"</a>\n" )^ "</div>\n" @@ -680,44 +680,44 @@ class html = (** 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 + 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 + Sys_error s -> + incr Odoc_info.errors ; + prerr_endline s (** Take a string and return the string where fully qualified type (or class or class type) idents have been replaced by links to the type referenced by the ident.*) method create_fully_qualified_idents_links m_name s = let f str_t = - let match_s = Str.matched_string str_t in - let rel = Name.get_relative m_name match_s in - let s_final = Odoc_info.apply_if_equal - Odoc_info.use_hidden_modules - match_s - rel - in - if List.mem match_s known_types_names then - "<a href=\""^(Naming.complete_target Naming.mark_type match_s)^"\">"^ - s_final^ - "</a>" - else - if List.mem match_s known_classes_names then - let (html_file, _) = Naming.html_files match_s in - "<a href=\""^html_file^"\">"^s_final^"</a>" - else - s_final + let match_s = Str.matched_string str_t in + let rel = Name.get_relative m_name match_s in + let s_final = Odoc_info.apply_if_equal + Odoc_info.use_hidden_modules + match_s + rel + in + if List.mem match_s known_types_names then + "<a href=\""^(Naming.complete_target Naming.mark_type match_s)^"\">"^ + s_final^ + "</a>" + else + if List.mem match_s known_classes_names then + let (html_file, _) = Naming.html_files match_s in + "<a href=\""^html_file^"\">"^s_final^"</a>" + else + s_final in let s2 = Str.global_substitute - (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)") - f - s + (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)") + f + s in s2 @@ -725,24 +725,24 @@ class html = 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 + 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 + (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)) + (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>" @@ -751,7 +751,7 @@ class html = (** Return html code to display a [Types.class_type].*) method html_of_class_type_expr m_name t = let s = String.concat "\n" - (Str.split (Str.regexp "\n") (Odoc_info.string_of_class_type t)) + (Str.split (Str.regexp "\n") (Odoc_info.string_of_class_type 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>" @@ -768,22 +768,22 @@ class html = (** 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)) + (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 ~complete: true mtyp)) + (Str.split (Str.regexp "\n") (Odoc_info.string_of_module_type ~complete: true mtyp)) in self#output_code in_title file s (** Generate a file containing the class type in the given file name. *) method output_class_type in_title file ctyp = let s = String.concat "\n" - (Str.split (Str.regexp "\n") (Odoc_info.string_of_class_type ~complete: true ctyp)) + (Str.split (Str.regexp "\n") (Odoc_info.string_of_class_type ~complete: true ctyp)) in self#output_code in_title file s @@ -795,18 +795,18 @@ class html = (* html mark *) "<a name=\""^(Naming.value_target v)^"\"></a>"^ (match v.val_code with - None -> Name.simple v.val_name + 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>" + 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 + 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 + self#html_of_described_parameter_list (Name.father v.val_name) v.val_parameters ) (** Return html code for an exception. *) @@ -817,19 +817,19 @@ class html = "<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) + [] -> "" + | _ -> + " "^(self#keyword "of")^" "^ + (self#html_of_type_expr_list (Name.father e.ex_name) " * " e.ex_args) )^ (match e.ex_alias with - None -> "" + 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>" - ) + ( + 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) @@ -842,95 +842,95 @@ class html = (* 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)^") " + [] -> "" + | 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" + 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" @@ -943,11 +943,11 @@ class html = "<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 + 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>" + 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) @@ -961,127 +961,127 @@ class html = (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 + 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>" + 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 + 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 + 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 - ) + 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 - ) + 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%\" class=\"code\">\n"^ - (match Parameter.complete_name p with - "" -> "?" - | s -> s - )^"</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" + "<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%\" class=\"code\">\n"^ + (match Parameter.complete_name p with + "" -> "?" + | s -> s + )^"</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 + (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 class=\"code\">"^(Parameter.complete_name p)^"</code> : "^ - (self#html_of_parameter_description p)^"</div>\n" + "<div class=\"info\"><code class=\"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)) + [] -> "" + | _ -> "<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" + "<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. *) method html_of_module ?(info=true) ?(complete=true) ?(with_link=true) m = @@ -1092,15 +1092,15 @@ class html = p buf "<pre>%s " (self#keyword "module"); ( if with_link then - p buf "<a href=\"%s\">%s</a>" html_file (Name.simple m.m_name) + p buf "<a href=\"%s\">%s</a>" html_file (Name.simple m.m_name) else - p buf "%s" (Name.simple m.m_name) + p buf "%s" (Name.simple m.m_name) ); p buf ": %s</pre>" (self#html_of_module_type father m.m_type); if info then - p buf "%s" ((if complete then self#html_of_info else self#html_of_info_first_sentence) m.m_info) + p buf "%s" ((if complete then self#html_of_info else self#html_of_info_first_sentence) m.m_info) else - (); + (); Buffer.contents buf (** Return html code for a module type. *) @@ -1112,19 +1112,19 @@ class html = p buf "<pre>%s " (self#keyword "module type"); ( if with_link then - p buf "<a href=\"%s\">%s</a>" html_file (Name.simple mt.mt_name) - else - p buf "%s" (Name.simple mt.mt_name) + p buf "<a href=\"%s\">%s</a>" html_file (Name.simple mt.mt_name) + else + p buf "%s" (Name.simple mt.mt_name) ); (match mt.mt_type with - None -> () - | Some mtyp -> p buf " = %s" (self#html_of_module_type father mtyp) + None -> () + | Some mtyp -> p buf " = %s" (self#html_of_module_type father mtyp) ); Buffer.add_string buf "</pre>"; if info then - p buf "%s" ((if complete then self#html_of_info else self#html_of_info_first_sentence) mt.mt_info) + p buf "%s" ((if complete then self#html_of_info else self#html_of_info_first_sentence) mt.mt_info) else - (); + (); Buffer.contents buf (** Return html code for an included module. *) @@ -1132,19 +1132,19 @@ class html = "<pre>"^(self#keyword "include")^" "^ ( match im.im_module with - None -> - im.im_name + 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>" + 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" @@ -1157,28 +1157,28 @@ class html = let p = Printf.bprintf in p buf "<pre>%s " (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 *) + go directly here when the class name is used as a type name *) p buf "<a name=\"%s\"></a>" - (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 }); + (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 }); print_DEBUG "html#html_of_class : virtual or not" ; if c.cl_virtual then p buf "%s " (self#keyword "virtual") else (); ( match c.cl_type_parameters with - [] -> () + [] -> () | l -> - p buf "[%s] " - (self#html_of_type_expr_list father ", " l) + p buf "[%s] " + (self#html_of_type_expr_list father ", " l) ); print_DEBUG "html#html_of_class : with link or not" ; ( if with_link then - p buf "<a href=\"%s\">%s</a>" html_file (Name.simple c.cl_name) + p buf "<a href=\"%s\">%s</a>" html_file (Name.simple c.cl_name) else - p buf "%s" (Name.simple c.cl_name) + p buf "%s" (Name.simple c.cl_name) ); Buffer.add_string buf " : " ; @@ -1186,7 +1186,7 @@ class html = Buffer.add_string buf "</pre>" ; print_DEBUG "html#html_of_class : info" ; Buffer.add_string buf - ((if complete then self#html_of_info else self#html_of_info_first_sentence) c.cl_info); + ((if complete then self#html_of_info else self#html_of_info_first_sentence) c.cl_info); Buffer.contents buf (** Return html code for a class type. *) @@ -1198,24 +1198,24 @@ class html = let (html_file, _) = Naming.html_files ct.clt_name in p buf "<pre>%s " (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 *) + go directly here when the class type name is used as a type name *) p buf "<a name=\"%s\"></a>" - (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 }); + (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 }); if ct.clt_virtual then p buf "%s "(self#keyword "virtual") else (); ( match ct.clt_type_parameters with - [] -> () - | l -> p buf "[%s] " (self#html_of_type_expr_list father ", " l) + [] -> () + | l -> p buf "[%s] " (self#html_of_type_expr_list father ", " l) ); if with_link then - p buf "<a href=\"%s\">%s</a>" html_file (Name.simple ct.clt_name) + p buf "<a href=\"%s\">%s</a>" html_file (Name.simple ct.clt_name) else - p buf "%s" (Name.simple ct.clt_name); + p buf "%s" (Name.simple ct.clt_name); Buffer.add_string buf " = "; Buffer.add_string buf (self#html_of_class_type_expr father ct.clt_type); @@ -1227,21 +1227,21 @@ class html = (** 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 } + 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 } @@ -1254,38 +1254,38 @@ class html = 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 + 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) + 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) + 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 @@ -1294,98 +1294,98 @@ class 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 _ -> - () + 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 _ -> - () + Class_signature ([], _) -> + () + | Class_signature (l, _) -> + self#generate_inheritance_info chanout l + | Class_type _ -> + () (** A method to create index files. *) method generate_elements_index : - 'a. - 'a list -> - ('a -> Odoc_info.Name.t) -> - ('a -> Odoc_info.info option) -> - ('a -> string) -> string -> string -> unit = + 'a. + 'a list -> + ('a -> Odoc_info.Name.t) -> + ('a -> Odoc_info.info option) -> + ('a -> string) -> string -> string -> unit = fun elements name info target title simple_file -> try - let chanout = open_out (Filename.concat !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 + 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) + Sys_error s -> + raise (Failure s) (** A method to generate a list of module/class files. *) method generate_elements : - 'a. ('a option -> 'a option -> 'a -> unit) -> 'a list -> unit = + 'a. ('a option -> 'a option -> 'a -> unit) -> 'a list -> unit = fun f_generate l -> - let rec iter pre_opt = function - [] -> () - | ele :: [] -> f_generate pre_opt None ele - | ele1 :: ele2 :: q -> - f_generate pre_opt (Some ele2) ele1 ; - iter (Some ele1) (ele2 :: q) - in - iter None l + let rec iter pre_opt = function + [] -> () + | ele :: [] -> f_generate pre_opt None ele + | ele1 :: ele2 :: q -> + f_generate pre_opt (Some ele2) ele1 ; + iter (Some ele1) (ele2 :: q) + in + iter None l (** Generate the code of the html page for the given class.*) method generate_for_class pre post cl = @@ -1393,55 +1393,55 @@ class html = 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)) - ~comments: (Class.class_comments cl) - (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_described_parameter_list (Name.father cl.cl_name) cl.cl_parameters); + 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)) + ~comments: (Class.class_comments cl) + (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_described_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 ~trans:false cl); - output_string chanout "</body></html>"; - close_out chanout; + 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 ~trans:false cl); + output_string chanout "</body></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 + 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) + 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 = @@ -1449,348 +1449,348 @@ class html = 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)) - ~comments: (Class.class_type_comments clt) - (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) - ); + 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)) + ~comments: (Class.class_type_comments clt) + (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 ~trans: false clt); - output_string chanout "</body></html>"; - close_out chanout; + 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 ~trans: false clt); + output_string chanout "</body></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 + 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) + 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)) - ~comments: (Module.module_type_comments mt) - (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 "</body></html>"; - close_out chanout; + 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)) + ~comments: (Module.module_type_comments mt) + (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 "</body></html>"; + close_out chanout; (* generate html files for submodules *) - self#generate_elements self#generate_for_module (Module.module_type_modules mt); + self#generate_elements self#generate_for_module (Module.module_type_modules mt); (* generate html files for module types *) - self#generate_elements self#generate_for_module_type (Module.module_type_module_types mt); + self#generate_elements self#generate_for_module_type (Module.module_type_module_types mt); (* generate html files for classes *) - self#generate_elements self#generate_for_class (Module.module_type_classes mt); + self#generate_elements self#generate_for_class (Module.module_type_classes mt); (* generate html files for class types *) - self#generate_elements self#generate_for_class_type (Module.module_type_class_types mt); + self#generate_elements self#generate_for_class_type (Module.module_type_class_types mt); (* generate the file with the complete module type *) - ( - match mt.mt_type with - None -> () - | Some mty -> self#output_module_type - mt.mt_name - (Filename.concat !Odoc_args.target_dir type_file) - mty - ) + ( + 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) + 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)) - ~comments: (Module.module_comments modu) - (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)^ - " "^ - "<a href=\""^type_file^"\">"^modu.m_name^"</a>"^ - "</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 "</body></html>"; - close_out chanout; + 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)) + ~comments: (Module.module_comments modu) + (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)^ + " "^ + "<a href=\""^type_file^"\">"^modu.m_name^"</a>"^ + "</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 "</body></html>"; + close_out chanout; (* generate html files for submodules *) - self#generate_elements self#generate_for_module (Module.module_modules modu); + self#generate_elements self#generate_for_module (Module.module_modules modu); (* generate html files for module types *) - self#generate_elements self#generate_for_module_type (Module.module_module_types modu); + self#generate_elements self#generate_for_module_type (Module.module_module_types modu); (* generate html files for classes *) - self#generate_elements self#generate_for_class (Module.module_classes modu); + self#generate_elements self#generate_for_class (Module.module_classes modu); (* generate html files for class types *) - self#generate_elements self#generate_for_class_type (Module.module_class_types modu); + self#generate_elements self#generate_for_class_type (Module.module_class_types modu); (* generate the file with the complete module type *) - self#output_module_type - modu.m_name - (Filename.concat !Odoc_args.target_dir type_file) - modu.m_type + self#output_module_type + modu.m_name + (Filename.concat !Odoc_args.target_dir type_file) + modu.m_type with - Sys_error s -> - raise (Failure s) + 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 + 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) + Sys_error s -> + raise (Failure s) (** Generate the values index in the file [index_values.html]. *) method generate_values_index module_list = self#generate_elements_index - list_values - (fun v -> v.val_name) - (fun v -> v.val_info) - Naming.complete_value_target - Odoc_messages.index_of_values - index_values + 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 = self#generate_elements_index - list_exceptions - (fun e -> e.ex_name) - (fun e -> e.ex_info) - Naming.complete_exception_target - Odoc_messages.index_of_exceptions - index_exceptions + 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 = self#generate_elements_index - list_types - (fun t -> t.ty_name) - (fun t -> t.ty_info) - Naming.complete_type_target - Odoc_messages.index_of_types - index_types + 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 = self#generate_elements_index - 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 + 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 = self#generate_elements_index - 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 + 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 = self#generate_elements_index - 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 + 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 = self#generate_elements_index - 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 + 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 = self#generate_elements_index - 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 + 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 self#generate_elements_index - 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 + 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]. *) @@ -1828,28 +1828,28 @@ class html = known_modules_names <- module_type_names @ module_names ; (* generate html for each module *) if not !Odoc_args.index_only then - self#generate_elements self#generate_for_module module_list ; + self#generate_elements self#generate_for_module module_list ; try - self#generate_index module_list; - self#generate_values_index module_list ; - self#generate_exceptions_index module_list ; - self#generate_types_index module_list ; - self#generate_attributes_index module_list ; - self#generate_methods_index module_list ; - self#generate_classes_index module_list ; - self#generate_class_types_index module_list ; - self#generate_modules_index module_list ; - self#generate_module_types_index module_list ; + self#generate_index module_list; + self#generate_values_index module_list ; + self#generate_exceptions_index module_list ; + self#generate_types_index module_list ; + self#generate_attributes_index module_list ; + self#generate_methods_index module_list ; + self#generate_classes_index module_list ; + self#generate_class_types_index module_list ; + self#generate_modules_index module_list ; + self#generate_module_types_index module_list ; with - Failure s -> - prerr_endline s ; - incr Odoc_info.errors + 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)) + (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 index 6ced0503f..1ad74d4e7 100644 --- a/ocamldoc/odoc_info.ml +++ b/ocamldoc/odoc_info.ml @@ -175,15 +175,15 @@ 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 + | 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 diff --git a/ocamldoc/odoc_info.mli b/ocamldoc/odoc_info.mli index cb7be3ff4..934b80275 100644 --- a/ocamldoc/odoc_info.mli +++ b/ocamldoc/odoc_info.mli @@ -98,7 +98,7 @@ module Name : (** [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]. *) + 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 @@ -113,15 +113,15 @@ module Parameter : (** 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 ; - } + 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 + Simple_name of simple_name | Tuple of param_info list * Types.type_expr (** A parameter is just a param_info.*) @@ -129,10 +129,10 @@ module Parameter : (** 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 ; - } + { + mp_name : string ; + mp_type : Types.module_type ; + } (** {3 Functions} *) (** Acces to the name as a string. For tuples, parenthesis and commas are added. *) @@ -160,19 +160,19 @@ module Exception : (** 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.*) - } - + { + 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 ; - } + { + 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.*) @@ -180,37 +180,37 @@ 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. *) - } + { + 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.*) - } + { + 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_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 ; - } + { + 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. *) @@ -218,31 +218,31 @@ 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 ; - } + { + val_name : Name.t ; (** Complete name of the value. *) + mutable val_info : info option ; (** Information found in the optional associated comment. *) + val_type : Types.type_expr ; (** Type of the value. *) + val_recursive : bool ; (** [true] if the value is recursive. *) + mutable val_parameters : Odoc_parameter.parameter list ; (** The parameters, if any. *) + mutable val_code : string option ; (** The code of the value, if we had the only the implementation file. *) + mutable val_loc : location ; + } (** Representation of a class attribute. *) type t_attribute = Odoc_value.t_attribute = - { - att_value : t_value ; (** an attribute has almost all the same information as a value *) - att_mutable : bool ; (** [true] if the attribute is mutable. *) - } + { + att_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. *) - } - + { + 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 @@ -256,87 +256,87 @@ module Class : (** {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_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 + 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. *) - } + { + 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. *) - } - + { + capp_name : Name.t ; (** The complete name of the applied class. *) + mutable capp_class : t_class option; (** The associated t_class if we found it. *) + capp_params : Types.type_expr list; (** The type of expressions the class is applied to. *) + capp_params_code : string list ; (** The code of these exprssions. *) + } + and class_constr = Odoc_class.class_constr = - { - cco_name : Name.t ; (** The complete name of the applied class. *) - mutable cco_class : cct option; + { + cco_name : Name.t ; (** The complete name of the applied class. *) + mutable cco_class : cct option; (** The associated class or class type if we found it. *) - cco_type_parameters : Types.type_expr list; (** The type parameters of the class, if needed. *) - } + 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_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] *) + 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. *) + (** 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 ; - } + { + 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 ? *) - } + { + 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_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 ; - } + { + 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} *) @@ -377,7 +377,7 @@ module Module : (** {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 of t_module | Element_module_type of t_module_type | Element_included_module of included_module | Element_class of Class.t_class @@ -393,16 +393,16 @@ module 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. *) - } - + { + 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. *) - } + { + 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 = @@ -411,37 +411,37 @@ module Module : | 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. *) + (** 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 ; (** The type of the module. *) - mutable m_info : info option ; (** Information found in the optional associated comment. *) - m_is_interface : bool ; (** [true] for modules read from interface files *) - m_file : string ; (** The file the module is defined in. *) - mutable m_kind : module_kind ; (** The way the module is defined. *) - mutable m_loc : location ; - mutable m_top_deps : Name.t list ; (** The toplevels module names this module depends on. *) - } + { + m_name : Name.t ; (** Complete name of the module. *) + m_type : Types.module_type ; (** The type of the module. *) + mutable m_info : info option ; (** Information found in the optional associated comment. *) + m_is_interface : bool ; (** [true] for modules read from interface files *) + m_file : string ; (** The file the module is defined in. *) + mutable m_kind : module_kind ; (** The way the module is defined. *) + mutable m_loc : location ; + mutable m_top_deps : Name.t list ; (** The toplevels module names this module depends on. *) + } 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. *) - } + { + 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 *) + (** 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 @@ -449,18 +449,18 @@ module Module : (** 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 ; + { + 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 ; - } + 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} *) @@ -563,12 +563,12 @@ module Module : 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 + ?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.*) @@ -700,15 +700,15 @@ 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 + | 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 @@ -752,85 +752,85 @@ module Scan : 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 - + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + method scan_module_list : Module.t_module list -> unit end end diff --git a/ocamldoc/odoc_latex.ml b/ocamldoc/odoc_latex.ml index 12f935d68..9e313f9d8 100644 --- a/ocamldoc/odoc_latex.ml +++ b/ocamldoc/odoc_latex.ml @@ -30,8 +30,8 @@ class text = 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" + 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. *) @@ -77,10 +77,10 @@ class text = val mutable subst_strings_simple = [ - ("MAXENCE"^"XXX", "{\\textbackslash}") ; - "}", "\\}" ; - "{", "\\{" ; - ("\\\\", "MAXENCE"^"XXX") ; + ("MAXENCE"^"XXX", "{\\textbackslash}") ; + "}", "\\}" ; + "{", "\\{" ; + ("\\\\", "MAXENCE"^"XXX") ; ] val mutable subst_strings_code = [ @@ -102,9 +102,9 @@ class text = method subst l s = List.fold_right - (fun (s, s2) -> fun acc -> Str.global_replace (Str.regexp s) s2 acc) - l - s + (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 @@ -114,19 +114,19 @@ class text = (** 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 len = String.length name in let buf = Buffer.create len in for i = 0 to len - 1 do - match name.[i] with - '_' -> if no_ then () else Buffer.add_char buf '_' - | '~' -> if no_ then () else Buffer.add_char buf '~' - | '@' -> Buffer.add_string buf "\"@" - | '!' -> Buffer.add_string buf "\"!" - | '|' -> Buffer.add_string buf "\"|" - | c -> Buffer.add_char buf c + match name.[i] with + '_' -> if no_ then () else Buffer.add_char buf '_' + | '~' -> if no_ then () else Buffer.add_char buf '~' + | '@' -> Buffer.add_string buf "\"@" + | '!' -> Buffer.add_string buf "\"!" + | '|' -> Buffer.add_string buf "\"|" + | c -> Buffer.add_char buf c done; Buffer.contents buf @@ -165,31 +165,31 @@ class text = (** 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 - + | 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 = @@ -229,13 +229,13 @@ class text = method latex_of_List tl = "\\begin{itemize}"^ (String.concat "" - (List.map (fun t -> "\\item "^(self#latex_of_text t)^"\n") tl))^ + (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))^ + (List.map (fun t -> "\\item "^(self#latex_of_text t)^"\n") tl))^ "\\end{enumerate}\n" method latex_of_Newline = "\n\n" @@ -249,8 +249,8 @@ class text = let s_title2 = self#section_style n s_title in s_title2^ (match label_opt with - None -> "" - | Some l -> self#make_label (self#label ~no_: false l)) + None -> "" + | Some l -> self#make_label (self#label ~no_: false l)) method latex_of_Latex s = s @@ -261,32 +261,32 @@ class text = 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 (self#label ~no_:false (Name.simple name)))^"]")) - | Some kind -> - let f_label = - match kind with - Odoc_info.RK_module -> self#module_label - | Odoc_info.RK_module_type -> self#module_type_label - | Odoc_info.RK_class -> self#class_label - | Odoc_info.RK_class_type -> self#class_type_label - | Odoc_info.RK_value -> self#value_label - | Odoc_info.RK_type -> self#type_label - | Odoc_info.RK_exception -> self#exception_label - | Odoc_info.RK_attribute -> self#attribute_label - | Odoc_info.RK_method -> self#method_label - | Odoc_info.RK_section -> assert false - in - (self#latex_of_text - [ - Odoc_info.Code (Odoc_info.use_hidden_modules name) ; - Latex ("["^(self#make_ref (f_label name))^"]") - ] - ) + 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 (self#label ~no_:false (Name.simple name)))^"]")) + | Some kind -> + let f_label = + match kind with + Odoc_info.RK_module -> self#module_label + | Odoc_info.RK_module_type -> self#module_type_label + | Odoc_info.RK_class -> self#class_label + | Odoc_info.RK_class_type -> self#class_type_label + | Odoc_info.RK_value -> self#value_label + | Odoc_info.RK_type -> self#type_label + | Odoc_info.RK_exception -> self#exception_label + | Odoc_info.RK_attribute -> self#attribute_label + | Odoc_info.RK_method -> self#method_label + | Odoc_info.RK_section -> assert false + in + (self#latex_of_text + [ + Odoc_info.Code (Odoc_info.use_hidden_modules name) ; + Latex ("["^(self#make_ref (f_label name))^"]") + ] + ) method latex_of_Superscript t = "$^{"^(self#latex_of_text t)^"}$" @@ -306,7 +306,7 @@ class virtual info = (** 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) + (self#text_of_info ~block: false info_opt) end (** This class is used to create objects which can generate a simple LaTeX documentation. *) @@ -325,153 +325,153 @@ class latex = *) method first_and_rest_of_info i_opt = match i_opt with - None -> ([], []) + None -> ([], []) | Some i -> - match i.Odoc_info.i_desc with - None -> ([], self#text_of_info ~block: true i_opt) - | Some t -> - let (first,_) = Odoc_info.first_sentence_and_rest_of_text t in - let (_, rest) = Odoc_info.first_sentence_and_rest_of_text (self#text_of_info ~block: false i_opt) in - (Odoc_info.text_no_title_no_list first, rest) + match i.Odoc_info.i_desc with + None -> ([], self#text_of_info ~block: true i_opt) + | Some t -> + let (first,_) = Odoc_info.first_sentence_and_rest_of_text t in + let (_, rest) = Odoc_info.first_sentence_and_rest_of_text (self#text_of_info ~block: false i_opt) in + (Odoc_info.text_no_title_no_list first, rest) (** Return LaTeX code for a value. *) method latex_of_value v = Odoc_info.reset_type_names () ; self#latex_of_text - ((Latex (self#make_label (self#value_label v.val_name))) :: - (to_text#text_of_value v)) + ((Latex (self#make_label (self#value_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 (self#attribute_label a.att_value.val_name))) :: - (to_text#text_of_attribute a)) + ((Latex (self#make_label (self#attribute_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 (self#method_label m.met_value.val_name))) :: - (to_text#text_of_method m)) + ((Latex (self#make_label (self#method_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#type_label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @ - (self#text_of_info t.ty_info) + 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#type_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 (self#type_label t.ty_name))) :: text) + ((Latex (self#make_label (self#type_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 (self#exception_label e.ex_name))) :: - (to_text#text_of_exception e)) + ((Latex (self#make_label (self#exception_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 = @@ -479,17 +479,17 @@ class latex = let f = Format.formatter_of_buffer buf in let father = Name.father m.m_name in let t = - Format.fprintf f "module %s" (Name.simple m.m_name); - Format.fprintf f " = %s" - (self#normal_module_type father m.m_type); - Format.pp_print_flush f (); - - (CodePre (Buffer.contents buf)) :: - ( - if with_link - then [Odoc_info.Latex ("\\\n["^(self#make_ref (self#module_label m.m_name))^"]")] - else [] - ) + Format.fprintf f "module %s" (Name.simple m.m_name); + Format.fprintf f " = %s" + (self#normal_module_type father m.m_type); + Format.pp_print_flush f (); + + (CodePre (Buffer.contents buf)) :: + ( + if with_link + then [Odoc_info.Latex ("\\\n["^(self#make_ref (self#module_label m.m_name))^"]")] + else [] + ) in self#latex_of_text t @@ -499,34 +499,34 @@ class latex = let f = Format.formatter_of_buffer buf in let father = Name.father mt.mt_name in let t = - Format.fprintf f "module type %s" (Name.simple mt.mt_name); - (match mt.mt_type with - None -> () - | Some mtyp -> - Format.fprintf f " = %s" - (self#normal_module_type father mtyp) - ); - - Format.pp_print_flush f (); - - (CodePre (Buffer.contents buf)) :: - ( - if with_link - then [Odoc_info.Latex ("\\\n["^(self#make_ref (self#module_type_label mt.mt_name))^"]")] - else [] - ) + Format.fprintf f "module type %s" (Name.simple mt.mt_name); + (match mt.mt_type with + None -> () + | Some mtyp -> + Format.fprintf f " = %s" + (self#normal_module_type father mtyp) + ); + + Format.pp_print_flush f (); + + (CodePre (Buffer.contents buf)) :: + ( + if with_link + then [Odoc_info.Latex ("\\\n["^(self#make_ref (self#module_type_label 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) - ] ) + Code + (match im.im_module with + None -> im.im_name + | Some (Mod m) -> m.m_name + | Some (Modtype mt) -> mt.mt_name) + ] ) (** Return the LaTeX code for the given class. *) method latex_of_class ?(with_link=true) c = @@ -535,27 +535,27 @@ class latex = let f = Format.formatter_of_buffer buf in let father = Name.father c.cl_name in let t = - Format.fprintf f "class %s" - (if c.cl_virtual then "virtual " else ""); - ( - match c.cl_type_parameters with - [] -> () - | l -> - Format.fprintf f "[" ; - let s1 = self#normal_type_list father ", " l in - Format.fprintf f "%s] " s1 - ); - Format.fprintf f "%s : " (Name.simple c.cl_name); - Format.fprintf f "%s" (self#normal_class_type father c.cl_type); - - Format.pp_print_flush f (); - - (CodePre (Buffer.contents buf)) :: - ( - if with_link - then [Odoc_info.Latex (" ["^(self#make_ref (self#class_label c.cl_name))^"]")] - else [] - ) + Format.fprintf f "class %s" + (if c.cl_virtual then "virtual " else ""); + ( + match c.cl_type_parameters with + [] -> () + | l -> + Format.fprintf f "[" ; + let s1 = self#normal_type_list father ", " l in + Format.fprintf f "%s] " s1 + ); + Format.fprintf f "%s : " (Name.simple c.cl_name); + Format.fprintf f "%s" (self#normal_class_type father c.cl_type); + + Format.pp_print_flush f (); + + (CodePre (Buffer.contents buf)) :: + ( + if with_link + then [Odoc_info.Latex (" ["^(self#make_ref (self#class_label c.cl_name))^"]")] + else [] + ) in self#latex_of_text t @@ -566,26 +566,26 @@ class latex = let f = Format.formatter_of_buffer buf in let father = Name.father ct.clt_name in let t = - Format.fprintf f "class type %s" - (if ct.clt_virtual then "virtual " else ""); - ( - match ct.clt_type_parameters with - [] -> () - | l -> - Format.fprintf f "[" ; - let s1 = self#normal_type_list father ", " l in - Format.fprintf f "%s] " s1 - ); - Format.fprintf f "%s = " (Name.simple ct.clt_name); - Format.fprintf f "%s" (self#normal_class_type father ct.clt_type); - - Format.pp_print_flush f (); - (CodePre (Buffer.contents buf)) :: - ( - if with_link - then [Odoc_info.Latex (" ["^(self#make_ref (self#class_type_label ct.clt_name))^"]")] - else [] - ) + Format.fprintf f "class type %s" + (if ct.clt_virtual then "virtual " else ""); + ( + match ct.clt_type_parameters with + [] -> () + | l -> + Format.fprintf f "[" ; + let s1 = self#normal_type_list father ", " l in + Format.fprintf f "%s] " s1 + ); + Format.fprintf f "%s = " (Name.simple ct.clt_name); + Format.fprintf f "%s" (self#normal_class_type father ct.clt_type); + + Format.pp_print_flush f (); + (CodePre (Buffer.contents buf)) :: + ( + if with_link + then [Odoc_info.Latex (" ["^(self#make_ref (self#class_type_label ct.clt_name))^"]")] + else [] + ) in self#latex_of_text t @@ -594,13 +594,13 @@ class latex = (self#latex_of_text [Newline])^ ( match class_ele with - Class_attribute att -> self#latex_of_attribute att + 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) ] + 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. *) @@ -608,7 +608,7 @@ class latex = (self#latex_of_text [Newline])^ ( match module_ele with - Element_module m -> self#latex_of_module m + 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 @@ -622,30 +622,30 @@ class latex = (** 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 cct -> - let label = - match cct with - Cl _ -> self#class_label inh.ic_name - | Cltype _ -> self#class_type_label inh.ic_name - in - (* we can create the reference *) - (Odoc_info.Code inh.ic_name) :: - (Odoc_info.Latex (" ["^(self#make_ref label)^"]")) :: - (match inh.ic_text with - None -> [] - | Some t -> Newline :: t - ) + 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 cct -> + let label = + match cct with + Cl _ -> self#class_label inh.ic_name + | Cltype _ -> self#class_type_label inh.ic_name + in + (* we can create the reference *) + (Odoc_info.Code inh.ic_name) :: + (Odoc_info.Latex (" ["^(self#make_ref label)^"]")) :: + (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) + 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 @@ -654,28 +654,28 @@ class latex = (** 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 _ -> - () + 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 _ -> - () + 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 = @@ -683,29 +683,29 @@ class latex = 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 (self#class_label c.cl_name)) ; - ] + (match first_t with + [] -> [] + | t -> (Raw " : ") :: t)) ; + Latex (self#make_label (self#class_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#class_label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")]); + (self#latex_of_text [Latex ("\\index{"^(self#class_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)); + (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) + (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 = @@ -713,65 +713,65 @@ class latex = 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 (self#class_type_label ct.clt_name)) ; - ] + (match first_t with + [] -> [] + | t -> (Raw " : ") :: t)) ; + Latex (self#make_label (self#class_type_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#class_type_label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")]); + (self#latex_of_text [Latex ("\\index{"^(self#class_type_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) + (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 (self#module_type_label mt.mt_name)) ; - ] + [ Raw (Odoc_messages.module_type^" ") ; Code mt.mt_name ] @ + (match first_t with + [] -> [] + | t -> (Raw " : ") :: t)) ; + Latex (self#make_label (self#module_type_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"); + 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#module_type_label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")]); + (self#latex_of_text [Latex ("\\index{"^(self#module_type_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))); + (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); + (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 - | _ -> () + 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) @@ -780,39 +780,39 @@ class latex = 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 (self#module_label m.m_name)) ; - ] + [ Raw (Odoc_messages.modul^" ") ; Code m.m_name ] @ + (match first_t with + [] -> [] + | t -> (Raw " : ") :: t)) ; + Latex (self#make_label (self#module_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"); + 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#module_label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")]); + (self#latex_of_text [Latex ("\\index{"^(self#module_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))); + (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); + (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 - | _ -> () + 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) @@ -826,7 +826,7 @@ class latex = "\\usepackage{ocamldoc}\n"^ ( match !Odoc_args.title with - None -> "" + None -> "" | Some s -> "\\title{"^(self#escape s)^"}\n" )^ "\\begin{document}\n"^ @@ -836,38 +836,38 @@ class latex = (** Generate the LaTeX file from a module list, in the {!Odoc_args.out_file} file. *) 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 - ); + ( + 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 !Odoc_args.out_file) 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 + let chanout = open_out (Filename.concat !Odoc_args.target_dir !Odoc_args.out_file) 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 + Failure s | Sys_error s -> - prerr_endline s ; - incr Odoc_info.errors + prerr_endline s ; + incr Odoc_info.errors end diff --git a/ocamldoc/odoc_lexer.mll b/ocamldoc/odoc_lexer.mll index 3d34f2789..7f06d933a 100644 --- a/ocamldoc/odoc_lexer.mll +++ b/ocamldoc/odoc_lexer.mll @@ -49,37 +49,37 @@ let remove_blanks s = 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 + 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 + 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 @@ -99,47 +99,47 @@ let identchar = rule main = parse [' ' '\013' '\009' '\012'] + { - 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)); + main lexbuf } | [ '\010' ] { - incr line_number; - incr Odoc_comments_global.nb_chars; + 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)); + 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)); + 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; + 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 + 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 @@ -147,245 +147,245 @@ rule main = parse | "*)" { - 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)); + 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 - } + 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 + 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 - ( + 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 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 + 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 + 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); + 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 - } + (* 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 + 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; + 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); + 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 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 + 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; + 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 + 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"; + 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 - } + 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 - } + 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 - } + EOF + } and simple = parse [' ' '\013' '\009' '\012'] + { - Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); - simple lexbuf + 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; + 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 - } + 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); + 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; + 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 - ) + 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 @@ -393,15 +393,15 @@ and simple = parse | "*)" { - let s = Lexing.lexeme lexbuf in - Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); - decr comments_level ; - simple lexbuf - } + 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 + incr Odoc_comments_global.nb_chars; + simple lexbuf } diff --git a/ocamldoc/odoc_man.ml b/ocamldoc/odoc_man.ml index 51d717145..a332e1c96 100644 --- a/ocamldoc/odoc_man.ml +++ b/ocamldoc/odoc_man.ml @@ -35,106 +35,106 @@ class virtual info = (** 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" + ".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 -> "" + 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 -> "" + 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" + ".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 + 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" + ".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 -> "" + 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; + (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 -> - "" + 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) + 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. *) @@ -168,52 +168,52 @@ class man = (** 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) + | 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 ] @@ -222,23 +222,23 @@ class man = 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) + 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 + (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)) + (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" @@ -246,7 +246,7 @@ class man = (** Groff string to display a [Types.class_type].*) method man_of_class_type_expr m_name t = let s = String.concat "\n" - (Str.split (Str.regexp "\n") (Odoc_misc.string_of_class_type t)) + (Str.split (Str.regexp "\n") (Odoc_misc.string_of_class_type t)) in let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in "\n.B "^(self#relative_idents m_name s2)^"\n" @@ -260,7 +260,7 @@ class man = (** 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)) + (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" @@ -279,19 +279,19 @@ class man = 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) + [] -> "" + | _ -> + ".B of "^ + (self#man_of_type_expr_list (Name.father e.ex_name) " * " e.ex_args) )^ (match e.ex_alias with - None -> "" + None -> "" | Some ea -> " = "^ - ( - match ea.ea_ex with - None -> ea.ea_name - | Some e -> e.ex_name - ) + ( + match ea.ea_ex with + None -> ea.ea_name + | Some e -> e.ex_name + ) )^ "\n.sp\n"^ (self#man_of_info e.ex_info)^ @@ -303,54 +303,54 @@ class man = 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) + [] -> "" + | 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" + 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" @@ -377,67 +377,67 @@ class man = (** 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" + "\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) - ) + 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 - ) + 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" + ".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. *) method man_of_class c = @@ -446,15 +446,15 @@ class man = Odoc_info.reset_type_names () ; let father = Name.father c.cl_name in p buf ".I class %s" - (if c.cl_virtual then "virtual " else ""); + (if c.cl_virtual then "virtual " else ""); ( match c.cl_type_parameters with - [] -> () + [] -> () | l -> p buf "[%s.I] " (Odoc_misc.string_of_type_list ", " l) ); p buf "%s : %s" - (Name.simple c.cl_name) - (self#man_of_class_type_expr (Name.father c.cl_name) c.cl_type); + (Name.simple c.cl_name) + (self#man_of_class_type_expr (Name.father c.cl_name) c.cl_type); p buf "\n.sp\n%s\n.sp\n" (self#man_of_info c.cl_info); Buffer.contents buf @@ -464,15 +464,15 @@ class man = let p = Printf.bprintf in Odoc_info.reset_type_names () ; p buf ".I class type %s" - (if ct.clt_virtual then "virtual " else ""); + (if ct.clt_virtual then "virtual " else ""); ( match ct.clt_type_parameters with - [] -> () - | l -> p buf "[%s.I ] " (Odoc_misc.string_of_type_list ", " l) + [] -> () + | l -> p buf "[%s.I ] " (Odoc_misc.string_of_type_list ", " l) ); p buf "%s = %s" - (Name.simple ct.clt_name) - (self#man_of_class_type_expr (Name.father ct.clt_name) ct.clt_type); + (Name.simple ct.clt_name) + (self#man_of_class_type_expr (Name.father ct.clt_name) ct.clt_type); p buf "\n.sp\n%s\n.sp\n" (self#man_of_info ct.clt_info); Buffer.contents buf @@ -487,7 +487,7 @@ class man = ".I module type "^(Name.simple mt.mt_name)^ " = "^ (match mt.mt_type with - None -> "" + None -> "" | Some t -> self#man_of_module_type (Name.father mt.mt_name) t )^ "\n.sp\n"^(self#man_of_info mt.mt_info)^"\n.sp\n" @@ -509,14 +509,14 @@ class man = ".I include "^ ( match im.im_module with - None -> im.im_name + 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 + 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" @@ -526,51 +526,51 @@ class man = 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)^"\" "^ - "OCamldoc "^ - "\""^(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" - ); - output_string chanout (self#man_of_class cl); - - (* parameters *) - output_string chanout - (self#man_of_parameter_list "" cl.cl_parameters); - (* a large blank *) - output_string chanout "\n.sp\n.sp\n"; + 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)^"\" "^ + "OCamldoc "^ + "\""^(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" + ); + output_string chanout (self#man_of_class cl); + + (* 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; + 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 + (* 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 + 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 = @@ -578,47 +578,47 @@ class man = 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)^"\" "^ - "OCamldoc "^ - "\""^(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" - ); - output_string chanout (self#man_of_class_type ct); - - (* a large blank *) - output_string chanout "\n.sp\n.sp\n"; + 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)^"\" "^ + "OCamldoc "^ + "\""^(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" + ); + output_string chanout (self#man_of_class_type ct); + + (* a large blank *) + output_string chanout "\n.sp\n.sp\n"; (* (* class inheritance *) - self#generate_class_inheritance_info chanout cl; + 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 + (* 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 + 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.*) @@ -626,69 +626,69 @@ class man = 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)^"\" "^ - "OCamldoc "^ - "\""^(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_type with - None -> "" - | Some t -> self#man_of_module_type (Name.father mt.mt_name) t - )^ - "\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 + 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)^"\" "^ + "OCamldoc "^ + "\""^(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_type with + None -> "" + | Some t -> self#man_of_module_type (Name.father mt.mt_name) t + )^ + "\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 + Sys_error s -> + incr Odoc_info.errors ; + prerr_endline s (** Generate the man file for the given module. @raise Failure if an error occurs.*) @@ -696,100 +696,100 @@ class man = 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)^"\" "^ - "OCamldoc "^ - "\""^(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_type (Name.father m.m_name) m.m_type)^ - "\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 + 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)^"\" "^ + "OCamldoc "^ + "\""^(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_type (Name.father m.m_name) m.m_type)^ + "\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) + 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 + 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 + (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 + 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 @@ -798,89 +798,89 @@ class man = 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 - ) + ( + 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)^"\" "^ - "OCamldoc "^ - "\""^(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 + let chanout = self#open_out file in + output_string chanout + (".TH \""^name^"\" "^ + "man "^ + "\""^(Odoc_misc.string_of_date ~hour: false date)^"\" "^ + "OCamldoc "^ + "\""^(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 + Sys_error s -> + incr Odoc_info.errors ; + prerr_endline s (** Generate all the man pages from a module list. *) method generate module_list = let sorted_module_list = Sort.list (fun m1 -> fun m2 -> m1.m_name < m2.m_name) module_list in let groups = self#create_groups sorted_module_list in let f group = - match group with - [] -> - () - | [Res_module m] -> self#generate_for_module m - | [Res_module_type mt] -> self#generate_for_module_type mt - | [Res_class cl] -> self#generate_for_class cl - | [Res_class_type ct] -> self#generate_for_class_type ct - | l -> - if !Odoc_args.man_mini then - () - else - self#generate_for_group l + match group with + [] -> + () + | [Res_module m] -> self#generate_for_module m + | [Res_module_type mt] -> self#generate_for_module_type mt + | [Res_class cl] -> self#generate_for_class cl + | [Res_class_type ct] -> self#generate_for_class_type ct + | l -> + if !Odoc_args.man_mini then + () + else + self#generate_for_group l in List.iter f groups end diff --git a/ocamldoc/odoc_merge.ml b/ocamldoc/odoc_merge.ml index d1b740221..1316fcbbc 100644 --- a/ocamldoc/odoc_merge.ml +++ b/ocamldoc/odoc_merge.ml @@ -33,10 +33,10 @@ let merge_info merge_options (m1 : info) (m2 : info) = | 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 + 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 @@ -44,10 +44,10 @@ let merge_info merge_options (m1 : info) (m2 : info) = | l, [] | [], l -> l | l1, l2 -> - if List.mem Merge_author merge_options then - l1 @ l2 - else - l1 + if List.mem Merge_author merge_options then + l1 @ l2 + else + l1 in let new_version = match m1.i_version , m2.i_version with @@ -55,10 +55,10 @@ let merge_info merge_options (m1 : info) (m2 : info) = | 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 + 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 @@ -66,10 +66,10 @@ let merge_info merge_options (m1 : info) (m2 : info) = | l, [] | [], l -> l | l1, l2 -> - if List.mem Merge_see merge_options then - l1 @ l2 - else - l1 + if List.mem Merge_see merge_options then + l1 @ l2 + else + l1 in let new_since = match m1.i_since, m2.i_since with @@ -77,10 +77,10 @@ let merge_info merge_options (m1 : info) (m2 : info) = | 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 + 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 @@ -88,10 +88,10 @@ let merge_info merge_options (m1 : info) (m2 : info) = | 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 + 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 @@ -99,23 +99,23 @@ let merge_info merge_options (m1 : info) (m2 : info) = | 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 + 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 @@ -123,23 +123,23 @@ let merge_info merge_options (m1 : info) (m2 : info) = | 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 + 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 @@ -147,10 +147,10 @@ let merge_info merge_options (m1 : info) (m2 : info) = | 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 + 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 @@ -158,10 +158,10 @@ let merge_info merge_options (m1 : info) (m2 : info) = | [], l | l, [] -> l | l1, l2 -> - if List.mem Merge_custom merge_options then - l1 @ l2 - else - l1 + if List.mem Merge_custom merge_options then + l1 @ l2 + else + l1 in { Odoc_types.i_desc = new_desc_opt ; @@ -195,65 +195,65 @@ let merge_types merge_options mli ml = | 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)) + 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)) + 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)) + 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 @@ -265,25 +265,25 @@ 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 } + Simple_name { sn_mli with sn_name = sn_ml.sn_name } else - pi_mli + 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. *) + 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.*) + (which should not occurs), we return the pi_mli, + without further investigation.*) if (List.length l_mli) <> (List.length l_ml) then - pi_mli + pi_mli else - let new_l = List.map2 merge_param_info l_mli l_ml in - Tuple (new_l, t_mli) + 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.*) @@ -309,71 +309,71 @@ let merge_classes merge_options mli ml = 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 - () + 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 -> - () + 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) ; + 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 - () + 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 -> - () + Not_found -> + () ) (Odoc_class.class_methods mli) @@ -386,71 +386,71 @@ let merge_class_types merge_options mli ml = 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 - () + 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 -> - () + 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 } ; + 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) ; + 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 - () + 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 -> - () + Not_found -> + () ) (Odoc_class.class_type_methods mli) @@ -464,86 +464,86 @@ let rec merge_module_types merge_options mli ml = 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 - () + 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 -> - () + 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 - () + 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 -> - () + 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 ; + 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 } ; + 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 - () + 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 -> - () + Not_found -> + () ) (Odoc_module.module_type_modules mli); @@ -551,27 +551,27 @@ let rec merge_module_types merge_options mli ml = 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 - () + 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 -> - () + Not_found -> + () ) (Odoc_module.module_type_module_types mli); @@ -581,39 +581,39 @@ let rec merge_module_types merge_options mli ml = 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 - () + 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 -> - () + Not_found -> + () ) (Odoc_module.module_type_values mli); @@ -621,27 +621,27 @@ let rec merge_module_types merge_options mli ml = 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 - () + 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 -> - () + Not_found -> + () ) (Odoc_module.module_type_classes mli); @@ -649,27 +649,27 @@ let rec merge_module_types merge_options mli ml = 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 - () + 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 -> - () + Not_found -> + () ) (Odoc_module.module_type_class_types mli) @@ -684,86 +684,86 @@ and merge_modules merge_options mli ml = 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 - () + 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 -> - () + 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 - () + 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 -> - () + 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 ; + 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 } ; + 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 - () + 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 -> - () + Not_found -> + () ) (Odoc_module.module_modules mli); @@ -771,27 +771,27 @@ and merge_modules merge_options mli ml = 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 - () + 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 -> - () + Not_found -> + () ) (Odoc_module.module_module_types mli); @@ -801,34 +801,34 @@ and merge_modules merge_options mli ml = 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 - () + 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 -> - () + Not_found -> + () ) (Odoc_module.module_values mli); @@ -836,27 +836,27 @@ and merge_modules merge_options mli ml = 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 - () + 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 -> - () + Not_found -> + () ) (Odoc_module.module_classes mli); @@ -864,27 +864,27 @@ and merge_modules merge_options mli ml = 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 - () + 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 -> - () + Not_found -> + () ) (Odoc_module.module_class_types mli); @@ -894,41 +894,41 @@ 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 + (* 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)) - | 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)) + 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 index 44e89ee61..3dadeecc0 100644 --- a/ocamldoc/odoc_merge.mli +++ b/ocamldoc/odoc_merge.mli @@ -18,8 +18,8 @@ val merge_info_opt : Odoc_types.merge_option list -> Odoc_types.info option -> - Odoc_types.info option -> - 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. diff --git a/ocamldoc/odoc_messages.ml b/ocamldoc/odoc_messages.ml index f21607d28..96da92798 100644 --- a/ocamldoc/odoc_messages.ml +++ b/ocamldoc/odoc_messages.ml @@ -54,9 +54,9 @@ 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" ; - ] + "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" diff --git a/ocamldoc/odoc_misc.ml b/ocamldoc/odoc_misc.ml index 2ec48c800..e7cce8717 100644 --- a/ocamldoc/odoc_misc.ml +++ b/ocamldoc/odoc_misc.ml @@ -20,12 +20,12 @@ let input_file_as_string nom = try let n = input chanin s 0 len in if n = 0 then - () + () else - ( - Buffer.add_substring buf s 0 n; - iter () - ) + ( + Buffer.add_substring buf s 0 n; + iter () + ) with End_of_file -> () in @@ -47,7 +47,7 @@ let string_of_type_list sep type_list = Types.Tarrow _ | Types.Ttuple _ -> true | Types.Tlink t2 | Types.Tsubst t2 -> need_parent t2 | Types.Tconstr _ -> - false + false | Types.Tvar | Types.Tunivar | Types.Tobject _ | Types.Tpoly _ | Types.Tfield _ | Types.Tnil | Types.Tvariant _ -> false in @@ -69,8 +69,8 @@ let string_of_type_list sep type_list = 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; + (fun t -> Format.fprintf Format.str_formatter "@,%s" sep; print_one_type t) + tyl; Format.fprintf Format.str_formatter "@]" end; Format.flush_str_formatter() @@ -83,7 +83,7 @@ let simpl_module_type t = Types.Tmty_ident p -> t | Types.Tmty_signature _ -> Types.Tmty_signature [] | Types.Tmty_functor (id, mt1, mt2) -> - Types.Tmty_functor (id, iter mt1, iter mt2) + Types.Tmty_functor (id, iter mt1, iter mt2) in iter t @@ -101,17 +101,17 @@ let simpl_class_type t = match t with Types.Tcty_constr (p,texp_list,ct) -> t | Types.Tcty_signature cs -> - (* on vire les vals et methods pour ne pas qu'elles soient imprimées - quand on affichera le type *) - let tnil = { Types.desc = Types.Tnil ; Types.level = 0; Types.id = 0 } in - Types.Tcty_signature { Types.cty_self = { cs.Types.cty_self with - Types.desc = Types.Tobject (tnil, ref None) }; - Types.cty_vars = Types.Vars.empty ; - Types.cty_concr = Types.Concr.empty ; - } + (* on vire les vals et methods pour ne pas qu'elles soient imprimées + quand on affichera le type *) + let tnil = { Types.desc = Types.Tnil ; Types.level = 0; Types.id = 0 } in + Types.Tcty_signature { Types.cty_self = { cs.Types.cty_self with + Types.desc = Types.Tobject (tnil, ref None) }; + Types.cty_vars = Types.Vars.empty ; + Types.cty_concr = Types.Concr.empty ; + } | Types.Tcty_fun (l, texp, ct) -> - let new_ct = iter ct in - Types.Tcty_fun (l, texp, new_ct) + let new_ct = iter ct in + Types.Tcty_fun (l, texp, new_ct) in iter t @@ -127,13 +127,13 @@ let get_fields type_expr = 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] + Types.Fabsent -> + acc + | _ -> + if label = "*dummy method*" then + acc + else + acc @ [label, typ] ) [] fields @@ -147,34 +147,34 @@ let rec string_of_text t = | 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.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" + (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" + 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)^"}" + "["^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) @@ -204,10 +204,10 @@ let string_of_raised_exceptions l = | _ -> Odoc_messages.raises^"\n"^ (String.concat "" - (List.map - (fun (ex, desc) -> "- "^ex^" "^(string_of_text desc)^"\n") - l - ) + (List.map + (fun (ex, desc) -> "- "^ex^" "^(string_of_text desc)^"\n") + l + ) )^"\n" let string_of_see (see_ref, t) = @@ -226,10 +226,10 @@ let string_of_sees l = | _ -> Odoc_messages.see_also^"\n"^ (String.concat "" - (List.map - (fun see -> "- "^(string_of_see see)^"\n") - l - ) + (List.map + (fun see -> "- "^(string_of_see see)^"\n") + l + ) )^"\n" let string_of_return_opt return_opt = @@ -287,10 +287,10 @@ let rec text_no_title_no_list t = | Odoc_types.Title (_,_,t) -> text_no_title_no_list t | Odoc_types.List l | Odoc_types.Enum l -> - (Odoc_types.Raw " ") :: - (text_list_concat - (Odoc_types.Raw ", ") - (List.map text_no_title_no_list l)) + (Odoc_types.Raw " ") :: + (text_list_concat + (Odoc_types.Raw ", ") + (List.map text_no_title_no_list l)) | Odoc_types.Raw _ | Odoc_types.Code _ | Odoc_types.CodePre _ @@ -317,7 +317,7 @@ let get_titles_in_text t = match ele with | Odoc_types.Title (n,lopt,t) -> l := (n,lopt,t) :: !l | Odoc_types.List l - | Odoc_types.Enum l -> List.iter iter_text l + | Odoc_types.Enum l -> List.iter iter_text l | Odoc_types.Raw _ | Odoc_types.Code _ | Odoc_types.CodePre _ @@ -352,12 +352,12 @@ let rec get_before_dot s = (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) + ' ' | '\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, "") @@ -367,11 +367,11 @@ let rec first_sentence_text t = | 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) + (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) + let (stop2, q2, rest) = first_sentence_text q in + (stop2, ele2 :: q2, rest) and first_sentence_text_ele text_ele = @@ -433,19 +433,19 @@ 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 + 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 @@ -459,16 +459,16 @@ let remove_option typ = let rec iter t = match t with | Types.Tconstr (p,tlist,_) -> - ( - match p with - Path.Pident id when Ident.name id = "option" -> - ( - match tlist with - [t2] -> t2.Types.desc - | _ -> t - ) - | _ -> t - ) + ( + match p with + Path.Pident id when Ident.name id = "option" -> + ( + match tlist with + [t2] -> t2.Types.desc + | _ -> t + ) + | _ -> t + ) | Types.Tvar | Types.Tunivar | Types.Tpoly _ diff --git a/ocamldoc/odoc_module.ml b/ocamldoc/odoc_module.ml index 1a18cc7db..b555e8a4a 100644 --- a/ocamldoc/odoc_module.ml +++ b/ocamldoc/odoc_module.ml @@ -51,7 +51,7 @@ and 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 ; @@ -84,7 +84,7 @@ and t_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. *) + Always [None] when the module type was extracted from the implementation file. *) mutable mt_loc : Odoc_types.location ; } @@ -96,8 +96,8 @@ let values l = List.fold_left (fun acc -> fun ele -> match ele with - Element_value v -> acc @ [v] - | _ -> acc + Element_value v -> acc @ [v] + | _ -> acc ) [] l @@ -107,8 +107,8 @@ let types l = List.fold_left (fun acc -> fun ele -> match ele with - Element_type t -> acc @ [t] - | _ -> acc + Element_type t -> acc @ [t] + | _ -> acc ) [] l @@ -118,8 +118,8 @@ let exceptions l = List.fold_left (fun acc -> fun ele -> match ele with - Element_exception e -> acc @ [e] - | _ -> acc + Element_exception e -> acc @ [e] + | _ -> acc ) [] l @@ -129,8 +129,8 @@ let classes l = List.fold_left (fun acc -> fun ele -> match ele with - Element_class c -> acc @ [c] - | _ -> acc + Element_class c -> acc @ [c] + | _ -> acc ) [] l @@ -140,8 +140,8 @@ let class_types l = List.fold_left (fun acc -> fun ele -> match ele with - Element_class_type ct -> acc @ [ct] - | _ -> acc + Element_class_type ct -> acc @ [ct] + | _ -> acc ) [] l @@ -151,8 +151,8 @@ let modules l = List.fold_left (fun acc -> fun ele -> match ele with - Element_module m -> acc @ [m] - | _ -> acc + Element_module m -> acc @ [m] + | _ -> acc ) [] l @@ -162,8 +162,8 @@ let mod_types l = List.fold_left (fun acc -> fun ele -> match ele with - Element_module_type mt -> acc @ [mt] - | _ -> acc + Element_module_type mt -> acc @ [mt] + | _ -> acc ) [] l @@ -173,8 +173,8 @@ let comments l = List.fold_left (fun acc -> fun ele -> match ele with - Element_module_comment t -> acc @ [t] - | _ -> acc + Element_module_comment t -> acc @ [t] + | _ -> acc ) [] l @@ -184,8 +184,8 @@ let included_modules l = List.fold_left (fun acc -> fun ele -> match ele with - Element_included_module m -> acc @ [m] - | _ -> acc + Element_included_module m -> acc @ [m] + | _ -> acc ) [] l @@ -197,33 +197,33 @@ let rec module_elements ?(trans=true) m = 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 + 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 ; - } + { 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 = Types.Tmty_signature [] ; - m_is_interface = false ; m_file = "" ; m_kind = k ; - m_loc = Odoc_types.dummy_loc ; - m_top_deps = [] ; - } + { m_name = "" ; m_info = None ; m_type = Types.Tmty_signature [] ; + m_is_interface = false ; m_file = "" ; m_kind = k ; + m_loc = Odoc_types.dummy_loc ; + m_top_deps = [] ; + } (* 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 } + { 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 @@ -236,15 +236,15 @@ and module_type_elements ?(trans=true) mt = | 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 - [] + 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 + match mta.mta_module with + None -> [] + | Some mt -> module_type_elements mt else [] in @@ -306,40 +306,40 @@ 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 - ) + 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 - [] + 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 - [] + if trans then + iter (Some k) + else + [] | Some (Module_type_struct _) -> - [] + [] | None -> - [] + [] in iter mt.mt_kind @@ -350,35 +350,35 @@ and module_parameters ?(trans=true) m = Module_functor (params, _) -> ( (* we create the couple (parameter, description opt), using - the description of the parameter if we can find it in the comment.*) + 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 + 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 + 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 + 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 } + { 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 _ -> @@ -399,13 +399,13 @@ let rec module_type_is_functor mt = 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 - ) + ( + match mta.mta_module with + None -> false + | Some mtyp -> module_type_is_functor mtyp + ) | Some (Module_type_with (k, _)) -> - iter (Some k) + iter (Some k) | Some (Module_type_struct _) | None -> false in @@ -418,7 +418,7 @@ let rec module_is_functor m = | Module_alias ma -> ( match ma.ma_module with - None -> false + None -> false | Some (Mod mo) -> module_is_functor mo | Some (Modtype mt) -> module_type_is_functor mt ) diff --git a/ocamldoc/odoc_name.ml b/ocamldoc/odoc_name.ml index 00adb2cb0..670166b0e 100644 --- a/ocamldoc/odoc_name.ml +++ b/ocamldoc/odoc_name.ml @@ -25,10 +25,10 @@ let infix_chars = [ '|' ; '/' ; '$' ; '%' ; - '=' ; - ':' ; - '~' ; - '!' ; + '=' ; + ':' ; + '~' ; + '!' ; ] type t = string @@ -48,31 +48,31 @@ let cut name = | 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 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) @@ -112,11 +112,11 @@ 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 + let s2 = get_relative h s in + if s = s2 then + iter q + else + s2 in iter l @@ -131,9 +131,9 @@ 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))) + 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 @@ -146,14 +146,14 @@ 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 + 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) diff --git a/ocamldoc/odoc_ocamlhtml.mll b/ocamldoc/odoc_ocamlhtml.mll index 5881f4a59..72b26960d 100644 --- a/ocamldoc/odoc_ocamlhtml.mll +++ b/ocamldoc/odoc_ocamlhtml.mll @@ -68,8 +68,8 @@ let print ?(esc=true) s = let print_class ?(esc=true) cl s = print ~esc: false ("<span class=\""^cl^"\">"^ - (if esc then escape s else s)^ - "</span>") + (if esc then escape s else s)^ + "</span>") ;; (** The table of keywords with colors *) @@ -174,21 +174,21 @@ let print_comment () = "<span class=\""^comment_class^"\">(*"^(escape s)^"*)</span>" else match s.[0] with - '*' -> - ( - try - let html = !html_of_comment (String.sub s 1 (len-1)) in - "</code><table><tr><td>"^(make_margin ())^"</td><td>"^ - "<span class=\""^comment_class^"\">"^ - "(**"^html^"*)"^ - "</span></td></tr></table><code class=\""^code_class^"\">" - with - e -> - prerr_endline (Printexc.to_string e); - "<span class=\""^comment_class^"\">(*"^(escape s)^"*)</span>" - ) + '*' -> + ( + try + let html = !html_of_comment (String.sub s 1 (len-1)) in + "</code><table><tr><td>"^(make_margin ())^"</td><td>"^ + "<span class=\""^comment_class^"\">"^ + "(**"^html^"*)"^ + "</span></td></tr></table><code class=\""^code_class^"\">" + with + e -> + prerr_endline (Printexc.to_string e); + "<span class=\""^comment_class^"\">(*"^(escape s)^"*)</span>" + ) | _ -> - "<span class=\""^comment_class^"\">(*"^(escape s)^"*)</span>" + "<span class=\""^comment_class^"\">(*"^(escape s)^"*)</span>" in print ~esc: false code @@ -270,16 +270,16 @@ let float_literal = 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 + 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 } @@ -303,7 +303,7 @@ rule token = parse { let s = Lexing.lexeme lexbuf in try let cl = Hashtbl.find keyword_table s in - (print_class cl s ; token lexbuf ) + (print_class cl s ; token lexbuf ) with Not_found -> (print s ; token lexbuf )} | uppercase identchar * @@ -320,40 +320,40 @@ rule token = parse lexbuf.Lexing.lex_start_pos <- string_start - lexbuf.Lexing.lex_abs_pos; print_class string_class ("\""^(get_stored_string())^"\"") ; - token lexbuf } + token lexbuf } | "'" [^ '\\' '\''] "'" { print_class string_class (Lexing.lexeme lexbuf) ; - token lexbuf } + token lexbuf } | "'" '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'" { print_class string_class (Lexing.lexeme lexbuf ) ; - token lexbuf } + token lexbuf } | "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" { print_class string_class (Lexing.lexeme lexbuf ) ; - token lexbuf } + token lexbuf } | "(*" { - reset_comment_buffer (); - comment_start_pos := [Lexing.lexeme_start lexbuf]; - comment lexbuf ; - print_comment (); + 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_start_pos := [Lexing.lexeme_start lexbuf]; comment lexbuf ; - print_comment (); + print_comment (); token lexbuf } | "*)" { lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; print (Lexing.lexeme lexbuf) ; - token lexbuf + token lexbuf } | "#" [' ' '\t']* ['0'-'9']+ [^ '\n' '\r'] * ('\n' | '\r' | "\r\n") (* # linenum ... *) { - 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 } @@ -418,8 +418,8 @@ rule token = parse and comment = parse "(*" { comment_start_pos := Lexing.lexeme_start lexbuf :: !comment_start_pos; - store_comment_char '('; - store_comment_char '*'; + store_comment_char '('; + store_comment_char '*'; comment lexbuf; } | "*)" @@ -427,15 +427,15 @@ and comment = parse | [] -> assert false | [x] -> comment_start_pos := [] | _ :: l -> - store_comment_char '*'; - store_comment_char ')'; - 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 '"'; + store_comment_char '"'; begin try string lexbuf with Error (Unterminated_string, _, _) -> let st = List.hd !comment_start_pos in @@ -444,36 +444,36 @@ and comment = parse comment lexbuf } | "''" { - store_comment_char '\''; - store_comment_char '\''; - 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 } + 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 } + 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 } + 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 } + comment lexbuf } and string = parse '"' @@ -520,9 +520,9 @@ let html_of_code ?(with_pre=true) code = with _ -> (* flush str_formatter because we already output - something in it *) - Format.pp_print_flush !fmt () ; - start^code^ending + something in it *) + Format.pp_print_flush !fmt () ; + start^code^ending ) in pre := old_pre; diff --git a/ocamldoc/odoc_opt.ml b/ocamldoc/odoc_opt.ml index 08d0f04f3..a8be1963e 100644 --- a/ocamldoc/odoc_opt.ml +++ b/ocamldoc/odoc_opt.ml @@ -37,15 +37,15 @@ 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_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 ) @@ -58,8 +58,8 @@ let _ = | Some f -> try Odoc_analyse.dump_modules f modules with Failure s -> - prerr_endline s ; - incr Odoc_global.errors + prerr_endline s ; + incr Odoc_global.errors let _ = match !Odoc_args.doc_generator with diff --git a/ocamldoc/odoc_parameter.ml b/ocamldoc/odoc_parameter.ml index c58a25446..1cd5cac5f 100644 --- a/ocamldoc/odoc_parameter.ml +++ b/ocamldoc/odoc_parameter.ml @@ -47,11 +47,11 @@ let complete_name p = let rec iter pi = match pi with Simple_name sn -> - sn.sn_name + sn.sn_name | Tuple ([], _) -> (* anonymous parameter *) - "??" + "??" | Tuple (pi_list, _) -> - "("^(String.concat "," (List.map iter pi_list))^")" + "("^(String.concat "," (List.map iter pi_list))^")" in iter p @@ -67,9 +67,9 @@ let update_parameter_text f p = let rec iter pi = match pi with Simple_name sn -> - sn.sn_text <- f sn.sn_name + sn.sn_text <- f sn.sn_name | Tuple (l, _) -> - List.iter iter l + List.iter iter l in iter p @@ -79,9 +79,9 @@ let desc_by_name pi name = let rec iter acc pi = match pi with Simple_name sn -> - (sn.sn_name, sn.sn_text) :: acc + (sn.sn_name, sn.sn_text) :: acc | Tuple (pi_list, _) -> - List.fold_left iter acc pi_list + List.fold_left iter acc pi_list in let l = iter [] pi in List.assoc name l @@ -93,9 +93,9 @@ let names pi = let rec iter acc pi = match pi with Simple_name sn -> - sn.sn_name :: acc + sn.sn_name :: acc | Tuple (pi_list, _) -> - List.fold_left iter acc pi_list + List.fold_left iter acc pi_list in iter [] pi @@ -105,9 +105,9 @@ let type_by_name pi name = let rec iter acc pi = match pi with Simple_name sn -> - (sn.sn_name, sn.sn_type) :: acc + (sn.sn_name, sn.sn_type) :: acc | Tuple (pi_list, _) -> - List.fold_left iter acc pi_list + List.fold_left iter acc pi_list in let l = iter [] pi in List.assoc name l @@ -119,12 +119,12 @@ let desc_from_info_opt info_opt s = 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 + "" -> 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 index 4603ed3a6..13e111101 100644 --- a/ocamldoc/odoc_parser.mly +++ b/ocamldoc/odoc_parser.mly @@ -92,20 +92,20 @@ param: (* 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") + 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^"\"")) + 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: @@ -129,19 +129,19 @@ raise_exc: (* isolate the exception construtor name *) let s = $2 in match Str.split (Str.regexp (blank^"+")) s with - [] + [] | _ :: [] -> - raise (Failure "usage: @raise Exception description") + 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^"\"")) + 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: diff --git a/ocamldoc/odoc_scan.ml b/ocamldoc/odoc_scan.ml index 2750c0368..96abc22f0 100644 --- a/ocamldoc/odoc_scan.ml +++ b/ocamldoc/odoc_scan.ml @@ -46,13 +46,13 @@ class scanner = 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) + (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.*) @@ -72,13 +72,13 @@ class scanner = 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) + (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.*) @@ -97,19 +97,19 @@ class scanner = (** 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) + (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.*) @@ -128,19 +128,19 @@ class scanner = (** 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) + (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.*) diff --git a/ocamldoc/odoc_search.ml b/ocamldoc/odoc_search.ml index 00d4199b9..7d32acd7c 100644 --- a/ocamldoc/odoc_search.ml +++ b/ocamldoc/odoc_search.ml @@ -80,10 +80,10 @@ module Search = | 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) + (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 [] @@ -98,197 +98,197 @@ module Search = 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 - [] + 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 + (Res_class c) :: l else - l + 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 - [] + 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 + (Res_class_type ct) :: l else - l + 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 - [] + 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 + (Res_module_type mt) :: l else - l + 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 - [] + 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 + (Res_module m) :: l else - l + 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 + (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 = diff --git a/ocamldoc/odoc_see_lexer.mll b/ocamldoc/odoc_see_lexer.mll index 2fa6a5314..8e7dfcd45 100644 --- a/ocamldoc/odoc_see_lexer.mll +++ b/ocamldoc/odoc_see_lexer.mll @@ -30,63 +30,63 @@ rule main = parse | [ '\010' ] { - print_DEBUG2 " [ '\010' ] "; - main lexbuf + print_DEBUG2 " [ '\010' ] "; + main lexbuf } | "<" { - print_DEBUG2 "call url lexbuf" ; - url lexbuf - } + print_DEBUG2 "call url lexbuf" ; + url lexbuf + } | "\"" { - print_DEBUG2 "call doc lexbuf" ; - doc lexbuf - } + print_DEBUG2 "call doc lexbuf" ; + doc lexbuf + } | '\'' { - print_DEBUG2 "call file lexbuf" ; - file lexbuf - } + print_DEBUG2 "call file lexbuf" ; + file lexbuf + } | eof { - print_DEBUG2 "EOF"; - EOF + print_DEBUG2 "EOF"; + EOF } | _ { - Buffer.reset buf ; - Buffer.add_string buf (Lexing.lexeme lexbuf); - desc lexbuf - } + 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)) + 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)) + 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)) + let s = Lexing.lexeme lexbuf in + See_file (String.sub s 0 ((String.length s) -1)) } @@ -95,6 +95,6 @@ and desc = parse { Desc (Buffer.contents buf) } | _ { - Buffer.add_string buf (Lexing.lexeme lexbuf); - desc lexbuf + Buffer.add_string buf (Lexing.lexeme lexbuf); + desc lexbuf } diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml index 649897390..e38c37b59 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -32,34 +32,34 @@ open Odoc_types module Signature_search = struct type ele = - | M of string - | MT of string - | V of string - | T of string - | C of string - | CT of string - | E of string - | ER of string - | P of string + | M of string + | MT of string + | V of string + | T of string + | C of string + | CT of string + | E of string + | ER of string + | P of string type tab = (ele, Types.signature_item) Hashtbl.t let add_to_hash table signat = match signat with - Types.Tsig_value (ident, _) -> - Hashtbl.add table (V (Name.from_ident ident)) signat - | Types.Tsig_exception (ident, _) -> - Hashtbl.add table (E (Name.from_ident ident)) signat - | Types.Tsig_type (ident, _) -> - Hashtbl.add table (T (Name.from_ident ident)) signat - | Types.Tsig_class (ident,_) -> - Hashtbl.add table (C (Name.from_ident ident)) signat - | Types.Tsig_cltype (ident, _) -> - Hashtbl.add table (CT (Name.from_ident ident)) signat - | Types.Tsig_module (ident, _) -> - Hashtbl.add table (M (Name.from_ident ident)) signat - | Types.Tsig_modtype (ident,_) -> - Hashtbl.add table (MT (Name.from_ident ident)) signat + Types.Tsig_value (ident, _) -> + Hashtbl.add table (V (Name.from_ident ident)) signat + | Types.Tsig_exception (ident, _) -> + Hashtbl.add table (E (Name.from_ident ident)) signat + | Types.Tsig_type (ident, _) -> + Hashtbl.add table (T (Name.from_ident ident)) signat + | Types.Tsig_class (ident,_) -> + Hashtbl.add table (C (Name.from_ident ident)) signat + | Types.Tsig_cltype (ident, _) -> + Hashtbl.add table (CT (Name.from_ident ident)) signat + | Types.Tsig_module (ident, _) -> + Hashtbl.add table (M (Name.from_ident ident)) signat + | Types.Tsig_modtype (ident,_) -> + Hashtbl.add table (MT (Name.from_ident ident)) signat let table signat = let t = Hashtbl.create 13 in @@ -69,46 +69,46 @@ module Signature_search = let search_value table name = match Hashtbl.find table (V name) with | (Types.Tsig_value (_, val_desc)) -> val_desc.Types.val_type - | _ -> assert false + | _ -> assert false let search_exception table name = match Hashtbl.find table (E name) with | (Types.Tsig_exception (_, type_expr_list)) -> - type_expr_list - | _ -> assert false + type_expr_list + | _ -> assert false let search_type table name = match Hashtbl.find table (T name) with | (Types.Tsig_type (_, type_decl)) -> type_decl - | _ -> assert false + | _ -> assert false let search_class table name = match Hashtbl.find table (C name) with | (Types.Tsig_class (_, class_decl)) -> class_decl - | _ -> assert false + | _ -> assert false let search_class_type table name = match Hashtbl.find table (CT name) with | (Types.Tsig_cltype (_, cltype_decl)) -> cltype_decl - | _ -> assert false + | _ -> assert false let search_module table name = match Hashtbl.find table (M name) with | (Types.Tsig_module (ident, module_type)) -> module_type - | _ -> assert false + | _ -> assert false let search_module_type table name = match Hashtbl.find table (MT name) with | (Types.Tsig_modtype (_, Types.Tmodtype_manifest module_type)) -> - Some module_type + Some module_type | (Types.Tsig_modtype (_, Types.Tmodtype_abstract)) -> - None - | _ -> assert false + None + | _ -> assert false let search_attribute_type name class_sig = let (_, type_expr) = Types.Vars.find name class_sig.Types.cty_vars in type_expr - + let search_method_type name class_sig = let fields = Odoc_misc.get_fields class_sig.Types.cty_self in List.assoc name fields @@ -121,7 +121,7 @@ module type Info_retriever = 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) + (Odoc_types.text -> 'a) -> string -> string -> (Odoc_types.info option * 'a list) end module Analyser = @@ -137,318 +137,318 @@ module Analyser = 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 + let s = String.sub !file the_start (the_end-the_start) in + s with - Invalid_argument _ -> - "" + 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 + let s = Odoc_misc.input_file_as_string input_f in + file := s; + file_name := f with - e -> - file := ""; - raise e + 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) + !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) + !file_name + (get_string_of_file pos_start pos_end) let merge_infos = Odoc_merge.merge_info_opt Odoc_types.all_merge_options let name_comment_from_type_kind pos_start pos_end pos_limit tk = match tk with - Parsetree.Ptype_abstract -> - (0, []) + 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) ]) + 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 - + | (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) + 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) let get_type_kind env name_comment_list type_kind = match type_kind with - Types.Type_abstract -> - Odoc_type.Type_abstract + 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) + 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) + 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 = + 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 + 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; + 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) + (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) + 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_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_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_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_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.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) + | 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 @@ -459,762 +459,762 @@ module Analyser = let table = Signature_search.table signat in (* we look for the comment of each item then analyse the item *) let rec f acc_eles acc_env last_pos = function - [] -> - let s = get_string_of_file last_pos pos_limit in - let (_, ele_coms) = My_ir.all_special !file_name s in - let ele_comments = - List.fold_left - (fun acc -> fun sc -> - match sc.Odoc_types.i_desc with - None -> - acc - | Some t -> - acc @ [Element_module_comment t]) - [] - ele_coms - in - acc_eles @ ele_comments + [] -> + 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 - table - 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) + | 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 + table + 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 + 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 table current_module_name - pos_start_ele pos_end_ele pos_limit comment_opt sig_item_desc = - match sig_item_desc with - Parsetree.Psig_value (name_pre, value_desc) -> - let type_expr = - try Signature_search.search_value table name_pre - with Not_found -> - raise (Failure (Odoc_messages.value_not_found current_module_name name_pre)) - in - let name = Name.parens_if_infix name_pre in - let subst_typ = Odoc_env.subst_type env type_expr in - let v = - { - val_name = Name.concat current_module_name name ; - val_info = comment_opt ; - val_type = subst_typ ; - val_recursive = false ; - val_parameters = Odoc_value.dummy_parameter_list subst_typ ; - val_code = None ; - val_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele)} - } - in - let (maybe_more, info_after_opt) = - My_ir.just_after_special - !file_name - (get_string_of_file pos_end_ele pos_limit) - in - v.val_info <- merge_infos v.val_info info_after_opt ; - (* update the parameter description *) - Odoc_value.update_value_parameters_text v; + pos_start_ele pos_end_ele pos_limit comment_opt sig_item_desc = + match sig_item_desc with + Parsetree.Psig_value (name_pre, value_desc) -> + let type_expr = + try Signature_search.search_value table name_pre + with Not_found -> + raise (Failure (Odoc_messages.value_not_found current_module_name name_pre)) + in + let name = Name.parens_if_infix name_pre in + let subst_typ = Odoc_env.subst_type env type_expr in + let v = + { + val_name = Name.concat current_module_name name ; + val_info = comment_opt ; + val_type = subst_typ ; + val_recursive = false ; + val_parameters = Odoc_value.dummy_parameter_list subst_typ ; + val_code = None ; + val_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele)} + } + in + let (maybe_more, info_after_opt) = + My_ir.just_after_special + !file_name + (get_string_of_file pos_end_ele pos_limit) + in + v.val_info <- merge_infos v.val_info info_after_opt ; + (* update the parameter description *) + Odoc_value.update_value_parameters_text v; - let new_env = Odoc_env.add_value env v.val_name in - (maybe_more, new_env, [ Element_value v ]) + let new_env = Odoc_env.add_value env v.val_name in + (maybe_more, new_env, [ Element_value v ]) - | Parsetree.Psig_exception (name, exception_decl) -> - let types_excep_decl = - try Signature_search.search_exception table name - with Not_found -> - raise (Failure (Odoc_messages.exception_not_found current_module_name name)) - in - let e = - { - ex_name = Name.concat current_module_name name ; - ex_info = comment_opt ; - ex_args = List.map (Odoc_env.subst_type env) types_excep_decl ; - ex_alias = None ; - ex_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } - } - 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_exception (name, exception_decl) -> + let types_excep_decl = + try Signature_search.search_exception table name + with Not_found -> + raise (Failure (Odoc_messages.exception_not_found current_module_name name)) + in + let e = + { + ex_name = Name.concat current_module_name name ; + ex_info = comment_opt ; + ex_args = List.map (Odoc_env.subst_type env) types_excep_decl ; + ex_alias = None ; + ex_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } + } + 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 = - try Signature_search.search_type table name - with Not_found -> - raise (Failure (Odoc_messages.type_not_found current_module_name name)) - in - (* get the type kind with the associated comments *) - let type_kind = get_type_kind new_env name_comment_list sig_type_decl.Types.type_kind in - (* 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_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 = + try Signature_search.search_type table name + with Not_found -> + raise (Failure (Odoc_messages.type_not_found current_module_name name)) + in + (* get the type kind with the associated comments *) + let type_kind = get_type_kind new_env name_comment_list sig_type_decl.Types.type_kind in + (* 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 table name - with Not_found -> - raise (Failure (Odoc_messages.module_not_found current_module_name name)) - in - let module_kind = analyse_module_kind env complete_name module_type sig_module_type in - let new_module = - { - m_name = complete_name ; - m_type = sig_module_type; - m_info = comment_opt ; - m_is_interface = true ; - m_file = !file_name ; - m_kind = module_kind ; - m_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ; - m_top_deps = [] ; - } - in - let (maybe_more, info_after_opt) = - My_ir.just_after_special - !file_name - (get_string_of_file pos_end_ele pos_limit) - in - new_module.m_info <- merge_infos new_module.m_info info_after_opt ; - let new_env = Odoc_env.add_module env new_module.m_name in - let new_env2 = - match new_module.m_type with (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *) - Types.Tmty_signature s -> Odoc_env.add_signature new_env new_module.m_name ~rel: (Name.simple new_module.m_name) s - | _ -> new_env - in - (maybe_more, new_env2, [ Element_module new_module ]) + | Parsetree.Psig_module (name, module_type) -> + let complete_name = Name.concat current_module_name name in + (* get the the module type in the signature by the module name *) + let sig_module_type = + try Signature_search.search_module table name + with Not_found -> + raise (Failure (Odoc_messages.module_not_found current_module_name name)) + in + let module_kind = analyse_module_kind env complete_name module_type sig_module_type in + let new_module = + { + m_name = complete_name ; + m_type = sig_module_type; + m_info = comment_opt ; + m_is_interface = true ; + m_file = !file_name ; + m_kind = module_kind ; + m_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ; + m_top_deps = [] ; + } + in + let (maybe_more, info_after_opt) = + My_ir.just_after_special + !file_name + (get_string_of_file pos_end_ele pos_limit) + in + new_module.m_info <- merge_infos new_module.m_info info_after_opt ; + let new_env = Odoc_env.add_module env new_module.m_name in + let new_env2 = + match new_module.m_type with (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *) + Types.Tmty_signature s -> Odoc_env.add_signature new_env new_module.m_name ~rel: (Name.simple new_module.m_name) s + | _ -> new_env + in + (maybe_more, new_env2, [ Element_module new_module ]) | Parsetree.Psig_modtype (name, Parsetree.Pmodtype_abstract) -> - let sig_mtype = - try Signature_search.search_module_type table name - with Not_found -> - raise (Failure (Odoc_messages.module_type_not_found current_module_name name)) - in - let 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 ]) + let sig_mtype = + try Signature_search.search_module_type table name + with Not_found -> + raise (Failure (Odoc_messages.module_type_not_found current_module_name name)) + in + let 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 table 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_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 table 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_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 = - try Signature_search.search_class table name - with Not_found -> - raise (Failure (Odoc_messages.class_not_found current_module_name name)) - in - let sig_class_type = sig_class_decl.Types.cty_type in - let (parameters, class_kind) = - analyse_class_kind - new_env - complete_name - class_desc.Parsetree.pci_loc.Location.loc_start - class_desc.Parsetree.pci_expr - sig_class_type - in - let new_class = - { - cl_name = complete_name ; - cl_info = assoc_com ; - cl_type = Odoc_env.subst_class_type env sig_class_type ; - cl_type_parameters = sig_class_decl.Types.cty_params; - cl_virtual = class_desc.Parsetree.pci_virt = Asttypes.Virtual ; - cl_kind = class_kind ; - cl_parameters = parameters ; - cl_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ; - } - in - let (maybe_more, info_after_opt) = - My_ir.just_after_special - !file_name - (get_string_of_file pos_end pos_limit2) - in - new_class.cl_info <- merge_infos new_class.cl_info info_after_opt ; - Odoc_class.class_update_parameters_text new_class ; - let (new_maybe_more, eles) = - f maybe_more (pos_end + maybe_more) q - in - (new_maybe_more, - ele_comments @ (( Element_class new_class ) :: eles)) - in - let (maybe_more, eles) = - f ~first: true 0 pos_start_ele class_description_list - in - (maybe_more, new_env, eles) + | Parsetree.Psig_class 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 = + try Signature_search.search_class table name + with Not_found -> + raise (Failure (Odoc_messages.class_not_found current_module_name name)) + in + let sig_class_type = sig_class_decl.Types.cty_type in + let (parameters, class_kind) = + analyse_class_kind + new_env + complete_name + class_desc.Parsetree.pci_loc.Location.loc_start + class_desc.Parsetree.pci_expr + sig_class_type + in + let new_class = + { + cl_name = complete_name ; + cl_info = assoc_com ; + cl_type = Odoc_env.subst_class_type env sig_class_type ; + cl_type_parameters = sig_class_decl.Types.cty_params; + cl_virtual = class_desc.Parsetree.pci_virt = Asttypes.Virtual ; + cl_kind = class_kind ; + cl_parameters = parameters ; + cl_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ; + } + in + let (maybe_more, info_after_opt) = + My_ir.just_after_special + !file_name + (get_string_of_file pos_end pos_limit2) + in + new_class.cl_info <- merge_infos new_class.cl_info info_after_opt ; + Odoc_class.class_update_parameters_text new_class ; + let (new_maybe_more, eles) = + f maybe_more (pos_end + maybe_more) q + in + (new_maybe_more, + ele_comments @ (( Element_class new_class ) :: eles)) + in + let (maybe_more, eles) = + f ~first: true 0 pos_start_ele class_description_list + in + (maybe_more, new_env, eles) - | Parsetree.Psig_class_type class_type_declaration_list -> + | 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 = - try Signature_search.search_class_type table name - with Not_found -> - raise (Failure (Odoc_messages.class_type_not_found current_module_name name)) - in - let sig_class_type = sig_cltype_decl.Types.clty_type in - let kind = analyse_class_type_kind - new_env - complete_name - ct_decl.Parsetree.pci_loc.Location.loc_start - ct_decl.Parsetree.pci_expr - sig_class_type - in - let ct = - { - clt_name = complete_name ; - clt_info = assoc_com ; - clt_type = Odoc_env.subst_class_type env sig_class_type ; - clt_type_parameters = sig_cltype_decl.clty_params ; - clt_virtual = ct_decl.Parsetree.pci_virt = Asttypes.Virtual ; - clt_kind = kind ; - clt_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ; - } - in - let (maybe_more, info_after_opt) = - My_ir.just_after_special - !file_name - (get_string_of_file pos_end pos_limit2) - in - ct.clt_info <- merge_infos ct.clt_info info_after_opt ; - let (new_maybe_more, eles) = - f maybe_more (pos_end + maybe_more) q - in - (new_maybe_more, - ele_comments @ (( Element_class_type ct) :: eles)) - in - let (maybe_more, eles) = - f ~first: true 0 pos_start_ele class_type_declaration_list - in - (maybe_more, new_env, eles) + 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 = + try Signature_search.search_class_type table name + with Not_found -> + raise (Failure (Odoc_messages.class_type_not_found current_module_name name)) + in + let sig_class_type = sig_cltype_decl.Types.clty_type in + let kind = analyse_class_type_kind + new_env + complete_name + ct_decl.Parsetree.pci_loc.Location.loc_start + ct_decl.Parsetree.pci_expr + sig_class_type + in + let ct = + { + clt_name = complete_name ; + clt_info = assoc_com ; + clt_type = Odoc_env.subst_class_type env sig_class_type ; + clt_type_parameters = sig_cltype_decl.clty_params ; + clt_virtual = ct_decl.Parsetree.pci_virt = Asttypes.Virtual ; + clt_kind = kind ; + clt_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ; + } + in + let (maybe_more, info_after_opt) = + My_ir.just_after_special + !file_name + (get_string_of_file pos_end pos_limit2) + in + ct.clt_info <- merge_infos ct.clt_info info_after_opt ; + let (new_maybe_more, eles) = + f maybe_more (pos_end + maybe_more) q + in + (new_maybe_more, + ele_comments @ (( Element_class_type ct) :: eles)) + in + let (maybe_more, eles) = + f ~first: true 0 pos_start_ele class_type_declaration_list + in + (maybe_more, new_env, eles) (** Return a module_type_kind from a Parsetree.module_type and a Types.module_type *) and analyse_module_type_kind env current_module_name module_type sig_module_type = match module_type.Parsetree.pmty_desc with - Parsetree.Pmty_ident longident -> - let name = - match sig_module_type with - Types.Tmty_ident path -> Name.from_path path - | _ -> Name.from_longident longident + 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 } + 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") - ) - + 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) - ) + ( + 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 _") - ) + | _ -> + (* 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) - ) + (* 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_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") - ) + ( + 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 _") - ) + ( + 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) - ) + ( + 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 path_name = Name.from_path p in - let name = Odoc_env.full_class_or_class_type_name env path_name in - let k = - Class_constr - { - cco_name = name ; - cco_class = None ; - cco_type_parameters = List.map (Odoc_env.subst_type env) typ_list - } - in - ([], k) + (Parsetree.Pcty_constr (_, _) (*of Longident.t * core_type list *), + Types.Tcty_constr (p, typ_list, _) (*of Path.t * type_expr list * class_type*)) -> + print_DEBUG "Tcty_constr _"; + let path_name = Name.from_path p in + let name = Odoc_env.full_class_or_class_type_name env path_name in + let k = + Class_constr + { + cco_name = name ; + cco_class = None ; + cco_type_parameters = List.map (Odoc_env.subst_type env) typ_list + } + in + ([], k) | (Parsetree.Pcty_signature (_, class_type_field_list), Types.Tcty_signature class_signature) -> - 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)) + 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. ici on a l'information pour savoir si on a un label explicite. *) - if parse_label = label then - ( - let new_param = Simple_name - { - sn_name = Btype.label_name label ; - sn_type = Odoc_env.subst_type env type_expr ; - sn_text = None ; (* will be updated when the class will be created *) - } - in - let (l, k) = analyse_class_kind env current_class_name last_pos pclass_type class_type in - ( (new_param :: l), k ) - ) - else - ( - raise (Failure "Parsetree.Pcty_fun (parse_label, _, pclass_type), labels différents") - ) - + (* si label = "", pas de label. ici on a l'information pour savoir si on a un label explicite. *) + if parse_label = label then + ( + let new_param = Simple_name + { + sn_name = Btype.label_name label ; + sn_type = Odoc_env.subst_type env type_expr ; + sn_text = None ; (* will be updated when the class will be created *) + } + in + let (l, k) = analyse_class_kind env current_class_name last_pos pclass_type class_type in + ( (new_param :: l), k ) + ) + else + ( + raise (Failure "Parsetree.Pcty_fun (parse_label, _, pclass_type), labels différents") + ) + | _ -> - raise (Failure "analyse_class_kind pas de correspondance dans le match") + 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_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) + 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 (...)") + 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 : + | (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 - + method m : int + end + class ['a] maxou x = - (object - val a = (x : 'a) - method m = a - end : cons ) + (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) + *) + 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") + 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 + 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)) + (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 = Types.Tmty_signature signat ; - m_info = info_opt ; - m_is_interface = true ; - m_file = !file_name ; - m_kind = Module_struct elements ; - m_loc = { loc_impl = None ; loc_inter = Some (!file_name, 0) } ; - m_top_deps = [] ; - } + { + m_name = mod_name ; + m_type = Types.Tmty_signature signat ; + m_info = info_opt ; + m_is_interface = true ; + m_file = !file_name ; + m_kind = Module_struct elements ; + m_loc = { loc_impl = None ; loc_inter = Some (!file_name, 0) } ; + m_top_deps = [] ; + } 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; - () + 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 index bf29fa3d4..3530659c1 100644 --- a/ocamldoc/odoc_sig.mli +++ b/ocamldoc/odoc_sig.mli @@ -19,55 +19,55 @@ module Signature_search : type tab = (ele, Types.signature_item) Hashtbl.t (** Create a table from a signature. This table is used by some - of the search functions below. *) + of the search functions below. *) val table : Types.signature -> tab (** This function returns the type expression for the value whose name is given, - in the given signature. - @raise Not_found if error.*) + in the given signature. + @raise Not_found if error.*) val search_value : tab -> string -> Types.type_expr (** This function returns the type expression list for the exception whose name is given, - in the given table. - @raise Not_found if error.*) + in the given table. + @raise Not_found if error.*) val search_exception : tab -> string -> Types.exception_declaration (** This function returns the Types.type_declaration for the type whose name is given, - in the given table. - @raise Not_found if error.*) + in the given table. + @raise Not_found if error.*) val search_type : tab -> string -> Types.type_declaration - + (** This function returns the Types.class_declaration for the class whose name is given, - in the given table. - @raise Not_found if error.*) + in the given table. + @raise Not_found if error.*) val search_class : tab -> string -> Types.class_declaration (** This function returns the Types.cltype_declaration for the class type whose name is given, - in the given table. - @raise Not_found if error.*) + in the given table. + @raise Not_found if error.*) val search_class_type : tab -> string -> Types.cltype_declaration (** This function returns the Types.module_type for the module whose name is given, - in the given table. - @raise Not_found if error.*) + in the given table. + @raise Not_found if error.*) val search_module : tab -> string -> Types.module_type (** This function returns the optional Types.module_type for the module type whose name is given, - in the given table. - @raise Not_found if error.*) + in the given table. + @raise Not_found if error.*) val search_module_type : tab -> string -> Types.module_type option (** This function returns the Types.type_expr for the given val name - in the given class signature. - @raise Not_found if error.*) + in the given class signature. + @raise Not_found if error.*) val search_attribute_type : - Types.Vars.key -> Types.class_signature -> Types.type_expr + 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.*) + in the given class signature. + @raise Not_found if error.*) val search_method_type : - string -> Types.class_signature -> Types.type_expr + string -> Types.class_signature -> Types.type_expr end (** Functions to retrieve simple and special comments from strings. *) @@ -77,32 +77,32 @@ module type Info_retriever = 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 + 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 + 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) + 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) + 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) + (Odoc_types.text -> 'a) -> string -> string -> (Odoc_types.info option * 'a list) end @@ -116,59 +116,59 @@ module Analyser : 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.*) + 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].*) + [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) + (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) + (Odoc_types.info option * Odoc_module.module_element list) (** 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. - [pos_limit] is the position of the last char we could use to look for a comment, - i.e. usually the beginning on the next element.*) + (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. + [pos_limit] is the position of the last char we could use to look for a comment, + i.e. usually the beginning on the next element.*) val name_comment_from_type_kind : - int -> int -> int -> Parsetree.type_kind -> int * (string * Odoc_types.info option) list + int -> int -> int -> Parsetree.type_kind -> int * (string * Odoc_types.info option) list (** This function converts a [Types.type_kind] into a [Odoc_type.type_kind], - by associating the comment found in the parsetree of each constructor/field, if any.*) + by associating the comment found in the parsetree of each constructor/field, if any.*) val get_type_kind : - Odoc_env.env -> (string * Odoc_types.info option) list -> - Types.type_kind -> Odoc_type.type_kind + Odoc_env.env -> (string * Odoc_types.info option) list -> + Types.type_kind -> Odoc_type.type_kind (** This function merge two optional info structures. *) val merge_infos : - Odoc_types.info option -> Odoc_types.info option -> - Odoc_types.info option + Odoc_types.info option -> Odoc_types.info option -> + Odoc_types.info option (** Return a module_type_kind from a Parsetree.module_type and a Types.module_type *) val analyse_module_type_kind : - Odoc_env.env -> Odoc_name.t -> - Parsetree.module_type -> Types.module_type -> - Odoc_module.module_type_kind + 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.*) + 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 + 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. *) + 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 diff --git a/ocamldoc/odoc_str.ml b/ocamldoc/odoc_str.ml index 434ae72f5..00d12ec66 100644 --- a/ocamldoc/odoc_str.ml +++ b/ocamldoc/odoc_str.ml @@ -19,8 +19,8 @@ let string_of_type t = "type "^ (String.concat "" (List.map - (fun p -> (Odoc_misc.string_of_type_expr p)^" ") - t.M.ty_parameters + (fun p -> (Odoc_misc.string_of_type_expr p)^" ") + t.M.ty_parameters ) )^ (Name.simple t.M.ty_name)^" "^ @@ -34,41 +34,41 @@ let string_of_type t = | 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 - ) + (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 - ) + (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" )^ @@ -83,7 +83,7 @@ let string_of_exception e = [] -> "" | _ ->" : "^ (String.concat " -> " - (List.map (fun t -> "("^(Odoc_misc.string_of_type_expr t)^")") e.M.ex_args) + (List.map (fun t -> "("^(Odoc_misc.string_of_type_expr t)^")") e.M.ex_args) ) )^ (match e.M.ex_alias with @@ -91,8 +91,8 @@ let string_of_exception e = | Some ea -> " = "^ (match ea.M.ea_ex with - None -> ea.M.ea_name - | Some e2 -> e2.M.ex_name + None -> ea.M.ea_name + | Some e2 -> e2.M.ex_name ) )^"\n"^ (match e.M.ex_info with diff --git a/ocamldoc/odoc_texi.ml b/ocamldoc/odoc_texi.ml index a75b48d06..ec6269384 100644 --- a/ocamldoc/odoc_texi.ml +++ b/ocamldoc/odoc_texi.ml @@ -76,20 +76,20 @@ let nothing = Verbatim "" let module_subparts = let rec iter acc = function | [] -> List.rev acc - (* skip aliases *) + (* skip aliases *) | Element_module { m_kind = Module_alias _ } :: n -> - iter acc n + iter acc n | Element_module_type { mt_kind = Some (Module_type_alias _) } :: n -> - iter acc n + iter acc n (* keep modules, module types, classes and class types *) | Element_module m :: n -> - iter (`Module m :: acc) n + iter (`Module m :: acc) n | Element_module_type mt :: n -> - iter (`Module_type mt :: acc) n + iter (`Module_type mt :: acc) n | Element_class c :: n -> - iter (`Class c :: acc) n + iter (`Class c :: acc) n | Element_class_type ct :: n -> - iter (`Class_type ct :: acc) n + iter (`Class_type ct :: acc) n (* forget the rest *) | _ :: n -> iter acc n in @@ -178,32 +178,32 @@ struct if subpart_list <> [] then begin let menu_line part_qual name = - let sname = Name.simple name in - if sname = name - then ( - puts chan (pad_to 35 - ("* " ^ sname ^ ":: ")) ; - puts_nl chan part_qual ) - else ( - puts chan (pad_to 35 - ("* " ^ sname ^ ": " ^ (fix_nodename name) ^ ". " )) ; - puts_nl chan part_qual ) + let sname = Name.simple name in + if sname = name + then ( + puts chan (pad_to 35 + ("* " ^ sname ^ ":: ")) ; + puts_nl chan part_qual ) + else ( + puts chan (pad_to 35 + ("* " ^ sname ^ ": " ^ (fix_nodename name) ^ ". " )) ; + puts_nl chan part_qual ) in puts_nl chan "@menu" ; List.iter - (function - | `Module { m_name = name } -> - menu_line Odoc_messages.modul name - | `Module_type { mt_name = name } -> - menu_line Odoc_messages.module_type name - | `Class { cl_name = name } -> - menu_line Odoc_messages.clas name - | `Class_type { clt_name = name } -> - menu_line Odoc_messages.class_type name - | `Blank -> nl chan - | `Comment c -> puts_nl chan (escape c) - | `Texi t -> puts_nl chan t - | `Index ind -> Printf.fprintf chan "* %s::\n" ind) + (function + | `Module { m_name = name } -> + menu_line Odoc_messages.modul name + | `Module_type { mt_name = name } -> + menu_line Odoc_messages.module_type name + | `Class { cl_name = name } -> + menu_line Odoc_messages.clas name + | `Class_type { clt_name = name } -> + menu_line Odoc_messages.class_type name + | `Blank -> nl chan + | `Comment c -> puts_nl chan (escape c) + | `Texi t -> puts_nl chan t + | `Index ind -> Printf.fprintf chan "* %s::\n" ind) subpart_list ; puts_nl chan "@end menu" end @@ -262,7 +262,7 @@ class text = (** Return the Texinfo code corresponding to the [text] parameter.*) method texi_of_text t = String.concat "" - (List.map self#texi_of_text_element t) + (List.map self#texi_of_text_element t) (** {3 Conversion methods} @@ -295,54 +295,54 @@ class text = method texi_of_Code s = "@code{" ^ (self#escape s) ^ "}" method texi_of_CodePre s = String.concat "\n" - [ "" ; "@example" ; self#escape s ; "@end example" ; "" ] + [ "" ; "@example" ; self#escape s ; "@end example" ; "" ] method texi_of_Bold t = "@strong{" ^ (self#texi_of_text t) ^ "}" method texi_of_Italic t = "@i{" ^ (self#texi_of_text t) ^ "}" method texi_of_Emphasize t = "@emph{" ^ (self#texi_of_text t) ^ "}" method texi_of_Center t = let sl = Str.split (Str.regexp "\n") (self#texi_of_text t) in String.concat "" - ((List.map (fun s -> "\n@center "^s) sl) @ [ "\n" ]) + ((List.map (fun s -> "\n@center "^s) sl) @ [ "\n" ]) method texi_of_Left t = String.concat "\n" - [ "" ; "@flushleft" ; self#texi_of_text t ; "@end flushleft" ; "" ] + [ "" ; "@flushleft" ; self#texi_of_text t ; "@end flushleft" ; "" ] method texi_of_Right t = String.concat "\n" - [ "" ; "@flushright" ; self#texi_of_text t ; "@end flushright"; "" ] + [ "" ; "@flushright" ; self#texi_of_text t ; "@end flushright"; "" ] method texi_of_List tl = String.concat "\n" - ( [ "" ; "@itemize" ] @ - (List.map (fun t -> "@item\n" ^ (self#texi_of_text t)) tl) @ - [ "@end itemize"; "" ] ) + ( [ "" ; "@itemize" ] @ + (List.map (fun t -> "@item\n" ^ (self#texi_of_text t)) tl) @ + [ "@end itemize"; "" ] ) method texi_of_Enum tl = String.concat "\n" - ( [ "" ; "@enumerate" ] @ - (List.map (fun t -> "@item\n" ^ (self#texi_of_text t)) tl) @ - [ "@end enumerate"; "" ] ) + ( [ "" ; "@enumerate" ] @ + (List.map (fun t -> "@item\n" ^ (self#texi_of_text t)) tl) @ + [ "@end enumerate"; "" ] ) method texi_of_Newline = "\n" method texi_of_Block t = String.concat "\n" - [ "@format" ; self#texi_of_text t ; "@end format" ; "" ] + [ "@format" ; self#texi_of_text t ; "@end format" ; "" ] method texi_of_Title n t = let t_begin = - try List.assoc n titles - with Not_found -> fallback_title in + try List.assoc n titles + with Not_found -> fallback_title in t_begin ^ (self#texi_of_text t) ^ "\n" method texi_of_Link s t = String.concat "" - [ "@uref{" ; s ; "," ; self#texi_of_text t ; "}" ] + [ "@uref{" ; s ; "," ; self#texi_of_text t ; "}" ] method texi_of_Ref name kind = let xname = - match kind with - | Some RK_module -> - Odoc_messages.modul ^ " " ^ (Name.simple name) - | Some RK_module_type -> - Odoc_messages.module_type ^ " " ^ (Name.simple name) - | Some RK_class -> - Odoc_messages.clas ^ " " ^ (Name.simple name) - | Some RK_class_type -> - Odoc_messages.class_type ^ " " ^ (Name.simple name) - | _ -> "" + match kind with + | Some RK_module -> + Odoc_messages.modul ^ " " ^ (Name.simple name) + | Some RK_module_type -> + Odoc_messages.module_type ^ " " ^ (Name.simple name) + | Some RK_class -> + Odoc_messages.clas ^ " " ^ (Name.simple name) + | Some RK_class_type -> + Odoc_messages.class_type ^ " " ^ (Name.simple name) + | _ -> "" in if xname = "" then self#escape name else Texi.xref ~xname name method texi_of_Superscript t = @@ -352,8 +352,8 @@ class text = method heading n t = let f = - try List.assoc n headings - with Not_found -> fallback_heading + try List.assoc n headings + with Not_found -> fallback_heading in f ^ (self#texi_of_text t) ^ "\n" @@ -386,33 +386,33 @@ class texi = method index (ind : indices) ent = Verbatim - (if !with_index - then (String.concat "" - [ "@" ; indices ind ; "index " ; - Texi.escape (Name.simple ent) ; "\n" ]) - else "") + (if !with_index + then (String.concat "" + [ "@" ; indices ind ; "index " ; + Texi.escape (Name.simple ent) ; "\n" ]) + else "") (** Two hacks to fix linebreaks in the descriptions.*) method private fix_linebreaks = let re = Str.regexp "\n[ \t]*" in fun t -> - List.map - (function - | Newline -> Raw "\n" - | Raw s -> Raw (Str.global_replace re "\n" s) - | List tel | Enum tel -> List (List.map self#fix_linebreaks tel) - | te -> te) t + List.map + (function + | Newline -> Raw "\n" + | Raw s -> Raw (Str.global_replace re "\n" s) + | List tel | Enum tel -> List (List.map self#fix_linebreaks tel) + | te -> te) t method private soft_fix_linebreaks = let re = Str.regexp "\n[ \t]*" in fun ind t -> - let rep = String.make (succ ind) ' ' in - rep.[0] <- '\n' ; - List.map - (function - | Raw s -> Raw (Str.global_replace re rep s) - | te -> te) t + let rep = String.make (succ ind) ' ' in + rep.[0] <- '\n' ; + List.map + (function + | Raw s -> Raw (Str.global_replace re rep s) + | te -> te) t (** {3 [text] values generation} Generates [text] values out of description parts. @@ -425,97 +425,97 @@ class texi = method text_of_sees_opt see_l = List.concat - (List.map - (function - | (See_url s, t) -> - [ linebreak ; Bold [ Raw Odoc_messages.see_also ] ; - Raw " " ; Link (s, t) ; Newline ] - | (See_file s, t) - | (See_doc s, t) -> - [ linebreak ; Bold [ Raw Odoc_messages.see_also ] ; - Raw " " ; Raw s ] @ t @ [ Newline ]) - see_l) + (List.map + (function + | (See_url s, t) -> + [ linebreak ; Bold [ Raw Odoc_messages.see_also ] ; + Raw " " ; Link (s, t) ; Newline ] + | (See_file s, t) + | (See_doc s, t) -> + [ linebreak ; Bold [ Raw Odoc_messages.see_also ] ; + Raw " " ; Raw s ] @ t @ [ Newline ]) + see_l) method text_of_params params_list = - List.concat - (List.map - (fun (s, t) -> - [ linebreak ; - Bold [ Raw Odoc_messages.parameters ] ; - Raw " " ; Raw s ; Raw ": " ] @ t @ [ Newline ] ) - params_list) + List.concat + (List.map + (fun (s, t) -> + [ linebreak ; + Bold [ Raw Odoc_messages.parameters ] ; + Raw " " ; Raw s ; Raw ": " ] @ t @ [ Newline ] ) + params_list) method text_of_raised_exceptions = function | [] -> [] | (s, t) :: [] -> - [ linebreak ; - Bold [ Raw Odoc_messages.raises ] ; - Raw " " ; Code s ; Raw " " ] - @ t @ [ Newline ] + [ linebreak ; + Bold [ Raw Odoc_messages.raises ] ; + Raw " " ; Code s ; Raw " " ] + @ t @ [ Newline ] | l -> - [ linebreak ; - Bold [ Raw Odoc_messages.raises ] ; - Raw " :" ; - List - (List.map - (fun (ex, desc) ->(Code ex) :: (Raw " ") :: desc ) l ) ; - Newline ] + [ linebreak ; + Bold [ Raw Odoc_messages.raises ] ; + Raw " :" ; + List + (List.map + (fun (ex, desc) ->(Code ex) :: (Raw " ") :: desc ) l ) ; + Newline ] method text_of_return_opt = function | None -> [] | Some t -> - (Bold [Raw Odoc_messages.returns ]) :: Raw " " :: t @ [ Newline ] + (Bold [Raw Odoc_messages.returns ]) :: Raw " " :: t @ [ Newline ] method text_of_custom c_l = List.flatten - (List.rev - (List.fold_left - (fun acc -> fun (tag, text) -> - try - let f = List.assoc tag tag_functions in - ( linebreak :: (f text) @ [ Newline ] ) :: acc - with - Not_found -> - Odoc_info.warning (Odoc_messages.tag_not_handled tag) ; - acc - ) [] c_l)) + (List.rev + (List.fold_left + (fun acc -> fun (tag, text) -> + try + let f = List.assoc tag tag_functions in + ( linebreak :: (f text) @ [ Newline ] ) :: acc + with + Not_found -> + Odoc_info.warning (Odoc_messages.tag_not_handled tag) ; + acc + ) [] c_l)) method text_of_info ?(block=false) = function | None -> [] | Some info -> - let t = - List.concat - [ ( match info.i_deprecated with - | None -> [] - | Some t -> - (Raw (Odoc_messages.deprecated ^ " ")) :: - (self#fix_linebreaks t) - @ [ Newline ; Newline ] ) ; - self#text_of_desc info.i_desc ; - if info.i_authors <> [] - then ( linebreak :: - self#text_of_author_list info.i_authors ) - else [] ; - if is info.i_version - then ( linebreak :: - self#text_of_version_opt info.i_version ) - else [] ; - self#text_of_sees_opt info.i_sees ; - if is info.i_since - then ( linebreak :: - self#text_of_since_opt info.i_since ) - else [] ; - self#text_of_params info.i_params ; - self#text_of_raised_exceptions info.i_raised_exceptions ; - if is info.i_return_value - then ( linebreak :: - self#text_of_return_opt info.i_return_value ) - else [] ; - self#text_of_custom info.i_custom ; - ] in - if block - then [ Block t ] - else (t @ [ Newline ] ) + let t = + List.concat + [ ( match info.i_deprecated with + | None -> [] + | Some t -> + (Raw (Odoc_messages.deprecated ^ " ")) :: + (self#fix_linebreaks t) + @ [ Newline ; Newline ] ) ; + self#text_of_desc info.i_desc ; + if info.i_authors <> [] + then ( linebreak :: + self#text_of_author_list info.i_authors ) + else [] ; + if is info.i_version + then ( linebreak :: + self#text_of_version_opt info.i_version ) + else [] ; + self#text_of_sees_opt info.i_sees ; + if is info.i_since + then ( linebreak :: + self#text_of_since_opt info.i_since ) + else [] ; + self#text_of_params info.i_params ; + self#text_of_raised_exceptions info.i_raised_exceptions ; + if is info.i_return_value + then ( linebreak :: + self#text_of_return_opt info.i_return_value ) + else [] ; + self#text_of_custom info.i_custom ; + ] in + if block + then [ Block t ] + else (t @ [ Newline ] ) method texi_of_info i = self#texi_of_text (self#text_of_info i) @@ -527,8 +527,8 @@ class texi = method text_el_of_type_expr m_name typ = Raw (indent 5 - (self#relative_idents m_name - (Odoc_info.string_of_type_expr typ))) + (self#relative_idents m_name + (Odoc_info.string_of_type_expr typ))) method text_of_short_type_expr m_name typ = [ Raw (self#normal_type m_name typ) ] @@ -537,12 +537,12 @@ class texi = method texi_of_value v = Odoc_info.reset_type_names () ; let t = [ self#fixedblock - [ Newline ; minus ; - Raw ("val " ^ (Name.simple v.val_name) ^ " :\n") ; - self#text_el_of_type_expr - (Name.father v.val_name) v.val_type ] ; - self#index `Value v.val_name ; Newline ] @ - (self#text_of_info v.val_info) in + [ Newline ; minus ; + Raw ("val " ^ (Name.simple v.val_name) ^ " :\n") ; + self#text_el_of_type_expr + (Name.father v.val_name) v.val_type ] ; + self#index `Value v.val_name ; Newline ] @ + (self#text_of_info v.val_info) in self#texi_of_text t @@ -550,16 +550,16 @@ class texi = method texi_of_attribute a = Odoc_info.reset_type_names () ; let t = [ self#fixedblock - [ Newline ; minus ; - Raw "val " ; - Raw (if a.att_mutable then "mutable " else "") ; - Raw (Name.simple a.att_value.val_name) ; - Raw " :\n" ; - self#text_el_of_type_expr - (Name.father a.att_value.val_name) - a.att_value.val_type ] ; - self#index `Class_att a.att_value.val_name ; Newline ] @ - (self#text_of_info a.att_value.val_info) in + [ Newline ; minus ; + Raw "val " ; + Raw (if a.att_mutable then "mutable " else "") ; + Raw (Name.simple a.att_value.val_name) ; + Raw " :\n" ; + self#text_el_of_type_expr + (Name.father a.att_value.val_name) + a.att_value.val_type ] ; + self#index `Class_att a.att_value.val_name ; Newline ] @ + (self#text_of_info a.att_value.val_info) in self#texi_of_text t @@ -567,24 +567,24 @@ class texi = method texi_of_method m = Odoc_info.reset_type_names () ; let t = [ self#fixedblock - [ Newline ; minus ; Raw "method " ; - Raw (if m.met_private then "private " else "") ; - Raw (if m.met_virtual then "virtual " else "") ; - Raw (Name.simple m.met_value.val_name) ; - Raw " :\n" ; - self#text_el_of_type_expr - (Name.father m.met_value.val_name) - m.met_value.val_type ] ; - self#index `Method m.met_value.val_name ; Newline ] @ - (self#text_of_info m.met_value.val_info) in + [ Newline ; minus ; Raw "method " ; + Raw (if m.met_private then "private " else "") ; + Raw (if m.met_virtual then "virtual " else "") ; + Raw (Name.simple m.met_value.val_name) ; + Raw " :\n" ; + self#text_el_of_type_expr + (Name.father m.met_value.val_name) + m.met_value.val_type ] ; + self#index `Method m.met_value.val_name ; Newline ] @ + (self#text_of_info m.met_value.val_info) in self#texi_of_text t method string_of_type_parameter = function - | [] -> "" - | [ tp ] -> (Odoc_info.string_of_type_expr tp) ^ " " - | l -> "(" ^ (String.concat ", " - (List.map Odoc_info.string_of_type_expr l)) ^ ") " + | [] -> "" + | [ tp ] -> (Odoc_info.string_of_type_expr tp) ^ " " + | l -> "(" ^ (String.concat ", " + (List.map Odoc_info.string_of_type_expr l)) ^ ") " method string_of_type_args = function | [] -> "" @@ -594,163 +594,163 @@ class texi = method texi_of_type ty = Odoc_info.reset_type_names () ; let t = - [ self#fixedblock ( - [ Newline ; minus ; Raw "type " ; - Raw (self#string_of_type_parameter ty.ty_parameters) ; - Raw (Name.simple ty.ty_name) ] @ - ( match ty.ty_manifest with - | None -> [] - | Some typ -> - (Raw " = ") :: (self#text_of_short_type_expr - (Name.father ty.ty_name) typ) ) @ - ( match ty.ty_kind with - | Type_abstract -> [ Newline ] - | Type_variant l -> - (Raw " =\n") :: - (List.flatten - (List.map - (fun constr -> - (Raw (" | " ^ constr.vc_name)) :: - (Raw (self#string_of_type_args constr.vc_args)) :: - (match constr.vc_text with - | None -> [ Newline ] - | Some t -> - ((Raw (indent 5 "\n(* ")) :: (self#soft_fix_linebreaks 8 t)) @ - [ Raw " *)" ; Newline ] - ) ) l ) ) - | Type_record l -> - (Raw " = {\n") :: - (List.flatten - (List.map - (fun r -> - [ Raw (" " ^ r.rf_name ^ " : ") ] @ - (self#text_of_short_type_expr - (Name.father r.rf_name) - r.rf_type) @ - [ Raw " ;" ] @ - (match r.rf_text with - | None -> [ Newline ] - | Some t -> - ((Raw (indent 5 "\n(* ")) :: (self#soft_fix_linebreaks 8 t)) @ - [ Raw " *)" ; Newline ] ) ) - l ) ) - @ [ Raw " }" ] ) ) ; - self#index `Type ty.ty_name ; Newline ] @ - (self#text_of_info ty.ty_info) in + [ self#fixedblock ( + [ Newline ; minus ; Raw "type " ; + Raw (self#string_of_type_parameter ty.ty_parameters) ; + Raw (Name.simple ty.ty_name) ] @ + ( match ty.ty_manifest with + | None -> [] + | Some typ -> + (Raw " = ") :: (self#text_of_short_type_expr + (Name.father ty.ty_name) typ) ) @ + ( match ty.ty_kind with + | Type_abstract -> [ Newline ] + | Type_variant l -> + (Raw " =\n") :: + (List.flatten + (List.map + (fun constr -> + (Raw (" | " ^ constr.vc_name)) :: + (Raw (self#string_of_type_args constr.vc_args)) :: + (match constr.vc_text with + | None -> [ Newline ] + | Some t -> + ((Raw (indent 5 "\n(* ")) :: (self#soft_fix_linebreaks 8 t)) @ + [ Raw " *)" ; Newline ] + ) ) l ) ) + | Type_record l -> + (Raw " = {\n") :: + (List.flatten + (List.map + (fun r -> + [ Raw (" " ^ r.rf_name ^ " : ") ] @ + (self#text_of_short_type_expr + (Name.father r.rf_name) + r.rf_type) @ + [ Raw " ;" ] @ + (match r.rf_text with + | None -> [ Newline ] + | Some t -> + ((Raw (indent 5 "\n(* ")) :: (self#soft_fix_linebreaks 8 t)) @ + [ Raw " *)" ; Newline ] ) ) + l ) ) + @ [ Raw " }" ] ) ) ; + self#index `Type ty.ty_name ; Newline ] @ + (self#text_of_info ty.ty_info) in self#texi_of_text t (** Return Texinfo code for an exception. *) method texi_of_exception e = Odoc_info.reset_type_names () ; let t = - [ self#fixedblock - ( [ Newline ; minus ; Raw "exception " ; - Raw (Name.simple e.ex_name) ; - Raw (self#string_of_type_args e.ex_args) ] @ - (match e.ex_alias with - | None -> [] - | Some ea -> [ Raw " = " ; Raw - ( match ea.ea_ex with - | None -> ea.ea_name - | Some e -> e.ex_name ) ; ] - ) ) ; - self#index `Exception e.ex_name ; Newline ] @ - (self#text_of_info e.ex_info) in + [ self#fixedblock + ( [ Newline ; minus ; Raw "exception " ; + Raw (Name.simple e.ex_name) ; + Raw (self#string_of_type_args e.ex_args) ] @ + (match e.ex_alias with + | None -> [] + | Some ea -> [ Raw " = " ; Raw + ( match ea.ea_ex with + | None -> ea.ea_name + | Some e -> e.ex_name ) ; ] + ) ) ; + self#index `Exception e.ex_name ; Newline ] @ + (self#text_of_info e.ex_info) in self#texi_of_text t (** Return the Texinfo code for the given module. *) method texi_of_module m = let is_alias = function - | { m_kind = Module_alias _ } -> true - | _ -> false in + | { m_kind = Module_alias _ } -> true + | _ -> false in let is_alias_there = function - | { m_kind = Module_alias { ma_module = None } } -> false - | _ -> true in + | { m_kind = Module_alias { ma_module = None } } -> false + | _ -> true in let resolve_alias_name = function - | { m_kind = Module_alias { ma_name = name } } -> name - | { m_name = name } -> name in + | { m_kind = Module_alias { ma_name = name } } -> name + | { m_name = name } -> name in let t = - [ [ self#fixedblock - [ Newline ; minus ; Raw "module " ; - Raw (Name.simple m.m_name) ; - Raw (if is_alias m - then " = " ^ (resolve_alias_name m) - else "" ) ] ] ; - ( if is_alias_there m - then [ Ref (resolve_alias_name m, Some RK_module) ; - Newline ; ] - else [] ) ; - ( if is_alias m - then [ self#index `Module m.m_name ; Newline ] - else [ Newline ] ) ; - self#text_of_info m.m_info ] + [ [ self#fixedblock + [ Newline ; minus ; Raw "module " ; + Raw (Name.simple m.m_name) ; + Raw (if is_alias m + then " = " ^ (resolve_alias_name m) + else "" ) ] ] ; + ( if is_alias_there m + then [ Ref (resolve_alias_name m, Some RK_module) ; + Newline ; ] + else [] ) ; + ( if is_alias m + then [ self#index `Module m.m_name ; Newline ] + else [ Newline ] ) ; + self#text_of_info m.m_info ] in self#texi_of_text (List.flatten t) (** Return the Texinfo code for the given module type. *) method texi_of_module_type mt = let is_alias = function - | { mt_kind = Some (Module_type_alias _) } -> true - | _ -> false in + | { mt_kind = Some (Module_type_alias _) } -> true + | _ -> false in let is_alias_there = function - | { mt_kind = Some (Module_type_alias { mta_module = None }) } -> false - | _ -> true in + | { mt_kind = Some (Module_type_alias { mta_module = None }) } -> false + | _ -> true in let resolve_alias_name = function - | { mt_kind = Some (Module_type_alias { mta_name = name }) } -> name - | { mt_name = name } -> name in + | { mt_kind = Some (Module_type_alias { mta_name = name }) } -> name + | { mt_name = name } -> name in let t = - [ [ self#fixedblock - [ Newline ; minus ; Raw "module type" ; - Raw (Name.simple mt.mt_name) ; - Raw (if is_alias mt - then " = " ^ (resolve_alias_name mt) - else "" ) ] ] ; - ( if is_alias_there mt - then [ Ref (resolve_alias_name mt, Some RK_module_type) ; - Newline ; ] - else [] ) ; - ( if is_alias mt - then [ self#index `Module_type mt.mt_name ; Newline ] - else [ Newline ] ) ; - self#text_of_info mt.mt_info ] + [ [ self#fixedblock + [ Newline ; minus ; Raw "module type" ; + Raw (Name.simple mt.mt_name) ; + Raw (if is_alias mt + then " = " ^ (resolve_alias_name mt) + else "" ) ] ] ; + ( if is_alias_there mt + then [ Ref (resolve_alias_name mt, Some RK_module_type) ; + Newline ; ] + else [] ) ; + ( if is_alias mt + then [ self#index `Module_type mt.mt_name ; Newline ] + else [ Newline ] ) ; + self#text_of_info mt.mt_info ] in self#texi_of_text (List.flatten t) (** Return the Texinfo code for the given included module. *) method texi_of_included_module im = let t = [ self#fixedblock - ( Newline :: minus :: (Raw "include module ") :: - ( match im.im_module with - | None -> - [ Raw im.im_name ] - | Some (Mod { m_name = name }) -> - [ Raw name ; Raw "\n " ; - Ref (name, Some RK_module) ] - | Some (Modtype { mt_name = name }) -> - [ Raw name ; Raw "\n " ; - Ref (name, Some RK_module_type) ] - ) ) ] in + ( Newline :: minus :: (Raw "include module ") :: + ( match im.im_module with + | None -> + [ Raw im.im_name ] + | Some (Mod { m_name = name }) -> + [ Raw name ; Raw "\n " ; + Ref (name, Some RK_module) ] + | Some (Modtype { mt_name = name }) -> + [ Raw name ; Raw "\n " ; + Ref (name, Some RK_module_type) ] + ) ) ] in self#texi_of_text t (** Return the Texinfo code for the given class. *) method texi_of_class c = Odoc_info.reset_type_names () ; let t = [ self#fixedblock - [ Newline ; minus ; Raw "class " ; - Raw (Name.simple c.cl_name) ] ; - Ref (c.cl_name, Some RK_class) ; Newline ; - Newline ] @ (self#text_of_info c.cl_info) in + [ Newline ; minus ; Raw "class " ; + Raw (Name.simple c.cl_name) ] ; + Ref (c.cl_name, Some RK_class) ; Newline ; + Newline ] @ (self#text_of_info c.cl_info) in self#texi_of_text t (** Return the Texinfo code for the given class type. *) method texi_of_class_type ct = Odoc_info.reset_type_names () ; let t = [ self#fixedblock - [ Newline ; minus ; Raw "class type " ; - Raw (Name.simple ct.clt_name) ] ; - Ref (ct.clt_name, Some RK_class_type) ; Newline ; - Newline ] @ (self#text_of_info ct.clt_info) in + [ Newline ; minus ; Raw "class type " ; + Raw (Name.simple ct.clt_name) ] ; + Ref (ct.clt_name, Some RK_class_type) ; Newline ; + Newline ] @ (self#text_of_info ct.clt_info) in self#texi_of_text t (** Return the Texinfo code for the given class element. *) @@ -772,7 +772,7 @@ class texi = | Element_exception e -> self#texi_of_exception e | Element_type t -> self#texi_of_type t | Element_module_comment t -> - self#texi_of_text (Newline :: t @ [Newline]) + self#texi_of_text (Newline :: t @ [Newline]) ) (** {3 Generating methods } @@ -781,26 +781,26 @@ class texi = (** Generate the Texinfo code for the given list of inherited classes.*) method generate_inheritance_info chanout inher_l = let f inh = - match inh.ic_class with - | None -> (* we can't make the reference *) - (Code inh.ic_name) :: - (match inh.ic_text with - | None -> [] - | Some t -> Newline :: t) - | Some cct -> (* we can create the reference *) - let kind = - match cct with - | Cl _ -> Some RK_class - | Cltype _ -> Some RK_class_type in - (Code inh.ic_name) :: - (Ref (inh.ic_name, kind)) :: - ( match inh.ic_text with - | None -> [] - | Some t -> Newline :: t) + match inh.ic_class with + | None -> (* we can't make the reference *) + (Code inh.ic_name) :: + (match inh.ic_text with + | None -> [] + | Some t -> Newline :: t) + | Some cct -> (* we can create the reference *) + let kind = + match cct with + | Cl _ -> Some RK_class + | Cltype _ -> Some RK_class_type in + (Code inh.ic_name) :: + (Ref (inh.ic_name, kind)) :: + ( match inh.ic_text with + | None -> [] + | Some t -> Newline :: t) in let text = [ - Bold [ Raw Odoc_messages.inherits ] ; - List (List.map f inher_l) ; Newline ] + Bold [ Raw Odoc_messages.inherits ] ; + List (List.map f inher_l) ; Newline ] in puts chanout (self#texi_of_text text) @@ -810,12 +810,12 @@ class texi = of the given class. *) method generate_class_inheritance_info chanout cl = let rec iter_kind = function - | Class_structure ([], _) -> () - | Class_structure (l, _) -> - self#generate_inheritance_info chanout l - | Class_constraint (k, _) -> iter_kind k - | Class_apply _ - | Class_constr _ -> () + | 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 @@ -825,12 +825,12 @@ class texi = 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 _ -> - () + | Class_signature ([], _) -> + () + | Class_signature (l, _) -> + self#generate_inheritance_info chanout l + | Class_type _ -> + () (** Generate the Texinfo code for the given class, in the given out channel. *) @@ -838,28 +838,28 @@ class texi = Odoc_info.reset_type_names () ; let depth = Name.depth c.cl_name in let title = [ - self#node depth c.cl_name ; - Title (depth, None, [ Raw (Odoc_messages.clas ^ " ") ; - Code c.cl_name ]) ; - self#index `Class c.cl_name ] in + self#node depth c.cl_name ; + Title (depth, None, [ Raw (Odoc_messages.clas ^ " ") ; + Code c.cl_name ]) ; + self#index `Class c.cl_name ] in puts chanout (self#texi_of_text title) ; if is c.cl_info then begin - let descr = [ Title (succ depth, None, - [ Raw Odoc_messages.description ]) ] in - puts chanout (self#texi_of_text descr) ; - puts chanout (self#texi_of_info c.cl_info) + let descr = [ Title (succ depth, None, + [ Raw Odoc_messages.description ]) ] in + puts chanout (self#texi_of_text descr) ; + puts chanout (self#texi_of_info c.cl_info) end ; let intf = [ Title (succ depth, None, - [ Raw Odoc_messages.interface]) ] in + [ Raw Odoc_messages.interface]) ] in puts chanout (self#texi_of_text intf); self#generate_class_inheritance_info chanout c ; List.iter - (fun ele -> puts chanout - (self#texi_of_class_element c.cl_name ele)) - (Class.class_elements ~trans:false c) + (fun ele -> puts chanout + (self#texi_of_class_element c.cl_name ele)) + (Class.class_elements ~trans:false c) (** Generate the Texinfo code for the given class type, @@ -868,28 +868,28 @@ class texi = Odoc_info.reset_type_names () ; let depth = Name.depth ct.clt_name in let title = [ - self#node depth ct.clt_name ; - Title (depth, None, [ Raw (Odoc_messages.class_type ^ " ") ; - Code ct.clt_name ]) ; - self#index `Class_type ct.clt_name ] in + self#node depth ct.clt_name ; + Title (depth, None, [ Raw (Odoc_messages.class_type ^ " ") ; + Code ct.clt_name ]) ; + self#index `Class_type ct.clt_name ] in puts chanout (self#texi_of_text title) ; if is ct.clt_info then begin - let descr = [ Title (succ depth, None, - [ Raw Odoc_messages.description ]) ] in - puts chanout (self#texi_of_text descr) ; - puts chanout (self#texi_of_info ct.clt_info) + let descr = [ Title (succ depth, None, + [ Raw Odoc_messages.description ]) ] in + puts chanout (self#texi_of_text descr) ; + puts chanout (self#texi_of_info ct.clt_info) end ; let intf = [ Title (succ depth, None, - [ Raw Odoc_messages.interface ]) ] in + [ Raw Odoc_messages.interface ]) ] in puts chanout (self#texi_of_text intf) ; self#generate_class_type_inheritance_info chanout ct; List.iter - (fun ele -> puts chanout - (self#texi_of_class_element ct.clt_name ele)) - (Class.class_type_elements ~trans:false ct) + (fun ele -> puts chanout + (self#texi_of_class_element ct.clt_name ele)) + (Class.class_type_elements ~trans:false ct) @@ -898,46 +898,46 @@ class texi = method generate_for_module_type chanout mt = let depth = Name.depth mt.mt_name in let title = [ - self#node depth mt.mt_name ; - Title (depth, None, [ Raw (Odoc_messages.module_type ^ " ") ; - Code mt.mt_name ]) ; - self#index `Module_type mt.mt_name ; Newline ] in + self#node depth mt.mt_name ; + Title (depth, None, [ Raw (Odoc_messages.module_type ^ " ") ; + Code mt.mt_name ]) ; + self#index `Module_type mt.mt_name ; Newline ] in puts chanout (self#texi_of_text title) ; if is mt.mt_info then begin - let descr = [ Title (succ depth, None, - [ Raw Odoc_messages.description ]) ] in - puts chanout (self#texi_of_text descr) ; - puts chanout (self#texi_of_info mt.mt_info) + let descr = [ Title (succ depth, None, + [ Raw Odoc_messages.description ]) ] in + puts chanout (self#texi_of_text descr) ; + puts chanout (self#texi_of_info mt.mt_info) end ; let mt_ele = Module.module_type_elements ~trans:false mt in let subparts = module_subparts mt_ele in if depth < maxdepth && subparts <> [] then begin - let menu = Texi.ifinfo - ( self#heading (succ depth) [ Raw "Subparts" ]) in - puts chanout menu ; - Texi.generate_menu chanout (subparts :> subparts) + let menu = Texi.ifinfo + ( self#heading (succ depth) [ Raw "Subparts" ]) in + puts chanout menu ; + Texi.generate_menu chanout (subparts :> subparts) end ; let intf = [ Title (succ depth, None, - [ Raw Odoc_messages.interface ]) ] in + [ Raw Odoc_messages.interface ]) ] in puts chanout (self#texi_of_text intf) ; List.iter - (fun ele -> puts chanout - (self#texi_of_module_element mt.mt_name ele)) - mt_ele ; + (fun ele -> puts chanout + (self#texi_of_module_element mt.mt_name ele)) + mt_ele ; (* create sub parts for modules, module types, classes and class types *) List.iter - (function - | `Module m -> self#generate_for_module chanout m - | `Module_type mt -> self#generate_for_module_type chanout mt - | `Class c -> self#generate_for_class chanout c - | `Class_type ct -> self#generate_for_class_type chanout ct) - subparts + (function + | `Module m -> self#generate_for_module chanout m + | `Module_type mt -> self#generate_for_module_type chanout mt + | `Class c -> self#generate_for_class chanout c + | `Class_type ct -> self#generate_for_class_type chanout ct) + subparts (** Generate the Texinfo code for the given module, @@ -945,47 +945,47 @@ class texi = method generate_for_module chanout m = let depth = Name.depth m.m_name in let title = [ - self#node depth m.m_name ; - Title (depth, None, [ Raw (Odoc_messages.modul ^ " ") ; - Code m.m_name ]) ; - self#index `Module m.m_name ; Newline ] in + self#node depth m.m_name ; + Title (depth, None, [ Raw (Odoc_messages.modul ^ " ") ; + Code m.m_name ]) ; + self#index `Module m.m_name ; Newline ] in puts chanout (self#texi_of_text title) ; if is m.m_info then begin - let descr = [ Title (succ depth, None, - [ Raw Odoc_messages.description ]) ] in - puts chanout (self#texi_of_text descr) ; - puts chanout (self#texi_of_info m.m_info) + let descr = [ Title (succ depth, None, + [ Raw Odoc_messages.description ]) ] in + puts chanout (self#texi_of_text descr) ; + puts chanout (self#texi_of_info m.m_info) end ; let m_ele = Module.module_elements ~trans:false m in let subparts = module_subparts m_ele in if depth < maxdepth && subparts <> [] then begin - let menu = Texi.ifinfo - ( self#heading (succ depth) [ Raw "Subparts" ]) in - puts chanout menu ; - Texi.generate_menu chanout (subparts :> subparts) + let menu = Texi.ifinfo + ( self#heading (succ depth) [ Raw "Subparts" ]) in + puts chanout menu ; + Texi.generate_menu chanout (subparts :> subparts) end ; let intf = [ Title (succ depth, None, - [ Raw Odoc_messages.interface]) ] in + [ Raw Odoc_messages.interface]) ] in puts chanout (self#texi_of_text intf) ; List.iter - (fun ele -> puts chanout - (self#texi_of_module_element m.m_name ele)) - m_ele ; + (fun ele -> puts chanout + (self#texi_of_module_element m.m_name ele)) + m_ele ; (* create sub nodes for modules, module types, classes and class types *) List.iter - (function - | `Module m -> self#generate_for_module chanout m - | `Module_type mt -> self#generate_for_module_type chanout mt - | `Class c -> self#generate_for_class chanout c - | `Class_type ct -> self#generate_for_class_type chanout ct ) - subparts + (function + | `Module m -> self#generate_for_module chanout m + | `Module_type mt -> self#generate_for_module_type chanout mt + | `Class c -> self#generate_for_class chanout c + | `Class_type ct -> self#generate_for_class_type chanout ct ) + subparts @@ -995,52 +995,52 @@ class texi = match !Odoc_args.title with | None -> ("", "doc.info") | Some s -> - let s' = self#escape s in - (s', s' ^ ".info") + let s' = self#escape s in + (s', s' ^ ".info") in (* write a standard Texinfo header *) List.iter - (puts_nl chan) - (List.flatten - [ [ "\\input texinfo @c -*-texinfo-*-" ; - "@c %**start of header" ; - "@setfilename " ^ filename ; - "@settitle " ^ title ; - "@c %**end of header" ; ] ; - - (if !with_index then - List.map - (fun (_, shortname) -> - "@defcodeindex " ^ shortname) - indices_names - else []) ; - - [ "@ifinfo" ; - "This file was generated by Ocamldoc using the Texinfo generator." ; - "@end ifinfo" ; - - "@c no titlepage." ; - - "@node Top, , , (dir)" ; - "@top "^ title ; ] - ] ) ; + (puts_nl chan) + (List.flatten + [ [ "\\input texinfo @c -*-texinfo-*-" ; + "@c %**start of header" ; + "@setfilename " ^ filename ; + "@settitle " ^ title ; + "@c %**end of header" ; ] ; + + (if !with_index then + List.map + (fun (_, shortname) -> + "@defcodeindex " ^ shortname) + indices_names + else []) ; + + [ "@ifinfo" ; + "This file was generated by Ocamldoc using the Texinfo generator." ; + "@end ifinfo" ; + + "@c no titlepage." ; + + "@node Top, , , (dir)" ; + "@top "^ title ; ] + ] ) ; if title <> "" then begin - puts_nl chan "@ifinfo" ; - puts_nl chan ("Documentation for " ^ title) ; - puts_nl chan "@end ifinfo" + puts_nl chan "@ifinfo" ; + puts_nl chan ("Documentation for " ^ title) ; + puts_nl chan "@end ifinfo" end else puts_nl chan "@c no title given" ; (* write a top menu *) Texi.generate_menu chan - ((List.map (fun m -> `Module m) m_list) @ - (if !with_index then - [ `Blank ; `Comment "Indices :" ] @ - (List.map - (fun (longname, _) -> `Index (longname ^ " index")) - indices_names ) - else [] )) + ((List.map (fun m -> `Module m) m_list) @ + (if !with_index then + [ `Blank ; `Comment "Indices :" ] @ + (List.map + (fun (longname, _) -> `Index (longname ^ " index")) + indices_names ) + else [] )) (** Writes the header of the TeX document. *) @@ -1048,14 +1048,14 @@ class texi = nl chan ; if !with_index then - List.iter (puts_nl chan) - (List.flatten - (List.map - (fun (longname, shortname) -> - [ "@node " ^ longname ^ " index," ; - "@unnumbered " ^ longname ^ " index" ; - "@printindex " ^ shortname ; ]) - indices_names )) ; + List.iter (puts_nl chan) + (List.flatten + (List.map + (fun (longname, shortname) -> + [ "@node " ^ longname ^ " index," ; + "@unnumbered " ^ longname ^ " index" ; + "@printindex " ^ shortname ; ]) + indices_names )) ; if !Odoc_args.with_toc then puts_nl chan "@contents" ; puts_nl chan "@bye" @@ -1066,22 +1066,22 @@ class texi = in the {!Odoc_args.out_file} file. *) method generate module_list = try - let chanout = open_out - (Filename.concat !Odoc_args.target_dir !Odoc_args.out_file) in - if !Odoc_args.with_header - then self#generate_texi_header chanout module_list ; - List.iter - (fun modu -> - Odoc_info.verbose ("Generate for module " ^ modu.m_name) ; - self#generate_for_module chanout modu) - module_list ; - if !Odoc_args.with_trailer - then self#generate_texi_trailer chanout ; - close_out chanout + let chanout = open_out + (Filename.concat !Odoc_args.target_dir !Odoc_args.out_file) in + if !Odoc_args.with_header + then self#generate_texi_header chanout module_list ; + List.iter + (fun modu -> + Odoc_info.verbose ("Generate for module " ^ modu.m_name) ; + self#generate_for_module chanout modu) + module_list ; + if !Odoc_args.with_trailer + then self#generate_texi_trailer chanout ; + close_out chanout with - | Failure s - | Sys_error s -> - prerr_endline s ; - incr Odoc_info.errors + | Failure s + | Sys_error s -> + prerr_endline s ; + incr Odoc_info.errors end diff --git a/ocamldoc/odoc_text.ml b/ocamldoc/odoc_text.ml index 5a712e5b4..5a9b9130f 100644 --- a/ocamldoc/odoc_text.ml +++ b/ocamldoc/odoc_text.ml @@ -18,13 +18,13 @@ module Texter = 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 + 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) - ) + _ -> + raise (Text_syntax (!Odoc_text_lexer.line_number, + !Odoc_text_lexer.char_number, + s) + ) end diff --git a/ocamldoc/odoc_text_lexer.mll b/ocamldoc/odoc_text_lexer.mll index 54b7db057..e8cc9f56f 100644 --- a/ocamldoc/odoc_text_lexer.mll +++ b/ocamldoc/odoc_text_lexer.mll @@ -169,77 +169,77 @@ rule main = parse { incr_cpts lexbuf ; if !verb_mode or !latex_mode or !code_pre_mode or - (!open_brackets >= 1) then - Char (Lexing.lexeme lexbuf) + (!open_brackets >= 1) then + Char (Lexing.lexeme lexbuf) else - let _ = - if !ele_ref_mode then - ele_ref_mode := false - in - END + 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) + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) else - let s = Lexing.lexeme lexbuf in - try + 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) + 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) + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) else - BOLD + 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) + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) else - ITALIC + 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) + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) else - LINK + 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) + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) else EMP } @@ -247,8 +247,8 @@ rule main = parse { 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) + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) else SUPERSCRIPT } @@ -256,8 +256,8 @@ rule main = parse { 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) + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) else SUBSCRIPT } @@ -265,17 +265,17 @@ rule main = parse { 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) + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) else - CENTER + 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) + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) else LEFT } @@ -283,8 +283,8 @@ rule main = parse { 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) + or (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) else RIGHT } @@ -292,8 +292,8 @@ rule main = parse { 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) + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) else LIST } @@ -301,43 +301,43 @@ rule main = parse { 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) + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) else - ENUM + 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) + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) else - ITEM + 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) + (!open_brackets >= 1) or !ele_ref_mode then + Char (Lexing.lexeme lexbuf) else - ( - latex_mode := true; - LATEX - ) + ( + 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) + !ele_ref_mode then + Char (Lexing.lexeme lexbuf) else - ( - latex_mode := false; - END_LATEX - ) + ( + latex_mode := false; + END_LATEX + ) } | begin_code end_code { @@ -349,35 +349,35 @@ rule main = parse { incr_cpts lexbuf ; if !verb_mode or !latex_mode or !code_pre_mode or !ele_ref_mode then - Char (Lexing.lexeme lexbuf) + Char (Lexing.lexeme lexbuf) else if !open_brackets <= 0 then - ( - open_brackets := 1; - CODE - ) - else - ( - incr open_brackets; - Char (Lexing.lexeme lexbuf) - ) + ( + 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) + Char (Lexing.lexeme lexbuf) else - if !open_brackets > 1 then - ( - decr open_brackets; - Char "]" - ) - else - ( - open_brackets := 0; - END_CODE - ) + if !open_brackets > 1 then + ( + decr open_brackets; + Char "]" + ) + else + ( + open_brackets := 0; + END_CODE + ) } | begin_code_pre end_code_pre @@ -390,26 +390,26 @@ rule main = parse { incr_cpts lexbuf ; if !verb_mode or !latex_mode or !code_pre_mode or !ele_ref_mode then - Char (Lexing.lexeme lexbuf) + Char (Lexing.lexeme lexbuf) else - ( - code_pre_mode := true; - CODE_PRE - ) + ( + 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) + Char (Lexing.lexeme lexbuf) else - if !code_pre_mode then - ( - code_pre_mode := false; - END_CODE_PRE - ) - else - Char (Lexing.lexeme lexbuf) + if !code_pre_mode then + ( + code_pre_mode := false; + END_CODE_PRE + ) + else + Char (Lexing.lexeme lexbuf) } | begin_ele_ref end @@ -422,66 +422,66 @@ rule main = parse { incr_cpts lexbuf ; if !verb_mode or !latex_mode or !code_pre_mode or !open_brackets >= 1 then - Char (Lexing.lexeme lexbuf) + Char (Lexing.lexeme lexbuf) else if not !ele_ref_mode then - ( - ele_ref_mode := true; - ELE_REF - ) - else - ( - Char (Lexing.lexeme lexbuf) - ) + ( + 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) + Char (Lexing.lexeme lexbuf) else - ( - verb_mode := true; - VERB - ) + ( + 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) + Char (Lexing.lexeme lexbuf) else - ( - verb_mode := false; - END_VERB - ) + ( + verb_mode := false; + END_VERB + ) } | shortcut_list_item { incr_cpts lexbuf ; if !shortcut_list_mode then - ( - SHORTCUT_LIST_ITEM - ) + ( + SHORTCUT_LIST_ITEM + ) else ( - shortcut_list_mode := true; - BEGIN_SHORTCUT_LIST_ITEM - ) + shortcut_list_mode := true; + BEGIN_SHORTCUT_LIST_ITEM + ) } | shortcut_enum_item { incr_cpts lexbuf ; if !shortcut_list_mode then - SHORTCUT_ENUM_ITEM + SHORTCUT_ENUM_ITEM else ( - shortcut_list_mode := true; - BEGIN_SHORTCUT_ENUM_ITEM - ) + shortcut_list_mode := true; + BEGIN_SHORTCUT_ENUM_ITEM + ) } | end_shortcut_list { @@ -491,15 +491,15 @@ rule main = parse 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 - ) + ( + 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 + BLANK_LINE } | eof { EOF } @@ -508,9 +508,9 @@ rule main = parse { incr_cpts lexbuf ; if !latex_mode or (!open_brackets >= 1) or !code_pre_mode or !ele_ref_mode then - Char (Lexing.lexeme lexbuf) + Char (Lexing.lexeme lexbuf) else - ERROR + ERROR } | _ { diff --git a/ocamldoc/odoc_to_text.ml b/ocamldoc/odoc_to_text.ml index 27d0d8072..77d9aec6c 100644 --- a/ocamldoc/odoc_to_text.ml +++ b/ocamldoc/odoc_to_text.ml @@ -34,134 +34,134 @@ class virtual info = (** @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 - ] + [ 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 -> [] + None -> [] | Some v -> [ Bold [Raw (Odoc_messages.version^": ")] ; - Raw v ; - Newline - ] + Raw v ; + Newline + ] (** @return [text] value for the given optional since information.*) method text_of_since_opt s_opt = match s_opt with - None -> [] + None -> [] | Some s -> [ Bold [Raw (Odoc_messages.since^": ")] ; - Raw s ; - Newline - ] + 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 " " ; + Code s ; + Raw " " + ] + @ t + @ [ Newline ] | _ -> - [ Bold [ Raw Odoc_messages.raises ] ; - Raw " " ; - List - (List.map - (fun (ex, desc) ->(Code ex) :: (Raw " ") :: desc ) - l - ) ; - 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 + 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 ]) :: + (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 - ] + (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 -> [] + 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 + (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 -> - [] + None -> + [] | Some info -> - let t = - (match info.i_deprecated with - None -> [] - | Some t -> ( Italic [Raw (Odoc_messages.deprecated^" ")] ) :: t - ) @ - (match info.i_desc with - None -> [] - | Some t when t = [Odoc_info.Raw ""] -> [] - | Some t -> t @ [ Newline ] - ) @ - (self#text_of_author_list info.i_authors) @ - (self#text_of_version_opt info.i_version) @ - (self#text_of_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 + let t = + (match info.i_deprecated with + None -> [] + | Some t -> ( Italic [Raw (Odoc_messages.deprecated^" ")] ) :: t + ) @ + (match info.i_desc with + None -> [] + | Some t when t = [Odoc_info.Raw ""] -> [] + | Some t -> t @ [ Newline ] + ) @ + (self#text_of_author_list info.i_authors) @ + (self#text_of_version_opt info.i_version) @ + (self#text_of_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. *) @@ -176,14 +176,14 @@ class virtual to_text = 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 + 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 + (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)") + f + s in s2 @@ -206,11 +206,11 @@ class virtual to_text = (** @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)) - ) + (List.map + (fun s -> [Code s ; Newline ]) + (Str.split (Str.regexp "\n") + (self#normal_type module_name t)) + ) in t @@ -221,13 +221,13 @@ class virtual to_text = (** 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) ] + [ 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)) + (Str.split (Str.regexp "\n") (Odoc_info.string_of_module_type t)) in [ Code s ] @@ -237,7 +237,7 @@ class virtual to_text = Format.fprintf Format.str_formatter "@[<hov 2>val %s :@ " s_name; let s = - (self#normal_type (Name.father v.val_name) v.val_type) + (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")] @ @@ -247,8 +247,8 @@ class virtual to_text = 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; + (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) :: @@ -259,9 +259,9 @@ class virtual to_text = 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 ; + (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) :: @@ -273,25 +273,25 @@ class virtual to_text = 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 " - ); + (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 () + 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")] @ @@ -300,220 +300,220 @@ class virtual to_text = (** 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 - ) + 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 - ) - ] + 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 - ) - ] + [ Bold [Raw Odoc_messages.parameters] ; + Raw ":" ; + List + (List.map + (fun p -> + (match Parameter.complete_name p with + "" -> Code "?" + | s -> Code s + ) :: + [Code " : "] @ + (self#text_of_short_type_expr m_name (Parameter.typ p)) @ + [Newline] @ + (self#text_of_parameter_description p) + ) + l + ) + ] (** Return [text] value for a list of module parameters. *) method text_of_module_parameter_list l = match l with - [] -> - [] + [] -> + [] | _ -> - [ Newline ; - Bold [Raw Odoc_messages.parameters] ; - Raw ":" ; - List - (List.map - (fun (p, desc_opt) -> - [Code (p.mp_name^" : ")] @ - (self#text_of_module_type p.mp_type) @ - (match desc_opt with - None -> [] - | Some t -> (Raw " ") :: t) - ) - l - ) - ] + [ Newline ; + Bold [Raw Odoc_messages.parameters] ; + Raw ":" ; + List + (List.map + (fun (p, desc_opt) -> + [Code (p.mp_name^" : ")] @ + (self#text_of_module_type p.mp_type) @ + (match desc_opt with + None -> [] + | Some t -> (Raw " ") :: t) + ) + l + ) + ] (**/**) (** Return [text] value for the given [class_kind].*) method text_of_class_kind father ckind = match ckind with - Class_structure _ -> - [Code Odoc_messages.object_end] - - | Class_apply capp -> - [Code - ( - ( - match capp.capp_class with - None -> capp.capp_name - | Some cl -> cl.cl_name - )^ - " "^ - (String.concat " " - (List.map - (fun s -> "("^s^")") - capp.capp_params_code)) - ) - ] - - | Class_constr cco -> - ( - match cco.cco_type_parameters with - [] -> [] - | l -> - (Code "["):: - (self#text_of_type_expr_list father ", " l)@ - [Code "] "] - )@ - [Code ( - match cco.cco_class with - None -> cco.cco_name - | Some (Cl cl) -> Name.get_relative father cl.cl_name - | Some (Cltype (clt,_)) -> Name.get_relative father clt.clt_name - ) - ] - - | Class_constraint (ck, ctk) -> - [Code "( "] @ - (self#text_of_class_kind father ck) @ - [Code " : "] @ - (self#text_of_class_type_kind father ctk) @ - [Code " )"] + Class_structure _ -> + [Code Odoc_messages.object_end] + + | Class_apply capp -> + [Code + ( + ( + match capp.capp_class with + None -> capp.capp_name + | Some cl -> cl.cl_name + )^ + " "^ + (String.concat " " + (List.map + (fun s -> "("^s^")") + capp.capp_params_code)) + ) + ] + + | Class_constr cco -> + ( + match cco.cco_type_parameters with + [] -> [] + | l -> + (Code "["):: + (self#text_of_type_expr_list father ", " l)@ + [Code "] "] + )@ + [Code ( + match cco.cco_class with + None -> cco.cco_name + | Some (Cl cl) -> Name.get_relative father cl.cl_name + | Some (Cltype (clt,_)) -> Name.get_relative father clt.clt_name + ) + ] + + | Class_constraint (ck, ctk) -> + [Code "( "] @ + (self#text_of_class_kind father ck) @ + [Code " : "] @ + (self#text_of_class_type_kind father ctk) @ + [Code " )"] (** Return [text] value for the given [class_type_kind].*) method text_of_class_type_kind father ctkind = match ctkind with - Class_type cta -> - ( - match cta.cta_type_parameters with - [] -> [] - | l -> - (Code "[") :: - (self#text_of_type_expr_list father ", " l) @ - [Code "] "] - ) @ - ( - match cta.cta_class with - None -> [ Code cta.cta_name ] - | Some (Cltype (clt, _)) -> - let rel = Name.get_relative father clt.clt_name in - [Code rel] - | Some (Cl cl) -> - let rel = Name.get_relative father cl.cl_name in - [Code rel] - ) - | Class_signature _ -> - [Code Odoc_messages.object_end] + Class_type cta -> + ( + 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, _)) -> + let rel = Name.get_relative father clt.clt_name in + [Code rel] + | Some (Cl cl) -> + let rel = Name.get_relative father cl.cl_name in + [Code rel] + ) + | Class_signature _ -> + [Code Odoc_messages.object_end] (** Return [text] value for a [module_kind]. *) method text_of_module_kind ?(with_def_syntax=true) k = match k with - Module_alias m_alias -> - (match m_alias.ma_module with - None -> - [Code ((if with_def_syntax then " = " else "")^m_alias.ma_name)] - | Some (Mod m) -> - [Code ((if with_def_syntax then " = " else "")^m.m_name)] - | Some (Modtype mt) -> - [Code ((if with_def_syntax then " = " else "")^mt.mt_name)] - ) + Module_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 " ) "] - + (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] - + (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 " )"] - + (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^" ")] + [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) + (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)] + [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 - + 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] + 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)) - ] + [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_types.mli b/ocamldoc/odoc_types.mli index a26e76cdc..c84f37bbb 100644 --- a/ocamldoc/odoc_types.mli +++ b/ocamldoc/odoc_types.mli @@ -101,9 +101,9 @@ type merge_option = | 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. *) + and all parameters are kept. *) | Merge_raised_exception (** Information on each raised_exception is concatenated, - and all raised exceptions are kept. *) + 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). *) diff --git a/ocamldoc/odoc_value.ml b/ocamldoc/odoc_value.ml index 1bbb80df6..b5b8eb0d4 100644 --- a/ocamldoc/odoc_value.ml +++ b/ocamldoc/odoc_value.ml @@ -30,14 +30,14 @@ type t_value = { (** Representation of a class attribute. *) type t_attribute = { att_value : t_value ; (** an attribute has almost all the same information - as a value *) + 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 *) + as a value *) met_private : bool ; met_virtual : bool ; } @@ -51,11 +51,11 @@ let value_parameter_text_by_name v name = None -> None | Some i -> try - let t = List.assoc name i.Odoc_types.i_params in - Some t + let t = List.assoc name i.Odoc_types.i_params in + Some t with - Not_found -> - None + Not_found -> + None (** Update the parameters text of a t_value, according to the val_info field. *) let update_value_parameters_text v = @@ -70,9 +70,9 @@ let parameter_list_from_arrows typ = let rec iter t = match t.Types.desc with Types.Tarrow (l, t1, t2, _) -> - (l, t1) :: (iter t2) + (l, t1) :: (iter t2) | _ -> - [] + [] in iter typ @@ -86,33 +86,33 @@ let dummy_parameter_list typ = match s with "" -> s | _ -> - match s.[0] with - '?' -> String.sub s 1 ((String.length s) - 1) - | _ -> 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 } + if label = "" then + Odoc_parameter.Tuple + (List.map (fun t2 -> iter ("", t2)) l, t) + else + (* if there is a label, then we don't want to decompose the tuple *) + Odoc_parameter.Simple_name + { Odoc_parameter.sn_name = normal_name label ; + Odoc_parameter.sn_type = t ; + Odoc_parameter.sn_text = None } | Types.Tlink t2 | Types.Tsubst t2 -> - (iter (label, t2)) + (iter (label, t2)) | _ -> - Odoc_parameter.Simple_name - { Odoc_parameter.sn_name = normal_name label ; - Odoc_parameter.sn_type = t ; - Odoc_parameter.sn_text = None } + 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 @@ -121,12 +121,12 @@ let is_function v = let rec f t = match t.Types.desc with Types.Tarrow _ -> - true + true | Types.Tlink t -> - f t - | _ -> - false + f t + | _ -> + false in f v.val_type - + diff --git a/ocamldoc/runocamldoc b/ocamldoc/runocamldoc index b5fcfb51e..a71d705cc 100644 --- a/ocamldoc/runocamldoc +++ b/ocamldoc/runocamldoc @@ -5,8 +5,8 @@ case "$1" in true) shift exec ../boot/ocamlrun -I ../otherlibs/unix -I ../otherlibs/str \ ./ocamldoc "$@" - ;; + ;; *) shift - exec ./ocamldoc "$@" - ;; + exec ./ocamldoc "$@" + ;; esac diff --git a/otherlibs/graph/color.c b/otherlibs/graph/color.c index 463453b61..f47fa5814 100644 --- a/otherlibs/graph/color.c +++ b/otherlibs/graph/color.c @@ -82,9 +82,9 @@ void gr_init_direct_rgb_to_pixel(void) #ifdef QUICKCOLORDEBUG fprintf(stderr, "visual %lx %lx %lx\n", - red_mask, - green_mask, - blue_mask); + red_mask, + green_mask, + blue_mask); #endif get_shifts(red_mask, &red_l, &red_r); @@ -112,8 +112,8 @@ void gr_init_direct_rgb_to_pixel(void) } if( red_l < 0 || red_r < 0 || - green_l < 0 || green_r < 0 || - blue_l < 0 || blue_r < 0 ){ + green_l < 0 || green_r < 0 || + blue_l < 0 || blue_r < 0 ){ #ifdef QUICKCOLORDEBUG fprintf(stderr, "Damn, boost failed\n"); #endif diff --git a/otherlibs/labltk/README b/otherlibs/labltk/README index cb9b8b8ab..6f63b4a4d 100644 --- a/otherlibs/labltk/README +++ b/otherlibs/labltk/README @@ -104,13 +104,13 @@ your .ml files. versions, using optional labeled arguments. For example, Bell.ring had/have the following types: - before: Bell.ring : unit -> unit - now: Bell.ring : ?displayof:Camltk.widget -> unit -> unit + before: Bell.ring : unit -> unit + now: Bell.ring : ?displayof:Camltk.widget -> unit -> unit If you use these functions as callbacks directly like Command Bell.ring, you need eta-expansions to flush these new optional arguments: - Button.create w [Command Bell.ring] + Button.create w [Command Bell.ring] => Button.create w [Command (fun () -> Bell.ring ())] diff --git a/otherlibs/labltk/Widgets.src b/otherlibs/labltk/Widgets.src index 1fb164ea4..291cbd87a 100644 --- a/otherlibs/labltk/Widgets.src +++ b/otherlibs/labltk/Widgets.src @@ -220,7 +220,7 @@ widget button { option WrapLength % Widget specific options option Command ["-command"; function ()] - option Default ["-default"; State] + option Default ["-default"; State] option Height ["-height"; Units/int] option State ["-state"; State] option Width ["-width"; Units/int] @@ -693,44 +693,44 @@ module Focus { type font external % builtin/builtin_font.ml type weight { - Weight_Normal(Normal) ["normal"] - Weight_Bold(Bold) ["bold"] + Weight_Normal(Normal) ["normal"] + Weight_Bold(Bold) ["bold"] } type slant { - Slant_Roman(Roman) ["roman"] - Slant_Italic(Italic) ["italic"] + Slant_Roman(Roman) ["roman"] + Slant_Italic(Italic) ["italic"] } type fontMetrics { Ascent ["-ascent"] - Descent ["-descent"] + Descent ["-descent"] Linespace ["-linespace"] Fixed ["-fixed"] } subtype options(font) { - Font_Family ["-family"; string] - Font_Size ["-size"; int] - Font_Weight ["-weight"; weight] - Font_Slant ["-slant"; slant] - Font_Underline ["-underline"; bool] - Font_Overstrike ["-overstrike"; bool] + Font_Family ["-family"; string] + Font_Size ["-size"; int] + Font_Weight ["-weight"; weight] + Font_Slant ["-slant"; slant] + Font_Underline ["-underline"; bool] + Font_Overstrike ["-overstrike"; bool] % later, JP only -% Charset ["-charset"; string] +% Charset ["-charset"; string] %% Beware of the order of Compound ! Put it as the first option -% Compound ["-compound"; [font list]] -% Copy ["-copy"; string] -} +% Compound ["-compound"; [font list]] +% Copy ["-copy"; string] +} module Font { function (string) actual ["font"; "actual"; font; - ?displayof:["-displayof"; widget]; - options(font) list] + ?displayof:["-displayof"; widget]; + options(font) list] ##ifdef CAMLTK function (string) actual_displayof ["font"; "actual"; font; - "-displayof"; widget; - options(font) list] + "-displayof"; widget; + options(font) list] ##endif function () configure ["font"; "configure"; font; options(font) list] function (font) create ["font"; "create"; ?name:[string]; options(font) list] @@ -739,24 +739,24 @@ module Font { ##endif function () delete ["font"; "delete"; font] function (string list) families ["font"; "families"; - ?displayof:["-displayof"; widget]] + ?displayof:["-displayof"; widget]] ##ifdef CAMLTK function (string list) families_displayof ["font"; "families"; - "-displayof"; widget] + "-displayof"; widget] ##endif function (int) measure ["font"; "measure"; font; string; - ?displayof:["-displayof"; widget]] + ?displayof:["-displayof"; widget]] ##ifdef CAMLTK function (int) measure_displayof ["font"; "measure"; font; "-displayof"; widget; string ] ##endif function (int) metrics ["font"; "metrics"; font; - ?displayof:["-displayof"; widget]; - fontMetrics ] + ?displayof:["-displayof"; widget]; + fontMetrics ] ##ifdef CAMLTK function (int) metrics_displayof ["font"; "metrics"; font; - "-displayof"; widget; - fontMetrics ] + "-displayof"; widget; + fontMetrics ] ##endif function (string list) names ["font"; "names"] % JP @@ -797,7 +797,7 @@ widget frame { option Clas ["-class"; string] ##endif option Colormap ["-colormap"; Colormap] - option Container ["-container"; bool] + option Container ["-container"; bool] option Height option Visual ["-visual"; Visual] option Width @@ -834,7 +834,7 @@ module Grab { subtype option(rowcolumnconfigure) { Minsize ["-minsize"; Units/int] Weight ["-weight"; float] - Pad ["-pad"; Units/int] + Pad ["-pad"; Units/int] } subtype option(grid) { @@ -1092,7 +1092,7 @@ subtype option(menucheck) { ##ifdef CAMLTK ImageBitmap SelectImageBitmap ImagePhoto SelectImagePhoto ##else - Image SelectImage + Image SelectImage ##endif IndicatorOn Label OffValue OnValue SelectColor @@ -1115,7 +1115,7 @@ type menuType { Menu_Menubar ["menubar"] Menu_Tearoff ["tearoff"] Menu_Normal ["normal"] -} +} % Separators and tearoffs don't have options @@ -1691,7 +1691,7 @@ module Selection { %%%%% send(n) type SendOption { SendDisplayOf ["-displayof"; widget] % DisplayOf is used for icccm ! - SendAsync ["-async"] + SendAsync ["-async"] } unsafe function () send ["send"; SendOption list; "--"; app: string; command: string list] @@ -1829,7 +1829,7 @@ widget text { % require result parser function (string list) dump [widget(text); "dump"; text_dump list; start: TextIndex; stop: TextIndex] function (string list) dump_char [widget(text); "dump"; text_dump list; index: TextIndex] - + function (string) get [widget(text); "get"; start: TextIndex; stop: TextIndex] function (string) get_char [widget(text); "get"; index: TextIndex] function () image_configure @@ -1951,7 +1951,7 @@ unsafe function () scaling_set ["tk"; "scaling"; ?displayof:["-displayof"; widge subtype option(chooseColor){ InitialColor ["-initialcolor"; Color] Parent ["-parent"; widget] - Title ["-title"; string] + Title ["-title"; string] } function (Color) chooseColor ["tk_chooseColor"; option(chooseColor) list] @@ -2252,8 +2252,8 @@ module Encoding { function (string) convertfrom ["encoding"; "convertfrom"; ?encoding: [string]; string] function (string) convertto ["encoding"; "convertto"; - ?encoding: [string]; string] + ?encoding: [string]; string] function (string list) names ["encoding"; "names"] function () system_set ["encoding"; "system"; string] function (string) system_get ["encoding"; "system"] -} +} diff --git a/otherlibs/labltk/builtin/builtin_GetCursor.ml b/otherlibs/labltk/builtin/builtin_GetCursor.ml index 4e7d61872..6c7034b16 100644 --- a/otherlibs/labltk/builtin/builtin_GetCursor.ml +++ b/otherlibs/labltk/builtin/builtin_GetCursor.ml @@ -5,11 +5,11 @@ (* type *) type color = | NamedColor of string - | Black (* tk keyword: black *) - | White (* tk keyword: white *) - | Red (* tk keyword: red *) - | Green (* tk keyword: green *) - | Blue (* tk keyword: blue *) + | Black (* tk keyword: black *) + | White (* tk keyword: white *) + | Red (* tk keyword: red *) + | Green (* tk keyword: green *) + | Blue (* tk keyword: blue *) | Yellow (* tk keyword: yellow *) ;; (* /type *) diff --git a/otherlibs/labltk/builtin/builtin_ScrollValue.ml b/otherlibs/labltk/builtin/builtin_ScrollValue.ml index 20869c6da..75a509e69 100644 --- a/otherlibs/labltk/builtin/builtin_ScrollValue.ml +++ b/otherlibs/labltk/builtin/builtin_ScrollValue.ml @@ -2,9 +2,9 @@ (* type *) type scrollValue = - | ScrollPage of int (* tk option: scroll <int> page *) - | ScrollUnit of int (* tk option: scroll <int> unit *) - | MoveTo of float (* tk option: moveto <float> *) + | ScrollPage of int (* tk option: scroll <int> page *) + | ScrollUnit of int (* tk option: scroll <int> unit *) + | MoveTo of float (* tk option: moveto <float> *) ;; (* /type *) diff --git a/otherlibs/labltk/builtin/builtin_bind.ml b/otherlibs/labltk/builtin/builtin_bind.ml index 4f6d59598..35d0d3c1a 100644 --- a/otherlibs/labltk/builtin/builtin_bind.ml +++ b/otherlibs/labltk/builtin/builtin_bind.ml @@ -129,32 +129,32 @@ type eventField = (* /type *) let filleventInfo ev v = function - | Ev_Above -> ev.ev_Above <- int_of_string v - | Ev_ButtonNumber -> ev.ev_ButtonNumber <- int_of_string v - | Ev_Count -> ev.ev_Count <- int_of_string v - | Ev_Detail -> ev.ev_Detail <- v - | Ev_Focus -> ev.ev_Focus <- v = "1" - | Ev_Height -> ev.ev_Height <- int_of_string v - | Ev_KeyCode -> ev.ev_KeyCode <- int_of_string v - | Ev_Mode -> ev.ev_Mode <- v + | Ev_Above -> ev.ev_Above <- int_of_string v + | Ev_ButtonNumber -> ev.ev_ButtonNumber <- int_of_string v + | Ev_Count -> ev.ev_Count <- int_of_string v + | Ev_Detail -> ev.ev_Detail <- v + | Ev_Focus -> ev.ev_Focus <- v = "1" + | Ev_Height -> ev.ev_Height <- int_of_string v + | Ev_KeyCode -> ev.ev_KeyCode <- int_of_string v + | Ev_Mode -> ev.ev_Mode <- v | Ev_OverrideRedirect -> ev.ev_OverrideRedirect <- v = "1" - | Ev_Place -> ev.ev_Place <- v - | Ev_State -> ev.ev_State <- v - | Ev_Time -> ev.ev_Time <- int_of_string v - | Ev_Width -> ev.ev_Width <- int_of_string v - | Ev_MouseX -> ev.ev_MouseX <- int_of_string v - | Ev_MouseY -> ev.ev_MouseY <- int_of_string v - | Ev_Char -> ev.ev_Char <- v - | Ev_BorderWidth -> ev.ev_BorderWidth <- int_of_string v - | Ev_SendEvent -> ev.ev_SendEvent <- v = "1" - | Ev_KeySymString -> ev.ev_KeySymString <- v - | Ev_KeySymInt -> ev.ev_KeySymInt <- int_of_string v - | Ev_RootWindow -> ev.ev_RootWindow <- int_of_string v - | Ev_SubWindow -> ev.ev_SubWindow <- int_of_string v - | Ev_Type -> ev.ev_Type <- int_of_string v - | Ev_Widget -> ev.ev_Widget <- cTKtoCAMLwidget v - | Ev_RootX -> ev.ev_RootX <- int_of_string v - | Ev_RootY -> ev.ev_RootY <- int_of_string v + | Ev_Place -> ev.ev_Place <- v + | Ev_State -> ev.ev_State <- v + | Ev_Time -> ev.ev_Time <- int_of_string v + | Ev_Width -> ev.ev_Width <- int_of_string v + | Ev_MouseX -> ev.ev_MouseX <- int_of_string v + | Ev_MouseY -> ev.ev_MouseY <- int_of_string v + | Ev_Char -> ev.ev_Char <- v + | Ev_BorderWidth -> ev.ev_BorderWidth <- int_of_string v + | Ev_SendEvent -> ev.ev_SendEvent <- v = "1" + | Ev_KeySymString -> ev.ev_KeySymString <- v + | Ev_KeySymInt -> ev.ev_KeySymInt <- int_of_string v + | Ev_RootWindow -> ev.ev_RootWindow <- int_of_string v + | Ev_SubWindow -> ev.ev_SubWindow <- int_of_string v + | Ev_Type -> ev.ev_Type <- int_of_string v + | Ev_Widget -> ev.ev_Widget <- cTKtoCAMLwidget v + | Ev_RootX -> ev.ev_RootX <- int_of_string v + | Ev_RootY -> ev.ev_RootY <- int_of_string v ;; let wrapeventInfo f what = @@ -189,7 +189,7 @@ let wrapeventInfo f what = let l = ref args in List.iter (function field -> match !l with - [] -> () + [] -> () | v::rest -> filleventInfo ev v field; l:=rest) what; f ev diff --git a/otherlibs/labltk/builtin/builtin_bindtags.ml b/otherlibs/labltk/builtin/builtin_bindtags.ml index e94c9668e..4529fcdfe 100644 --- a/otherlibs/labltk/builtin/builtin_bindtags.ml +++ b/otherlibs/labltk/builtin/builtin_bindtags.ml @@ -2,8 +2,8 @@ (* type *) type bindings = - | TagBindings of string (* tk option: <string> *) - | WidgetBindings of widget (* tk option: <widget> *) + | TagBindings of string (* tk option: <string> *) + | WidgetBindings of widget (* tk option: <widget> *) ;; (* /type *) diff --git a/otherlibs/labltk/builtin/builtin_index.ml b/otherlibs/labltk/builtin/builtin_index.ml index 3735fc040..a42af5539 100644 --- a/otherlibs/labltk/builtin/builtin_index.ml +++ b/otherlibs/labltk/builtin/builtin_index.ml @@ -11,23 +11,23 @@ (* type *) type index = - | Number of int (* no keyword *) + | Number of int (* no keyword *) | ActiveElement (* tk keyword: active *) - | End (* tk keyword: end *) - | Last (* tk keyword: last *) - | NoIndex (* tk keyword: none *) - | Insert (* tk keyword: insert *) - | SelFirst (* tk keyword: sel.first *) - | SelLast (* tk keyword: sel.last *) - | At of int (* tk keyword: @n *) + | End (* tk keyword: end *) + | Last (* tk keyword: last *) + | NoIndex (* tk keyword: none *) + | Insert (* tk keyword: insert *) + | SelFirst (* tk keyword: sel.first *) + | SelLast (* tk keyword: sel.last *) + | At of int (* tk keyword: @n *) | AtXY of int * int (* tk keyword: @x,y *) - | AnchorPoint (* tk keyword: anchor *) + | AnchorPoint (* tk keyword: anchor *) | Pattern of string (* no keyword *) | LineChar of int * int (* tk keyword: l.c *) | Mark of string (* no keyword *) | TagFirst of string (* tk keyword: tag.first *) | TagLast of string (* tk keyword: tag.last *) - | Embedded of widget (* no keyword *) + | Embedded of widget (* no keyword *) ;; (* /type *) diff --git a/otherlibs/labltk/builtin/builtin_text.ml b/otherlibs/labltk/builtin/builtin_text.ml index d4333dcb5..b2d69589b 100644 --- a/otherlibs/labltk/builtin/builtin_text.ml +++ b/otherlibs/labltk/builtin/builtin_text.ml @@ -12,12 +12,12 @@ type textTag = string;; (* type *) type textModifier = - | CharOffset of int (* tk keyword: +/- Xchars *) - | LineOffset of int (* tk keyword: +/- Xlines *) - | LineStart (* tk keyword: linestart *) - | LineEnd (* tk keyword: lineend *) - | WordStart (* tk keyword: wordstart *) - | WordEnd (* tk keyword: wordend *) + | CharOffset of int (* tk keyword: +/- Xchars *) + | LineOffset of int (* tk keyword: +/- Xlines *) + | LineStart (* tk keyword: linestart *) + | LineEnd (* tk keyword: lineend *) + | WordStart (* tk keyword: wordstart *) + | WordEnd (* tk keyword: wordend *) ;; (* /type *) diff --git a/otherlibs/labltk/builtin/builtinf_bind.ml b/otherlibs/labltk/builtin/builtinf_bind.ml index e6b793d6d..d78541e1d 100644 --- a/otherlibs/labltk/builtin/builtinf_bind.ml +++ b/otherlibs/labltk/builtin/builtinf_bind.ml @@ -16,24 +16,24 @@ FUNCTION *) let bind widget eventsequence action = tkCommand [| TkToken "bind"; - TkToken (Widget.name widget); - cCAMLtoTKeventSequence eventsequence; - begin match action with - BindRemove -> TkToken "" - | BindSet (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) - in - TkToken ("camlcb " ^ cbId ^ (writeeventField what)) - | BindSetBreakable (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) - in - TkToken ("camlcb " ^ cbId ^ (writeeventField what) ^ - " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0") - | BindExtend (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) - in - TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) - end |] + TkToken (Widget.name widget); + cCAMLtoTKeventSequence eventsequence; + begin match action with + BindRemove -> TkToken "" + | BindSet (what, f) -> + let cbId = register_callback widget (wrapeventInfo f what) + in + TkToken ("camlcb " ^ cbId ^ (writeeventField what)) + | BindSetBreakable (what, f) -> + let cbId = register_callback widget (wrapeventInfo f what) + in + TkToken ("camlcb " ^ cbId ^ (writeeventField what) ^ + " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0") + | BindExtend (what, f) -> + let cbId = register_callback widget (wrapeventInfo f what) + in + TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) + end |] ;; (* FUNCTION @@ -45,24 +45,24 @@ let bind widget eventsequence action = let bind_class clas eventsequence action = tkCommand [| TkToken "bind"; - TkToken clas; - cCAMLtoTKeventSequence eventsequence; - begin match action with - BindRemove -> TkToken "" - | BindSet (what, f) -> - let cbId = register_callback Widget.dummy - (wrapeventInfo f what) in - TkToken ("camlcb " ^ cbId ^ (writeeventField what)) - | BindSetBreakable (what, f) -> - let cbId = register_callback Widget.dummy - (wrapeventInfo f what) in - TkToken ("camlcb " ^ cbId ^ (writeeventField what)^ - " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0" ) - | BindExtend (what, f) -> - let cbId = register_callback Widget.dummy - (wrapeventInfo f what) in - TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) - end |] + TkToken clas; + cCAMLtoTKeventSequence eventsequence; + begin match action with + BindRemove -> TkToken "" + | BindSet (what, f) -> + let cbId = register_callback Widget.dummy + (wrapeventInfo f what) in + TkToken ("camlcb " ^ cbId ^ (writeeventField what)) + | BindSetBreakable (what, f) -> + let cbId = register_callback Widget.dummy + (wrapeventInfo f what) in + TkToken ("camlcb " ^ cbId ^ (writeeventField what)^ + " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0" ) + | BindExtend (what, f) -> + let cbId = register_callback Widget.dummy + (wrapeventInfo f what) in + TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) + end |] ;; (* FUNCTION diff --git a/otherlibs/labltk/builtin/builtini_GetCursor.ml b/otherlibs/labltk/builtin/builtini_GetCursor.ml index b3e1af075..8f4e3971f 100644 --- a/otherlibs/labltk/builtin/builtini_GetCursor.ml +++ b/otherlibs/labltk/builtin/builtini_GetCursor.ml @@ -1,12 +1,12 @@ ##ifdef CAMLTK let cCAMLtoTKcolor = function - NamedColor x -> TkToken x - | Black -> TkToken "black" - | White -> TkToken "white" - | Red -> TkToken "red" - | Green -> TkToken "green" - | Blue -> TkToken "blue" + NamedColor x -> TkToken x + | Black -> TkToken "black" + | White -> TkToken "white" + | Red -> TkToken "red" + | Green -> TkToken "green" + | Blue -> TkToken "blue" | Yellow -> TkToken "yellow" ;; diff --git a/otherlibs/labltk/builtin/builtini_bind.ml b/otherlibs/labltk/builtin/builtini_bind.ml index 101e26186..13109cb0a 100644 --- a/otherlibs/labltk/builtin/builtini_bind.ml +++ b/otherlibs/labltk/builtin/builtini_bind.ml @@ -121,11 +121,11 @@ let cCAMLtoTKevent (ev : event) = | `Unmap -> "Unmap" | `Visibility -> "Visibility" | `Virtual s -> - if !modified then raise IllegalVirtualEvent else "<"^s^">" + if !modified then raise IllegalVirtualEvent else "<"^s^">" | `Modified(ml, ev) -> - modified := true; - String.concat ~sep:"" (List.map ~f:cCAMLtoTKmodifier ml) - ^ convert ev + modified := true; + String.concat ~sep:"" (List.map ~f:cCAMLtoTKmodifier ml) + ^ convert ev in "<" ^ convert ev ^ ">" ;; diff --git a/otherlibs/labltk/builtin/builtini_index.ml b/otherlibs/labltk/builtin/builtini_index.ml index 9e43c4f76..7718cab95 100644 --- a/otherlibs/labltk/builtin/builtini_index.ml +++ b/otherlibs/labltk/builtin/builtini_index.ml @@ -2,23 +2,23 @@ (* sp to avoid being picked up by doc scripts *) type index_constrs = - CNumber + CNumber | CActiveElement - | CEnd - | CLast - | CNoIndex - | CInsert - | CSelFirst - | CSelLast + | CEnd + | CLast + | CNoIndex + | CInsert + | CSelFirst + | CSelLast | CAt | CAtXY | CAnchorPoint - | CPattern - | CLineChar - | CMark - | CTagFirst - | CTagLast - | CEmbedded + | CPattern + | CLineChar + | CMark + | CTagFirst + | CTagLast + | CEmbedded ;; let index_any_table = @@ -54,18 +54,18 @@ let cCAMLtoTKindex table = function | SelLast -> chk_sub "SelLast" table CSelLast; TkToken "sel.last" | At n -> chk_sub "At" table CAt; TkToken ("@"^string_of_int n) | AtXY (x,y) -> chk_sub "AtXY" table CAtXY; - TkToken ("@"^string_of_int x^","^string_of_int y) + TkToken ("@"^string_of_int x^","^string_of_int y) | AnchorPoint -> chk_sub "AnchorPoint" table CAnchorPoint; TkToken "anchor" | Pattern s -> chk_sub "Pattern" table CPattern; TkToken s | LineChar (l,c) -> chk_sub "LineChar" table CLineChar; - TkToken (string_of_int l^"."^string_of_int c) + TkToken (string_of_int l^"."^string_of_int c) | Mark s -> chk_sub "Mark" table CMark; TkToken s | TagFirst t -> chk_sub "TagFirst" table CTagFirst; - TkToken (t^".first") + TkToken (t^".first") | TagLast t -> chk_sub "TagLast" table CTagLast; - TkToken (t^".last") + TkToken (t^".last") | Embedded w -> chk_sub "Embedded" table CEmbedded; - cCAMLtoTKwidget widget_any_table w + cCAMLtoTKwidget widget_any_table w ;; let char_index c s = @@ -83,7 +83,7 @@ let cTKtoCAMLindex s = try let p = char_index '.' s in LineChar(int_of_string (String.sub s 0 p), - int_of_string (String.sub s (p+1) (String.length s - p - 1))) + int_of_string (String.sub s (p+1) (String.length s - p - 1))) with Not_found -> try Number (int_of_string s) diff --git a/otherlibs/labltk/builtin/builtini_palette.ml b/otherlibs/labltk/builtin/builtini_palette.ml index b9529c3fa..e1fe37dbe 100644 --- a/otherlibs/labltk/builtin/builtini_palette.ml +++ b/otherlibs/labltk/builtin/builtini_palette.ml @@ -3,8 +3,8 @@ let cCAMLtoTKpaletteType = function GrayShades (foo) -> TkToken (string_of_int foo) | RGBShades (r,v,b) -> TkToken (string_of_int r^"/"^ - string_of_int v^"/"^ - string_of_int b) + string_of_int v^"/"^ + string_of_int b) ;; ##else diff --git a/otherlibs/labltk/builtin/canvas_bind.ml b/otherlibs/labltk/builtin/canvas_bind.ml index c153525de..1b46fae01 100644 --- a/otherlibs/labltk/builtin/canvas_bind.ml +++ b/otherlibs/labltk/builtin/canvas_bind.ml @@ -9,16 +9,16 @@ let bind widget tag eventsequence action = begin match action with | BindRemove -> TkToken "" | BindSet (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) in - TkToken ("camlcb " ^ cbId ^ (writeeventField what)) + let cbId = register_callback widget (wrapeventInfo f what) in + TkToken ("camlcb " ^ cbId ^ (writeeventField what)) | BindSetBreakable (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) in - TkToken ("camlcb " ^ cbId ^ (writeeventField what)^ - " ; if { $BreakBindingsSequence == 1 } then { break ;} ; \ - set BreakBindingsSequence 0") + let cbId = register_callback widget (wrapeventInfo f what) in + TkToken ("camlcb " ^ cbId ^ (writeeventField what)^ + " ; if { $BreakBindingsSequence == 1 } then { break ;} ; \ + set BreakBindingsSequence 0") | BindExtend (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) in - TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) + let cbId = register_callback widget (wrapeventInfo f what) in + TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) end |] ;; diff --git a/otherlibs/labltk/builtin/dialog.ml b/otherlibs/labltk/builtin/dialog.ml index 260ec78e1..e6654d8c4 100644 --- a/otherlibs/labltk/builtin/dialog.ml +++ b/otherlibs/labltk/builtin/dialog.ml @@ -3,12 +3,12 @@ let create ?name parent title mesg bitmap def buttons = let w = Widget.new_atom "toplevel" ~parent ?name in let res = tkEval [|TkToken"tk_dialog"; - cCAMLtoTKwidget widget_any_table w; - TkToken title; - TkToken mesg; - cCAMLtoTKbitmap bitmap; - TkToken (string_of_int def); - TkTokenList (List.map (function x -> TkToken x) buttons)|] + cCAMLtoTKwidget widget_any_table w; + TkToken title; + TkToken mesg; + cCAMLtoTKbitmap bitmap; + TkToken (string_of_int def); + TkTokenList (List.map (function x -> TkToken x) buttons)|] in int_of_string res ;; @@ -16,12 +16,12 @@ let create ?name parent title mesg bitmap def buttons = let create_named parent name title mesg bitmap def buttons = let w = Widget.new_atom "toplevel" ~parent ~name in let res = tkEval [|TkToken"tk_dialog"; - cCAMLtoTKwidget widget_any_table w; - TkToken title; - TkToken mesg; - cCAMLtoTKbitmap bitmap; - TkToken (string_of_int def); - TkTokenList (List.map (function x -> TkToken x) buttons)|] + cCAMLtoTKwidget widget_any_table w; + TkToken title; + TkToken mesg; + cCAMLtoTKbitmap bitmap; + TkToken (string_of_int def); + TkTokenList (List.map (function x -> TkToken x) buttons)|] in int_of_string res ;; diff --git a/otherlibs/labltk/builtin/optionmenu.ml b/otherlibs/labltk/builtin/optionmenu.ml index 8b738d9d3..c0a760aba 100644 --- a/otherlibs/labltk/builtin/optionmenu.ml +++ b/otherlibs/labltk/builtin/optionmenu.ml @@ -10,7 +10,7 @@ let create ?name parent variable values = tkEval [|TkToken "tk_optionMenu"; TkToken (Widget.name w); cCAMLtoTKtextVariable variable; - TkTokenList (List.map (function x -> TkToken x) values)|] in + TkTokenList (List.map (function x -> TkToken x) values)|] in if res <> Widget.name mw then raise (TkError "internal error in Optionmenu.create") else @@ -24,7 +24,7 @@ let create_named parent name variable values = tkEval [|TkToken "tk_optionMenu"; TkToken (Widget.name w); cCAMLtoTKtextVariable variable; - TkTokenList (List.map (function x -> TkToken x) values)|] in + TkTokenList (List.map (function x -> TkToken x) values)|] in if res <> Widget.name mw then raise (TkError "internal error in Optionmenu.create") else diff --git a/otherlibs/labltk/builtin/selection_handle_set.ml b/otherlibs/labltk/builtin/selection_handle_set.ml index 946f25424..fe19489a5 100644 --- a/otherlibs/labltk/builtin/selection_handle_set.ml +++ b/otherlibs/labltk/builtin/selection_handle_set.ml @@ -7,8 +7,8 @@ let handle_set opts w cmd = TkToken"handle"; TkTokenList (List.map - (function x -> cCAMLtoTKicccm w icccm_selection_handle_table x) - opts); + (function x -> cCAMLtoTKicccm w icccm_selection_handle_table x) + opts); cCAMLtoTKwidget widget_any_table w; let id = register_callback w (function args -> let (a1,args) = int_of_string (List.hd args), List.tl args in @@ -29,11 +29,11 @@ selection_handle_icccm_optionals (fun opts w -> TkTokenList opts; cCAMLtoTKwidget w; let id = register_callback w ~callback: - begin fun args -> - let pos = int_of_string (List.hd args) in - let len = int_of_string (List.nth args 1) in - tkreturn (command ~pos ~len) - end + begin fun args -> + let pos = int_of_string (List.hd args) in + let len = int_of_string (List.nth args 1) in + tkreturn (command ~pos ~len) + end in TkToken ("camlcb " ^ id) |]) ;; diff --git a/otherlibs/labltk/builtin/selection_own_set.ml b/otherlibs/labltk/builtin/selection_own_set.ml index 011abef84..253cdb5b6 100644 --- a/otherlibs/labltk/builtin/selection_own_set.ml +++ b/otherlibs/labltk/builtin/selection_own_set.ml @@ -7,8 +7,8 @@ let own_set v1 v2 = TkToken"own"; TkTokenList (List.map - (function x -> cCAMLtoTKicccm v2 icccm_selection_ownset_table x) - v1); + (function x -> cCAMLtoTKicccm v2 icccm_selection_ownset_table x) + v1); cCAMLtoTKwidget widget_any_table v2 |] ;; diff --git a/otherlibs/labltk/builtin/text_tag_bind.ml b/otherlibs/labltk/builtin/text_tag_bind.ml index e07fbaf20..7a1bab3a5 100644 --- a/otherlibs/labltk/builtin/text_tag_bind.ml +++ b/otherlibs/labltk/builtin/text_tag_bind.ml @@ -11,16 +11,16 @@ let tag_bind widget tag eventsequence action = begin match action with | BindRemove -> TkToken "" | BindSet (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) in - TkToken ("camlcb " ^ cbId ^ (writeeventField what)) + let cbId = register_callback widget (wrapeventInfo f what) in + TkToken ("camlcb " ^ cbId ^ (writeeventField what)) | BindSetBreakable (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) in - TkToken ("camlcb " ^ cbId ^ (writeeventField what) ^ - " ; if { $BreakBindingsSequence == 1 } then { break ;} ; \ - set BreakBindingsSequence 0") + let cbId = register_callback widget (wrapeventInfo f what) in + TkToken ("camlcb " ^ cbId ^ (writeeventField what) ^ + " ; if { $BreakBindingsSequence == 1 } then { break ;} ; \ + set BreakBindingsSequence 0") | BindExtend (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) in - TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) + let cbId = register_callback widget (wrapeventInfo f what) in + TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) end |] ;; @@ -38,16 +38,16 @@ let tag_bind ~tag ~events ?(extend = false) ?(breakable = false) begin match action with | None -> TkToken "" | Some f -> - let cbId = - register_callback widget ~callback: (wrapeventInfo f fields) in - let cb = if extend then "+camlcb " else "camlcb " in - let cb = cb ^ cbId ^ writeeventField fields in - let cb = - if breakable then - cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}" - ^ " ; set BreakBindingsSequence 0" - else cb in - TkToken cb + let cbId = + register_callback widget ~callback: (wrapeventInfo f fields) in + let cb = if extend then "+camlcb " else "camlcb " in + let cb = cb ^ cbId ^ writeeventField fields in + let cb = + if breakable then + cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}" + ^ " ; set BreakBindingsSequence 0" + else cb in + TkToken cb end |] ;; diff --git a/otherlibs/labltk/compiler/compile.ml b/otherlibs/labltk/compiler/compile.ml index 78adbcee6..42754dfd3 100644 --- a/otherlibs/labltk/compiler/compile.ml +++ b/otherlibs/labltk/compiler/compile.ml @@ -87,7 +87,7 @@ let rec types_of_template = function | ListArg l -> List.flatten (List.map ~f:types_of_template l) | OptionalArgs (l, tl, _) -> begin - match List.flatten (List.map ~f:types_of_template tl) with + match List.flatten (List.map ~f:types_of_template tl) with ["", t] -> ["?" ^ l, t] | [_, _] -> raise (Failure "0 label required") | _ -> raise (Failure "0 or more than 1 args in for optionals") @@ -149,7 +149,7 @@ let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) = | UserDefined "widget" -> if !Flags.camltk then "widget" else begin - if any then "any widget" else + if any then "any widget" else let c = String.make 1 (Char.chr(Char.code 'a' + !counter)) in incr counter; "'" ^ c ^ " widget" @@ -158,20 +158,20 @@ let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) = if !Flags.camltk then s else begin (* a bit dirty hack for ImageBitmap and ImagePhoto *) - try + try let typdef = Hashtbl.find types_table s in if typdef.variant then if return then try "[>" ^ String.concat ~sep:"|" - (List.map typdef.constructors ~f: + (List.map typdef.constructors ~f: begin fun c -> "`" ^ c.var_name ^ (match types_of_template c.template with - [] -> "" + [] -> "" | l -> " of " ^ ppMLtype (Product (List.map l - ~f:(labeloff ~at:"ppMLtype UserDefined")))) + ~f:(labeloff ~at:"ppMLtype UserDefined")))) end) ^ "]" with Not_found -> prerr_endline ("ppMLtype " ^ s ^ " ?"); s @@ -179,7 +179,7 @@ let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) = "[< " ^ s ^ "]" else s else s - with Not_found -> s + with Not_found -> s end | Subtype (s, s') -> if !Flags.camltk then "(* " ^ s' ^ " *) " ^ s else s' ^ "_" ^ s @@ -274,10 +274,10 @@ let write_constructor_set ~w ~sep = function | x::l -> w ("C" ^ x.ml_name); List.iter l ~f: (function x -> - w sep; - w ("C" ^ x.ml_name)) + w sep; + w ("C" ^ x.ml_name)) -(* CamlTk: Definition of a type *) +(* CamlTk: Definition of a type *) let camltk_write_type ~intf:w ~impl:w' name ~def:typdef = (* Put markers for extraction *) w "(* type *)\n"; @@ -335,9 +335,9 @@ let rec converterTKtoCAML ~arg = function ["(Obj.magic (cTKtoCAMLwidget "; arg; ") :"; s'; "widget)"] | Subtype (s, s') -> if !Flags.camltk then - "cTKtoCAML" ^ s ^ " " ^ arg + "cTKtoCAML" ^ s ^ " " ^ arg else - "cTKtoCAML" ^ s' ^ "_" ^ s ^ " " ^ arg + "cTKtoCAML" ^ s' ^ "_" ^ s ^ " " ^ arg | List ty -> begin match type_parser_arity ty with OneToken -> @@ -400,8 +400,8 @@ let rec wrapper_code ~name ty = String.concat ~sep:"" readarg ^ name ^ " " ^ String.concat ~sep:" " (List.map2 ~f:(fun v (l, _) -> - if !Flags.camltk then v - else labelstring l ^ v) vnames tyl) + if !Flags.camltk then v + else labelstring l ^ v) vnames tyl) (* all other types are read in one operation *) | List ty -> @@ -562,11 +562,11 @@ let rec converterCAMLtoTK ~context_widget argname ty = let name = "cCAMLtoTK" ^ s ^ " " in let args = argname in let args = - if !Flags.camltk then begin - if is_subtyped s then (* unconstraint subtype *) - s ^ "_any_table " ^ args - else args - end else args + if !Flags.camltk then begin + if is_subtyped s then (* unconstraint subtype *) + s ^ "_any_table " ^ args + else args + end else args in let args = if requires_widget_context s then @@ -575,30 +575,30 @@ let rec converterCAMLtoTK ~context_widget argname ty = name ^ args | Subtype ("widget", s') -> if !Flags.camltk then - let name = "cCAMLtoTKwidget " in - let args = "widget_"^s'^"_table "^argname in - let args = - if requires_widget_context "widget" then - context_widget^" "^args + let name = "cCAMLtoTKwidget " in + let args = "widget_"^s'^"_table "^argname in + let args = + if requires_widget_context "widget" then + context_widget^" "^args else args in - name^args + name^args else begin - let name = "cCAMLtoTKwidget " in - let args = "(" ^ argname ^ " : " ^ s' ^ " widget)" in - name ^ args + let name = "cCAMLtoTKwidget " in + let args = "(" ^ argname ^ " : " ^ s' ^ " widget)" in + name ^ args end | Subtype (s, s') -> let name = - if !Flags.camltk then "cCAMLtoTK" ^ s ^ " " - else "cCAMLtoTK" ^ s' ^ "_" ^ s ^ " " + if !Flags.camltk then "cCAMLtoTK" ^ s ^ " " + else "cCAMLtoTK" ^ s' ^ "_" ^ s ^ " " in let args = - if !Flags.camltk then begin - s^"_"^s'^"_table "^argname - end else begin + if !Flags.camltk then begin + s^"_"^s'^"_table "^argname + end else begin if safetype then "(" ^ argname ^ " : [< " ^ s' ^ "_" ^ s ^ "])" else argname - end + end in let args = if requires_widget_context s then context_widget ^ " " ^ args @@ -648,20 +648,20 @@ let code_of_template ~context_widget ?func:(funtemplate=false) template = StringArg s -> "TkToken \"" ^ s ^ "\"" | TypeArg (_, List (Subtype (sup, sub) as ty)) when not !Flags.camltk -> begin try - let typdef = Hashtbl.find types_table sup in - let classdef = List.assoc sub typdef.subtypes in - let lbl = gettklabel (List.hd classdef) in - catch_opts := (sub ^ "_" ^ sup, lbl); - newvar := newvar2; - "TkTokenList opts" + let typdef = Hashtbl.find types_table sup in + let classdef = List.assoc sub typdef.subtypes in + let lbl = gettklabel (List.hd classdef) in + catch_opts := (sub ^ "_" ^ sup, lbl); + newvar := newvar2; + "TkTokenList opts" with Not_found -> - raise (Failure (Printf.sprintf "type %s(%s) not found" sup sub)); + raise (Failure (Printf.sprintf "type %s(%s) not found" sup sub)); end | TypeArg (l, List ty) -> (if !Flags.camltk then - "TkTokenList (List.map (function x -> " + "TkTokenList (List.map (function x -> " else - "TkTokenList (List.map ~f:(function x -> ") + "TkTokenList (List.map ~f:(function x -> ") ^ converterCAMLtoTK ~context_widget "x" ty ^ ") " ^ !newvar l ^ ")" | TypeArg (l, Function tyarg) -> @@ -801,9 +801,9 @@ let rec write_result_parsing ~w = function w "(splitlist res)" | List ty -> if !Flags.camltk then - w (" List.map " ^ converterTKtoCAML ~arg:"(splitlist res)" ty) + w (" List.map " ^ converterTKtoCAML ~arg:"(splitlist res)" ty) else - w (" List.map ~f: " ^ converterTKtoCAML ~arg:"(splitlist res)" ty) + w (" List.map ~f: " ^ converterTKtoCAML ~arg:"(splitlist res)" ty) | Product tyl -> raise (Failure "Product -> record was done. ???") | Record tyl -> (* of course all the labels are "" *) let rnames = varnames ~prefix:"r" (List.length tyl) in @@ -937,11 +937,11 @@ let camltk_write_function ~w def = | l -> let has_normal_argument = ref false in List.iter (fun (l,x) -> - w " "; - if l <> "" then - if l.[0] = '?' then w (l ^ ":") else has_normal_argument := true - else has_normal_argument := true; - w x) l; + w " "; + if l <> "" then + if l.[0] = '?' then w (l ^ ":") else has_normal_argument := true + else has_normal_argument := true; + w x) l; if not !has_normal_argument then w " ()"; w " =\n" end; @@ -1015,16 +1015,16 @@ let write_external ~w def = begin try let realname = find_in_path !search_path (fname ^ ".ml") in let ic = open_in_bin realname in - try - let code_list = Ppparse.parse_channel ic in - close_in ic; - List.iter (Ppexec.exec (fun _ -> ()) w) - (if !Flags.camltk then - Code.Define "CAMLTK" :: code_list else code_list ); - with - | Ppparse.Error s -> - close_in ic; - raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s)) + try + let code_list = Ppparse.parse_channel ic in + close_in ic; + List.iter (Ppexec.exec (fun _ -> ()) w) + (if !Flags.camltk then + Code.Define "CAMLTK" :: code_list else code_list ); + with + | Ppparse.Error s -> + close_in ic; + raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s)) with | Not_found -> raise (Compiler_Error ("can't find external file: " ^ fname)) diff --git a/otherlibs/labltk/compiler/intf.ml b/otherlibs/labltk/compiler/intf.ml index e155ec5ee..58955b962 100644 --- a/otherlibs/labltk/compiler/intf.ml +++ b/otherlibs/labltk/compiler/intf.ml @@ -145,11 +145,11 @@ let camltk_write_function_type ~w def = List.iter tys ~f: begin fun (l, t) -> if l <> "" then - if l.[0] = '?' then w (l^":") - else begin - have_normal_arg := true; - w (" (* " ^ l ^ ":*)") - end + if l.[0] = '?' then w (l^":") + else begin + have_normal_arg := true; + w (" (* " ^ l ^ ":*)") + end else have_normal_arg := true; w (ppMLtype t ~counter); w " -> " @@ -171,19 +171,19 @@ let write_external_type ~w def = begin try let realname = find_in_path !search_path (fname ^ ".mli") in let ic = open_in_bin realname in - try - let code_list = Ppparse.parse_channel ic in - close_in ic; + try + let code_list = Ppparse.parse_channel ic in + close_in ic; if not def.safe then w "(* unsafe *)\n"; - List.iter (Ppexec.exec (fun _ -> ()) w) - (if !Flags.camltk then - Code.Define "CAMLTK" :: code_list else code_list ); + List.iter (Ppexec.exec (fun _ -> ()) w) + (if !Flags.camltk then + Code.Define "CAMLTK" :: code_list else code_list ); if def.safe then w "\n\n" else w "\n(* /unsafe *)\n\n" - with - | Ppparse.Error s -> - close_in ic; - raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s)) + with + | Ppparse.Error s -> + close_in ic; + raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s)) with | Not_found -> raise (Compiler_Error ("can't find external file: " ^ fname)) diff --git a/otherlibs/labltk/compiler/lexer.mll b/otherlibs/labltk/compiler/lexer.mll index 5c04dc674..c65c9a604 100644 --- a/otherlibs/labltk/compiler/lexer.mll +++ b/otherlibs/labltk/compiler/lexer.mll @@ -162,8 +162,8 @@ and comment = parse and linenum = parse | ['0'-'9']+ { let next_line = int_of_string (Lexing.lexeme lexbuf) in - current_line := next_line - 1 - } + current_line := next_line - 1 + } | _ { raise (Lexical_error("illegal ##line directive: no line number"))} and line = parse diff --git a/otherlibs/labltk/compiler/maincompile.ml b/otherlibs/labltk/compiler/maincompile.ml index 19b770554..585deecaa 100644 --- a/otherlibs/labltk/compiler/maincompile.ml +++ b/otherlibs/labltk/compiler/maincompile.ml @@ -54,16 +54,16 @@ let parse_file filename = close_in ic; let buf = Buffer.create 50000 in List.iter (Ppexec.exec - (fun l -> Buffer.add_string buf - (Printf.sprintf "##line %d\n" l)) - (Buffer.add_string buf)) - (if !Flags.camltk then Code.Define "CAMLTK" :: code_list - else code_list); + (fun l -> Buffer.add_string buf + (Printf.sprintf "##line %d\n" l)) + (Buffer.add_string buf)) + (if !Flags.camltk then Code.Define "CAMLTK" :: code_list + else code_list); Lexing.from_string (Buffer.contents buf) with | Ppparse.Error s -> - close_in ic; - raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s)) + close_in ic; + raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s)) in try while true do @@ -145,22 +145,22 @@ let option_hack oc = let hack = { parser_arity = OneToken; constructors = begin - let constrs = + let constrs = List.map typdef.constructors ~f: begin fun c -> { component = Constructor; - ml_name = (if !Flags.camltk then "C" ^ c.ml_name - else c.ml_name); - var_name = c.var_name; (* as variants *) - template = - begin match c.template with - ListArg (x :: _) -> x - | _ -> fatal_error "bogus hack" - end; - result = UserDefined "options_constrs"; - safe = true } + ml_name = (if !Flags.camltk then "C" ^ c.ml_name + else c.ml_name); + var_name = c.var_name; (* as variants *) + template = + begin match c.template with + ListArg (x :: _) -> x + | _ -> fatal_error "bogus hack" + end; + result = UserDefined "options_constrs"; + safe = true } end in - if !Flags.camltk then constrs else uniq_clauses constrs (* JPF ?? *) + if !Flags.camltk then constrs else uniq_clauses constrs (* JPF ?? *) end; subtypes = []; requires_widget_context = false; @@ -238,13 +238,13 @@ let compile () = end; List.iter ~f:(fun s -> output_string oc s; output_string oc' s) begin - if !Flags.camltk then - [ "open CTk\n"; + if !Flags.camltk then + [ "open CTk\n"; "open Tkintf\n"; "open Widget\n"; "open Textvariable\n\n" ] - else - [ "open StdLabels\n"; + else + [ "open StdLabels\n"; "open Tk\n"; "open Tkintf\n"; "open Widget\n"; @@ -254,14 +254,14 @@ let compile () = begin match wdef.module_type with Widget -> if !Flags.camltk then begin - camltk_write_create ~w:(output_string oc) wname; - camltk_write_named_create ~w:(output_string oc) wname; - camltk_write_create_p ~w:(output_string oc') wname; - camltk_write_named_create_p ~w:(output_string oc') wname; - end else begin - labltk_write_create ~w:(output_string oc) wname; + camltk_write_create ~w:(output_string oc) wname; + camltk_write_named_create ~w:(output_string oc) wname; + camltk_write_create_p ~w:(output_string oc') wname; + camltk_write_named_create_p ~w:(output_string oc') wname; + end else begin + labltk_write_create ~w:(output_string oc) wname; labltk_write_create_p ~w:(output_string oc') wname - end + end | Family -> () end; List.iter ~f:(write_function ~w:(output_string oc)) @@ -295,8 +295,8 @@ let compile () = Hashtbl.iter (fun name _ -> let cname = realname name in output_string oc (Printf.sprintf "module %s = %s;;\n" - (String.capitalize name) - (String.capitalize cname))) module_table; + (String.capitalize name) + (String.capitalize cname))) module_table; close_out oc end else begin let oc = open_out_bin (destfile "labltk.ml") in @@ -316,20 +316,20 @@ module Timer = Timer;; Hashtbl.iter (fun name _ -> let cname = realname name in output_string oc (Printf.sprintf "module %s = %s;;\n" - (String.capitalize name) - (String.capitalize name))) module_table; + (String.capitalize name) + (String.capitalize name))) module_table; (* widget typer *) output_string oc "\n(** Widget typers *)\n\nopen Widget\n\n"; Hashtbl.iter (fun name def -> match def.module_type with - | Widget -> - output_string oc (Printf.sprintf - "let %s (w : any widget) =\n" name); - output_string oc (Printf.sprintf - " Rawwidget.check_class w widget_%s_table;\n" name); - output_string oc (Printf.sprintf - " (Obj.magic w : %s widget);;\n\n" name); - | _ -> () ) module_table; + | Widget -> + output_string oc (Printf.sprintf + "let %s (w : any widget) =\n" name); + output_string oc (Printf.sprintf + " Rawwidget.check_class w widget_%s_table;\n" name); + output_string oc (Printf.sprintf + " (Obj.magic w : %s widget);;\n\n" name); + | _ -> () ) module_table; close_out oc end; @@ -370,9 +370,9 @@ module Timer = Timer;; output_string oc "camltk.cmo : cTk.cmo "; Hashtbl.iter (fun name _ -> - let name = realname name in - output_string oc name; - output_string oc ".cmo ") module_table; + let name = realname name in + output_string oc name; + output_string oc ".cmo ") module_table; output_string oc "\n" end; diff --git a/otherlibs/labltk/compiler/ppexec.ml b/otherlibs/labltk/compiler/ppexec.ml index 6754a6521..994688203 100644 --- a/otherlibs/labltk/compiler/ppexec.ml +++ b/otherlibs/labltk/compiler/ppexec.ml @@ -25,8 +25,8 @@ let rec nop = function | Ifdef (_, _, c1, c2o) -> List.iter nop c1; begin match c2o with - | Some c2 -> List.iter nop c2 - | None -> () + | Some c2 -> List.iter nop c2 + | None -> () end | _ -> () ;; @@ -34,27 +34,27 @@ let rec nop = function let rec exec lp f = function | Line line -> if !debug then - prerr_endline (Printf.sprintf "%03d: %s" !linenum - (String.sub line 0 ((String.length line) - 1))); + prerr_endline (Printf.sprintf "%03d: %s" !linenum + (String.sub line 0 ((String.length line) - 1))); f line; incr linenum | Ifdef (sw, k, c1, c2o) -> if List.mem k !defined = sw then begin - List.iter (exec lp f) c1; - begin match c2o with - | Some c2 -> List.iter nop c2 - | None -> () - end; - lp !linenum + List.iter (exec lp f) c1; + begin match c2o with + | Some c2 -> List.iter nop c2 + | None -> () + end; + lp !linenum end else begin - List.iter nop c1; - match c2o with - | Some c2 -> - lp !linenum; - List.iter (exec lp f) c2 - | None -> () + List.iter nop c1; + match c2o with + | Some c2 -> + lp !linenum; + List.iter (exec lp f) c2 + | None -> () end | Define k -> defined := k :: !defined | Undef k -> defined := List.fold_right (fun k' s -> - if k = k' then s else k' :: s) [] !defined + if k = k' then s else k' :: s) [] !defined ;; diff --git a/otherlibs/labltk/compiler/pplex.mll b/otherlibs/labltk/compiler/pplex.mll index d68ee4db6..bb30c233a 100644 --- a/otherlibs/labltk/compiler/pplex.mll +++ b/otherlibs/labltk/compiler/pplex.mll @@ -34,7 +34,7 @@ rule token = parse let str = Lexing.lexeme lexbuf in let line = !linenum in if String.length str <> 0 && str.[String.length str - 1] = '\n' then - begin + begin incr linenum end; OTHER (str) diff --git a/otherlibs/labltk/compiler/ppparse.ml b/otherlibs/labltk/compiler/ppparse.ml index 91287d34a..3d1ee2af4 100644 --- a/otherlibs/labltk/compiler/ppparse.ml +++ b/otherlibs/labltk/compiler/ppparse.ml @@ -26,11 +26,11 @@ let parse_channel ic = and loc_end = Lexing.lexeme_end lexbuf in raise (Error (Printf.sprintf "parse error at char %d, %d: %s" - loc_start loc_end s)) + loc_start loc_end s)) | Parsing.Parse_error -> let loc_start = Lexing.lexeme_start lexbuf and loc_end = Lexing.lexeme_end lexbuf in raise (Error (Printf.sprintf "parse error at char %d, %d" - loc_start loc_end)) + loc_start loc_end)) ;; diff --git a/otherlibs/labltk/examples_camltk/addition.ml b/otherlibs/labltk/examples_camltk/addition.ml index 8f9365bdb..d4b333dcd 100644 --- a/otherlibs/labltk/examples_camltk/addition.ml +++ b/otherlibs/labltk/examples_camltk/addition.ml @@ -36,7 +36,7 @@ let main () = r := int_of_string (Entry.get w); refresh () with - Failure "int_of_string" -> + Failure "int_of_string" -> Label.configure result_display [Text "error"] in (* Set the callbacks *) diff --git a/otherlibs/labltk/examples_camltk/fileinput.ml b/otherlibs/labltk/examples_camltk/fileinput.ml index 35e7e8358..c6190bdd4 100644 --- a/otherlibs/labltk/examples_camltk/fileinput.ml +++ b/otherlibs/labltk/examples_camltk/fileinput.ml @@ -23,7 +23,7 @@ let entry0_w = Entry.create top_w [] ;; let button0_w = Button.create top_w [Text "Quit"; Command (fun _ -> exit 0)] ;; Fileevent.add_fileinput fd_in (fun _ -> let n = Unix.read fd_in buffer 0 (String.length buffer) in - let txt = String.sub buffer 0 n in + let txt = String.sub buffer 0 n in Text.insert text0_w (TextIndex (End, [])) txt []) ;; let send _ = let txt = Entry.get entry0_w ^ "\n" in diff --git a/otherlibs/labltk/examples_camltk/taddition.ml b/otherlibs/labltk/examples_camltk/taddition.ml index b4745d6c0..990812d73 100644 --- a/otherlibs/labltk/examples_camltk/taddition.ml +++ b/otherlibs/labltk/examples_camltk/taddition.ml @@ -36,7 +36,7 @@ let main () = r := int_of_string (Entry.get w); refresh () with - Failure "int_of_string" -> + Failure "int_of_string" -> Label.configure result_display [Text "error"] in (* Set the callbacks *) diff --git a/otherlibs/labltk/examples_camltk/tetris.ml b/otherlibs/labltk/examples_camltk/tetris.ml index f4239a804..79d9e3f1a 100644 --- a/otherlibs/labltk/examples_camltk/tetris.ml +++ b/otherlibs/labltk/examples_camltk/tetris.ml @@ -22,7 +22,7 @@ open Camltk exception Done type cell = {mutable color : int; - tag : tagOrId * tagOrId * tagOrId} + tag : tagOrId * tagOrId * tagOrId} type falling_block = { mutable pattern: int array list; @@ -220,8 +220,8 @@ let init fw = let f = Frame.create fw [BorderWidth (Pixels 2)] in let c = Canvas.create f [Width (Pixels (block_size * 10)); Height (Pixels (block_size * 20)); - BorderWidth (Pixels cell_border); - Relief Sunken; + BorderWidth (Pixels cell_border); + Relief Sunken; Background Black] and r = Frame.create f [] and r' = Frame.create f [] in @@ -229,9 +229,9 @@ let init fw = let nl = Label.create r [Text "Next"; Font "variable"] in let nc = Canvas.create r [Width (Pixels (block_size * 4)); Height (Pixels (block_size * 4)); - BorderWidth (Pixels cell_border); - Relief Sunken; - Background Black] in + BorderWidth (Pixels cell_border); + Relief Sunken; + Background Black] in let scl = Label.create r [Text "Score"; Font "variable"] in let sc = Label.create r [TextVariable scorev; Font "variable"] in let lnl = Label.create r [Text "Lines"; Font "variable"] in @@ -249,21 +249,21 @@ let init fw = let cells_src = Array.create 20 (Array.create 10 ()) in let cells = Array.map (Array.map (fun () -> {tag= - (let t1, t2, t3 = - Canvas.create_rectangle c - (Pixels (-block_size - 8)) (Pixels (-block_size - 8)) + (let t1, t2, t3 = + Canvas.create_rectangle c + (Pixels (-block_size - 8)) (Pixels (-block_size - 8)) (Pixels (-9)) (Pixels (-9)) [], - Canvas.create_rectangle c - (Pixels (-block_size - 10)) (Pixels (-block_size - 10)) + Canvas.create_rectangle c + (Pixels (-block_size - 10)) (Pixels (-block_size - 10)) (Pixels (-11)) (Pixels (-11)) [], - Canvas.create_rectangle c - (Pixels (-block_size - 12)) (Pixels (-block_size - 12)) + Canvas.create_rectangle c + (Pixels (-block_size - 12)) (Pixels (-block_size - 12)) (Pixels (-13)) (Pixels (-13)) [] in - Canvas.raise_top c t1; - Canvas.raise_top c t2; - Canvas.lower_bot c t3; - t1,t2,t3); + Canvas.raise_top c t1; + Canvas.raise_top c t2; + Canvas.lower_bot c t3; + t1,t2,t3); color= 0})) cells_src in let nexts_src = Array.create 4 (Array.create 4 ()) in @@ -271,20 +271,20 @@ let init fw = Array.map (Array.map (fun () -> {tag= (let t1, t2, t3 = - Canvas.create_rectangle nc - (Pixels (-block_size - 8)) (Pixels (-block_size - 8)) + Canvas.create_rectangle nc + (Pixels (-block_size - 8)) (Pixels (-block_size - 8)) (Pixels (-9)) (Pixels (-9)) [], - Canvas.create_rectangle nc - (Pixels (-block_size - 10)) (Pixels (-block_size - 10)) + Canvas.create_rectangle nc + (Pixels (-block_size - 10)) (Pixels (-block_size - 10)) (Pixels (-11)) (Pixels (-11)) [], - Canvas.create_rectangle nc - (Pixels (-block_size - 12)) (Pixels (-block_size - 12)) + Canvas.create_rectangle nc + (Pixels (-block_size - 12)) (Pixels (-block_size - 12)) (Pixels (-13)) (Pixels (-13)) [] in - Canvas.raise_top nc t1; - Canvas.raise_top nc t2; - Canvas.lower_bot nc t3; - t1, t2, t3); + Canvas.raise_top nc t1; + Canvas.raise_top nc t2; + Canvas.lower_bot nc t3; + t1, t2, t3); color= 0})) nexts_src in let game_over () = () in @@ -313,27 +313,27 @@ let cell_set (c, cf) x y col = end else begin - Canvas.configure_rectangle c t2 + Canvas.configure_rectangle c t2 [FillColor (Array.get colors (col - 1)); - Outline (Array.get colors (col - 1))]; - Canvas.configure_rectangle c t1 + Outline (Array.get colors (col - 1))]; + Canvas.configure_rectangle c t1 [FillColor Black; - Outline Black]; - Canvas.configure_rectangle c t3 + Outline Black]; + Canvas.configure_rectangle c t3 [FillColor (NamedColor "light gray"); - Outline (NamedColor "light gray")]; - if cur.color = 0 && col <> 0 then - begin - Canvas.move c t1 - (Pixels (block_size * (x+1)+10+ cell_border*2)) + Outline (NamedColor "light gray")]; + if cur.color = 0 && col <> 0 then + begin + Canvas.move c t1 + (Pixels (block_size * (x+1)+10+ cell_border*2)) (Pixels (block_size * (y+1)+10+ cell_border*2)); - Canvas.move c t2 + Canvas.move c t2 (Pixels (block_size * (x+1)+10+ cell_border*2)) (Pixels (block_size * (y+1)+10+ cell_border*2)); - Canvas.move c t3 + Canvas.move c t3 (Pixels (block_size * (x+1)+10+ cell_border*2)) (Pixels (block_size * (y+1)+10+ cell_border*2)) - end + end end; cur.color <- col @@ -343,14 +343,14 @@ let draw_block field col d x y = let xd = Array.get d iy in for ix = 0 to 3 do if xd land !base <> 0 then - begin - try cell_set field (ix + x) (iy + y) col with _ -> () - end + begin + try cell_set field (ix + x) (iy + y) col with _ -> () + end else - begin - (* cell_set field (ix + x) (iy + y) 0 *) () - end; - base := !base lsl 1 + begin + (* cell_set field (ix + x) (iy + y) 0 *) () + end; + base := !base lsl 1 done done diff --git a/otherlibs/labltk/examples_labltk/lang.ml b/otherlibs/labltk/examples_labltk/lang.ml index 53d2d5e51..e92377ecc 100644 --- a/otherlibs/labltk/examples_labltk/lang.ml +++ b/otherlibs/labltk/examples_labltk/lang.ml @@ -41,7 +41,7 @@ let _ = ["Amharic(አማáˆáŠ›)", "ሠላáˆ"; "Arabic", "�����������"; "Croatian (Hrvatski)", "Bog (Bok), Dobar dan"; - "Czech (Äesky)", "Dobrý den"; + "Czech (Äesky)", "Dobrý den"; "Danish (Dansk)", "Hej, Goddag"; "English", "Hello"; "Esperanto", "Saluton"; diff --git a/otherlibs/labltk/frx/frx_after.ml b/otherlibs/labltk/frx/frx_after.ml index 955f1cb48..7fe6a4f2a 100644 --- a/otherlibs/labltk/frx/frx_after.ml +++ b/otherlibs/labltk/frx/frx_after.ml @@ -21,4 +21,4 @@ let idle f = f() in Hashtbl.add callback_naming_table id wrapped; tkCommand [| TkToken "after"; TkToken "idle"; - TkToken ("camlcb "^ string_of_cbid id) |] + TkToken ("camlcb "^ string_of_cbid id) |] diff --git a/otherlibs/labltk/frx/frx_ctext.ml b/otherlibs/labltk/frx/frx_ctext.ml index 01ede5457..0d4fd836e 100644 --- a/otherlibs/labltk/frx/frx_ctext.ml +++ b/otherlibs/labltk/frx/frx_ctext.ml @@ -32,11 +32,11 @@ let create top opts navigation = (* Make the text widget an embedded canvas object *) ignore (Canvas.create_window c (Pixels 0) (Pixels 0) - [Anchor NW; Window t; Tags [Tag "main"]]); + [Anchor NW; Window t; Tags [Tag "main"]]); Canvas.focus c (Tag "main"); (* Canvas.configure c [Width (Pixels (Winfo.reqwidth t)); - Height(Pixels (Winfo.reqheight t))]; + Height(Pixels (Winfo.reqheight t))]; *) Canvas.configure c [YScrollCommand (Scrollbar.set yscroll)]; (* The horizontal scrollbar is directly attached to the @@ -46,12 +46,12 @@ let create top opts navigation = Scrollbar.configure yscroll [ScrollCommand (Canvas.yview c)]; let scroll, check = Frx_fit.vert t in Text.configure t [ - XScrollCommand (Scrollbar.set xscroll); + XScrollCommand (Scrollbar.set xscroll); YScrollCommand (fun first last -> - scroll first last; - let x,y,w,h = Canvas.bbox c [Tag "main"] in - Canvas.configure c - [ScrollRegion (Pixels x, Pixels y, Pixels w, Pixels h)]) + scroll first last; + let x,y,w,h = Canvas.bbox c [Tag "main"] in + Canvas.configure c + [ScrollRegion (Pixels x, Pixels y, Pixels w, Pixels h)]) ]; bind c [[],Configure] (BindSet ([Ev_Width], (fun ei -> diff --git a/otherlibs/labltk/frx/frx_dialog.ml b/otherlibs/labltk/frx/frx_dialog.ml index 440278586..0b65b419e 100644 --- a/otherlibs/labltk/frx/frx_dialog.ml +++ b/otherlibs/labltk/frx/frx_dialog.ml @@ -41,7 +41,7 @@ let f w name title mesg bitmap def buttons = Label.create_named ftop "msg" [Justify Justify_Left; Text mesg; WrapLength (Pixels 600)] in pack [l][Side Side_Right; Expand true; Fill Fill_Both; - PadX (Millimeters 3.0); PadY (Millimeters 3.0)]; + PadX (Millimeters 3.0); PadY (Millimeters 3.0)]; begin match bitmap with Predefined "" -> () | _ -> @@ -55,21 +55,21 @@ let f w name title mesg bitmap def buttons = let buttons = mapi (fun i bname -> let b = Button.create t - [Text bname; - Command (fun () -> Textvariable.set waitv (string_of_int i))] in + [Text bname; + Command (fun () -> Textvariable.set waitv (string_of_int i))] in if i = def then begin let f = Frame.create_named fbot "default" - [Relief Sunken; BorderWidth (Pixels 1)] in + [Relief Sunken; BorderWidth (Pixels 1)] in raise_window_above b f; - pack [f][Side Side_Left; Expand true; - PadX (Millimeters 3.0); PadY (Millimeters 2.0)]; + pack [f][Side Side_Left; Expand true; + PadX (Millimeters 3.0); PadY (Millimeters 2.0)]; pack [b][In f; PadX (Millimeters 2.0); PadY (Millimeters 2.0)]; - bind t [[], KeyPressDetail "Return"] - (BindSet ([], (fun _ -> Button.flash b; Button.invoke b))) - end + bind t [[], KeyPressDetail "Return"] + (BindSet ([], (fun _ -> Button.flash b; Button.invoke b))) + end else pack [b][In fbot; Side Side_Left; Expand true; - PadX (Millimeters 3.0); PadY (Millimeters 2.0)]; + PadX (Millimeters 3.0); PadY (Millimeters 2.0)]; b ) 0 buttons in @@ -106,9 +106,9 @@ let f w name title mesg bitmap def buttons = [] -> () | x::l -> try - match !grabstatus with - Some(GrabGlobal) -> Grab.set_global x - | _ -> Grab.set x + match !grabstatus with + Some(GrabGlobal) -> Grab.set_global x + | _ -> Grab.set x with TkError _ -> () end; diff --git a/otherlibs/labltk/frx/frx_fillbox.ml b/otherlibs/labltk/frx/frx_fillbox.ml index f0a45f0b7..d9e474188 100644 --- a/otherlibs/labltk/frx/frx_fillbox.ml +++ b/otherlibs/labltk/frx/frx_fillbox.ml @@ -25,41 +25,41 @@ and kocolor = NamedColor "#dc5c5c" let new_vertical parent w h = let c = Canvas.create_named parent "fillbox" [Width (Pixels w); Height (Pixels h); BorderWidth (Pixels 1); - Relief Sunken] + Relief Sunken] in let i = Canvas.create_rectangle c (Pixels 0) (Pixels 0) (Pixels w) (Pixels 0) [FillColor okcolor; Outline okcolor] in c, (function - 0 -> Canvas.configure_rectangle c i [FillColor okcolor; - Outline okcolor]; - Canvas.coords_set c i [Pixels 0; Pixels 0; - Pixels w; Pixels 0] + 0 -> Canvas.configure_rectangle c i [FillColor okcolor; + Outline okcolor]; + Canvas.coords_set c i [Pixels 0; Pixels 0; + Pixels w; Pixels 0] | -1 -> Canvas.configure_rectangle c i [FillColor kocolor; - Outline kocolor] - | n -> - let percent = if n > 100 then 100 else n in - let hf = percent*h/100 in - Canvas.coords_set c i [Pixels 0; Pixels 0; - Pixels w; Pixels hf]) + Outline kocolor] + | n -> + let percent = if n > 100 then 100 else n in + let hf = percent*h/100 in + Canvas.coords_set c i [Pixels 0; Pixels 0; + Pixels w; Pixels hf]) let new_horizontal parent w h = let c = Canvas.create_named parent "fillbox" [Width (Pixels w); Height (Pixels h); BorderWidth (Pixels 1); - Relief Sunken] + Relief Sunken] in let i = Canvas.create_rectangle c (Pixels 0) (Pixels 0) (Pixels 0) (Pixels h) [FillColor okcolor; Outline okcolor] in c, (function - 0 -> Canvas.configure_rectangle c i [FillColor okcolor; - Outline okcolor]; - Canvas.coords_set c i [Pixels 0; Pixels 0; - Pixels 0; Pixels h] + 0 -> Canvas.configure_rectangle c i [FillColor okcolor; + Outline okcolor]; + Canvas.coords_set c i [Pixels 0; Pixels 0; + Pixels 0; Pixels h] | -1 -> Canvas.configure_rectangle c i [FillColor kocolor; - Outline kocolor] - | n -> - let percent = if n > 100 then 100 else n in - let wf = percent*w/100 in - Canvas.coords_set c i [Pixels 0; Pixels 0; - Pixels wf; Pixels h]) + Outline kocolor] + | n -> + let percent = if n > 100 then 100 else n in + let wf = percent*w/100 in + Canvas.coords_set c i [Pixels 0; Pixels 0; + Pixels wf; Pixels h]) diff --git a/otherlibs/labltk/frx/frx_fit.ml b/otherlibs/labltk/frx/frx_fit.ml index 71e5b1979..2011699ab 100644 --- a/otherlibs/labltk/frx/frx_fit.ml +++ b/otherlibs/labltk/frx/frx_fit.ml @@ -35,47 +35,47 @@ let vert wid = and check1 first last = let curheight = int_of_string (cget wid CHeight) in if !debug then begin - Printf.eprintf "%s C %d %f %f\n" - (Widget.name wid) curheight first last; - flush stderr - end; + Printf.eprintf "%s C %d %f %f\n" + (Widget.name wid) curheight first last; + flush stderr + end; if first = 0.0 && last = 1.0 then () (* Don't attempt anything if widget is not visible *) else if not (Winfo.viewable wid) then begin if !debug then - (Printf.eprintf "%s C notviewable\n" (Widget.name wid); + (Printf.eprintf "%s C notviewable\n" (Widget.name wid); flush stderr); - (* Try again later *) - bind wid [[], Expose] (BindSet ([], fun _ -> - bind wid [[], Expose] BindRemove; - check())) + (* Try again later *) + bind wid [[], Expose] (BindSet ([], fun _ -> + bind wid [[], Expose] BindRemove; + check())) end else begin - let delta = - if last = 0.0 then 1 - else if last = !last_last then + let delta = + if last = 0.0 then 1 + else if last = !last_last then (* it didn't change since our last resize ! *) - 1 + 1 else begin - last_last := last; + last_last := last; (* never to more than double *) - let visible = max 0.5 (last -. first) in - max 1 (truncate (float curheight *. (1. -. visible))) + let visible = max 0.5 (last -. first) in + max 1 (truncate (float curheight *. (1. -. visible))) end in newsize := max (curheight + delta) !newsize; - if !debug then - (Printf.eprintf "%s newsize: %d\n" (Widget.name wid) !newsize; + if !debug then + (Printf.eprintf "%s newsize: %d\n" (Widget.name wid) !newsize; flush stderr); - if !pending_resize then () - else begin - pending_resize := true; - Timer.set 300 (fun () -> Frx_after.idle resize) - end + if !pending_resize then () + else begin + pending_resize := true; + Timer.set 300 (fun () -> Frx_after.idle resize) + end end and scroll first last = if !debug then - (Printf.eprintf "%s V %f %f\n" (Widget.name wid) first last; + (Printf.eprintf "%s V %f %f\n" (Widget.name wid) first last; flush stderr); if first = 0.0 && last = 1.0 then () else check1 first last diff --git a/otherlibs/labltk/frx/frx_font.ml b/otherlibs/labltk/frx/frx_font.ml index 2f93c4dbd..023470261 100644 --- a/otherlibs/labltk/frx/frx_font.ml +++ b/otherlibs/labltk/frx/frx_font.ml @@ -41,11 +41,11 @@ let find fmly wght slant pxlsz = else let c = get_canvas() in try - let tag = Canvas.create_text c (Pixels 0) (Pixels 0) + let tag = Canvas.create_text c (Pixels 0) (Pixels 0) [Text "foo"; Font fontspec] in - Canvas.delete c [tag]; - available_fonts := StringSet.add fontspec !available_fonts; - fontspec + Canvas.delete c [tag]; + available_fonts := StringSet.add fontspec !available_fonts; + fontspec with _ -> raise (Invalid_argument fontspec) diff --git a/otherlibs/labltk/frx/frx_listbox.ml b/otherlibs/labltk/frx/frx_listbox.ml index 332dca5d5..8bb2941c0 100644 --- a/otherlibs/labltk/frx/frx_listbox.ml +++ b/otherlibs/labltk/frx/frx_listbox.ml @@ -22,7 +22,7 @@ let version = "$Id$" *) let scroll_link sb lb = Listbox.configure lb - [YScrollCommand (Scrollbar.set sb)]; + [YScrollCommand (Scrollbar.set sb)]; Scrollbar.configure sb [ScrollCommand (Listbox.yview lb)] @@ -36,9 +36,9 @@ let scroll_link sb lb = *) let add_completion lb action = - let prefx = ref "" (* current match prefix *) + let prefx = ref "" (* current match prefix *) and maxi = Listbox.size lb - 1 (* maximum index (doesn't matter actually) *) - and current = ref 0 (* current position *) + and current = ref 0 (* current position *) and lastevent = ref 0 in let rec move_forward () = @@ -71,11 +71,11 @@ let add_completion lb action = bind lb [[], KeyPress] (BindSet([Ev_Char; Ev_Time], - (function ev -> - (* consider only keys producing characters. The callback is called - * even if you press Shift. + (function ev -> + (* consider only keys producing characters. The callback is called + * even if you press Shift. *) - if ev.ev_Char <> "" then complete ev.ev_Time ev.ev_Char))); + if ev.ev_Char <> "" then complete ev.ev_Time ev.ev_Char))); (* Key specific bindings override KeyPress *) bind lb [[], KeyPressDetail "Return"] (BindSet([], action)); (* Finally, we have to set focus, otherwise events dont get through *) diff --git a/otherlibs/labltk/frx/frx_mem.ml b/otherlibs/labltk/frx/frx_mem.ml index c3f041d00..4bab86862 100644 --- a/otherlibs/labltk/frx/frx_mem.ml +++ b/otherlibs/labltk/frx/frx_mem.ml @@ -67,17 +67,17 @@ let init () = let liver = (float st.live_words) /. (float st.heap_words) and freer = (float st.free_words) /. (float st.heap_words) in Place.configure flive [X (Pixels 0); Y (Pixels 0); - RelWidth liver; RelHeight 1.0]; + RelWidth liver; RelHeight 1.0]; Place.configure ffree [RelX liver; Y (Pixels 0); - RelWidth freer; RelHeight 1.0]; + RelWidth freer; RelHeight 1.0]; Place.configure fdead [RelX (liver +. freer); Y (Pixels 0); - RelWidth (1.0 -. freer -. liver); RelHeight 1.0] + RelWidth (1.0 -. freer -. liver); RelHeight 1.0] in let rec tim () = if Winfo.exists top then begin - display(); - Timer.set (!delay * 1000) tim + display(); + Timer.set (!delay * 1000) tim end in tim() diff --git a/otherlibs/labltk/frx/frx_misc.ml b/otherlibs/labltk/frx/frx_misc.ml index 38d27fda1..d2be00922 100644 --- a/otherlibs/labltk/frx/frx_misc.ml +++ b/otherlibs/labltk/frx/frx_misc.ml @@ -19,9 +19,9 @@ let autodef f = (function () -> match !v with None -> - let x = f() in - v := Some x; - x + let x = f() in + v := Some x; + x | Some x -> x) open Camltk @@ -32,38 +32,38 @@ let create_photo options = (* Check options *) List.iter (function Data s -> - begin match !hasopt with - None -> hasopt := Some (Data s) - | Some _ -> raise (Protocol.TkError "two data sources in options") - end + begin match !hasopt with + None -> hasopt := Some (Data s) + | Some _ -> raise (Protocol.TkError "two data sources in options") + end | File f -> - begin match !hasopt with - None -> hasopt := Some (File f) - | Some _ -> raise (Protocol.TkError "two data sources in options") - end + begin match !hasopt with + None -> hasopt := Some (File f) + | Some _ -> raise (Protocol.TkError "two data sources in options") + end | o -> ()) options; match !hasopt with None -> raise (Protocol.TkError "no data source in options") | Some (Data s) -> begin - let tmpfile = Filename.temp_file "img" "" in - let oc = open_out_bin tmpfile in - output_string oc s; - close_out oc; - let newopts = - List.map (function - | Data s -> File tmpfile - | o -> o) - options in - try - let i = Imagephoto.create newopts in - (try Sys.remove tmpfile with Sys_error _ -> ()); - i - with - e -> - (try Sys.remove tmpfile with Sys_error _ -> ()); - raise e + let tmpfile = Filename.temp_file "img" "" in + let oc = open_out_bin tmpfile in + output_string oc s; + close_out oc; + let newopts = + List.map (function + | Data s -> File tmpfile + | o -> o) + options in + try + let i = Imagephoto.create newopts in + (try Sys.remove tmpfile with Sys_error _ -> ()); + i + with + e -> + (try Sys.remove tmpfile with Sys_error _ -> ()); + raise e end | Some (File s) -> Imagephoto.create options | _ -> assert false diff --git a/otherlibs/labltk/frx/frx_req.ml b/otherlibs/labltk/frx/frx_req.ml index 088977d59..029f4973b 100644 --- a/otherlibs/labltk/frx/frx_req.ml +++ b/otherlibs/labltk/frx/frx_req.ml @@ -42,8 +42,8 @@ let open_simple title action notaction memory = let activate _ = let v = Entry.get e in - Grab.release t; (* because of wm *) - destroy t; (* so action can call open_simple *) + Grab.release t; (* because of wm *) + destroy t; (* so action can call open_simple *) action v in bind e [[], KeyPressDetail "Return"] (BindSet ([], activate)); @@ -51,11 +51,11 @@ let open_simple title action notaction memory = let f = Frame.create t [] in let bok = Button.create f [Text "Ok"; Command activate] in let bcancel = Button.create f - [Text "Cancel"; + [Text "Cancel"; Command (fun () -> notaction(); Grab.release t; destroy t)] in bind e [[], KeyPressDetail "Escape"] - (BindSet ([], (fun _ -> Button.invoke bcancel))); + (BindSet ([], (fun _ -> Button.invoke bcancel))); pack [bok] [Side Side_Left; Expand true]; pack [bcancel] [Side Side_Right; Expand true]; pack [tit;e] [Fill Fill_X]; @@ -78,8 +78,8 @@ let open_simple_synchronous title memory = let waiting = Textvariable.create_temporary t in let activate _ = - Grab.release t; (* because of wm *) - destroy t; (* so action can call open_simple *) + Grab.release t; (* because of wm *) + destroy t; (* so action can call open_simple *) Textvariable.set waiting "1" in bind e [[], KeyPressDetail "Return"] (BindSet ([], activate)); @@ -88,12 +88,12 @@ let open_simple_synchronous title memory = let bok = Button.create f [Text "Ok"; Command activate] in let bcancel = Button.create f - [Text "Cancel"; - Command (fun () -> - Grab.release t; destroy t; Textvariable.set waiting "0")] in + [Text "Cancel"; + Command (fun () -> + Grab.release t; destroy t; Textvariable.set waiting "0")] in bind e [[], KeyPressDetail "Escape"] - (BindSet ([], (fun _ -> Button.invoke bcancel))); + (BindSet ([], (fun _ -> Button.invoke bcancel))); pack [bok] [Side Side_Left; Expand true]; pack [bcancel] [Side Side_Right; Expand true]; pack [tit;e] [Fill Fill_X]; @@ -140,7 +140,7 @@ let open_list title elements action notaction = let f = Frame.create t [] in let bok = Button.create f [Text "Ok"; Command activate] in let bcancel = Button.create f - [Text "Cancel"; + [Text "Cancel"; Command (fun () -> notaction(); Grab.release t; destroy t)] in pack [bok; bcancel] [Side Side_Left; Fill Fill_X; Expand true]; @@ -168,14 +168,14 @@ let open_passwd title = in let fb = Frame.create t [] in let bok = Button.create fb - [Text "Ok"; Command (fun _ -> - username := Entry.get eu; - password := Entry.get ep; + [Text "Ok"; Command (fun _ -> + username := Entry.get eu; + password := Entry.get ep; Grab.release t; (* because of wm *) destroy t)] (* will return from tkwait *) and bcancel = Button.create fb [Text "Cancel"; Command (fun _ -> - cancelled := true; + cancelled := true; Grab.release t; (* because of wm *) destroy t)] (* will return from tkwait *) in @@ -185,7 +185,7 @@ let open_passwd title = bind ep [[], KeyPressDetail "Return"] (BindSetBreakable ([], (fun _ -> Button.flash bok; Button.invoke bok; - break()))); + break()))); pack [bok] [Side Side_Left; Expand true]; pack [bcancel] [Side Side_Right; Expand true]; diff --git a/otherlibs/labltk/frx/frx_rpc.ml b/otherlibs/labltk/frx/frx_rpc.ml index 23ccd2526..5f29cbce5 100644 --- a/otherlibs/labltk/frx/frx_rpc.ml +++ b/otherlibs/labltk/frx/frx_rpc.ml @@ -25,7 +25,7 @@ let register name f = Textvariable.set (Textvariable.coerce ("camltkrpc("^name^")")) (string_of_cbid id); tkCommand [| TkToken "proc"; TkToken name; TkToken "args"; - TkToken ("camlcb "^(string_of_cbid id)^" $args") |] + TkToken ("camlcb "^(string_of_cbid id)^" $args") |] (* RPC *) let invoke interp f args = diff --git a/otherlibs/labltk/frx/frx_synth.ml b/otherlibs/labltk/frx/frx_synth.ml index 5ce23b1d4..d7acf06f7 100644 --- a/otherlibs/labltk/frx/frx_synth.ml +++ b/otherlibs/labltk/frx/frx_synth.ml @@ -39,25 +39,25 @@ let get_event name = let var = "camltk_events(" ^ name ^")" in let tkvar = Textvariable.coerce var in let rec set () = - Textvariable.handle tkvar - (fun () -> - begin match Textvariable.get tkvar with - "all" -> (* Invoke all callbacks *) - Hashtbl.iter - (fun p f -> - try - f (cTKtoCAMLwidget p) - with _ -> ()) + Textvariable.handle tkvar + (fun () -> + begin match Textvariable.get tkvar with + "all" -> (* Invoke all callbacks *) + Hashtbl.iter + (fun p f -> + try + f (cTKtoCAMLwidget p) + with _ -> ()) h - | p -> (* Invoke callback for p *) - try - let w = cTKtoCAMLwidget p - and f = Hashtbl.find h p in - f w - with - _ -> () + | p -> (* Invoke callback for p *) + try + let w = cTKtoCAMLwidget p + and f = Hashtbl.find h p in + f w + with + _ -> () end; - set ()(* reactivate the callback *) + set ()(* reactivate the callback *) ) in set(); h diff --git a/otherlibs/labltk/frx/frx_text.ml b/otherlibs/labltk/frx/frx_text.ml index cd405baab..7c1f551b1 100644 --- a/otherlibs/labltk/frx/frx_text.ml +++ b/otherlibs/labltk/frx/frx_text.ml @@ -59,7 +59,7 @@ let navigation_keys tx = let tags = bindtags_get tx in match tags with (WidgetBindings t)::l when t = tx -> - bindtags tx ((WidgetBindings tx) :: (TagBindings "TEXT_RO") :: l) + bindtags tx ((WidgetBindings tx) :: (TagBindings "TEXT_RO") :: l) | _ -> () let new_scrollable_text top options navigation = @@ -86,7 +86,7 @@ let topsearch t = let f = Frame.create_named top "fpattern" [] in let m = Label.create_named f "search" [Text "Search pattern"] and e = Entry.create_named f "pattern" - [Relief Sunken; TextVariable (patternv()) ] in + [Relief Sunken; TextVariable (patternv()) ] in let hgroup = Frame.create top [] and bgroup = Frame.create top [] in let fdir = Frame.create hgroup [] @@ -95,17 +95,17 @@ let topsearch t = and exactv = Textvariable.create_temporary fdir in let forw = Radiobutton.create_named fdir "forward" - [Text "Forward"; Variable direction; Value "f"] + [Text "Forward"; Variable direction; Value "f"] and backw = Radiobutton.create_named fdir "backward" - [Text "Backward"; Variable direction; Value "b"] + [Text "Backward"; Variable direction; Value "b"] and exact = Checkbutton.create_named fmisc "exact" - [Text "Exact match"; Variable exactv] + [Text "Exact match"; Variable exactv] and case = Checkbutton.create_named fmisc "case" - [Text "Fold Case"; Variable (casev())] + [Text "Fold Case"; Variable (casev())] and searchb = Button.create_named bgroup "search" [Text "Search"] and contb = Button.create_named bgroup "continue" [Text "Continue"] and dismissb = Button.create_named bgroup "dismiss" - [Text "Dismiss"; + [Text "Dismiss"; Command (fun () -> Text.tag_delete t ["search"]; destroy top)] in Radiobutton.invoke forw; @@ -122,7 +122,7 @@ let topsearch t = let search cont = fun () -> let opts = ref [] in if Textvariable.get direction = "f" then - opts := Forwards :: !opts + opts := Forwards :: !opts else opts := Backwards :: !opts ; if Textvariable.get exactv = "1" then opts := Exact :: !opts; @@ -131,25 +131,25 @@ let topsearch t = try let forward = Textvariable.get direction = "f" in let i = Text.search t !opts (Entry.get e) - (if cont then !current_index - else if forward then textBegin - else TextIndex(End, [CharOffset (-1)])) (* does not work with end *) - (if forward then textEnd - else textBegin) in + (if cont then !current_index + else if forward then textBegin + else TextIndex(End, [CharOffset (-1)])) (* does not work with end *) + (if forward then textEnd + else textBegin) in let found = TextIndex (i, []) in - current_index := - TextIndex(i, [CharOffset (if forward then 1 else (-1))]); - Text.tag_delete t ["search"]; - Text.tag_add t "search" found (TextIndex (i, [WordEnd])); - Text.tag_configure t "search" - [Relief Raised; BorderWidth (Pixels 1); - Background Red]; - Text.see t found + current_index := + TextIndex(i, [CharOffset (if forward then 1 else (-1))]); + Text.tag_delete t ["search"]; + Text.tag_add t "search" found (TextIndex (i, [WordEnd])); + Text.tag_configure t "search" + [Relief Raised; BorderWidth (Pixels 1); + Background Red]; + Text.see t found with Invalid_argument _ -> Bell.ring() in bind e [[], KeyPressDetail "Return"] - (BindSet ([], fun _ -> search false ())); + (BindSet ([], fun _ -> search false ())); Button.configure searchb [Command (search false)]; Button.configure contb [Command (search true)]; Tkwait.visibility top; @@ -159,71 +159,71 @@ let addsearch tx = let tags = bindtags_get tx in match tags with (WidgetBindings t)::l when t = tx -> - bindtags tx ((WidgetBindings tx) :: (TagBindings "SEARCH") :: l) + bindtags tx ((WidgetBindings tx) :: (TagBindings "SEARCH") :: l) | _ -> () (* We use Mod1 instead of Meta or Alt *) let init () = List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], - (fun ei -> page_up ei.ev_Widget; break())))) - [ - [[], KeyPressDetail "BackSpace"]; - [[], KeyPressDetail "Delete"]; - [[], KeyPressDetail "Prior"]; - [[], KeyPressDetail "b"]; - [[Mod1], KeyPressDetail "v"] - ]; + tag_bind "TEXT_RO" ev + (BindSetBreakable ([Ev_Widget], + (fun ei -> page_up ei.ev_Widget; break())))) + [ + [[], KeyPressDetail "BackSpace"]; + [[], KeyPressDetail "Delete"]; + [[], KeyPressDetail "Prior"]; + [[], KeyPressDetail "b"]; + [[Mod1], KeyPressDetail "v"] + ]; List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], - (fun ei -> page_down ei.ev_Widget; break())))) - [ - [[], KeyPressDetail "space"]; - [[], KeyPressDetail "Next"]; - [[Control], KeyPressDetail "v"] - ]; + tag_bind "TEXT_RO" ev + (BindSetBreakable ([Ev_Widget], + (fun ei -> page_down ei.ev_Widget; break())))) + [ + [[], KeyPressDetail "space"]; + [[], KeyPressDetail "Next"]; + [[Control], KeyPressDetail "v"] + ]; List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], - (fun ei -> line_up ei.ev_Widget; break())))) - [ - [[], KeyPressDetail "Up"]; - [[Mod1], KeyPressDetail "z"] - ]; + tag_bind "TEXT_RO" ev + (BindSetBreakable ([Ev_Widget], + (fun ei -> line_up ei.ev_Widget; break())))) + [ + [[], KeyPressDetail "Up"]; + [[Mod1], KeyPressDetail "z"] + ]; List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], - (fun ei -> line_down ei.ev_Widget; break())))) - [ - [[], KeyPressDetail "Down"]; - [[Control], KeyPressDetail "z"] - ]; + tag_bind "TEXT_RO" ev + (BindSetBreakable ([Ev_Widget], + (fun ei -> line_down ei.ev_Widget; break())))) + [ + [[], KeyPressDetail "Down"]; + [[Control], KeyPressDetail "z"] + ]; List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], - (fun ei -> top ei.ev_Widget; break())))) - [ - [[], KeyPressDetail "Home"]; - [[Mod1], KeyPressDetail "less"] - ]; + tag_bind "TEXT_RO" ev + (BindSetBreakable ([Ev_Widget], + (fun ei -> top ei.ev_Widget; break())))) + [ + [[], KeyPressDetail "Home"]; + [[Mod1], KeyPressDetail "less"] + ]; List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], - (fun ei -> bottom ei.ev_Widget; break())))) - [ - [[], KeyPressDetail "End"]; - [[Mod1], KeyPressDetail "greater"] - ]; + tag_bind "TEXT_RO" ev + (BindSetBreakable ([Ev_Widget], + (fun ei -> bottom ei.ev_Widget; break())))) + [ + [[], KeyPressDetail "End"]; + [[Mod1], KeyPressDetail "greater"] + ]; List.iter (function ev -> - tag_bind "SEARCH" ev - (BindSetBreakable ([Ev_Widget], - (fun ei -> topsearch ei.ev_Widget; break())))) - [ + tag_bind "SEARCH" ev + (BindSetBreakable ([Ev_Widget], + (fun ei -> topsearch ei.ev_Widget; break())))) + [ [[Control], KeyPressDetail "s"] - ] + ] diff --git a/otherlibs/labltk/jpf/jpf_font.ml b/otherlibs/labltk/jpf/jpf_font.ml index 93deab643..c9c3d0526 100644 --- a/otherlibs/labltk/jpf/jpf_font.ml +++ b/otherlibs/labltk/jpf/jpf_font.ml @@ -80,9 +80,9 @@ let parse_xlfd xlfd_string = if cur >= len then [String.sub str beg (len - beg)] else if char_sep (String.get str cur) then - let nextw = succ cur in - (String.sub str beg (cur - beg)) - ::(split nextw nextw) + let nextw = succ cur in + (String.sub str beg (cur - beg)) + ::(split nextw nextw) else split beg (succ cur) in split 0 0 in @@ -190,11 +190,11 @@ let nearest_pixel_size dispname vector_ok pattern = Hashtbl.iter (fun s xlfd -> if vector_ok then if s = 0 then begin - if is_vector_font xlfd then begin - log (Printf.sprintf "%s is vector" (string_of_valid_xlfd xlfd)); - xlfd.pixelSize <- pxlsz; - Hashtbl.add newtbl pxlsz xlfd - end + if is_vector_font xlfd then begin + log (Printf.sprintf "%s is vector" (string_of_valid_xlfd xlfd)); + xlfd.pixelSize <- pxlsz; + Hashtbl.add newtbl pxlsz xlfd + end end else Hashtbl.add newtbl s xlfd else if not (is_vector_font xlfd) && s <> 0 then Hashtbl.add newtbl s xlfd) tbl; diff --git a/otherlibs/labltk/jpf/shell.ml b/otherlibs/labltk/jpf/shell.ml index 45b342258..485a0d874 100644 --- a/otherlibs/labltk/jpf/shell.ml +++ b/otherlibs/labltk/jpf/shell.ml @@ -21,16 +21,16 @@ let subshell cmd = let r,w = pipe () in match fork () with 0 -> close r; dup2 w stdout; - close stderr; - execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]; exit 127 + close stderr; + execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]; exit 127 | id -> close w; let rc = in_channel_of_descr r in let rec it () = try - let x = input_line rc in x:: it () + let x = input_line rc in x:: it () with _ -> [] in - let answer = it() in - close_in rc; (* because of finalize_channel *) - let p, st = waitpid [] id in answer + let answer = it() in + close_in rc; (* because of finalize_channel *) + let p, st = waitpid [] id in answer diff --git a/otherlibs/labltk/support/camltkwrap.mli b/otherlibs/labltk/support/camltkwrap.mli index 914ad0223..9c9321c21 100644 --- a/otherlibs/labltk/support/camltkwrap.mli +++ b/otherlibs/labltk/support/camltkwrap.mli @@ -50,7 +50,7 @@ module Widget : sig (* [dummy] is a widget used as context when we don't have any. It is *not* a real widget. *) - + val new_atom : parent: widget -> ?name: string -> string -> widget (* incompatible with the classic camltk *) @@ -80,10 +80,10 @@ module Widget : sig val chk_sub : string -> 'a list -> 'a -> unit val check_class : widget -> string list -> unit - (* Widget subtyping *) + (* Widget subtyping *) exception IllegalWidgetType of string - (* Raised when widget command applied illegally*) + (* Raised when widget command applied illegally*) (* this function is not used, but introduced for the compatibility with labltk. useless for camltk users *) @@ -95,10 +95,10 @@ module Protocol : sig (* Lower level interface *) exception TkError of string - (* Raised by the communication functions *) + (* Raised by the communication functions *) val debug : bool ref - (* When set to true, displays approximation of intermediate Tcl code *) + (* When set to true, displays approximation of intermediate Tcl code *) type tkArgs = TkToken of string @@ -108,7 +108,7 @@ module Protocol : sig (* Misc *) external splitlist : string -> string list - = "camltk_splitlist" + = "camltk_splitlist" val add_destroy_hook : (widget -> unit) -> unit @@ -133,19 +133,19 @@ module Protocol : sig val openTk : ?display:string -> ?clas:string -> unit -> widget (* [openTk ~display:display ~clas:clas ()] is equivalent to - [opentk ["-display"; display; "-name"; clas]] *) + [opentk ["-display"; display; "-name"; clas]] *) (* Legacy opentk functions *) val openTkClass: string -> widget (* [openTkClass class] is equivalent to [opentk ["-name"; class]] *) val openTkDisplayClass: string -> string -> widget (* [openTkDisplayClass disp class] is equivalent to - [opentk ["-display"; disp; "-name"; class]] *) + [opentk ["-display"; disp; "-name"; class]] *) val closeTk : unit -> unit val finalizeTk : unit -> unit (* Finalize tcl/tk before exiting. This function will be automatically - called when you call [Pervasives.exit ()] *) + called when you call [Pervasives.exit ()] *) val mainLoop : unit -> unit @@ -164,23 +164,23 @@ module Protocol : sig type cbid = Protocol.cbid type callback_buffer = string list - (* Buffer for reading callback arguments *) + (* Buffer for reading callback arguments *) val callback_naming_table : (cbid, callback_buffer -> unit) Hashtbl.t (* CAMLTK val callback_memo_table : (widget, cbid) Hashtbl.t *) val callback_memo_table : (widget, cbid) Hashtbl.t - (* Exported for debug purposes only. Don't use them unless you - know what you are doing *) + (* Exported for debug purposes only. Don't use them unless you + know what you are doing *) val new_function_id : unit -> cbid val string_of_cbid : cbid -> string val register_callback : widget -> callback:(callback_buffer -> unit) -> string - (* Callback support *) + (* Callback support *) val clear_callback : cbid -> unit - (* Remove a given callback from the table *) + (* Remove a given callback from the table *) val remove_callbacks : widget -> unit - (* Clean up callbacks associated to widget. Must be used only when - the Destroy event is bind by the user and masks the default - Destroy event binding *) + (* Clean up callbacks associated to widget. Must be used only when + the Destroy event is bind by the user and masks the default + Destroy event binding *) val cTKtoCAMLwidget : string -> widget val cCAMLtoTKwidget : string list -> widget -> tkArgs @@ -196,27 +196,27 @@ module Textvariable : sig open Protocol type textVariable = Textvariable.textVariable - (* TextVariable is an abstract type *) + (* TextVariable is an abstract type *) val create : ?on: widget -> unit -> textVariable - (* Allocation of a textVariable with lifetime associated to widget - if a widget is specified *) + (* Allocation of a textVariable with lifetime associated to widget + if a widget is specified *) val create_temporary : widget -> textVariable (* for backward compatibility - [create_temporary w] is equivalent to [create ~on:w ()] *) + [create_temporary w] is equivalent to [create ~on:w ()] *) val set : textVariable -> string -> unit - (* Setting the val of a textVariable *) + (* Setting the val of a textVariable *) val get : textVariable -> string - (* Reading the val of a textVariable *) + (* Reading the val of a textVariable *) val name : textVariable -> string - (* Its tcl name *) + (* Its tcl name *) val cCAMLtoTKtextVariable : textVariable -> tkArgs - (* Internal conversion function *) + (* Internal conversion function *) val handle : textVariable -> (unit -> unit) -> unit - (* Callbacks on variable modifications *) + (* Callbacks on variable modifications *) val coerce : string -> textVariable @@ -231,7 +231,7 @@ module Fileevent : sig val remove_fileinput: file_descr -> unit val add_fileoutput : file_descr -> (unit -> unit) -> unit val remove_fileoutput: file_descr -> unit - (* see [tk] module *) + (* see [tk] module *) end module Timer : sig diff --git a/otherlibs/labltk/support/cltkEval.c b/otherlibs/labltk/support/cltkEval.c index 236dc299a..ae86452f2 100644 --- a/otherlibs/labltk/support/cltkEval.c +++ b/otherlibs/labltk/support/cltkEval.c @@ -203,8 +203,8 @@ CAMLprim value camltk_tcl_direct_eval(value v) Tcl_DStringInit(&buf); Tcl_DStringAppend(&buf, argv[0], -1); for (i=1; i<size; i++) { - Tcl_DStringAppend(&buf, " ", -1); - Tcl_DStringAppend(&buf, argv[i], -1); + Tcl_DStringAppend(&buf, " ", -1); + Tcl_DStringAppend(&buf, argv[i], -1); } result = Tcl_Eval(cltclinterp, Tcl_DStringValue(&buf)); Tcl_DStringFree(&buf); @@ -217,13 +217,13 @@ CAMLprim value camltk_tcl_direct_eval(value v) } else { /* implement the autoload stuff */ if (Tcl_GetCommandInfo(cltclinterp,"unknown",&info)) { /* unknown found */ for (i = size; i >= 0; i--) - argv[i+1] = argv[i]; + argv[i+1] = argv[i]; argv[0] = "unknown"; result = (*info.proc)(info.clientData,cltclinterp,size+1,argv); } else { /* ah, it isn't there at all */ result = TCL_ERROR; Tcl_AppendResult(cltclinterp, "Unknown command \"", - argv[0], "\"", NULL); + argv[0], "\"", NULL); } } diff --git a/otherlibs/labltk/support/cltkImg.c b/otherlibs/labltk/support/cltkImg.c index f30166ef5..7eaca3689 100644 --- a/otherlibs/labltk/support/cltkImg.c +++ b/otherlibs/labltk/support/cltkImg.c @@ -59,16 +59,16 @@ CAMLprim value camltk_getimgdata (value imgname) /* ML */ CAMLreturn(res); } else { int y; /* varies from 0 to height - 1 */ - int yoffs = 0; /* byte offset of line in src */ - int yidx = 0; /* byte offset of line in dst */ + int yoffs = 0; /* byte offset of line in src */ + int yidx = 0; /* byte offset of line in dst */ for (y=0; y<pib.height; y++,yoffs+=pib.pitch,yidx+=pib.width * 3) { - int x; /* varies from 0 to width - 1 */ - int xoffs = yoffs; /* byte offset of pxl in src */ - int xidx = yidx; /* byte offset of pxl in dst */ + int x; /* varies from 0 to width - 1 */ + int xoffs = yoffs; /* byte offset of pxl in src */ + int xidx = yidx; /* byte offset of pxl in dst */ for (x=0; x<pib.width; x++,xoffs+=pib.pixelSize,xidx+=3) { - Byte(res, xidx) = pib.pixelPtr[xoffs+pib.offset[0]]; - Byte(res, xidx + 1) = pib.pixelPtr[xoffs+pib.offset[1]]; - Byte(res, xidx + 2) = pib.pixelPtr[xoffs+pib.offset[2]]; + Byte(res, xidx) = pib.pixelPtr[xoffs+pib.offset[0]]; + Byte(res, xidx + 1) = pib.pixelPtr[xoffs+pib.offset[1]]; + Byte(res, xidx + 2) = pib.pixelPtr[xoffs+pib.offset[2]]; }; } CAMLreturn(res); @@ -77,7 +77,7 @@ CAMLprim value camltk_getimgdata (value imgname) /* ML */ CAMLprim void camltk_setimgdata_native (value imgname, value pixmap, value x, value y, - value w, value h) /* ML */ + value w, value h) /* ML */ { Tk_PhotoHandle ph; Tk_PhotoImageBlock pib; @@ -107,5 +107,5 @@ CAMLprim void camltk_setimgdata_bytecode(argv,argn) int argn; { camltk_setimgdata_native(argv[0], argv[1], argv[2], argv[3], - argv[4], argv[5]); + argv[4], argv[5]); } diff --git a/otherlibs/labltk/support/cltkMain.c b/otherlibs/labltk/support/cltkMain.c index 6047f8551..6a3a35641 100644 --- a/otherlibs/labltk/support/cltkMain.c +++ b/otherlibs/labltk/support/cltkMain.c @@ -103,32 +103,32 @@ CAMLprim value camltk_opentk(value argv) tmp = Field(argv, 1); /* starts from argv[1] */ while ( tmp != Val_int(0) ) { - argc++; - tmp = Field(tmp, 1); + argc++; + tmp = Field(tmp, 1); } if( argc != 0 ){ - int i; - char *args; - char **tkargv; - char argcstr[256]; /* string of argc */ - - tkargv = (char**)stat_alloc(sizeof( char* ) * argc ); - tmp = Field(argv, 1); /* starts from argv[1] */ - i = 0; - - while ( tmp != Val_int(0) ) { - tkargv[i] = String_val(Field(tmp, 0)); - tmp = Field(tmp, 1); - i++; - } - - sprintf( argcstr, "%d", argc ); + int i; + char *args; + char **tkargv; + char argcstr[256]; /* string of argc */ + + tkargv = (char**)stat_alloc(sizeof( char* ) * argc ); + tmp = Field(argv, 1); /* starts from argv[1] */ + i = 0; + + while ( tmp != Val_int(0) ) { + tkargv[i] = String_val(Field(tmp, 0)); + tmp = Field(tmp, 1); + i++; + } + + sprintf( argcstr, "%d", argc ); Tcl_SetVar(cltclinterp, "argc", argcstr, TCL_GLOBAL_ONLY); args = Tcl_Merge(argc, tkargv); /* args must be freed by Tcl_Free */ Tcl_SetVar(cltclinterp, "argv", args, TCL_GLOBAL_ONLY); Tcl_Free(args); - stat_free( tkargv ); + stat_free( tkargv ); } } if (Tk_Init(cltclinterp) != TCL_OK) diff --git a/otherlibs/labltk/support/cltkMisc.c b/otherlibs/labltk/support/cltkMisc.c index a6e823d1d..e9824b6e9 100644 --- a/otherlibs/labltk/support/cltkMisc.c +++ b/otherlibs/labltk/support/cltkMisc.c @@ -39,7 +39,7 @@ CAMLprim value camltk_splitlist (value v) switch(result) { case TCL_OK: { value res = copy_string_list(argc,argv); - Tcl_Free((char *)argv); /* only one large block was allocated */ + Tcl_Free((char *)argv); /* only one large block was allocated */ /* argv points into utf: utf must be freed after argv are freed */ stat_free( utf ); return res; diff --git a/otherlibs/labltk/support/cltkVar.c b/otherlibs/labltk/support/cltkVar.c index 971336850..83fedbafd 100644 --- a/otherlibs/labltk/support/cltkVar.c +++ b/otherlibs/labltk/support/cltkVar.c @@ -76,10 +76,10 @@ typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData, */ static char * tracevar(clientdata, interp, name1, name2, flags) ClientData clientdata; - Tcl_Interp *interp; /* Interpreter containing variable. */ - char *name1; /* Name of variable. */ - char *name2; /* Second part of variable name. */ - int flags; /* Information about what happened. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Name of variable. */ + char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ { Tcl_UntraceVar2(interp, name1, name2, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, diff --git a/otherlibs/labltk/support/cltkWait.c b/otherlibs/labltk/support/cltkWait.c index f562ff6e6..7c3cef53f 100644 --- a/otherlibs/labltk/support/cltkWait.c +++ b/otherlibs/labltk/support/cltkWait.c @@ -45,8 +45,8 @@ struct WinCBData { }; static void WaitVisibilityProc(clientData, eventPtr) - ClientData clientData; - XEvent *eventPtr; /* Information about event (not used). */ + ClientData clientData; + XEvent *eventPtr; /* Information about event (not used). */ { struct WinCBData *vis = clientData; value cbid = Val_int(vis->cbid); diff --git a/otherlibs/labltk/support/protocol.ml b/otherlibs/labltk/support/protocol.ml index 586c937b4..6e3208cfe 100644 --- a/otherlibs/labltk/support/protocol.ml +++ b/otherlibs/labltk/support/protocol.ml @@ -179,11 +179,11 @@ let protected_dispatch id args = with | e -> try - Printf.eprintf "Uncaught exception: %s\n" (Printexc.to_string e); - flush stderr; - (* raise x *) + Printf.eprintf "Uncaught exception: %s\n" (Printexc.to_string e); + flush stderr; + (* raise x *) with - Out_of_memory -> raise Out_of_memory + Out_of_memory -> raise Out_of_memory | Sys.Break -> raise Sys.Break let _ = Callback.register "camlcb" protected_dispatch diff --git a/otherlibs/labltk/support/rawwidget.ml b/otherlibs/labltk/support/rawwidget.ml index 4ddf1a301..8eba3b8b1 100644 --- a/otherlibs/labltk/support/rawwidget.ml +++ b/otherlibs/labltk/support/rawwidget.ml @@ -148,8 +148,8 @@ let new_atom ~parent ?name:nom clas = else parentpath ^ "." ^ name in let w = Typed(path,clas) in - Hashtbl.add table path w; - w + Hashtbl.add table path w; + w (* Just create a path. Only to check existence of widgets *) (* Use with care *) diff --git a/otherlibs/labltk/support/textvariable.ml b/otherlibs/labltk/support/textvariable.ml index af272e682..4581976b5 100644 --- a/otherlibs/labltk/support/textvariable.ml +++ b/otherlibs/labltk/support/textvariable.ml @@ -96,9 +96,9 @@ let add w v = try Hashtbl.find memo w with Not_found -> - let r = ref StringSet.empty in - Hashtbl.add memo w r; - r in + let r = ref StringSet.empty in + Hashtbl.add memo w r; + r in r := StringSet.add v !r (* to be used with care ! *) diff --git a/otherlibs/labltk/tkanim/gifanimtest.ml b/otherlibs/labltk/tkanim/gifanimtest.ml index acd51c80b..5b7998544 100644 --- a/otherlibs/labltk/tkanim/gifanimtest.ml +++ b/otherlibs/labltk/tkanim/gifanimtest.ml @@ -39,33 +39,33 @@ let main () = (* Check it is really animated or not. *) match anim with | Still x -> - (* Use whatever you want in CamlTk with this ImagePhoto. *) - prerr_endline "Sorry, it is not an animated GIF." + (* Use whatever you want in CamlTk with this ImagePhoto. *) + prerr_endline "Sorry, it is not an animated GIF." | Animated x -> - (* OK, let's animate it. *) - let l = Label.create t [] in - pack [l] []; - - (* animate returns an interface function. *) + (* OK, let's animate it. *) + let l = Label.create t [] in + pack [l] []; + + (* animate returns an interface function. *) let f = animate l x in - (* Button1 toggles the animation *) - bind l [[], ButtonPressDetail 1] (BindSet ([], (fun _ -> - f false))); + (* Button1 toggles the animation *) + bind l [[], ButtonPressDetail 1] (BindSet ([], (fun _ -> + f false))); - (* Button2 displays the next frame. *) - bind l [[], ButtonPressDetail 2] (BindSet ([], (fun _ -> - f true))); + (* Button2 displays the next frame. *) + bind l [[], ButtonPressDetail 2] (BindSet ([], (fun _ -> + f true))); - (* Button3 quits. *) - bind l [[], ButtonPressDetail 3] (BindSet ([], (fun _ -> - closeTk ()))); + (* Button3 quits. *) + bind l [[], ButtonPressDetail 3] (BindSet ([], (fun _ -> + closeTk ()))); - (* start the animation *) - f false; + (* start the animation *) + f false; - (* Go to the main loop. *) - mainLoop () + (* Go to the main loop. *) + mainLoop () let _ = Printexc.print main () diff --git a/otherlibs/labltk/tkanim/tkAnimGIF.c b/otherlibs/labltk/tkanim/tkAnimGIF.c index af82aa607..264193bc0 100644 --- a/otherlibs/labltk/tkanim/tkAnimGIF.c +++ b/otherlibs/labltk/tkanim/tkAnimGIF.c @@ -24,60 +24,60 @@ */ static int FileMatchGIF _ANSI_ARGS_((FILE *f, char *fileName, - char *formatString, int *widthPtr, int *heightPtr)); + char *formatString, int *widthPtr, int *heightPtr)); static int FileReadGIF _ANSI_ARGS_((Tcl_Interp *interp, - FILE *f, char *fileName, char *formatString)); - -#define INTERLACE 0x40 -#define LOCALCOLORMAP 0x80 -#define BitSet(byte, bit) (((byte) & (bit)) == (bit)) -#define MAXCOLORMAPSIZE 256 -#define CM_RED 0 -#define CM_GREEN 1 -#define CM_BLUE 2 -#define MAX_LWZ_BITS 12 + FILE *f, char *fileName, char *formatString)); + +#define INTERLACE 0x40 +#define LOCALCOLORMAP 0x80 +#define BitSet(byte, bit) (((byte) & (bit)) == (bit)) +#define MAXCOLORMAPSIZE 256 +#define CM_RED 0 +#define CM_GREEN 1 +#define CM_BLUE 2 +#define MAX_LWZ_BITS 12 #define LM_to_uint(a,b) (((b)<<8)|(a)) -#define ReadOK(file,buffer,len) (fread(buffer, len, 1, file) != 0) +#define ReadOK(file,buffer,len) (fread(buffer, len, 1, file) != 0) /* * Prototypes for local procedures defined in this file: */ -static int DoExtension _ANSI_ARGS_((FILE *fd, int label, - int *transparent, int *delay, int *loop)); -static int GetCode _ANSI_ARGS_((FILE *fd, int code_size, - int flag)); -static int GetDataBlock _ANSI_ARGS_((FILE *fd, - unsigned char *buf)); -static int LWZReadByte _ANSI_ARGS_((FILE *fd, int flag, - int input_code_size)); -static int ReadColorMap _ANSI_ARGS_((FILE *fd, int number, - unsigned char buffer[3][MAXCOLORMAPSIZE])); -static int ReadGIFHeader _ANSI_ARGS_((FILE *f, int *widthPtr, - int *heightPtr)); -static int ReadImage _ANSI_ARGS_((Tcl_Interp *interp, - char *imagePtr, FILE *fd, int len, int height, - unsigned char cmap[3][MAXCOLORMAPSIZE], - int interlace, int transparent)); +static int DoExtension _ANSI_ARGS_((FILE *fd, int label, + int *transparent, int *delay, int *loop)); +static int GetCode _ANSI_ARGS_((FILE *fd, int code_size, + int flag)); +static int GetDataBlock _ANSI_ARGS_((FILE *fd, + unsigned char *buf)); +static int LWZReadByte _ANSI_ARGS_((FILE *fd, int flag, + int input_code_size)); +static int ReadColorMap _ANSI_ARGS_((FILE *fd, int number, + unsigned char buffer[3][MAXCOLORMAPSIZE])); +static int ReadGIFHeader _ANSI_ARGS_((FILE *f, int *widthPtr, + int *heightPtr)); +static int ReadImage _ANSI_ARGS_((Tcl_Interp *interp, + char *imagePtr, FILE *fd, int len, int height, + unsigned char cmap[3][MAXCOLORMAPSIZE], + int interlace, int transparent)); static int FileMatchGIF(f, fileName, formatString, widthPtr, heightPtr) - FILE *f; /* The image file, open for reading. */ - char *fileName; /* The name of the image file. */ - char *formatString; /* User-specified format string, or NULL. */ - int *widthPtr, *heightPtr; /* The dimensions of the image are - * returned here if the file is a valid - * raw GIF file. */ + FILE *f; /* The image file, open for reading. */ + char *fileName; /* The name of the image file. */ + char *formatString; /* User-specified format string, or NULL. */ + int *widthPtr, *heightPtr; /* The dimensions of the image are + * returned here if the file is a valid + * raw GIF file. */ { - return ReadGIFHeader(f, widthPtr, heightPtr); + return ReadGIFHeader(f, widthPtr, heightPtr); } static int FileReadGIF(interp, f, fileName, formatString) - Tcl_Interp *interp; /* Interpreter to use for reporting errors. */ - FILE *f; /* The image file, open for reading. */ - char *fileName; /* The name of the image file. */ - char *formatString; /* User-specified format string, or NULL. */ + Tcl_Interp *interp; /* Interpreter to use for reporting errors. */ + FILE *f; /* The image file, open for reading. */ + char *fileName; /* The name of the image file. */ + char *formatString; /* User-specified format string, or NULL. */ { int logicalWidth, logicalHeight; int nBytes; @@ -106,28 +106,28 @@ FileReadGIF(interp, f, fileName, formatString) int loop = -1; if((winPtr = Tk_MainWindow(interp)) == NULL){ - return TCL_ERROR; + return TCL_ERROR; } #ifdef TKANIM_DEBUG fprintf(stderr, "\n\t\tHeader check..."); #endif if (!ReadGIFHeader(f, &logicalWidth, &logicalHeight)) { - Tcl_AppendResult(interp, "couldn't read GIF header from file \"", - fileName, "\"", NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "couldn't read GIF header from file \"", + fileName, "\"", NULL); + return TCL_ERROR; } #ifdef TKANIM_DEBUG fprintf(stderr, "done "); #endif if ((logicalWidth <= 0) || (logicalHeight <= 0)) { - Tcl_AppendResult(interp, "GIF image file \"", fileName, - "\" has dimension(s) <= 0", (char *) NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "GIF image file \"", fileName, + "\" has dimension(s) <= 0", (char *) NULL); + return TCL_ERROR; } if (fread(buf, 1, 3, f) != 3) { - return TCL_OK; + return TCL_OK; } bitPixel = 2<<(buf[0]&0x07); colorResolution = (((buf[0]&0x70)>>3)+1); @@ -135,11 +135,11 @@ FileReadGIF(interp, f, fileName, formatString) aspectRatio = buf[2]; if (BitSet(buf[0], LOCALCOLORMAP)) { /* Global Colormap */ - if (!ReadColorMap(f, bitPixel, colorMap)) { - Tcl_AppendResult(interp, "error reading color map", - (char *) NULL); - return TCL_ERROR; - } + if (!ReadColorMap(f, bitPixel, colorMap)) { + Tcl_AppendResult(interp, "error reading color map", + (char *) NULL); + return TCL_ERROR; + } } #ifdef TKANIM_DEBUG @@ -157,204 +157,204 @@ FileReadGIF(interp, f, fileName, formatString) Tcl_DStringAppend(&resultbuf, "{", -1); while (1) { - if (fread(buf, 1, 1, f) != 1) { - /* - * Premature end of image. We should really notify - * the user, but for now just show garbage. - */ + if (fread(buf, 1, 1, f) != 1) { + /* + * Premature end of image. We should really notify + * the user, but for now just show garbage. + */ #ifdef TKANIM_DEBUG fprintf(stderr, "Premature end of image"); #endif - break; - } + break; + } - if (buf[0] == ';') { - /* - * GIF terminator. - */ + if (buf[0] == ';') { + /* + * GIF terminator. + */ #ifdef TKANIM_DEBUG fprintf(stderr, ";"); prevpos = ftell(f); #endif - break; - } + break; + } - if (buf[0] == '!') { - /* - * This is a GIF extension. - */ + if (buf[0] == '!') { + /* + * This is a GIF extension. + */ #ifdef TKANIM_DEBUG fprintf(stderr, "!"); prevpos = ftell(f); #endif - if (fread(buf, 1, 1, f) != 1) { - Tcl_AppendResult( interp, - "error reading extension function code in GIF image", NULL ); + if (fread(buf, 1, 1, f) != 1) { + Tcl_AppendResult( interp, + "error reading extension function code in GIF image", NULL ); /* - interp->result = - "error reading extension function code in GIF image"; + interp->result = + "error reading extension function code in GIF image"; */ - goto error; - } - if (DoExtension(f, buf[0], &transparent, &delay, &loop) < 0) { - Tcl_AppendResult( interp, - "error reading extension in GIF image", NULL ); + goto error; + } + if (DoExtension(f, buf[0], &transparent, &delay, &loop) < 0) { + Tcl_AppendResult( interp, + "error reading extension in GIF image", NULL ); /* - interp->result = "error reading extension in GIF image"; -*/ goto error; - } - continue; - } - - if (buf[0] == '\0') { - /* - * Not a valid start character; ignore it. - */ + interp->result = "error reading extension in GIF image"; +*/ goto error; + } + continue; + } + + if (buf[0] == '\0') { + /* + * Not a valid start character; ignore it. + */ #ifdef TKANIM_DEBUG - fprintf(stderr, "0", buf[0]); - prevpos = ftell(f); + fprintf(stderr, "0", buf[0]); + prevpos = ftell(f); #endif - continue; - } + continue; + } - if (buf[0] != ',') { - /* - * Not a valid start character; ignore it. - */ + if (buf[0] != ',') { + /* + * Not a valid start character; ignore it. + */ #ifdef TKANIM_DEBUG fprintf(stderr, "?(%c)", buf[0]); prevpos = ftell(f); #endif - continue; - } + continue; + } - if (fread(buf, 1, 9, f) != 9) { - Tcl_AppendResult( interp, - "couldn't read left/top/width/height in GIF image", NULL ); + if (fread(buf, 1, 9, f) != 9) { + Tcl_AppendResult( interp, + "couldn't read left/top/width/height in GIF image", NULL ); /* - interp->result = "couldn't read left/top/width/height in GIF image"; + interp->result = "couldn't read left/top/width/height in GIF image"; */ - goto error; - } + goto error; + } - useGlobalColormap = ! BitSet(buf[8], LOCALCOLORMAP); + useGlobalColormap = ! BitSet(buf[8], LOCALCOLORMAP); - bitPixel = 1<<((buf[8]&0x07)+1); + bitPixel = 1<<((buf[8]&0x07)+1); - imageLeftPos= LM_to_uint(buf[0], buf[1]); - imageTopPos= LM_to_uint(buf[2], buf[3]); - imageWidth= LM_to_uint(buf[4], buf[5]); - imageHeight= LM_to_uint(buf[6], buf[7]); + imageLeftPos= LM_to_uint(buf[0], buf[1]); + imageTopPos= LM_to_uint(buf[2], buf[3]); + imageWidth= LM_to_uint(buf[4], buf[5]); + imageHeight= LM_to_uint(buf[6], buf[7]); - block.width = imageWidth; - block.height = imageHeight; - block.pixelSize = 3; - block.pitch = 3 * imageWidth; - block.offset[0] = 0; - block.offset[1] = 1; - block.offset[2] = 2; - block.offset[3] = 3; - nBytes = imageHeight * block.pitch; - block.pixelPtr = (unsigned char *) ckalloc((unsigned) nBytes); + block.width = imageWidth; + block.height = imageHeight; + block.pixelSize = 3; + block.pitch = 3 * imageWidth; + block.offset[0] = 0; + block.offset[1] = 1; + block.offset[2] = 2; + block.offset[3] = 3; + nBytes = imageHeight * block.pitch; + block.pixelPtr = (unsigned char *) ckalloc((unsigned) nBytes); - sprintf(widthbuf, "%d", imageWidth); - sprintf(heightbuf, "%d", imageHeight); + sprintf(widthbuf, "%d", imageWidth); + sprintf(heightbuf, "%d", imageHeight); - /* save result */ + /* save result */ - { + { #if (TK_MAJOR_VERSION >= 8 && TK_MINOR_VERSION >= 1) - Tcl_Obj *argv[7]; - int i; - - argv[0] = Tcl_NewStringObj("image", -1); - argv[1] = Tcl_NewStringObj("create", -1); - argv[2] = Tcl_NewStringObj("photo", -1); - argv[3] = Tcl_NewStringObj("-width", -1); - argv[4] = Tcl_NewStringObj(widthbuf, -1); - argv[5] = Tcl_NewStringObj("-height", -1); - argv[6] = Tcl_NewStringObj(heightbuf, -1); + Tcl_Obj *argv[7]; + int i; + + argv[0] = Tcl_NewStringObj("image", -1); + argv[1] = Tcl_NewStringObj("create", -1); + argv[2] = Tcl_NewStringObj("photo", -1); + argv[3] = Tcl_NewStringObj("-width", -1); + argv[4] = Tcl_NewStringObj(widthbuf, -1); + argv[5] = Tcl_NewStringObj("-height", -1); + argv[6] = Tcl_NewStringObj(heightbuf, -1); - for(i=0; i<7; i++){ Tcl_IncrRefCount(argv[i]); } + for(i=0; i<7; i++){ Tcl_IncrRefCount(argv[i]); } - if( Tk_ImageObjCmd((ClientData) winPtr, interp, - /* "image create photo -width <imageWidth> - -height <imageHeight>" */ - 7, argv) == TCL_ERROR ){ - return TCL_ERROR; - } - - for(i=0; i<7; i++){ Tcl_DecrRefCount(argv[i]); } + if( Tk_ImageObjCmd((ClientData) winPtr, interp, + /* "image create photo -width <imageWidth> + -height <imageHeight>" */ + 7, argv) == TCL_ERROR ){ + return TCL_ERROR; + } + + for(i=0; i<7; i++){ Tcl_DecrRefCount(argv[i]); } #else - char *argv[7] = {"image", "create", "photo", "-width", NULL, - "-height", NULL}; - argv[4] = widthbuf; - argv[6] = heightbuf; + char *argv[7] = {"image", "create", "photo", "-width", NULL, + "-height", NULL}; + argv[4] = widthbuf; + argv[6] = heightbuf; #ifdef TKANIM_DEBUG fprintf(stderr, "\n\t\timage creation (%s %s %s %s %s %s %s)", - argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6]); + argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6]); #endif - if( Tk_ImageCmd((ClientData) winPtr, interp, - /* "image create photo -width <imageWidth> - -height <imageHeight>" */ - 7, argv) == TCL_ERROR ){ - return TCL_ERROR; - } + if( Tk_ImageCmd((ClientData) winPtr, interp, + /* "image create photo -width <imageWidth> + -height <imageHeight>" */ + 7, argv) == TCL_ERROR ){ + return TCL_ERROR; + } #endif #ifdef TKANIM_DEBUG fprintf(stderr, " done "); #endif - } + } - imageName = interp->result; + imageName = interp->result; #if (TK_MAJOR_VERSION < 8) - photoHandle = Tk_FindPhoto(interp->result); + photoHandle = Tk_FindPhoto(interp->result); #else - photoHandle = Tk_FindPhoto(interp, interp->result); + photoHandle = Tk_FindPhoto(interp, interp->result); #endif - if (!useGlobalColormap) { - if (!ReadColorMap(f, bitPixel, localColorMap)) { - Tcl_AppendResult(interp, "error reading color map", - (char *) NULL); - goto error; - } - if (ReadImage(interp, (char *) block.pixelPtr, f, imageWidth, - imageHeight, localColorMap, BitSet(buf[8], INTERLACE), - transparent) != TCL_OK) { - goto error; - } - } else { - if (ReadImage(interp, (char *) block.pixelPtr, f, imageWidth, - imageHeight, colorMap, BitSet(buf[8], INTERLACE), - transparent) != TCL_OK) { - goto error; - } - } - Tk_PhotoPutBlock(photoHandle, &block, 0, 0, - imageWidth, imageHeight); + if (!useGlobalColormap) { + if (!ReadColorMap(f, bitPixel, localColorMap)) { + Tcl_AppendResult(interp, "error reading color map", + (char *) NULL); + goto error; + } + if (ReadImage(interp, (char *) block.pixelPtr, f, imageWidth, + imageHeight, localColorMap, BitSet(buf[8], INTERLACE), + transparent) != TCL_OK) { + goto error; + } + } else { + if (ReadImage(interp, (char *) block.pixelPtr, f, imageWidth, + imageHeight, colorMap, BitSet(buf[8], INTERLACE), + transparent) != TCL_OK) { + goto error; + } + } + Tk_PhotoPutBlock(photoHandle, &block, 0, 0, + imageWidth, imageHeight); #ifdef TKANIM_DEBUG fprintf(stderr, " Retrieving result\n"); #endif - /* retrieve result */ - sprintf(newresbuf, "{%s %d %d %d %d %d} ", - imageName, imageWidth, imageHeight, imageLeftPos, imageTopPos, - delay); + /* retrieve result */ + sprintf(newresbuf, "{%s %d %d %d %d %d} ", + imageName, imageWidth, imageHeight, imageLeftPos, imageTopPos, + delay); #ifdef TKANIM_DEBUG fprintf(stderr, " newresbuf = %s\n", newresbuf); #endif - ckfree((char *) block.pixelPtr); + ckfree((char *) block.pixelPtr); #ifdef TKANIM_DEBUG fprintf(stderr, " free done (now append result)"); #endif - Tcl_DStringAppend( &resultbuf, newresbuf, -1 ); + Tcl_DStringAppend( &resultbuf, newresbuf, -1 ); #ifdef TKANIM_DEBUG - fprintf(stderr, "\n\t\tFrame done (%d)", ftell(f) - prevpos); - prevpos = ftell(f); + fprintf(stderr, "\n\t\tFrame done (%d)", ftell(f) - prevpos); + prevpos = ftell(f); #endif } sprintf( widthbuf, "%d", loop ); @@ -379,67 +379,67 @@ static int DoExtension(fd, label, transparent, delay, loop) FILE *fd; int label; -int *transparent; +int *transparent; int *delay; int *loop; { - static unsigned char buf[256]; - int count = 0; - - switch (label) { - case 0x01: /* Plain Text Extension */ - break; - - case 0xff: /* Application Extension */ - count = GetDataBlock(fd, (unsigned char*) buf); - if( count < 0){ - return 1; - } - if( !strncmp (buf, "NETSCAPE", 8) ) { - /* we ignore check of "2.0" */ - count = GetDataBlock (fd, (unsigned char*) buf); - if( count < 0){ - return 1; - } - if( buf[0] != 1 ){ - fprintf(stderr, "??? %d", buf[0]); - } - *loop = LM_to_uint(buf[1], buf[2]); - } - do { - count = GetDataBlock(fd, (unsigned char*) buf); - } while (count > 0); - return count; - break; - - case 0xfe: /* Comment Extension */ - do { - count = GetDataBlock(fd, (unsigned char*) buf); - } while (count > 0); - return count; - - case 0xf9: /* Graphic Control Extension */ - count = GetDataBlock(fd, (unsigned char*) buf); - if (count < 0) { - return 1; - } - if ((buf[0] & 0x1) != 0) { - *transparent = buf[3]; - } - - /* Delay time */ - *delay = LM_to_uint(buf[1],buf[2]); - - do { - count = GetDataBlock(fd, (unsigned char*) buf); - } while (count > 0); - return count; - } - - do { - count = GetDataBlock(fd, (unsigned char*) buf); - } while (count > 0); - return count; + static unsigned char buf[256]; + int count = 0; + + switch (label) { + case 0x01: /* Plain Text Extension */ + break; + + case 0xff: /* Application Extension */ + count = GetDataBlock(fd, (unsigned char*) buf); + if( count < 0){ + return 1; + } + if( !strncmp (buf, "NETSCAPE", 8) ) { + /* we ignore check of "2.0" */ + count = GetDataBlock (fd, (unsigned char*) buf); + if( count < 0){ + return 1; + } + if( buf[0] != 1 ){ + fprintf(stderr, "??? %d", buf[0]); + } + *loop = LM_to_uint(buf[1], buf[2]); + } + do { + count = GetDataBlock(fd, (unsigned char*) buf); + } while (count > 0); + return count; + break; + + case 0xfe: /* Comment Extension */ + do { + count = GetDataBlock(fd, (unsigned char*) buf); + } while (count > 0); + return count; + + case 0xf9: /* Graphic Control Extension */ + count = GetDataBlock(fd, (unsigned char*) buf); + if (count < 0) { + return 1; + } + if ((buf[0] & 0x1) != 0) { + *transparent = buf[3]; + } + + /* Delay time */ + *delay = LM_to_uint(buf[1],buf[2]); + + do { + count = GetDataBlock(fd, (unsigned char*) buf); + } while (count > 0); + return count; + } + + do { + count = GetDataBlock(fd, (unsigned char*) buf); + } while (count > 0); + return count; } /* @@ -447,37 +447,37 @@ int *loop; * * ReadGIFHeader -- * - * This procedure reads the GIF header from the beginning of a - * GIF file and returns the dimensions of the image. + * This procedure reads the GIF header from the beginning of a + * GIF file and returns the dimensions of the image. * * Results: - * The return value is 1 if file "f" appears to start with - * a valid GIF header, 0 otherwise. If the header is valid, - * then *widthPtr and *heightPtr are modified to hold the - * dimensions of the image. + * The return value is 1 if file "f" appears to start with + * a valid GIF header, 0 otherwise. If the header is valid, + * then *widthPtr and *heightPtr are modified to hold the + * dimensions of the image. * * Side effects: - * The access position in f advances. + * The access position in f advances. * *---------------------------------------------------------------------- */ static int ReadGIFHeader(f, widthPtr, heightPtr) - FILE *f; /* Image file to read the header from */ - int *widthPtr, *heightPtr; /* The dimensions of the image are - * returned here. */ + FILE *f; /* Image file to read the header from */ + int *widthPtr, *heightPtr; /* The dimensions of the image are + * returned here. */ { unsigned char buf[7]; if ((fread(buf, 1, 6, f) != 6) - || ((strncmp("GIF87a", (char *) buf, 6) != 0) - && (strncmp("GIF89a", (char *) buf, 6) != 0))) { - return 0; + || ((strncmp("GIF87a", (char *) buf, 6) != 0) + && (strncmp("GIF89a", (char *) buf, 6) != 0))) { + return 0; } if (fread(buf, 1, 4, f) != 4) { - return 0; + return 0; } *widthPtr = LM_to_uint(buf[0],buf[1]); @@ -498,18 +498,18 @@ FILE *fd; int number; unsigned char buffer[3][MAXCOLORMAPSIZE]; { - int i; - unsigned char rgb[3]; - - for (i = 0; i < number; ++i) { - if (! ReadOK(fd, rgb, sizeof(rgb))) - return 0; - - buffer[CM_RED][i] = rgb[0] ; - buffer[CM_GREEN][i] = rgb[1] ; - buffer[CM_BLUE][i] = rgb[2] ; - } - return 1; + int i; + unsigned char rgb[3]; + + for (i = 0; i < number; ++i) { + if (! ReadOK(fd, rgb, sizeof(rgb))) + return 0; + + buffer[CM_RED][i] = rgb[0] ; + buffer[CM_GREEN][i] = rgb[1] ; + buffer[CM_BLUE][i] = rgb[2] ; + } + return 1; } @@ -521,112 +521,112 @@ GetDataBlock(fd, buf) FILE *fd; unsigned char *buf; { - unsigned char count; + unsigned char count; - if (! ReadOK(fd,&count,1)) { - return -1; - } + if (! ReadOK(fd,&count,1)) { + return -1; + } - ZeroDataBlock = count == 0; + ZeroDataBlock = count == 0; - if ((count != 0) && (! ReadOK(fd, buf, count))) { - return -1; - } + if ((count != 0) && (! ReadOK(fd, buf, count))) { + return -1; + } - return count; + return count; } static int ReadImage(interp, imagePtr, fd, len, height, cmap, interlace, transparent) Tcl_Interp *interp; -char *imagePtr; +char *imagePtr; FILE *fd; int len, height; unsigned char cmap[3][MAXCOLORMAPSIZE]; int interlace; int transparent; { - unsigned char c; - int v; - int xpos = 0, ypos = 0, pass = 0; - char *colStr; - - - /* - * Initialize the Compression routines - */ - if (! ReadOK(fd,&c,1)) { - Tcl_AppendResult(interp, "error reading GIF image: ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - - if (LWZReadByte(fd, 1, c) < 0) { - interp->result = "format error in GIF image"; - return TCL_ERROR; - } - - if (transparent!=-1 && - (colStr = Tcl_GetVar(interp, "TRANSPARENT_GIF_COLOR", 0L))) { - XColor *colorPtr; - colorPtr = Tk_GetColor(interp, Tk_MainWindow(interp), - Tk_GetUid(colStr)); - if (colorPtr) { + unsigned char c; + int v; + int xpos = 0, ypos = 0, pass = 0; + char *colStr; + + + /* + * Initialize the Compression routines + */ + if (! ReadOK(fd,&c,1)) { + Tcl_AppendResult(interp, "error reading GIF image: ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + if (LWZReadByte(fd, 1, c) < 0) { + interp->result = "format error in GIF image"; + return TCL_ERROR; + } + + if (transparent!=-1 && + (colStr = Tcl_GetVar(interp, "TRANSPARENT_GIF_COLOR", 0L))) { + XColor *colorPtr; + colorPtr = Tk_GetColor(interp, Tk_MainWindow(interp), + Tk_GetUid(colStr)); + if (colorPtr) { /* - printf("color is %d %d %d\n", - colorPtr->red >> 8, - colorPtr->green >> 8, - colorPtr->blue >> 8); + printf("color is %d %d %d\n", + colorPtr->red >> 8, + colorPtr->green >> 8, + colorPtr->blue >> 8); */ - cmap[CM_RED][transparent] = colorPtr->red >> 8; - cmap[CM_GREEN][transparent] = colorPtr->green >> 8; - cmap[CM_BLUE][transparent] = colorPtr->blue >> 8; - Tk_FreeColor(colorPtr); - } - } - - while ((v = LWZReadByte(fd,0,c)) >= 0 ) { - - imagePtr[ (xpos*3) + (ypos *len*3)] = cmap[CM_RED][v]; - imagePtr[ (xpos*3) + (ypos *len*3) +1] = cmap[CM_GREEN][v]; - imagePtr[ (xpos*3) + (ypos *len*3) +2] = cmap[CM_BLUE][v]; - - ++xpos; - if (xpos == len) { - xpos = 0; - if (interlace) { - switch (pass) { - case 0: - case 1: - ypos += 8; break; - case 2: - ypos += 4; break; - case 3: - ypos += 2; break; - } - - if (ypos >= height) { - ++pass; - switch (pass) { - case 1: - ypos = 4; break; - case 2: - ypos = 2; break; - case 3: - ypos = 1; break; - default: - return TCL_OK; - } - } - } else { - ++ypos; - } - } - if (ypos >= height) - break; - } - return TCL_OK; + cmap[CM_RED][transparent] = colorPtr->red >> 8; + cmap[CM_GREEN][transparent] = colorPtr->green >> 8; + cmap[CM_BLUE][transparent] = colorPtr->blue >> 8; + Tk_FreeColor(colorPtr); + } + } + + while ((v = LWZReadByte(fd,0,c)) >= 0 ) { + + imagePtr[ (xpos*3) + (ypos *len*3)] = cmap[CM_RED][v]; + imagePtr[ (xpos*3) + (ypos *len*3) +1] = cmap[CM_GREEN][v]; + imagePtr[ (xpos*3) + (ypos *len*3) +2] = cmap[CM_BLUE][v]; + + ++xpos; + if (xpos == len) { + xpos = 0; + if (interlace) { + switch (pass) { + case 0: + case 1: + ypos += 8; break; + case 2: + ypos += 4; break; + case 3: + ypos += 2; break; + } + + if (ypos >= height) { + ++pass; + switch (pass) { + case 1: + ypos = 4; break; + case 2: + ypos = 2; break; + case 3: + ypos = 1; break; + default: + return TCL_OK; + } + } + } else { + ++ypos; + } + } + if (ypos >= height) + break; + } + return TCL_OK; } static int @@ -635,128 +635,128 @@ FILE *fd; int flag; int input_code_size; { - static int fresh = 0; - int code, incode; - static int code_size, set_code_size; - static int max_code, max_code_size; - static int firstcode, oldcode; - static int clear_code, end_code; - static int table[2][(1<< MAX_LWZ_BITS)]; - static int stack[(1<<(MAX_LWZ_BITS))*2], *sp; - register int i; - - - if (flag) { - - set_code_size = input_code_size; - code_size = set_code_size+1; - clear_code = 1 << set_code_size ; - end_code = clear_code + 1; - max_code_size = 2*clear_code; - max_code = clear_code+2; - - GetCode(fd, 0, 1); - - fresh = 1; - - for (i = 0; i < clear_code; ++i) { - table[0][i] = 0; - table[1][i] = i; - } - for (; i < (1<<MAX_LWZ_BITS); ++i) { - table[0][i] = table[1][0] = 0; - } - - sp = stack; - - return 0; - - } else if (fresh) { - - fresh = 0; - do { - firstcode = oldcode = GetCode(fd, code_size, 0); - } while (firstcode == clear_code); - return firstcode; - } - - if (sp > stack) - return *--sp; - - while ((code = GetCode(fd, code_size, 0)) >= 0) { - if (code == clear_code) { - for (i = 0; i < clear_code; ++i) { - table[0][i] = 0; - table[1][i] = i; - } - - for (; i < (1<<MAX_LWZ_BITS); ++i) { - table[0][i] = table[1][i] = 0; - } - - code_size = set_code_size+1; - max_code_size = 2*clear_code; - max_code = clear_code+2; - sp = stack; - firstcode = oldcode = GetCode(fd, code_size, 0); - return firstcode; - - } else if (code == end_code) { - int count; - unsigned char buf[260]; - - if (ZeroDataBlock) - return -2; - - while ((count = GetDataBlock(fd, buf)) > 0) - ; - - if (count != 0) - return -2; - } - - incode = code; - - if (code >= max_code) { - *sp++ = firstcode; - code = oldcode; - } - - while (code >= clear_code) { - *sp++ = table[1][code]; - if (code == table[0][code]) { - return -2; - - fprintf(stderr, "circular table entry BIG ERROR\n"); - /* - * Used to be this instead, Steve Ball suggested - * the change to just return. - - printf("circular table entry BIG ERROR\n"); - */ - } - code = table[0][code]; - } - - *sp++ = firstcode = table[1][code]; - - if ((code = max_code) <(1<<MAX_LWZ_BITS)) { - - table[0][code] = oldcode; - table[1][code] = firstcode; - ++max_code; - if ((max_code>=max_code_size) && (max_code_size < (1<<MAX_LWZ_BITS))) { - max_code_size *= 2; - ++code_size; - } - } - - oldcode = incode; - - if (sp > stack) - return *--sp; - } - return code; + static int fresh = 0; + int code, incode; + static int code_size, set_code_size; + static int max_code, max_code_size; + static int firstcode, oldcode; + static int clear_code, end_code; + static int table[2][(1<< MAX_LWZ_BITS)]; + static int stack[(1<<(MAX_LWZ_BITS))*2], *sp; + register int i; + + + if (flag) { + + set_code_size = input_code_size; + code_size = set_code_size+1; + clear_code = 1 << set_code_size ; + end_code = clear_code + 1; + max_code_size = 2*clear_code; + max_code = clear_code+2; + + GetCode(fd, 0, 1); + + fresh = 1; + + for (i = 0; i < clear_code; ++i) { + table[0][i] = 0; + table[1][i] = i; + } + for (; i < (1<<MAX_LWZ_BITS); ++i) { + table[0][i] = table[1][0] = 0; + } + + sp = stack; + + return 0; + + } else if (fresh) { + + fresh = 0; + do { + firstcode = oldcode = GetCode(fd, code_size, 0); + } while (firstcode == clear_code); + return firstcode; + } + + if (sp > stack) + return *--sp; + + while ((code = GetCode(fd, code_size, 0)) >= 0) { + if (code == clear_code) { + for (i = 0; i < clear_code; ++i) { + table[0][i] = 0; + table[1][i] = i; + } + + for (; i < (1<<MAX_LWZ_BITS); ++i) { + table[0][i] = table[1][i] = 0; + } + + code_size = set_code_size+1; + max_code_size = 2*clear_code; + max_code = clear_code+2; + sp = stack; + firstcode = oldcode = GetCode(fd, code_size, 0); + return firstcode; + + } else if (code == end_code) { + int count; + unsigned char buf[260]; + + if (ZeroDataBlock) + return -2; + + while ((count = GetDataBlock(fd, buf)) > 0) + ; + + if (count != 0) + return -2; + } + + incode = code; + + if (code >= max_code) { + *sp++ = firstcode; + code = oldcode; + } + + while (code >= clear_code) { + *sp++ = table[1][code]; + if (code == table[0][code]) { + return -2; + + fprintf(stderr, "circular table entry BIG ERROR\n"); + /* + * Used to be this instead, Steve Ball suggested + * the change to just return. + + printf("circular table entry BIG ERROR\n"); + */ + } + code = table[0][code]; + } + + *sp++ = firstcode = table[1][code]; + + if ((code = max_code) <(1<<MAX_LWZ_BITS)) { + + table[0][code] = oldcode; + table[1][code] = firstcode; + ++max_code; + if ((max_code>=max_code_size) && (max_code_size < (1<<MAX_LWZ_BITS))) { + max_code_size *= 2; + ++code_size; + } + } + + oldcode = incode; + + if (sp > stack) + return *--sp; + } + return code; } @@ -766,118 +766,118 @@ FILE *fd; int code_size; int flag; { - static unsigned char buf[280]; - static int curbit, lastbit, done, last_byte; - int i, j, ret; - unsigned char count; + static unsigned char buf[280]; + static int curbit, lastbit, done, last_byte; + int i, j, ret; + unsigned char count; - if (flag) { - curbit = 0; - lastbit = 0; - done = 0; - return 0; - } + if (flag) { + curbit = 0; + lastbit = 0; + done = 0; + return 0; + } - if ( (curbit+code_size) >= lastbit) { - if (done) { - /* ran off the end of my bits */ - return -1; - } - buf[0] = buf[last_byte-2]; - buf[1] = buf[last_byte-1]; + if ( (curbit+code_size) >= lastbit) { + if (done) { + /* ran off the end of my bits */ + return -1; + } + buf[0] = buf[last_byte-2]; + buf[1] = buf[last_byte-1]; - if ((count = GetDataBlock(fd, &buf[2])) == 0) - done = 1; + if ((count = GetDataBlock(fd, &buf[2])) == 0) + done = 1; - last_byte = 2 + count; - curbit = (curbit - lastbit) + 16; - lastbit = (2+count)*8 ; - } + last_byte = 2 + count; + curbit = (curbit - lastbit) + 16; + lastbit = (2+count)*8 ; + } - ret = 0; - for (i = curbit, j = 0; j < code_size; ++i, ++j) - ret |= ((buf[ i / 8 ] & (1 << (i % 8))) != 0) << j; + ret = 0; + for (i = curbit, j = 0; j < code_size; ++i, ++j) + ret |= ((buf[ i / 8 ] & (1 << (i % 8))) != 0) << j; - curbit += code_size; + curbit += code_size; - return ret; + return ret; } int Tk_AnimationCmd(clientData, interp, argc, argv) - ClientData clientData; /* Main window associated with interpreter. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + ClientData clientData; /* Main window associated with interpreter. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ { char c; int length; if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " option ?arg arg ...?\"", (char *) NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; } c = argv[1][0]; length = strlen(argv[1]); if((c == 'c') && (length >= 2) && (strncmp(argv[1], "create", length) == 0)) { - char * realFileName; - Tcl_DString buffer; - FILE *f; + char * realFileName; + Tcl_DString buffer; + FILE *f; #ifdef TKANIM_DEBUG fprintf(stderr, "AnimationCmd => create "); #endif - if ( argc != 3 ){ - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " create GifFile\"", (char *) NULL); - return TCL_ERROR; - } + if ( argc != 3 ){ + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " create GifFile\"", (char *) NULL); + return TCL_ERROR; + } #ifdef TKANIM_DEBUG fprintf(stderr, "\n\tRealFileName = "); #endif - realFileName = Tcl_TranslateFileName(interp, argv[2], - &buffer); - if(realFileName == NULL) { - Tcl_DStringFree(&buffer); - return TCL_ERROR; - } + realFileName = Tcl_TranslateFileName(interp, argv[2], + &buffer); + if(realFileName == NULL) { + Tcl_DStringFree(&buffer); + return TCL_ERROR; + } #ifdef TKANIM_DEBUG fprintf(stderr, "%s ", realFileName); #endif #ifdef TKANIM_DEBUG fprintf(stderr, "\n\tOpen ", realFileName); #endif - f = fopen(realFileName, "rb"); - Tcl_DStringFree(&buffer); - if (f == NULL ){ - Tcl_AppendResult(interp, "couldn't read image file \"", - argv[2], "\": ", Tcl_PosixError(interp), - (char *) NULL); - return TCL_ERROR; - } + f = fopen(realFileName, "rb"); + Tcl_DStringFree(&buffer); + if (f == NULL ){ + Tcl_AppendResult(interp, "couldn't read image file \"", + argv[2], "\": ", Tcl_PosixError(interp), + (char *) NULL); + return TCL_ERROR; + } #ifdef TKANIM_DEBUG fprintf(stderr, "success ", realFileName); #endif #ifdef TKANIM_DEBUG fprintf(stderr, "\n\tRead ", realFileName); #endif - if( FileReadGIF(interp, f, argv[2], "gif") != TCL_OK ){ + if( FileReadGIF(interp, f, argv[2], "gif") != TCL_OK ){ #ifdef TKANIM_DEBUG - fprintf(stderr, "\n\tRead failed", realFileName); + fprintf(stderr, "\n\tRead failed", realFileName); #endif - return TCL_ERROR; - } - fclose(f); + return TCL_ERROR; + } + fclose(f); #ifdef TKANIM_DEBUG fprintf(stderr, "\n\tRead done", realFileName); #endif #ifdef TKANIM_DEBUG - fprintf(stderr, "done\n"); + fprintf(stderr, "done\n"); #endif } return TCL_OK; @@ -899,8 +899,8 @@ int Tkanim_Init(interp) fprintf(stderr, "Tkanim initialize..."); #endif Tcl_CreateCommand(interp, "animation", Tk_AnimationCmd, - (ClientData) NULL, - (Tcl_CmdDeleteProc *) TkDeleteTkAnim); + (ClientData) NULL, + (Tcl_CmdDeleteProc *) TkDeleteTkAnim); #ifdef TKANIM_DEBUG fprintf(stderr, "done\n"); #endif diff --git a/otherlibs/labltk/tkanim/tkAppInit.c b/otherlibs/labltk/tkanim/tkAppInit.c index 932a37fc1..60807d915 100644 --- a/otherlibs/labltk/tkanim/tkAppInit.c +++ b/otherlibs/labltk/tkanim/tkAppInit.c @@ -16,8 +16,8 @@ /* * tkAppInit.c -- * - * Provides a default version of the Tcl_AppInit procedure for - * use in wish and similar Tk-based applications. + * Provides a default version of the Tcl_AppInit procedure for + * use in wish and similar Tk-based applications. * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. @@ -32,7 +32,7 @@ static char sccsid[] = "@(#) tkAppInit.c 1.19 95/12/23 17:09:24"; #include "tk.h" -int Tkanimation_Init _ANSI_ARGS_ ((Tcl_Interp *interp)); +int Tkanimation_Init _ANSI_ARGS_ ((Tcl_Interp *interp)); /* * The following variable is a special hack that is needed in order for @@ -43,7 +43,7 @@ extern int matherr(); int *tclDummyMathPtr = (int *) matherr; #ifdef TK_TEST -EXTERN int Tktest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int Tktest_Init _ANSI_ARGS_((Tcl_Interp *interp)); #endif /* TK_TEST */ /* @@ -51,25 +51,25 @@ EXTERN int Tktest_Init _ANSI_ARGS_((Tcl_Interp *interp)); * * main -- * - * This is the main program for the application. + * This is the main program for the application. * * Results: - * None: Tk_Main never returns here, so this procedure never - * returns either. + * None: Tk_Main never returns here, so this procedure never + * returns either. * * Side effects: - * Whatever the application does. + * Whatever the application does. * *---------------------------------------------------------------------- */ int main(argc, argv) - int argc; /* Number of command-line arguments. */ - char **argv; /* Values of command-line arguments. */ + int argc; /* Number of command-line arguments. */ + char **argv; /* Values of command-line arguments. */ { Tk_Main(argc, argv, Tcl_AppInit); - return 0; /* Needed only to prevent compiler warning. */ + return 0; /* Needed only to prevent compiler warning. */ } /* @@ -77,34 +77,34 @@ main(argc, argv) * * Tcl_AppInit -- * - * This procedure performs application-specific initialization. - * Most applications, especially those that incorporate additional - * packages, will have their own version of this procedure. + * This procedure performs application-specific initialization. + * Most applications, especially those that incorporate additional + * packages, will have their own version of this procedure. * * Results: - * Returns a standard Tcl completion code, and leaves an error - * message in interp->result if an error occurs. + * Returns a standard Tcl completion code, and leaves an error + * message in interp->result if an error occurs. * * Side effects: - * Depends on the startup script. + * Depends on the startup script. * *---------------------------------------------------------------------- */ int Tcl_AppInit(interp) - Tcl_Interp *interp; /* Interpreter for application. */ + Tcl_Interp *interp; /* Interpreter for application. */ { if (Tcl_Init(interp) == TCL_ERROR) { - return TCL_ERROR; + return TCL_ERROR; } if (Tk_Init(interp) == TCL_ERROR) { - return TCL_ERROR; + return TCL_ERROR; } Tcl_StaticPackage(interp, "Tk", Tk_Init, (Tcl_PackageInitProc *) NULL); #ifdef TK_TEST if (Tktest_Init(interp) == TCL_ERROR) { - return TCL_ERROR; + return TCL_ERROR; } #endif /* TK_TEST */ @@ -121,7 +121,7 @@ Tcl_AppInit(interp) */ if (Tkanim_Init(interp) == TCL_ERROR) { - return TCL_ERROR; + return TCL_ERROR; } /* diff --git a/otherlibs/labltk/tkanim/tkanim.mli b/otherlibs/labltk/tkanim/tkanim.mli index 26f425035..e83ceb9bd 100644 --- a/otherlibs/labltk/tkanim/tkanim.mli +++ b/otherlibs/labltk/tkanim/tkanim.mli @@ -31,7 +31,7 @@ type imageType = (* This data type is required to distinguish normal still images and animated gifs. Usually objects typed imagePhoto or - imageBitmap are used for Still. *) + imageBitmap are used for Still. *) (*** Flags ***) @@ -47,8 +47,8 @@ val init : unit -> unit val available : unit -> bool (* [available ()] returns true if there is Tkanim Tcl/Tk - extension linked statically/dynamically in Tcl/Tk - interpreter. Otherwise, return false. *) + extension linked statically/dynamically in Tcl/Tk + interpreter. Otherwise, return false. *) (*** User interface ***) @@ -56,24 +56,24 @@ val available : unit -> bool val create : string -> imageType (* [create file] loads a gif87 or gif89 image file and parse it, - and returns [Animated animated_gif] if the image file has - more than one images. Otherwise, it returns - [Still (ImagePhoto image_photo)] *) + and returns [Animated animated_gif] if the image file has + more than one images. Otherwise, it returns + [Still (ImagePhoto image_photo)] *) val delete : animatedGif -> unit (* [delete anim] deletes all the images in anim. Usually animatedGifs contain many images, so you must not forget to - use this function to free the memory. *) + use this function to free the memory. *) val width : animatedGif -> int val height : animatedGif -> int (* [width anim] and [height anim] return the width and height of - given animated gif. *) + given animated gif. *) val images : animatedGif -> imagePhoto list (* [images anim] returns the list of still images used in the - animation *) + animation *) val animate : widget -> animatedGif -> bool -> unit val animate_canvas_item : widget -> tagOrId -> animatedGif -> bool -> unit @@ -92,4 +92,4 @@ val animate_canvas_item : widget -> tagOrId -> animatedGif -> bool -> unit val gifdata : string -> imageType (* [gifdata data] reads [data] as a row data of a gif file and - decodes it. *) + decodes it. *) diff --git a/otherlibs/num/Makefile.Mac b/otherlibs/num/Makefile.Mac index cf8a53fed..6e3c1e5fd 100644 --- a/otherlibs/num/Makefile.Mac +++ b/otherlibs/num/Makefile.Mac @@ -61,4 +61,4 @@ depend Ä begin MakeDepend -w -objext .x Å.c :::boot:ocamlrun :::tools:ocamldep Å.mli Å.ml - end | streamedit -e "/¶t/ replace // ' ' -c °" > Makefile.Mac.depend + end | streamedit -e "/¶t/ replace // ' ' -c °" > Makefile.Mac.depend diff --git a/otherlibs/unix/sockopt.c b/otherlibs/unix/sockopt.c index 1bef4f631..437074f93 100644 --- a/otherlibs/unix/sockopt.c +++ b/otherlibs/unix/sockopt.c @@ -1,14 +1,14 @@ /***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ -/* */ +/* */ /***********************************************************************/ /* $Id$ */ @@ -93,7 +93,7 @@ CAMLprim value getsockopt_int(int *sockopt, value socket, optsize = sizeof(optval); if (getsockopt(Int_val(socket), level, sockopt[Int_val(option)], - (void *) &optval, &optsize) == -1) + (void *) &optval, &optsize) == -1) uerror("getsockopt", Nothing); return Val_int(optval); } @@ -103,7 +103,7 @@ CAMLprim value setsockopt_int(int *sockopt, value socket, int level, { int optval = Int_val(status); if (setsockopt(Int_val(socket), level, sockopt[Int_val(option)], - (void *) &optval, sizeof(optval)) == -1) + (void *) &optval, sizeof(optval)) == -1) uerror("setsockopt", Nothing); return Val_unit; } @@ -131,11 +131,11 @@ CAMLprim value getsockopt_optint(int *sockopt, value socket, { struct linger optval; socklen_param_type optsize; - value res = Val_int(0); /* None */ + value res = Val_int(0); /* None */ optsize = sizeof(optval); if (getsockopt(Int_val(socket), level, sockopt[Int_val(option)], - (void *) &optval, &optsize) == -1) + (void *) &optval, &optsize) == -1) uerror("getsockopt_optint", Nothing); if (optval.l_onoff != 0) { res = alloc_small(1, 0); @@ -153,7 +153,7 @@ CAMLprim value setsockopt_optint(int *sockopt, value socket, int level, if (optval.l_onoff) optval.l_linger = Int_val (Field (status, 0)); if (setsockopt(Int_val(socket), level, sockopt[Int_val(option)], - (void *) &optval, sizeof(optval)) == -1) + (void *) &optval, sizeof(optval)) == -1) uerror("setsockopt_optint", Nothing); return Val_unit; } @@ -176,7 +176,7 @@ CAMLprim value getsockopt_float(int *sockopt, value socket, optsize = sizeof(tv); if (getsockopt(Int_val(socket), level, sockopt[Int_val(option)], - (void *) &tv, &optsize) == -1) + (void *) &tv, &optsize) == -1) uerror("getsockopt_float", Nothing); return copy_double((double) tv.tv_sec + (double) tv.tv_usec / 1e6); } @@ -191,7 +191,7 @@ CAMLprim value setsockopt_float(int *sockopt, value socket, int level, tv.tv_sec = (int)tv_f; tv.tv_usec = (int) (1e6 * (tv_f - tv.tv_sec)); if (setsockopt(Int_val(socket), level, sockopt[Int_val(option)], - (void *) &tv, sizeof(tv)) == -1) + (void *) &tv, sizeof(tv)) == -1) uerror("setsockopt_float", Nothing); return Val_unit; } diff --git a/otherlibs/win32graph/dib.c b/otherlibs/win32graph/dib.c index dcbe6b10e..d881a0281 100644 --- a/otherlibs/win32graph/dib.c +++ b/otherlibs/win32graph/dib.c @@ -300,8 +300,8 @@ static HANDLE ReadDIBFile (int hFile,int dwBitsSize) if ((_lread (hFile, (LPSTR) &bmfHeader, sizeof (bmfHeader)) != sizeof (bmfHeader)) || (bmfHeader.bfType != DIB_HEADER_MARKER)) { - // ShowDbgMsg("Not a DIB file!"); - return NULL; + // ShowDbgMsg("Not a DIB file!"); + return NULL; } // Allocate memory for DIB @@ -310,8 +310,8 @@ static HANDLE ReadDIBFile (int hFile,int dwBitsSize) if (hDIB == 0) { - // ShowDbgMsg("Couldn't allocate memory!"); - return NULL; + // ShowDbgMsg("Couldn't allocate memory!"); + return NULL; } pDIB = GlobalLock (hDIB); @@ -398,19 +398,19 @@ static void DIBPaint (HDC hDC,LPRECT lpDCRect,HANDLE hDIB) return; // Lock down the DIB, and get a pointer to the beginning of the bit // buffer. - lpDIBHdr = GlobalLock (hDIB); - lpDIBBits = FindDIBBits (lpDIBHdr); + lpDIBHdr = GlobalLock (hDIB); + lpDIBBits = FindDIBBits (lpDIBHdr); // Make sure to use the stretching mode best for color pictures. - SetStretchBltMode (hDC, COLORONCOLOR); - SetDIBitsToDevice (hDC, // hDC + SetStretchBltMode (hDC, COLORONCOLOR); + SetDIBitsToDevice (hDC, // hDC lpDCRect->left, // DestX lpDCRect->top, // DestY RECTWIDTH (lpDCRect), // nDestWidth RECTHEIGHT (lpDCRect), // nDestHeight - 0, // SrcX + 0, // SrcX 0, // (int) DIBHeight (lpDIBHdr), // SrcY - 0, // nStartScan + 0, // nStartScan (WORD) DIBHeight (lpDIBHdr), // nNumScans lpDIBBits, // lpBits (LPBITMAPINFO) lpDIBHdr, // lpBitsInfo @@ -421,76 +421,76 @@ static void DIBPaint (HDC hDC,LPRECT lpDCRect,HANDLE hDIB) static unsigned int Getfilesize(char *name) { - FILE *f; - unsigned int size; - - f = fopen(name,"rb"); - if (f == NULL) - return 0; - fseek(f,0,SEEK_END); - size = ftell(f); - fclose(f); - return size; + FILE *f; + unsigned int size; + + f = fopen(name,"rb"); + if (f == NULL) + return 0; + fseek(f,0,SEEK_END); + size = ftell(f); + fclose(f); + return size; } HANDLE ChargerBitmap(char *FileName,POINT *lppt) { - HFILE hFile; - OFSTRUCT ofstruct; - HANDLE result; - LPSTR lpDIBHdr; - unsigned int size; - - size = Getfilesize(FileName); - hFile=OpenFile((LPSTR) FileName, &ofstruct, OF_READ | OF_SHARE_DENY_WRITE); - result = ReadDIBFile(hFile,size); - if (hFile) _lclose(hFile); - if (result) { - LPBITMAPINFOHEADER lpbmi; - LPBITMAPCOREHEADER lpbmc; - - lpDIBHdr = GlobalLock (result); - lpbmi = (LPBITMAPINFOHEADER) lpDIBHdr; - lpbmc = (LPBITMAPCOREHEADER) lpDIBHdr; - - if (lpbmi->biSize == sizeof (BITMAPINFOHEADER)) { - lppt->y = lpbmi->biHeight; - lppt->x = lpbmi->biWidth; - } - else { - lppt->y = lpbmc->bcHeight; - lppt->x = lpbmc->bcWidth; - } - GlobalUnlock(result); - } - return(result); + HFILE hFile; + OFSTRUCT ofstruct; + HANDLE result; + LPSTR lpDIBHdr; + unsigned int size; + + size = Getfilesize(FileName); + hFile=OpenFile((LPSTR) FileName, &ofstruct, OF_READ | OF_SHARE_DENY_WRITE); + result = ReadDIBFile(hFile,size); + if (hFile) _lclose(hFile); + if (result) { + LPBITMAPINFOHEADER lpbmi; + LPBITMAPCOREHEADER lpbmc; + + lpDIBHdr = GlobalLock (result); + lpbmi = (LPBITMAPINFOHEADER) lpDIBHdr; + lpbmc = (LPBITMAPCOREHEADER) lpDIBHdr; + + if (lpbmi->biSize == sizeof (BITMAPINFOHEADER)) { + lppt->y = lpbmi->biHeight; + lppt->x = lpbmi->biWidth; + } + else { + lppt->y = lpbmc->bcHeight; + lppt->x = lpbmc->bcWidth; + } + GlobalUnlock(result); + } + return(result); } void DessinerBitmap(HANDLE hDIB,HDC hDC,LPRECT lpDCRect) { - DIBPaint (hDC, + DIBPaint (hDC, lpDCRect, hDIB); } void AfficheBitmap(char *filename,HDC hDC,int x,int y) { - RECT rc; - HANDLE hdib; - POINT pt; - char titi[60]; - - hdib = ChargerBitmap(filename,&pt); - if (hdib == NULL) { - return; + RECT rc; + HANDLE hdib; + POINT pt; + char titi[60]; + + hdib = ChargerBitmap(filename,&pt); + if (hdib == NULL) { + return; } - rc.top = y; - rc.left = x; - rc.right = pt.x+x; - rc.bottom = pt.y+y; - pt.y += GetSystemMetrics(SM_CYCAPTION); - DessinerBitmap(hdib,hDC,&rc); - GlobalFree(hdib); + rc.top = y; + rc.left = x; + rc.right = pt.x+x; + rc.bottom = pt.y+y; + pt.y += GetSystemMetrics(SM_CYCAPTION); + DessinerBitmap(hdib,hDC,&rc); + GlobalFree(hdib); } diff --git a/otherlibs/win32graph/draw.c b/otherlibs/win32graph/draw.c index 785942f3e..960eb186f 100644 --- a/otherlibs/win32graph/draw.c +++ b/otherlibs/win32graph/draw.c @@ -26,389 +26,389 @@ GR_WINDOW grwindow; static void GetCurrentPosition(HDC hDC,POINT *pt) { - MoveToEx(hDC,0,0,pt); - MoveToEx(hDC,pt->x,pt->y,0); + MoveToEx(hDC,0,0,pt); + MoveToEx(hDC,pt->x,pt->y,0); } static value gr_draw_or_fill_arc(value *argv,int argc,BOOL fill); CAMLprim value gr_plot(value vx, value vy) { - int x = Int_val(vx); - int y = Int_val(vy); - gr_check_open(); - // gr_moveto(vx,vy); - // gr_lineto(Val_int(Int_val(vx)+1),vy); - // return Val_unit; - if(grremember_mode) - SetPixel(grwindow.gcBitmap, x, Wcvt(y),grwindow.CurrentColor); - if(grdisplay_mode) { - SetPixel(grwindow.gc, x, Wcvt(y),grwindow.CurrentColor); - } - // gr_moveto(vx+1,vy); - return Val_unit; + int x = Int_val(vx); + int y = Int_val(vy); + gr_check_open(); + // gr_moveto(vx,vy); + // gr_lineto(Val_int(Int_val(vx)+1),vy); + // return Val_unit; + if(grremember_mode) + SetPixel(grwindow.gcBitmap, x, Wcvt(y),grwindow.CurrentColor); + if(grdisplay_mode) { + SetPixel(grwindow.gc, x, Wcvt(y),grwindow.CurrentColor); + } + // gr_moveto(vx+1,vy); + return Val_unit; } CAMLprim value gr_moveto(value vx, value vy) { - grwindow.grx = Int_val(vx); - grwindow.gry = Int_val(vy); - if(grremember_mode) - MoveToEx(grwindow.gcBitmap,grwindow.grx,Wcvt(grwindow.gry),0); - if (grdisplay_mode) - MoveToEx(grwindow.gc,grwindow.grx,Wcvt(grwindow.gry),0); - return Val_unit; + grwindow.grx = Int_val(vx); + grwindow.gry = Int_val(vy); + if(grremember_mode) + MoveToEx(grwindow.gcBitmap,grwindow.grx,Wcvt(grwindow.gry),0); + if (grdisplay_mode) + MoveToEx(grwindow.gc,grwindow.grx,Wcvt(grwindow.gry),0); + return Val_unit; } CAMLprim value gr_current_x(void) { - return Val_int(grwindow.grx); + return Val_int(grwindow.grx); } CAMLprim value gr_current_y(void) { - return Val_int(grwindow.gry); + return Val_int(grwindow.gry); } CAMLprim value gr_lineto(value vx, value vy) { - int x = Int_val(vx); - int y = Int_val(vy); - gr_check_open(); - SelectObject(grwindow.gc,grwindow.CurrentPen); - SelectObject(grwindow.gcBitmap,grwindow.CurrentPen); - if (grremember_mode) - LineTo(grwindow.gcBitmap,x,Wcvt(y)); - if (grdisplay_mode) - LineTo(grwindow.gc, x, Wcvt(y)); - grwindow.grx = x; - grwindow.gry = y; - return Val_unit; + int x = Int_val(vx); + int y = Int_val(vy); + gr_check_open(); + SelectObject(grwindow.gc,grwindow.CurrentPen); + SelectObject(grwindow.gcBitmap,grwindow.CurrentPen); + if (grremember_mode) + LineTo(grwindow.gcBitmap,x,Wcvt(y)); + if (grdisplay_mode) + LineTo(grwindow.gc, x, Wcvt(y)); + grwindow.grx = x; + grwindow.gry = y; + return Val_unit; } CAMLprim value gr_draw_rect(value vx, value vy, value vw, value vh) { #if 0 - int x = Int_val(vx); - int y = Int_val(vy); - int w = Int_val(vw); - int h = Int_val(vh); - - gr_check_open(); - if(grdisplay_mode) { - Rectangle(grwindow.gc,x, Wcvt(y) , x+w, Wcvt(y+h)); - } - if(grremember_mode) { - Rectangle(grwindow.gcBitmap,x, Wcvt(y), x+w, Wcvt(h+y)); - } - return Val_unit; + int x = Int_val(vx); + int y = Int_val(vy); + int w = Int_val(vw); + int h = Int_val(vh); + + gr_check_open(); + if(grdisplay_mode) { + Rectangle(grwindow.gc,x, Wcvt(y) , x+w, Wcvt(y+h)); + } + if(grremember_mode) { + Rectangle(grwindow.gcBitmap,x, Wcvt(y), x+w, Wcvt(h+y)); + } + return Val_unit; #else - // (x,y)=top bottom - int x, y, w, h; - POINT pt[5]; - x=Int_val(vx); - y=Int_val(vy); - w=Int_val(vw); - h=Int_val(vh); - - // pt[0].x = x; pt[0].y = UD(y+h-1); - pt[0].x = x; - pt[0].y = Wcvt(y-1); - pt[1].x = x+w; - pt[1].y = pt[0].y; - // pt[2].x = pt[1].x; pt[2].y = UD(y-1); - pt[2].x = pt[1].x; - pt[2].y = Wcvt(y+h-1); - pt[3].x = pt[0].x; - pt[3].y = pt[2].y; - pt[4].x = pt[0].x; - pt[4].y = pt[0].y; - if (grremember_mode) { - Polyline(grwindow.gcBitmap,pt, 5); - } - if (grdisplay_mode) { - Polyline(grwindow.gc,pt, 5); - } - return Val_unit; + // (x,y)=top bottom + int x, y, w, h; + POINT pt[5]; + x=Int_val(vx); + y=Int_val(vy); + w=Int_val(vw); + h=Int_val(vh); + + // pt[0].x = x; pt[0].y = UD(y+h-1); + pt[0].x = x; + pt[0].y = Wcvt(y-1); + pt[1].x = x+w; + pt[1].y = pt[0].y; + // pt[2].x = pt[1].x; pt[2].y = UD(y-1); + pt[2].x = pt[1].x; + pt[2].y = Wcvt(y+h-1); + pt[3].x = pt[0].x; + pt[3].y = pt[2].y; + pt[4].x = pt[0].x; + pt[4].y = pt[0].y; + if (grremember_mode) { + Polyline(grwindow.gcBitmap,pt, 5); + } + if (grdisplay_mode) { + Polyline(grwindow.gc,pt, 5); + } + return Val_unit; #endif } CAMLprim value gr_draw_text(value text,value x) { - POINT pt; - int oldmode = SetBkMode(grwindow.gc,TRANSPARENT); - SetBkMode(grwindow.gcBitmap,TRANSPARENT); - SetTextAlign(grwindow.gcBitmap, TA_UPDATECP|TA_BOTTOM); - SetTextAlign(grwindow.gc, TA_UPDATECP|TA_BOTTOM); - if (grremember_mode) { - TextOut(grwindow.gcBitmap,0,0,(char *)text,x); - } - if(grdisplay_mode) { - TextOut(grwindow.gc,0,0,(char *)text,x); - } - GetCurrentPosition(grwindow.gc,&pt); - grwindow.grx = pt.x; - grwindow.gry = grwindow.height - pt.y; - SetBkMode(grwindow.gc,oldmode); - SetBkMode(grwindow.gcBitmap,oldmode); - return Val_unit; + POINT pt; + int oldmode = SetBkMode(grwindow.gc,TRANSPARENT); + SetBkMode(grwindow.gcBitmap,TRANSPARENT); + SetTextAlign(grwindow.gcBitmap, TA_UPDATECP|TA_BOTTOM); + SetTextAlign(grwindow.gc, TA_UPDATECP|TA_BOTTOM); + if (grremember_mode) { + TextOut(grwindow.gcBitmap,0,0,(char *)text,x); + } + if(grdisplay_mode) { + TextOut(grwindow.gc,0,0,(char *)text,x); + } + GetCurrentPosition(grwindow.gc,&pt); + grwindow.grx = pt.x; + grwindow.gry = grwindow.height - pt.y; + SetBkMode(grwindow.gc,oldmode); + SetBkMode(grwindow.gcBitmap,oldmode); + return Val_unit; } CAMLprim value gr_fill_rect(value vx, value vy, value vw, value vh) { - int x = Int_val(vx); - int y = Int_val(vy); - int w = Int_val(vw); - int h = Int_val(vh); - RECT rc; + int x = Int_val(vx); + int y = Int_val(vy); + int w = Int_val(vw); + int h = Int_val(vh); + RECT rc; - gr_check_open(); - rc.left = x; - rc.top = Wcvt(y); - rc.right = x+w; - rc.bottom = Wcvt(y)-h; - if (grdisplay_mode) - FillRect(grwindow.gc,&rc,grwindow.CurrentBrush); - if (grremember_mode) - FillRect(grwindow.gcBitmap,&rc,grwindow.CurrentBrush); - return Val_unit; + gr_check_open(); + rc.left = x; + rc.top = Wcvt(y); + rc.right = x+w; + rc.bottom = Wcvt(y)-h; + if (grdisplay_mode) + FillRect(grwindow.gc,&rc,grwindow.CurrentBrush); + if (grremember_mode) + FillRect(grwindow.gcBitmap,&rc,grwindow.CurrentBrush); + return Val_unit; } CAMLprim value gr_sound(value freq, value vdur) { - Beep(freq,vdur); - return Val_unit; + Beep(freq,vdur); + return Val_unit; } CAMLprim value gr_point_color(value vx, value vy) { - int x = Int_val(vx); - int y = Int_val(vy); - COLORREF rgb; - unsigned long b,g,r; + int x = Int_val(vx); + int y = Int_val(vy); + COLORREF rgb; + unsigned long b,g,r; - gr_check_open(); - rgb = GetPixel(grwindow.gcBitmap,x,Wcvt(y)); - b = (unsigned long)((rgb & 0xFF0000) >> 16); - g = (unsigned long)((rgb & 0x00FF00) >> 8); - r = (unsigned long)(rgb & 0x0000FF); - return Val_long((r<<16) + (g<<8) + b); + gr_check_open(); + rgb = GetPixel(grwindow.gcBitmap,x,Wcvt(y)); + b = (unsigned long)((rgb & 0xFF0000) >> 16); + g = (unsigned long)((rgb & 0x00FF00) >> 8); + r = (unsigned long)(rgb & 0x0000FF); + return Val_long((r<<16) + (g<<8) + b); } CAMLprim value gr_circle(value x,value y,value radius) { - int left,top,right,bottom; + int left,top,right,bottom; - gr_check_open(); - left = x - radius/2; - top = Wcvt(y) - radius/2; - right = left+radius; - bottom = top+radius; - Ellipse(grwindow.gcBitmap,left,top,right,bottom); - return Val_unit; + gr_check_open(); + left = x - radius/2; + top = Wcvt(y) - radius/2; + right = left+radius; + bottom = top+radius; + Ellipse(grwindow.gcBitmap,left,top,right,bottom); + return Val_unit; } CAMLprim value gr_set_window_title(value text) { - SetWindowText(grwindow.hwnd,(char *)text); - return Val_unit; + SetWindowText(grwindow.hwnd,(char *)text); + return Val_unit; } CAMLprim value gr_draw_arc(value *argv ,int argc) { - return gr_draw_or_fill_arc(argv,argc,FALSE); + return gr_draw_or_fill_arc(argv,argc,FALSE); } CAMLprim value gr_set_line_width(value vwidth) { - int width = Int_val(vwidth); - HPEN oldPen,newPen; + int width = Int_val(vwidth); + HPEN oldPen,newPen; - gr_check_open(); - oldPen = grwindow.CurrentPen; - newPen = CreatePen(PS_SOLID,width,grwindow.CurrentColor); - SelectObject(grwindow.gcBitmap,newPen); - SelectObject(grwindow.gc,newPen); - DeleteObject(oldPen); - grwindow.CurrentPen = newPen; - return Val_unit; + gr_check_open(); + oldPen = grwindow.CurrentPen; + newPen = CreatePen(PS_SOLID,width,grwindow.CurrentColor); + SelectObject(grwindow.gcBitmap,newPen); + SelectObject(grwindow.gc,newPen); + DeleteObject(oldPen); + grwindow.CurrentPen = newPen; + return Val_unit; } CAMLprim value gr_set_color(value vcolor) { - HBRUSH oldBrush, newBrush; - LOGBRUSH lb; - LOGPEN pen; - HPEN newPen; - int color = Long_val(vcolor); - - int r = (color & 0xFF0000) >> 16, - g = (color & 0x00FF00) >> 8 , - b = color & 0x0000FF; - COLORREF c = RGB(r,g,b); - memset(&lb,0,sizeof(lb)); - memset(&pen,0,sizeof(LOGPEN)); - gr_check_open(); - GetObject(grwindow.CurrentPen,sizeof(LOGPEN),&pen); - pen.lopnColor = c; - newPen = CreatePenIndirect(&pen); - SelectObject(grwindow.gcBitmap,newPen); - SelectObject(grwindow.gc,newPen); - DeleteObject(grwindow.CurrentPen); - grwindow.CurrentPen = newPen; - SetTextColor(grwindow.gc,c); - SetTextColor(grwindow.gcBitmap,c); - // printf("gr_set_color, vcolor = %x, lbColor = %x\n", Int_val(vcolor), lb.lbColor); - oldBrush = grwindow.CurrentBrush; - lb.lbStyle = BS_SOLID; - lb.lbColor = c; - newBrush = CreateBrushIndirect(&lb); - SelectObject(grwindow.gc,newBrush); - SelectObject(grwindow.gcBitmap,newBrush); - DeleteObject(oldBrush); - grwindow.CurrentBrush = newBrush; - grwindow.CurrentColor = c; - return Val_unit; + HBRUSH oldBrush, newBrush; + LOGBRUSH lb; + LOGPEN pen; + HPEN newPen; + int color = Long_val(vcolor); + + int r = (color & 0xFF0000) >> 16, + g = (color & 0x00FF00) >> 8 , + b = color & 0x0000FF; + COLORREF c = RGB(r,g,b); + memset(&lb,0,sizeof(lb)); + memset(&pen,0,sizeof(LOGPEN)); + gr_check_open(); + GetObject(grwindow.CurrentPen,sizeof(LOGPEN),&pen); + pen.lopnColor = c; + newPen = CreatePenIndirect(&pen); + SelectObject(grwindow.gcBitmap,newPen); + SelectObject(grwindow.gc,newPen); + DeleteObject(grwindow.CurrentPen); + grwindow.CurrentPen = newPen; + SetTextColor(grwindow.gc,c); + SetTextColor(grwindow.gcBitmap,c); + // printf("gr_set_color, vcolor = %x, lbColor = %x\n", Int_val(vcolor), lb.lbColor); + oldBrush = grwindow.CurrentBrush; + lb.lbStyle = BS_SOLID; + lb.lbColor = c; + newBrush = CreateBrushIndirect(&lb); + SelectObject(grwindow.gc,newBrush); + SelectObject(grwindow.gcBitmap,newBrush); + DeleteObject(oldBrush); + grwindow.CurrentBrush = newBrush; + grwindow.CurrentColor = c; + return Val_unit; } static value gr_draw_or_fill_arc(value *argv,int argc,BOOL fill) { - int x, y, r_x, r_y, start, end; - int x1, y1, x2, y2, x3, y3, x4, y4; - double cvt = 3.141592653/180.0; - // HPEN newPen = CreatePen(PS_SOLID,1,grwindow.CurrentColor); - HPEN oldPen; - - r_x = Int_val(argv[2]); - r_y = Int_val(argv[3]); - if ((r_x < 0) || (r_y < 0)) - invalid_argument("draw_arc: radius must be positive"); - x = Int_val(argv[0]); - y = Int_val(argv[1]); - start = Int_val(argv[4]); - end = Int_val(argv[5]); - - // Upper-left corner of bounding rect. - x1= x - r_x; - y1= y + r_y; - // Lower-right corner of bounding rect. - x2= x + r_x; - y2= y - r_y; - // Starting point - x3=x + (int)(100.0*cos(cvt*start)); - y3=y + (int)(100.0*sin(cvt*start)); - // Ending point - x4=x + (int)(100.0*cos(cvt*end)); - y4=y + (int)(100.0*sin(cvt*end)); - - if (grremember_mode) { - oldPen = SelectObject(grwindow.gcBitmap,grwindow.CurrentPen); - SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush); - if( fill ) - Pie(grwindow.gcBitmap,x1, UD(y1), x2, UD(y2), - x3, UD(y3), x4, UD(y4)); - else - Arc(grwindow.gcBitmap,x1, UD(y1), x2, UD(y2), - x3, UD(y3), x4, UD(y4)); - // SelectObject(grwindow.gcBitmap,oldPen); - } - if( grdisplay_mode ) { - oldPen = SelectObject(grwindow.gc,grwindow.CurrentPen); - SelectObject(grwindow.gc,grwindow.CurrentBrush); - if (fill) - Pie(grwindow.gc,x1, UD(y1), x2, UD(y2), - x3, UD(y3), x4, UD(y4)); - else - Arc(grwindow.gc,x1, UD(y1), x2, UD(y2), - x3, UD(y3), x4, UD(y4)); - // SelectObject(grwindow.gc,oldPen); - } - // DeleteObject(newPen); - return Val_unit; + int x, y, r_x, r_y, start, end; + int x1, y1, x2, y2, x3, y3, x4, y4; + double cvt = 3.141592653/180.0; + // HPEN newPen = CreatePen(PS_SOLID,1,grwindow.CurrentColor); + HPEN oldPen; + + r_x = Int_val(argv[2]); + r_y = Int_val(argv[3]); + if ((r_x < 0) || (r_y < 0)) + invalid_argument("draw_arc: radius must be positive"); + x = Int_val(argv[0]); + y = Int_val(argv[1]); + start = Int_val(argv[4]); + end = Int_val(argv[5]); + + // Upper-left corner of bounding rect. + x1= x - r_x; + y1= y + r_y; + // Lower-right corner of bounding rect. + x2= x + r_x; + y2= y - r_y; + // Starting point + x3=x + (int)(100.0*cos(cvt*start)); + y3=y + (int)(100.0*sin(cvt*start)); + // Ending point + x4=x + (int)(100.0*cos(cvt*end)); + y4=y + (int)(100.0*sin(cvt*end)); + + if (grremember_mode) { + oldPen = SelectObject(grwindow.gcBitmap,grwindow.CurrentPen); + SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush); + if( fill ) + Pie(grwindow.gcBitmap,x1, UD(y1), x2, UD(y2), + x3, UD(y3), x4, UD(y4)); + else + Arc(grwindow.gcBitmap,x1, UD(y1), x2, UD(y2), + x3, UD(y3), x4, UD(y4)); + // SelectObject(grwindow.gcBitmap,oldPen); + } + if( grdisplay_mode ) { + oldPen = SelectObject(grwindow.gc,grwindow.CurrentPen); + SelectObject(grwindow.gc,grwindow.CurrentBrush); + if (fill) + Pie(grwindow.gc,x1, UD(y1), x2, UD(y2), + x3, UD(y3), x4, UD(y4)); + else + Arc(grwindow.gc,x1, UD(y1), x2, UD(y2), + x3, UD(y3), x4, UD(y4)); + // SelectObject(grwindow.gc,oldPen); + } + // DeleteObject(newPen); + return Val_unit; } CAMLprim value gr_show_bitmap(value filename,int x,int y) { - AfficheBitmap(filename,grwindow.gcBitmap,x,Wcvt(y)); - AfficheBitmap(filename,grwindow.gc,x,Wcvt(y)); - return Val_unit; + AfficheBitmap(filename,grwindow.gcBitmap,x,Wcvt(y)); + AfficheBitmap(filename,grwindow.gc,x,Wcvt(y)); + return Val_unit; } CAMLprim value gr_get_mousex(void) { - POINT pt; - GetCursorPos(&pt); - MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1); - return pt.x; + POINT pt; + GetCursorPos(&pt); + MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1); + return pt.x; } CAMLprim value gr_get_mousey(void) { - POINT pt; - GetCursorPos(&pt); - MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1); - return grwindow.height - pt.y - 1; + POINT pt; + GetCursorPos(&pt); + MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1); + return grwindow.height - pt.y - 1; } static void gr_font(char *fontname) { - HFONT hf = CreationFont(fontname); + HFONT hf = CreationFont(fontname); - if (hf && hf != INVALID_HANDLE_VALUE) { - HFONT oldFont = SelectObject(grwindow.gc,hf); - SelectObject(grwindow.gcBitmap,hf); - DeleteObject(grwindow.CurrentFont); - grwindow.CurrentFont = hf; - } + if (hf && hf != INVALID_HANDLE_VALUE) { + HFONT oldFont = SelectObject(grwindow.gc,hf); + SelectObject(grwindow.gcBitmap,hf); + DeleteObject(grwindow.CurrentFont); + grwindow.CurrentFont = hf; + } } CAMLprim value gr_set_font(value fontname) { - gr_check_open(); - gr_font(String_val(fontname)); - return Val_unit; + gr_check_open(); + gr_font(String_val(fontname)); + return Val_unit; } CAMLprim value gr_set_text_size (value sz) { - return Val_unit; + return Val_unit; } CAMLprim value gr_draw_char(value chr) { - char str[1]; - gr_check_open(); - str[0] = Int_val(chr); - gr_draw_text((value)str, 1); - return Val_unit; + char str[1]; + gr_check_open(); + str[0] = Int_val(chr); + gr_draw_text((value)str, 1); + return Val_unit; } CAMLprim value gr_draw_string(value str) { - gr_check_open(); - gr_draw_text(str, string_length(str)); - return Val_unit; + gr_check_open(); + gr_draw_text(str, string_length(str)); + return Val_unit; } CAMLprim value gr_text_size(value str) { - SIZE extent; - value res; + SIZE extent; + value res; - mlsize_t len = string_length(str); - if (len > 32767) len = 32767; + mlsize_t len = string_length(str); + if (len > 32767) len = 32767; - GetTextExtentPoint(grwindow.gc,String_val(str), len,&extent); + GetTextExtentPoint(grwindow.gc,String_val(str), len,&extent); - res = alloc_tuple(2); - Field(res, 0) = Val_long(extent.cx); - Field(res, 1) = Val_long(extent.cy); + res = alloc_tuple(2); + Field(res, 0) = Val_long(extent.cx); + Field(res, 1) = Val_long(extent.cy); - return res; + return res; } #if 0 @@ -421,154 +421,154 @@ static int gr_tail = 0; /* position of next write */ void gr_enqueue_char(unsigned char c) { - if (QueueIsFull) return; - gr_queue[gr_tail] = c; - gr_tail++; - if (gr_tail >= SIZE_QUEUE) gr_tail = 0; + if (QueueIsFull) return; + gr_queue[gr_tail] = c; + gr_tail++; + if (gr_tail >= SIZE_QUEUE) gr_tail = 0; } #endif -#define Button_down 1 -#define Button_up 2 -#define Key_pressed 4 -#define Mouse_motion 8 -#define Poll 16 +#define Button_down 1 +#define Button_up 2 +#define Key_pressed 4 +#define Mouse_motion 8 +#define Poll 16 MSG * InspectMessages = NULL; CAMLprim value gr_wait_event(value eventlist) { - value res; - int mask; - BOOL poll; - int mouse_x, mouse_y, button, key; - int root_x, root_y, win_x, win_y; - int r,i,stop; - unsigned int modifiers; - POINT pt; - MSG msg; - - gr_check_open(); - mask = 0; - poll = FALSE; - while (eventlist != Val_int(0)) { - switch (Int_val(Field(eventlist,0))) { - case 0: /* Button_down */ - mask |= Button_down; - break; - case 1: /* Button_up */ - mask |= Button_up; - break; - case 2: /* Key_pressed */ - mask |= Key_pressed; - break; - case 3: /* Mouse_motion */ - mask |= Mouse_motion; - break; - case 4: /* Poll */ - poll = TRUE; - break; - } - eventlist = Field(eventlist,1); - } - mouse_x = -1; - mouse_y = -1; - button = 0; - key = -1; - - if (poll) { - // Poll uses info on last event stored in global variables - mouse_x = MouseLastX; - mouse_y = MouseLastY; - button = MouseLbuttonDown | MouseMbuttonDown | MouseRbuttonDown; - key = LastKey; - } - else { // Not polled. Block for a message - InspectMessages = &msg; - while (1) { - WaitForSingleObject(EventHandle,INFINITE); - stop = 0; - switch (msg.message) { - case WM_LBUTTONDOWN: - case WM_MBUTTONDOWN: - case WM_RBUTTONDOWN: - button = 1; - if (mask&Button_down) stop = 1; - break; - case WM_LBUTTONUP: - case WM_MBUTTONUP: - case WM_RBUTTONUP: - button = 0; - if (mask&Button_up) stop = 1; - break; - case WM_MOUSEMOVE: - if (mask&Mouse_motion) stop = 1; - break; - case WM_CHAR: - key = msg.wParam & 0xFF; - if (mask&Key_pressed) stop = 1; - break; - } - if (stop) { - pt = msg.pt; - MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1); - mouse_x = pt.x; - mouse_y = grwindow.height- 1 - pt.y; - break; - } - if (msg.message == WM_CLOSE) - break; - } - InspectMessages = NULL; - } - res = alloc_small(5, 0); - Field(res, 0) = Val_int(mouse_x); - Field(res, 1) = Val_int(mouse_y); - Field(res, 2) = Val_bool(button); - Field(res, 3) = Val_bool(key != -1); - Field(res, 4) = Val_int(key & 0xFF); - return res; + value res; + int mask; + BOOL poll; + int mouse_x, mouse_y, button, key; + int root_x, root_y, win_x, win_y; + int r,i,stop; + unsigned int modifiers; + POINT pt; + MSG msg; + + gr_check_open(); + mask = 0; + poll = FALSE; + while (eventlist != Val_int(0)) { + switch (Int_val(Field(eventlist,0))) { + case 0: /* Button_down */ + mask |= Button_down; + break; + case 1: /* Button_up */ + mask |= Button_up; + break; + case 2: /* Key_pressed */ + mask |= Key_pressed; + break; + case 3: /* Mouse_motion */ + mask |= Mouse_motion; + break; + case 4: /* Poll */ + poll = TRUE; + break; + } + eventlist = Field(eventlist,1); + } + mouse_x = -1; + mouse_y = -1; + button = 0; + key = -1; + + if (poll) { + // Poll uses info on last event stored in global variables + mouse_x = MouseLastX; + mouse_y = MouseLastY; + button = MouseLbuttonDown | MouseMbuttonDown | MouseRbuttonDown; + key = LastKey; + } + else { // Not polled. Block for a message + InspectMessages = &msg; + while (1) { + WaitForSingleObject(EventHandle,INFINITE); + stop = 0; + switch (msg.message) { + case WM_LBUTTONDOWN: + case WM_MBUTTONDOWN: + case WM_RBUTTONDOWN: + button = 1; + if (mask&Button_down) stop = 1; + break; + case WM_LBUTTONUP: + case WM_MBUTTONUP: + case WM_RBUTTONUP: + button = 0; + if (mask&Button_up) stop = 1; + break; + case WM_MOUSEMOVE: + if (mask&Mouse_motion) stop = 1; + break; + case WM_CHAR: + key = msg.wParam & 0xFF; + if (mask&Key_pressed) stop = 1; + break; + } + if (stop) { + pt = msg.pt; + MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1); + mouse_x = pt.x; + mouse_y = grwindow.height- 1 - pt.y; + break; + } + if (msg.message == WM_CLOSE) + break; + } + InspectMessages = NULL; + } + res = alloc_small(5, 0); + Field(res, 0) = Val_int(mouse_x); + Field(res, 1) = Val_int(mouse_y); + Field(res, 2) = Val_bool(button); + Field(res, 3) = Val_bool(key != -1); + Field(res, 4) = Val_int(key & 0xFF); + return res; } CAMLprim value gr_fill_poly(value vect) { - int n_points, i; - POINT *p,*poly; - n_points = Wosize_val(vect); - if (n_points < 3) - gr_fail("fill_poly: not enough points",0); - - poly = (POINT *)malloc(n_points*sizeof(POINT)); - - p = poly; - for( i = 0; i < n_points; i++ ){ - p->x = Int_val(Field(Field(vect,i),0)); - p->y = UD(Int_val(Field(Field(vect,i),1))); - p++; - } - if (grremember_mode) { - SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush); - Polygon(grwindow.gcBitmap,poly,n_points); - } - if (grdisplay_mode) { - SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush); - Polygon(grwindow.gc,poly,n_points); - } - free(poly); - - return Val_unit; + int n_points, i; + POINT *p,*poly; + n_points = Wosize_val(vect); + if (n_points < 3) + gr_fail("fill_poly: not enough points",0); + + poly = (POINT *)malloc(n_points*sizeof(POINT)); + + p = poly; + for( i = 0; i < n_points; i++ ){ + p->x = Int_val(Field(Field(vect,i),0)); + p->y = UD(Int_val(Field(Field(vect,i),1))); + p++; + } + if (grremember_mode) { + SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush); + Polygon(grwindow.gcBitmap,poly,n_points); + } + if (grdisplay_mode) { + SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush); + Polygon(grwindow.gc,poly,n_points); + } + free(poly); + + return Val_unit; } CAMLprim value gr_fill_arc(value *argv,int argc) { - return gr_draw_or_fill_arc(argv,argc,TRUE); + return gr_draw_or_fill_arc(argv,argc,TRUE); } // Image primitives struct image { - int w; - int h; - HBITMAP data; - HBITMAP mask; + int w; + int h; + HBITMAP data; + HBITMAP mask; }; #define Width(i) (((struct image *)Data_custom_val(i))->w) @@ -580,204 +580,204 @@ struct image { static void finalize_image (value i) { - free (Data(i)); - if (Mask(i) != NULL) free(Mask(i)); + free (Data(i)); + if (Mask(i) != NULL) free(Mask(i)); } static struct custom_operations image_ops = { - "_image", - finalize_image, - custom_compare_default, - custom_hash_default, - custom_serialize_default, - custom_deserialize_default + "_image", + finalize_image, + custom_compare_default, + custom_hash_default, + custom_serialize_default, + custom_deserialize_default }; CAMLprim value gr_create_image(value w,value h) { - HBITMAP cbm; - value res; + HBITMAP cbm; + value res; - if (Int_val (w) < 0 || Int_val (h) < 0) - gr_fail("create_image: width and height must be positive",0); + if (Int_val (w) < 0 || Int_val (h) < 0) + gr_fail("create_image: width and height must be positive",0); - cbm = CreateCompatibleBitmap(grwindow.gcBitmap, Int_val(w), Int_val(h)); - res = alloc_custom(&image_ops, sizeof(struct image), - w * h, Max_image_mem); - if (res) { - Width (res) = Int_val(w); - Height (res) = Int_val(h); - Data (res) = cbm; - Mask (res) = NULL; - } - return res; + cbm = CreateCompatibleBitmap(grwindow.gcBitmap, Int_val(w), Int_val(h)); + res = alloc_custom(&image_ops, sizeof(struct image), + w * h, Max_image_mem); + if (res) { + Width (res) = Int_val(w); + Height (res) = Int_val(h); + Data (res) = cbm; + Mask (res) = NULL; + } + return res; } CAMLprim value gr_blit_image (value i, value x, value y) { - HBITMAP oldBmp = SelectObject(grwindow.tempDC,Data(i)); - int xsrc = Int_val(x); - int ysrc = UD(Int_val(y) + Height(i) - 1); - BitBlt(grwindow.tempDC,0, 0, Width(i), Height(i), - grwindow.gcBitmap, xsrc, ysrc, SRCCOPY); - SelectObject(grwindow.tempDC,oldBmp); - return Val_unit; + HBITMAP oldBmp = SelectObject(grwindow.tempDC,Data(i)); + int xsrc = Int_val(x); + int ysrc = UD(Int_val(y) + Height(i) - 1); + BitBlt(grwindow.tempDC,0, 0, Width(i), Height(i), + grwindow.gcBitmap, xsrc, ysrc, SRCCOPY); + SelectObject(grwindow.tempDC,oldBmp); + return Val_unit; } CAMLprim value gr_draw_image(value i, value x, value y) { - HBITMAP oldBmp; - - int xdst = Int_val(x); -// int ydst = UD(Int_val(y) + Height(i) - 1); - int ydst = Wcvt(Int_val(y)+Height(i)-1); - if (Mask(i) == NULL) { - if (grremember_mode) { - oldBmp = SelectObject(grwindow.tempDC,Data(i)); - BitBlt(grwindow.gcBitmap,xdst, ydst, Width(i), Height(i), - grwindow.tempDC, 0, 0, SRCCOPY); - SelectObject(grwindow.tempDC,oldBmp); - } - if (grdisplay_mode) { - oldBmp = SelectObject(grwindow.tempDC,Data(i)); - BitBlt(grwindow.gc,xdst, ydst, Width(i), Height(i), - grwindow.tempDC, 0, 0, SRCCOPY); - SelectObject(grwindow.tempDC,oldBmp); - } - } - else { - if (grremember_mode) { - oldBmp = SelectObject(grwindow.tempDC,Mask(i)); - BitBlt(grwindow.gcBitmap,xdst, ydst, Width(i), Height(i), - grwindow.tempDC, 0, 0, SRCAND); - SelectObject(grwindow.tempDC,Data(i)); - BitBlt(grwindow.gcBitmap,xdst, ydst, Width(i), Height(i), - grwindow.tempDC, 0, 0, SRCPAINT); - SelectObject(grwindow.tempDC,oldBmp); - } - if (grdisplay_mode) { - oldBmp = SelectObject(grwindow.tempDC,Mask(i)); - BitBlt(grwindow.gc,xdst, ydst, Width(i), Height(i), - grwindow.tempDC, 0, 0, SRCAND); - SelectObject(grwindow.tempDC,Data(i)); - BitBlt(grwindow.gc,xdst, ydst, Width(i), Height(i), - grwindow.tempDC, 0, 0, SRCPAINT); - SelectObject(grwindow.tempDC,oldBmp); - } - } - - return Val_unit; + HBITMAP oldBmp; + + int xdst = Int_val(x); +// int ydst = UD(Int_val(y) + Height(i) - 1); + int ydst = Wcvt(Int_val(y)+Height(i)-1); + if (Mask(i) == NULL) { + if (grremember_mode) { + oldBmp = SelectObject(grwindow.tempDC,Data(i)); + BitBlt(grwindow.gcBitmap,xdst, ydst, Width(i), Height(i), + grwindow.tempDC, 0, 0, SRCCOPY); + SelectObject(grwindow.tempDC,oldBmp); + } + if (grdisplay_mode) { + oldBmp = SelectObject(grwindow.tempDC,Data(i)); + BitBlt(grwindow.gc,xdst, ydst, Width(i), Height(i), + grwindow.tempDC, 0, 0, SRCCOPY); + SelectObject(grwindow.tempDC,oldBmp); + } + } + else { + if (grremember_mode) { + oldBmp = SelectObject(grwindow.tempDC,Mask(i)); + BitBlt(grwindow.gcBitmap,xdst, ydst, Width(i), Height(i), + grwindow.tempDC, 0, 0, SRCAND); + SelectObject(grwindow.tempDC,Data(i)); + BitBlt(grwindow.gcBitmap,xdst, ydst, Width(i), Height(i), + grwindow.tempDC, 0, 0, SRCPAINT); + SelectObject(grwindow.tempDC,oldBmp); + } + if (grdisplay_mode) { + oldBmp = SelectObject(grwindow.tempDC,Mask(i)); + BitBlt(grwindow.gc,xdst, ydst, Width(i), Height(i), + grwindow.tempDC, 0, 0, SRCAND); + SelectObject(grwindow.tempDC,Data(i)); + BitBlt(grwindow.gc,xdst, ydst, Width(i), Height(i), + grwindow.tempDC, 0, 0, SRCPAINT); + SelectObject(grwindow.tempDC,oldBmp); + } + } + + return Val_unit; } CAMLprim value gr_make_image(value matrix) { - int width, height,has_transp,i,j; - value img; - HBITMAP oldBmp; - height = Wosize_val(matrix); - if (height == 0) { - width = 0; - } - else { - width = Wosize_val(Field(matrix, 0)); - for (i = 1; i < height; i++) { - if (width != (int) Wosize_val(Field(matrix, i))) - gr_fail("make_image: non-rectangular matrix",0); - } - } - Begin_roots1(matrix) - img = gr_create_image(Val_int(width), Val_int(height)); - End_roots(); - has_transp = 0; - oldBmp = SelectObject(grwindow.tempDC,Data(img)); - for (i = 0; i < height; i++) { - for (j = 0; j < width; j++) { - int col = Long_val (Field (Field (matrix, i), j)); - if (col == -1){ - has_transp = 1; - SetPixel(grwindow.tempDC,j, i, 0); - } - else { - int red = (col >> 16) & 0xFF; - int green = (col >> 8) & 0xFF; - int blue = col & 0xFF; - SetPixel(grwindow.tempDC,j, i, RGB(red, green, blue)); - } - } - } - SelectObject(grwindow.tempDC,oldBmp); - if (has_transp) { - HBITMAP cbm; - cbm = CreateCompatibleBitmap(grwindow.gc, width, height); - Mask(img) = cbm; - oldBmp = SelectObject(grwindow.tempDC,Mask(img)); - for (i = 0; i < height; i++) { - for (j = 0; j < width; j++) { - int col = Long_val (Field (Field (matrix, i), j)); - SetPixel(grwindow.tempDC,j, i, col == -1 ? 0xFFFFFF : 0); - } - } - SelectObject(grwindow.tempDC,oldBmp); - } - return img; + int width, height,has_transp,i,j; + value img; + HBITMAP oldBmp; + height = Wosize_val(matrix); + if (height == 0) { + width = 0; + } + else { + width = Wosize_val(Field(matrix, 0)); + for (i = 1; i < height; i++) { + if (width != (int) Wosize_val(Field(matrix, i))) + gr_fail("make_image: non-rectangular matrix",0); + } + } + Begin_roots1(matrix) + img = gr_create_image(Val_int(width), Val_int(height)); + End_roots(); + has_transp = 0; + oldBmp = SelectObject(grwindow.tempDC,Data(img)); + for (i = 0; i < height; i++) { + for (j = 0; j < width; j++) { + int col = Long_val (Field (Field (matrix, i), j)); + if (col == -1){ + has_transp = 1; + SetPixel(grwindow.tempDC,j, i, 0); + } + else { + int red = (col >> 16) & 0xFF; + int green = (col >> 8) & 0xFF; + int blue = col & 0xFF; + SetPixel(grwindow.tempDC,j, i, RGB(red, green, blue)); + } + } + } + SelectObject(grwindow.tempDC,oldBmp); + if (has_transp) { + HBITMAP cbm; + cbm = CreateCompatibleBitmap(grwindow.gc, width, height); + Mask(img) = cbm; + oldBmp = SelectObject(grwindow.tempDC,Mask(img)); + for (i = 0; i < height; i++) { + for (j = 0; j < width; j++) { + int col = Long_val (Field (Field (matrix, i), j)); + SetPixel(grwindow.tempDC,j, i, col == -1 ? 0xFFFFFF : 0); + } + } + SelectObject(grwindow.tempDC,oldBmp); + } + return img; } static value alloc_int_vect(mlsize_t size) { - value res; - mlsize_t i; + value res; + mlsize_t i; - if (size == 0) return Atom(0); - if (size <= Max_young_wosize) { - res = alloc(size, 0); - } - else { - res = alloc_shr(size, 0); - } - for (i = 0; i < size; i++) { - Field(res, i) = Val_long(0); - } - return res; + if (size == 0) return Atom(0); + if (size <= Max_young_wosize) { + res = alloc(size, 0); + } + else { + res = alloc_shr(size, 0); + } + for (i = 0; i < size; i++) { + Field(res, i) = Val_long(0); + } + return res; } CAMLprim value gr_dump_image (value img) { - int height = Height(img); - int width = Width(img); - value matrix = Val_unit; - int i, j; - HBITMAP oldBmp; - - Begin_roots2(img, matrix) - matrix = alloc_int_vect (height); - for (i = 0; i < height; i++) { - modify (&Field (matrix, i), alloc_int_vect (width)); - } - End_roots(); - - oldBmp = SelectObject(grwindow.tempDC,Data(img)); - for (i = 0; i < height; i++) { - for (j = 0; j < width; j++) { - int col = GetPixel(grwindow.tempDC,j, i); - int blue = (col >> 16) & 0xFF; - int green = (col >> 8) & 0xFF; - int red = col & 0xFF; - Field(Field(matrix, i), j) = Val_long((red << 16) + - (green << 8) + blue); - } - } - SelectObject(grwindow.tempDC,oldBmp); - if (Mask(img) != NULL) { - oldBmp = SelectObject(grwindow.tempDC,Mask(img)); - for (i = 0; i < height; i++) { - for (j = 0; j < width; j++) { - if (GetPixel(grwindow.tempDC,j, i) != 0) - Field(Field(matrix, i), j) = - Val_long(-1); - } - } - SelectObject(grwindow.tempDC,oldBmp); - } - return matrix; + int height = Height(img); + int width = Width(img); + value matrix = Val_unit; + int i, j; + HBITMAP oldBmp; + + Begin_roots2(img, matrix) + matrix = alloc_int_vect (height); + for (i = 0; i < height; i++) { + modify (&Field (matrix, i), alloc_int_vect (width)); + } + End_roots(); + + oldBmp = SelectObject(grwindow.tempDC,Data(img)); + for (i = 0; i < height; i++) { + for (j = 0; j < width; j++) { + int col = GetPixel(grwindow.tempDC,j, i); + int blue = (col >> 16) & 0xFF; + int green = (col >> 8) & 0xFF; + int red = col & 0xFF; + Field(Field(matrix, i), j) = Val_long((red << 16) + + (green << 8) + blue); + } + } + SelectObject(grwindow.tempDC,oldBmp); + if (Mask(img) != NULL) { + oldBmp = SelectObject(grwindow.tempDC,Mask(img)); + for (i = 0; i < height; i++) { + for (j = 0; j < width; j++) { + if (GetPixel(grwindow.tempDC,j, i) != 0) + Field(Field(matrix, i), j) = + Val_long(-1); + } + } + SelectObject(grwindow.tempDC,oldBmp); + } + return matrix; } diff --git a/otherlibs/win32graph/libgraph.h b/otherlibs/win32graph/libgraph.h index 067f157a3..877298429 100644 --- a/otherlibs/win32graph/libgraph.h +++ b/otherlibs/win32graph/libgraph.h @@ -30,7 +30,7 @@ extern HWND grdisplay; /* The display connection */ //extern struct canvas grbstore; /* The pixmap used for backing store */ //extern int grwhite, grblack; /* Black and white pixels for X */ //extern int grbackground; /* Background color for X -// (used for CAML color -1) */ +// (used for CAML color -1) */ extern COLORREF grbackground; extern BOOL grdisplay_mode; /* Display-mode flag */ extern BOOL grremember_mode; /* Remember-mode flag */ @@ -84,20 +84,20 @@ extern RECT WindowRect; extern int grCurrentColor; typedef struct tagWindow { - HDC gc; - HDC gcBitmap; - HWND hwnd; - HBRUSH CurrentBrush; - HPEN CurrentPen; - DWORD CurrentColor; - int width; - int height; - int grx; - int gry; - HBITMAP hBitmap; - HFONT CurrentFont; - int CurrentFontSize; - HDC tempDC; // For image operations; + HDC gc; + HDC gcBitmap; + HWND hwnd; + HBRUSH CurrentBrush; + HPEN CurrentPen; + DWORD CurrentColor; + int width; + int height; + int grx; + int gry; + HBITMAP hBitmap; + HFONT CurrentFont; + int CurrentFontSize; + HDC tempDC; // For image operations; } GR_WINDOW; extern GR_WINDOW grwindow; diff --git a/otherlibs/win32graph/open.c b/otherlibs/win32graph/open.c index 08f5701f0..047e84c5b 100644 --- a/otherlibs/win32graph/open.c +++ b/otherlibs/win32graph/open.c @@ -55,156 +55,156 @@ HFONT CreationFont(char *name) void SetCoordinates(HWND hwnd) { - RECT rc; + RECT rc; - GetClientRect(hwnd,&rc); - grwindow.width = rc.right; - grwindow.height = rc.bottom; - gr_reset(); + GetClientRect(hwnd,&rc); + grwindow.width = rc.right; + grwindow.height = rc.bottom; + gr_reset(); } void ResetForClose(HWND hwnd) { - DeleteObject(grwindow.hBitmap); - memset(&grwindow,0,sizeof(grwindow)); + DeleteObject(grwindow.hBitmap); + memset(&grwindow,0,sizeof(grwindow)); } - + static LRESULT CALLBACK GraphicsWndProc(HWND hwnd,UINT msg,WPARAM wParam,LPARAM lParam) { - PAINTSTRUCT ps; - HDC hdc; - - switch (msg) { - // Create the MDI client invisible window - case WM_CREATE: - break; - case WM_PAINT: - hdc = BeginPaint(hwnd,&ps); - BitBlt(hdc,0,0,grwindow.width,grwindow.height, - grwindow.gcBitmap,0,0,SRCCOPY); - EndPaint(hwnd,&ps); - break; - // Move the child windows - case WM_SIZE: - // Position the MDI client window between the tool and status bars - if (wParam != SIZE_MINIMIZED) { - SetCoordinates(hwnd); - } - - return 0; - // End application - case WM_DESTROY: - ResetForClose(hwnd); - break; - case WM_LBUTTONDOWN: - MouseLbuttonDown = 1; - break; - case WM_LBUTTONUP: - MouseLbuttonDown = 0; - break; - case WM_RBUTTONDOWN: - MouseRbuttonDown = 1; - break; - case WM_RBUTTONUP: - MouseRbuttonDown = 0; - break; - case WM_MBUTTONDOWN: - MouseMbuttonDown = 1; - break; - case WM_MBUTTONUP: - MouseMbuttonDown = 0; - break; - case WM_CHAR: + PAINTSTRUCT ps; + HDC hdc; + + switch (msg) { + // Create the MDI client invisible window + case WM_CREATE: + break; + case WM_PAINT: + hdc = BeginPaint(hwnd,&ps); + BitBlt(hdc,0,0,grwindow.width,grwindow.height, + grwindow.gcBitmap,0,0,SRCCOPY); + EndPaint(hwnd,&ps); + break; + // Move the child windows + case WM_SIZE: + // Position the MDI client window between the tool and status bars + if (wParam != SIZE_MINIMIZED) { + SetCoordinates(hwnd); + } + + return 0; + // End application + case WM_DESTROY: + ResetForClose(hwnd); + break; + case WM_LBUTTONDOWN: + MouseLbuttonDown = 1; + break; + case WM_LBUTTONUP: + MouseLbuttonDown = 0; + break; + case WM_RBUTTONDOWN: + MouseRbuttonDown = 1; + break; + case WM_RBUTTONUP: + MouseRbuttonDown = 0; + break; + case WM_MBUTTONDOWN: + MouseMbuttonDown = 1; + break; + case WM_MBUTTONUP: + MouseMbuttonDown = 0; + break; + case WM_CHAR: LastKey = wParam & 0xFF; break; - case WM_KEYUP: + case WM_KEYUP: LastKey = -1; break; - case WM_MOUSEMOVE: + case WM_MOUSEMOVE: #if 0 - pt.x = GET_X_LPARAM(lParam); - pt.y = GET_Y_LPARAM(lParam); - MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1); - MouseLastX = pt.x; - MouseLastY = grwindow.height - 1 - pt.y; + pt.x = GET_X_LPARAM(lParam); + pt.y = GET_Y_LPARAM(lParam); + MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1); + MouseLastX = pt.x; + MouseLastY = grwindow.height - 1 - pt.y; #else - MouseLastX = GET_X_LPARAM(lParam); - MouseLastY = grwindow.height - 1 - GET_Y_LPARAM(lParam); + MouseLastX = GET_X_LPARAM(lParam); + MouseLastY = grwindow.height - 1 - GET_Y_LPARAM(lParam); #endif - break; - } - return DefWindowProc(hwnd,msg,wParam,lParam); + break; + } + return DefWindowProc(hwnd,msg,wParam,lParam); } int DoRegisterClass(void) { - WNDCLASS wc; - - memset(&wc,0,sizeof(WNDCLASS)); - wc.style = CS_HREDRAW|CS_VREDRAW |CS_DBLCLKS|CS_OWNDC ; - wc.lpfnWndProc = (WNDPROC)GraphicsWndProc; - wc.hInstance = hInst; - wc.hbrBackground = (HBRUSH)(COLOR_WINDOW+1); - wc.lpszClassName = szOcamlWindowClass; - wc.lpszMenuName = 0; - wc.hCursor = LoadCursor(NULL,IDC_ARROW); - wc.hIcon = 0; - return RegisterClass(&wc); + WNDCLASS wc; + + memset(&wc,0,sizeof(WNDCLASS)); + wc.style = CS_HREDRAW|CS_VREDRAW |CS_DBLCLKS|CS_OWNDC ; + wc.lpfnWndProc = (WNDPROC)GraphicsWndProc; + wc.hInstance = hInst; + wc.hbrBackground = (HBRUSH)(COLOR_WINDOW+1); + wc.lpszClassName = szOcamlWindowClass; + wc.lpszMenuName = 0; + wc.hCursor = LoadCursor(NULL,IDC_ARROW); + wc.hIcon = 0; + return RegisterClass(&wc); } static value gr_reset(void) { - RECT rc; - int screenx,screeny; - - screenx = GetSystemMetrics(SM_CXSCREEN); - screeny = GetSystemMetrics(SM_CYSCREEN); - GetClientRect(grwindow.hwnd,&rc); - grwindow.gc = GetDC(grwindow.hwnd); - grwindow.width = rc.right; - grwindow.height = rc.bottom; - if (grwindow.gcBitmap == (HDC)0) { -// grwindow.hBitmap = CreateCompatibleBitmap(grwindow.gc,grwindow.width,grwindow.height); - grwindow.hBitmap = CreateCompatibleBitmap(grwindow.gc,screenx,screeny); - grwindow.gcBitmap = CreateCompatibleDC(grwindow.gc); - grwindow.tempDC = CreateCompatibleDC(grwindow.gc); - SelectObject(grwindow.gcBitmap,grwindow.hBitmap); - SetMapMode(grwindow.gcBitmap,MM_TEXT); - MoveToEx(grwindow.gcBitmap,0,grwindow.height-1,0); - BitBlt(grwindow.gcBitmap,0,0,screenx,screeny, - grwindow.gcBitmap,0,0,WHITENESS); - grwindow.CurrentFontSize = 15; - grwindow.CurrentFont = CreationFont("Courier"); - } - grwindow.CurrentColor = GetSysColor(COLOR_WINDOWTEXT); - grwindow.grx = 0; - grwindow.gry = 0; - grwindow.CurrentPen = SelectObject(grwindow.gc,GetStockObject(WHITE_PEN)); - SelectObject(grwindow.gc,grwindow.CurrentPen); - SelectObject(grwindow.gcBitmap,grwindow.CurrentPen); - grwindow.CurrentBrush = SelectObject(grwindow.gc,GetStockObject(WHITE_BRUSH)); - SelectObject(grwindow.gc,grwindow.CurrentBrush); - SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush); - SelectObject(grwindow.gc,grwindow.CurrentFont); - SelectObject(grwindow.gcBitmap,grwindow.CurrentFont); - grdisplay_mode = grremember_mode = 1; - MoveToEx(grwindow.gc,0,grwindow.height-1,0); - MoveToEx(grwindow.gcBitmap,0,grwindow.height-1,0); - SetTextAlign(grwindow.gcBitmap,TA_BOTTOM); - SetTextAlign(grwindow.gc,TA_BOTTOM); - return Val_unit; + RECT rc; + int screenx,screeny; + + screenx = GetSystemMetrics(SM_CXSCREEN); + screeny = GetSystemMetrics(SM_CYSCREEN); + GetClientRect(grwindow.hwnd,&rc); + grwindow.gc = GetDC(grwindow.hwnd); + grwindow.width = rc.right; + grwindow.height = rc.bottom; + if (grwindow.gcBitmap == (HDC)0) { +// grwindow.hBitmap = CreateCompatibleBitmap(grwindow.gc,grwindow.width,grwindow.height); + grwindow.hBitmap = CreateCompatibleBitmap(grwindow.gc,screenx,screeny); + grwindow.gcBitmap = CreateCompatibleDC(grwindow.gc); + grwindow.tempDC = CreateCompatibleDC(grwindow.gc); + SelectObject(grwindow.gcBitmap,grwindow.hBitmap); + SetMapMode(grwindow.gcBitmap,MM_TEXT); + MoveToEx(grwindow.gcBitmap,0,grwindow.height-1,0); + BitBlt(grwindow.gcBitmap,0,0,screenx,screeny, + grwindow.gcBitmap,0,0,WHITENESS); + grwindow.CurrentFontSize = 15; + grwindow.CurrentFont = CreationFont("Courier"); + } + grwindow.CurrentColor = GetSysColor(COLOR_WINDOWTEXT); + grwindow.grx = 0; + grwindow.gry = 0; + grwindow.CurrentPen = SelectObject(grwindow.gc,GetStockObject(WHITE_PEN)); + SelectObject(grwindow.gc,grwindow.CurrentPen); + SelectObject(grwindow.gcBitmap,grwindow.CurrentPen); + grwindow.CurrentBrush = SelectObject(grwindow.gc,GetStockObject(WHITE_BRUSH)); + SelectObject(grwindow.gc,grwindow.CurrentBrush); + SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush); + SelectObject(grwindow.gc,grwindow.CurrentFont); + SelectObject(grwindow.gcBitmap,grwindow.CurrentFont); + grdisplay_mode = grremember_mode = 1; + MoveToEx(grwindow.gc,0,grwindow.height-1,0); + MoveToEx(grwindow.gcBitmap,0,grwindow.height-1,0); + SetTextAlign(grwindow.gcBitmap,TA_BOTTOM); + SetTextAlign(grwindow.gc,TA_BOTTOM); + return Val_unit; } void SuspendGraphicThread(void) { - SuspendThread(threadHandle); + SuspendThread(threadHandle); } void ResumeGraphicThread(void) { - ResumeThread(threadHandle); + ResumeThread(threadHandle); } /* For handshake between the event handling thread and the main thread */ @@ -232,17 +232,17 @@ static DWORD WINAPI gr_open_graph_internal(value arg) if (!registered) { registered = DoRegisterClass(); if (!registered) { - open_graph_errmsg = "Cannot register the window class"; - SetEvent(open_graph_event); - return 1; + open_graph_errmsg = "Cannot register the window class"; + SetEvent(open_graph_event); + return 1; } } grwindow.hwnd = CreateWindow(szOcamlWindowClass, - WINDOW_NAME, - WS_OVERLAPPEDWINDOW, - x,y, - w,h, - NULL,0,hInst,NULL); + WINDOW_NAME, + WS_OVERLAPPEDWINDOW, + x,y, + w,h, + NULL,0,hInst,NULL); if (grwindow.hwnd == NULL) { open_graph_errmsg = "Cannot create window"; SetEvent(open_graph_event); @@ -295,9 +295,9 @@ CAMLprim value gr_open_graph(value arg) open_graph_event = CreateEvent(NULL, FALSE, FALSE, NULL); threadHandle = CreateThread(NULL,0, - (LPTHREAD_START_ROUTINE)gr_open_graph_internal,(void **)arg, - 0, - &tid); + (LPTHREAD_START_ROUTINE)gr_open_graph_internal,(void **)arg, + 0, + &tid); WaitForSingleObject(open_graph_event, INFINITE); CloseHandle(open_graph_event); if (open_graph_errmsg != NULL) gr_fail("%s", open_graph_errmsg); @@ -306,70 +306,70 @@ CAMLprim value gr_open_graph(value arg) CAMLprim value gr_close_graph(void) { - if (gr_initialized) { - DeleteDC(grwindow.tempDC); - DeleteDC(grwindow.gcBitmap); - DestroyWindow(grwindow.hwnd); - memset(&grwindow,0,sizeof(grwindow)); - gr_initialized = 0; - } - return Val_unit; + if (gr_initialized) { + DeleteDC(grwindow.tempDC); + DeleteDC(grwindow.gcBitmap); + DestroyWindow(grwindow.hwnd); + memset(&grwindow,0,sizeof(grwindow)); + gr_initialized = 0; + } + return Val_unit; } CAMLprim value gr_clear_graph(void) { - gr_check_open(); - if(grremember_mode) { - BitBlt(grwindow.gcBitmap,0,0,grwindow.width,grwindow.height, - grwindow.gcBitmap,0,0,WHITENESS); - } - if(grdisplay_mode) { - BitBlt(grwindow.gc,0,0,grwindow.width,grwindow.height, - grwindow.gc,0,0,WHITENESS); - } - return Val_unit; + gr_check_open(); + if(grremember_mode) { + BitBlt(grwindow.gcBitmap,0,0,grwindow.width,grwindow.height, + grwindow.gcBitmap,0,0,WHITENESS); + } + if(grdisplay_mode) { + BitBlt(grwindow.gc,0,0,grwindow.width,grwindow.height, + grwindow.gc,0,0,WHITENESS); + } + return Val_unit; } CAMLprim value gr_size_x(void) { - gr_check_open(); - return Val_int(grwindow.width); + gr_check_open(); + return Val_int(grwindow.width); } CAMLprim value gr_size_y(void) { - gr_check_open(); - return Val_int(grwindow.height); + gr_check_open(); + return Val_int(grwindow.height); } CAMLprim value gr_synchronize(void) { - gr_check_open(); - BitBlt(grwindow.gc,0,0,grwindow.width,grwindow.height, - grwindow.gcBitmap,0,0,SRCCOPY); - return Val_unit ; + gr_check_open(); + BitBlt(grwindow.gc,0,0,grwindow.width,grwindow.height, + grwindow.gcBitmap,0,0,SRCCOPY); + return Val_unit ; } CAMLprim value gr_display_mode(value flag) { - grdisplay_mode = (Int_val(flag)) ? 1 : 0; - return Val_unit ; + grdisplay_mode = (Int_val(flag)) ? 1 : 0; + return Val_unit ; } CAMLprim value gr_remember_mode(value flag) { - grremember_mode = (Int_val(flag)) ? 1 : 0; - return Val_unit ; + grremember_mode = (Int_val(flag)) ? 1 : 0; + return Val_unit ; } CAMLprim value gr_sigio_signal(value unit) { - return Val_unit; + return Val_unit; } CAMLprim value gr_sigio_handler(void) { - return Val_unit; + return Val_unit; } diff --git a/otherlibs/win32unix/README b/otherlibs/win32unix/README index 6b6eebfdf..237aa627d 100644 --- a/otherlibs/win32unix/README +++ b/otherlibs/win32unix/README @@ -91,7 +91,7 @@ diff -c -r d:/msdev/crt/src/osfinfo.c crt/src/osfinfo.c ! return -1; } + #else -+ /* Windows 95 lossage */ ++ /* Windows 95 lossage */ + if (isdev == FILE_TYPE_UNKNOWN) isdev = FILE_TYPE_PIPE; + #endif diff --git a/otherlibs/win32unix/lockf.c b/otherlibs/win32unix/lockf.c index c2c9c3507..918305281 100644 --- a/otherlibs/win32unix/lockf.c +++ b/otherlibs/win32unix/lockf.c @@ -57,7 +57,7 @@ puts a lock on a region of the file opened as fd. The region starts at the curre #endif static void set_file_pointer(HANDLE h, LARGE_INTEGER dest, - PLARGE_INTEGER cur, DWORD method) + PLARGE_INTEGER cur, DWORD method) { LONG high = dest.HighPart; DWORD ret = SetFilePointer(h, dest.LowPart, &high, method); @@ -70,95 +70,95 @@ static void set_file_pointer(HANDLE h, LARGE_INTEGER dest, CAMLprim value unix_lockf(value fd, value cmd, value span) { - int ret; - OVERLAPPED overlap; - DWORD l_start; - DWORD l_len; - HANDLE h; - OSVERSIONINFO VersionInfo; - LARGE_INTEGER cur_position; - LARGE_INTEGER end_position; - LARGE_INTEGER offset_position; - - VersionInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); - if(GetVersionEx(&VersionInfo) == 0) - { - invalid_argument("lockf only supported on WIN32_NT platforms: could not determine current platform."); - } + int ret; + OVERLAPPED overlap; + DWORD l_start; + DWORD l_len; + HANDLE h; + OSVERSIONINFO VersionInfo; + LARGE_INTEGER cur_position; + LARGE_INTEGER end_position; + LARGE_INTEGER offset_position; + + VersionInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); + if(GetVersionEx(&VersionInfo) == 0) + { + invalid_argument("lockf only supported on WIN32_NT platforms: could not determine current platform."); + } /* file locking only exists on NT versions */ - if(VersionInfo.dwPlatformId != VER_PLATFORM_WIN32_NT) - { - invalid_argument("lockf only supported on WIN32_NT platforms"); - } - - h = Handle_val(fd); - - overlap.Offset = 0; - overlap.OffsetHigh = 0; - overlap.hEvent = 0; - l_len = Long_val(span); - - offset_position.HighPart = 0; - cur_position.HighPart = 0; - end_position.HighPart = 0; - offset_position.LowPart = 0; - cur_position.LowPart = 0; - end_position.LowPart = 0; - - if(l_len == 0) - { + if(VersionInfo.dwPlatformId != VER_PLATFORM_WIN32_NT) + { + invalid_argument("lockf only supported on WIN32_NT platforms"); + } + + h = Handle_val(fd); + + overlap.Offset = 0; + overlap.OffsetHigh = 0; + overlap.hEvent = 0; + l_len = Long_val(span); + + offset_position.HighPart = 0; + cur_position.HighPart = 0; + end_position.HighPart = 0; + offset_position.LowPart = 0; + cur_position.LowPart = 0; + end_position.LowPart = 0; + + if(l_len == 0) + { /* save current pointer */ - set_file_pointer(h,offset_position,&cur_position,FILE_CURRENT); + set_file_pointer(h,offset_position,&cur_position,FILE_CURRENT); /* set to end and query */ - set_file_pointer(h,offset_position,&end_position,FILE_END); - l_len = end_position.LowPart; + set_file_pointer(h,offset_position,&end_position,FILE_END); + l_len = end_position.LowPart; /* restore previous current pointer */ - set_file_pointer(h,cur_position,NULL,FILE_BEGIN); - } - else - { - if (l_len < 0) - { - set_file_pointer(h,offset_position,&cur_position,FILE_CURRENT); - l_len = abs(l_len); - if(l_len > cur_position.LowPart) - { - errno = EINVAL; - uerror("lockf", Nothing); - return Val_unit; - } - overlap.Offset = cur_position.LowPart - l_len; - } - } + set_file_pointer(h,cur_position,NULL,FILE_BEGIN); + } + else + { + if (l_len < 0) + { + set_file_pointer(h,offset_position,&cur_position,FILE_CURRENT); + l_len = abs(l_len); + if(l_len > cur_position.LowPart) + { + errno = EINVAL; + uerror("lockf", Nothing); + return Val_unit; + } + overlap.Offset = cur_position.LowPart - l_len; + } + } switch (Int_val(cmd)) - { - case 0: /* F_ULOCK */ - if(UnlockFileEx(h, 0, l_len,0,&overlap) == 0) - { - errno = EACCES; - ret = -1; - } - break; - case 1: /* F_LOCK */ + { + case 0: /* F_ULOCK */ + if(UnlockFileEx(h, 0, l_len,0,&overlap) == 0) + { + errno = EACCES; + ret = -1; + } + break; + case 1: /* F_LOCK */ /* this should block until write lock is obtained */ - if(LockFileEx(h,LOCKFILE_EXCLUSIVE_LOCK,0,l_len,0,&overlap) == 0) - { - errno = EACCES; - ret = -1; - } - break; - case 2: /* F_TLOCK */ + if(LockFileEx(h,LOCKFILE_EXCLUSIVE_LOCK,0,l_len,0,&overlap) == 0) + { + errno = EACCES; + ret = -1; + } + break; + case 2: /* F_TLOCK */ /* * this should return immediately if write lock can-not * be obtained. */ - if(LockFileEx(h,LOCKFILE_FAIL_IMMEDIATELY | LOCKFILE_EXCLUSIVE_LOCK,0,l_len,0,&overlap) == 0) - { - errno = EACCES; - ret = -1; - } - break; - case 3: /* F_TEST */ + if(LockFileEx(h,LOCKFILE_FAIL_IMMEDIATELY | LOCKFILE_EXCLUSIVE_LOCK,0,l_len,0,&overlap) == 0) + { + errno = EACCES; + ret = -1; + } + break; + case 3: /* F_TEST */ /* * I'm doing this by aquiring an immediate write * lock and then releasing it. It is not clear that @@ -166,40 +166,40 @@ CAMLprim value unix_lockf(value fd, value cmd, value span) * it is not clear the nature of the lock test performed * by ocaml (unix) currently. */ - if(LockFileEx(h,LOCKFILE_FAIL_IMMEDIATELY | LOCKFILE_EXCLUSIVE_LOCK,0,l_len,0,&overlap) == 0) - { - errno = EACCES; - ret = -1; - } - else - { - UnlockFileEx(h, 0, l_len,0,&overlap); - ret = 0; - } - break; - case 4: /* F_RLOCK */ + if(LockFileEx(h,LOCKFILE_FAIL_IMMEDIATELY | LOCKFILE_EXCLUSIVE_LOCK,0,l_len,0,&overlap) == 0) + { + errno = EACCES; + ret = -1; + } + else + { + UnlockFileEx(h, 0, l_len,0,&overlap); + ret = 0; + } + break; + case 4: /* F_RLOCK */ /* this should block until read lock is obtained */ - if(LockFileEx(h,0,0,l_len,0,&overlap) == 0) - { - errno = EACCES; - ret = -1; - } - break; - case 5: /* F_TRLOCK */ + if(LockFileEx(h,0,0,l_len,0,&overlap) == 0) + { + errno = EACCES; + ret = -1; + } + break; + case 5: /* F_TRLOCK */ /* * this should return immediately if read lock can-not * be obtained. */ - if(LockFileEx(h,LOCKFILE_FAIL_IMMEDIATELY,0,l_len,0,&overlap) == 0) - { - errno = EACCES; - ret = -1; - } - break; - default: - errno = EINVAL; - ret = -1; - } + if(LockFileEx(h,LOCKFILE_FAIL_IMMEDIATELY,0,l_len,0,&overlap) == 0) + { + errno = EACCES; + ret = -1; + } + break; + default: + errno = EINVAL; + ret = -1; + } if (ret == -1) uerror("lockf", Nothing); return Val_unit; } diff --git a/otherlibs/win32unix/read.c b/otherlibs/win32unix/read.c index 2c727173e..704cec2c7 100644 --- a/otherlibs/win32unix/read.c +++ b/otherlibs/win32unix/read.c @@ -34,8 +34,8 @@ CAMLprim value unix_read(value fd, value buf, value ofs, value len) ret = recv(s, iobuf, numbytes, 0); leave_blocking_section(); if (ret == SOCKET_ERROR) { - win32_maperr(WSAGetLastError()); - uerror("read", Nothing); + win32_maperr(WSAGetLastError()); + uerror("read", Nothing); } numread = ret; } else { @@ -45,8 +45,8 @@ CAMLprim value unix_read(value fd, value buf, value ofs, value len) ret = ReadFile(h, iobuf, numbytes, &numread, NULL); leave_blocking_section(); if (! ret) { - win32_maperr(GetLastError()); - uerror("read", Nothing); + win32_maperr(GetLastError()); + uerror("read", Nothing); } } memmove (&Byte(buf, Long_val(ofs)), iobuf, numread); diff --git a/otherlibs/win32unix/rename.c b/otherlibs/win32unix/rename.c index 51139485b..d84bcd66a 100644 --- a/otherlibs/win32unix/rename.c +++ b/otherlibs/win32unix/rename.c @@ -20,10 +20,10 @@ CAMLprim value unix_rename(value path1, value path2) { if (MoveFileEx(String_val(path1), String_val(path2), - MOVEFILE_REPLACE_EXISTING | MOVEFILE_WRITE_THROUGH | - MOVEFILE_COPY_ALLOWED) == 0) { + MOVEFILE_REPLACE_EXISTING | MOVEFILE_WRITE_THROUGH | + MOVEFILE_COPY_ALLOWED) == 0) { win32_maperr(GetLastError()); uerror("rename", path1); - } + } return Val_unit; } diff --git a/otherlibs/win32unix/sockopt.c b/otherlibs/win32unix/sockopt.c index a9572de79..13d6a03e3 100644 --- a/otherlibs/win32unix/sockopt.c +++ b/otherlibs/win32unix/sockopt.c @@ -37,7 +37,7 @@ CAMLprim value getsockopt_int(int *sockopt, value socket, optsize = sizeof(optval); if (getsockopt(Socket_val(socket), level, sockopt[Int_val(option)], - (void *) &optval, &optsize) == -1) + (void *) &optval, &optsize) == -1) uerror("getsockopt", Nothing); return Val_int(optval); } @@ -48,7 +48,7 @@ CAMLprim value setsockopt_int(int *sockopt, value socket, int level, int optval = Int_val(status); if (setsockopt(Socket_val(socket), level, sockopt[Int_val(option)], - (void *) &optval, sizeof(optval)) == -1) + (void *) &optval, sizeof(optval)) == -1) uerror("setsockopt", Nothing); return Val_unit; } @@ -76,12 +76,12 @@ CAMLprim value getsockopt_optint(int *sockopt, value socket, { struct linger optval; int optsize; - value res = Val_int(0); /* None */ + value res = Val_int(0); /* None */ optsize = sizeof(optval); if (getsockopt(Socket_val(socket), level, sockopt[Int_val(option)], - (void *) &optval, &optsize) == -1) + (void *) &optval, &optsize) == -1) uerror("getsockopt_optint", Nothing); if (optval.l_onoff != 0) { res = alloc_small(1, 0); @@ -100,7 +100,7 @@ CAMLprim value setsockopt_optint(int *sockopt, value socket, int level, optval.l_linger = Int_val (Field (status, 0)); if (setsockopt(Socket_val(socket), level, sockopt[Int_val(option)], - (void *) &optval, sizeof(optval)) == -1) + (void *) &optval, sizeof(optval)) == -1) uerror("setsockopt_optint", Nothing); return Val_unit; } @@ -124,7 +124,7 @@ CAMLprim value getsockopt_float(int *sockopt, value socket, optsize = sizeof(tv); if (getsockopt(Socket_val(socket), level, sockopt[Int_val(option)], - (void *) &tv, &optsize) == -1) + (void *) &tv, &optsize) == -1) uerror("getsockopt_float", Nothing); return copy_double((double) tv.tv_sec + (double) tv.tv_usec / 1e6); } @@ -140,7 +140,7 @@ CAMLprim value setsockopt_float(int *sockopt, value socket, int level, tv.tv_usec = (int) (1e6 * (tv_f - tv.tv_sec)); if (setsockopt(Socket_val(socket), level, sockopt[Int_val(option)], - (void *) &tv, sizeof(tv)) == -1) + (void *) &tv, sizeof(tv)) == -1) uerror("setsockopt_float", Nothing); return Val_unit; } diff --git a/otherlibs/win32unix/windir.c b/otherlibs/win32unix/windir.c index 13a7edec3..0a681e76c 100644 --- a/otherlibs/win32unix/windir.c +++ b/otherlibs/win32unix/windir.c @@ -36,7 +36,7 @@ CAMLprim value win_findfirst(name) if (err == ERROR_NO_MORE_FILES) raise_end_of_file(); else { - win32_maperr(err); + win32_maperr(err); uerror("opendir", Nothing); } } diff --git a/otherlibs/win32unix/write.c b/otherlibs/win32unix/write.c index 5c0e54e3d..8571ff679 100644 --- a/otherlibs/win32unix/write.c +++ b/otherlibs/win32unix/write.c @@ -34,26 +34,26 @@ CAMLprim value unix_write(value fd, value buf, value vofs, value vlen) numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len; memmove (iobuf, &Byte(buf, ofs), numbytes); if (Descr_kind_val(fd) == KIND_SOCKET) { - int ret; - SOCKET s = Socket_val(fd); - enter_blocking_section(); - ret = send(s, iobuf, numbytes, 0); - leave_blocking_section(); - if (ret == SOCKET_ERROR) { - win32_maperr(WSAGetLastError()); - uerror("write", Nothing); - } - numwritten = ret; + int ret; + SOCKET s = Socket_val(fd); + enter_blocking_section(); + ret = send(s, iobuf, numbytes, 0); + leave_blocking_section(); + if (ret == SOCKET_ERROR) { + win32_maperr(WSAGetLastError()); + uerror("write", Nothing); + } + numwritten = ret; } else { - BOOL ret; - HANDLE h = Handle_val(fd); - enter_blocking_section(); - ret = WriteFile(h, iobuf, numbytes, &numwritten, NULL); - leave_blocking_section(); - if (! ret) { - win32_maperr(GetLastError()); - uerror("write", Nothing); - } + BOOL ret; + HANDLE h = Handle_val(fd); + enter_blocking_section(); + ret = WriteFile(h, iobuf, numbytes, &numwritten, NULL); + leave_blocking_section(); + if (! ret) { + win32_maperr(GetLastError()); + uerror("write", Nothing); + } } written += numwritten; ofs += numwritten; diff --git a/parsing/parser.mly b/parsing/parser.mly index a037ccb08..48b0dba6f 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -1205,14 +1205,14 @@ with_constraint: /* Polymorphic types */ typevar_list: - QUOTE ident { [$2] } - | typevar_list QUOTE ident { $3 :: $1 } + QUOTE ident { [$2] } + | typevar_list QUOTE ident { $3 :: $1 } ; poly_type: - core_type - { mktyp(Ptyp_poly([], $1)) } - | typevar_list DOT core_type - { mktyp(Ptyp_poly(List.rev $1, $3)) } + core_type + { mktyp(Ptyp_poly([], $1)) } + | typevar_list DOT core_type + { mktyp(Ptyp_poly(List.rev $1, $3)) } ; /* Core types */ diff --git a/stdlib/headernt.c b/stdlib/headernt.c index 690f576eb..9c723bcc9 100644 --- a/stdlib/headernt.c +++ b/stdlib/headernt.c @@ -77,7 +77,7 @@ static __inline char * read_runtime_path(HANDLE h) static BOOL WINAPI ctrl_handler(DWORD event) { if (event == CTRL_C_EVENT || event == CTRL_BREAK_EVENT) - return TRUE; /* pretend we've handled them */ + return TRUE; /* pretend we've handled them */ else return FALSE; } diff --git a/stdlib/queue.ml b/stdlib/queue.ml index 5a08721f5..096d7141d 100644 --- a/stdlib/queue.ml +++ b/stdlib/queue.ml @@ -113,8 +113,8 @@ let copy q = let rec copy cell = if cell == tail then tail' else { - content = cell.content; - next = copy cell.next + content = cell.content; + next = copy cell.next } in tail'.next <- copy tail.next; @@ -135,7 +135,7 @@ let iter f q = let rec iter cell = f cell.content; if cell != tail then - iter cell.next in + iter cell.next in iter tail.next let fold f accu q = @@ -146,9 +146,9 @@ let fold f accu q = let rec fold accu cell = let accu = f accu cell.content in if cell == tail then - accu + accu else - fold accu cell.next in + fold accu cell.next in fold accu tail.next let transfer q1 q2 = diff --git a/test/Makefile b/test/Makefile index 79872d213..cb5da20ff 100644 --- a/test/Makefile +++ b/test/Makefile @@ -74,6 +74,7 @@ genlex.out: $(CODE_GENLEX) clean:: rm -f Lex/*.cm[iox] Lex/*.[os] rm -f Lex/*~ + rm -f Lex/grammar.output Lex/grammar.ml Lex/grammar.mli: Lex/grammar.mly ../yacc/ocamlyacc$(EXE) $(CAMLYACC) $(YACCFLAGS) Lex/grammar.mly diff --git a/typing/ctype.ml b/typing/ctype.ml index 0f268c12f..965856f78 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -539,7 +539,7 @@ let rec generalize_structure var_level ty = else if ty.level > !current_level then begin ty.level <- generic_level; begin match ty.desc with - Tconstr (_, _, abbrev) -> + Tconstr (_, _, abbrev) -> iter_abbrev (generalize_structure var_level) !abbrev | _ -> () end; @@ -892,9 +892,9 @@ let rec copy_sep fixed free bound visited ty = let t = newvar() in (* Stub *) let visited = match ty.desc with - Tarrow _ | Ttuple _ | Tvariant _ | Tconstr _ | Tobject _ -> + Tarrow _ | Ttuple _ | Tvariant _ | Tconstr _ | Tobject _ -> (ty,(t,bound)) :: visited - | _ -> visited in + | _ -> visited in let copy_rec = copy_sep fixed free bound visited in t.desc <- begin match ty.desc with @@ -906,13 +906,13 @@ let rec copy_sep fixed free bound visited ty = let more' = copy_rec more in let row = copy_row copy_rec fixed row keep more' in Tvariant row - | Tpoly (t1, tl) -> - let tl = List.map repr tl in - let tl' = List.map (fun t -> newty Tunivar) tl in - let bound = tl @ bound in - let visited = - List.map2 (fun ty t -> ty,(t,bound)) tl tl' @ visited in - Tpoly (copy_rec t1, tl') + | Tpoly (t1, tl) -> + let tl = List.map repr tl in + let tl' = List.map (fun t -> newty Tunivar) tl in + let bound = tl @ bound in + let visited = + List.map2 (fun ty t -> ty,(t,bound)) tl tl' @ visited in + Tpoly (copy_rec t1, tl') | _ -> copy_type_desc copy_rec ty.desc end; t @@ -1221,18 +1221,18 @@ let rec unify_univar t1 t2 = function let repr_univ = List.map (fun (t,o) -> repr t, o) in let cl1 = repr_univ cl1 and cl2 = repr_univ cl2 in begin try - let r1 = List.assq t1 cl1 in - match !r1 with - Some t -> if t2 != repr t then raise (Unify []) - | None -> - try - let r2 = List.assq t2 cl2 in - if !r2 <> None then raise (Unify []); - r1 := Some t2; r2 := Some t1 - with Not_found -> - raise (Unify []) + let r1 = List.assq t1 cl1 in + match !r1 with + Some t -> if t2 != repr t then raise (Unify []) + | None -> + try + let r2 = List.assq t2 cl2 in + if !r2 <> None then raise (Unify []); + r1 := Some t2; r2 := Some t1 + with Not_found -> + raise (Unify []) with Not_found -> - unify_univar t1 t2 rem + unify_univar t1 t2 rem end | [] -> raise (Unify []) @@ -1258,12 +1258,12 @@ let occur_univar ty = true then match ty.desc with - Tunivar -> + Tunivar -> if not (TypeSet.mem ty bound) then raise (Unify [ty, newgenvar()]) - | Tpoly (ty, tyl) -> + | Tpoly (ty, tyl) -> let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in occur_rec bound ty - | _ -> iter_type_expr (occur_rec bound) ty + | _ -> iter_type_expr (occur_rec bound) ty in try occur_rec TypeSet.empty ty; unmark_type ty @@ -1357,9 +1357,9 @@ let rec unify env t1 t2 = update_level env t2.level t1; t2.desc <- Tlink t1 | (Tunivar, Tunivar) -> - unify_univar t1 t2 !univar_pairs; - update_level env t1.level t2; - t1.desc <- Tlink t2 + unify_univar t1 t2 !univar_pairs; + update_level env t1.level t2; + t1.desc <- Tlink t2 | (Tconstr (p1, [], a1), Tconstr (p2, [], a2)) when Path.same p1 p2 (* This optimization assumes that t1 does not expand to t2 @@ -1450,15 +1450,15 @@ and unify3 env t1 t1' t2 t2' = | (Tnil, Tnil) -> () | (Tpoly (t1, []), Tpoly (t2, [])) -> - unify env t1 t2 + unify env t1 t2 | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> if List.length tl1 <> List.length tl2 then raise (Unify []); - let old_univars = !univar_pairs in - let cl1 = List.map (fun t -> t, ref None) tl1 - and cl2 = List.map (fun t -> t, ref None) tl2 in - univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars; - begin try - unify env t1 t2; + let old_univars = !univar_pairs in + let cl1 = List.map (fun t -> t, ref None) tl1 + and cl2 = List.map (fun t -> t, ref None) tl2 in + univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars; + begin try + unify env t1 t2; let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in List.iter (fun t1 -> @@ -1470,9 +1470,9 @@ and unify3 env t1 t1' t2 t2' = with Not_found -> assert false) tl1; univar_pairs := old_univars - with exn -> - univar_pairs := old_univars; raise exn - end + with exn -> + univar_pairs := old_univars; raise exn + end | (_, _) -> raise (Unify []) end; @@ -1697,11 +1697,11 @@ let unify_var env t1 t2 = match t1.desc with Tvar -> begin try - occur env t1 t2; - update_level env t1.level t2; - t1.desc <- Tlink t2 + occur env t1 t2; + update_level env t1.level t2; + t1.desc <- Tlink t2 with Unify trace -> - raise (Unify ((t1,t2)::trace)) + raise (Unify ((t1,t2)::trace)) end | _ -> unify env t1 t2 @@ -1834,7 +1834,7 @@ let rec moregen inst_nongen type_pairs env t1 t2 = try match (t1.desc, t2.desc) with (Tunivar, Tunivar) -> - unify_univar t1 t2 !univar_pairs + unify_univar t1 t2 !univar_pairs | (Tvar, _) when if inst_nongen then t1.level <> generic_level - 1 else t1.level = generic_level -> moregen_occur env t1.level t2; @@ -1874,19 +1874,19 @@ let rec moregen inst_nongen type_pairs env t1 t2 = moregen_fields inst_nongen type_pairs env t1' t2' | (Tnil, Tnil) -> () - | (Tpoly (t1, []), Tpoly (t2, [])) -> - moregen inst_nongen type_pairs env t1 t2 - | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> - let old_univars = !univar_pairs in - let cl1 = List.map (fun t -> t, ref None) tl1 - and cl2 = List.map (fun t -> t, ref None) tl2 in - univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars; - begin try - moregen inst_nongen type_pairs env t1 t2; - univar_pairs := old_univars - with exn -> - univar_pairs := old_univars; raise exn - end + | (Tpoly (t1, []), Tpoly (t2, [])) -> + moregen inst_nongen type_pairs env t1 t2 + | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> + let old_univars = !univar_pairs in + let cl1 = List.map (fun t -> t, ref None) tl1 + and cl2 = List.map (fun t -> t, ref None) tl2 in + univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars; + begin try + moregen inst_nongen type_pairs env t1 t2; + univar_pairs := old_univars + with exn -> + univar_pairs := old_univars; raise exn + end | (_, _) -> raise (Unify []) end @@ -2070,21 +2070,21 @@ let rec eqtype rename type_pairs subst env t1 t2 = eqtype_fields rename type_pairs subst env t1' t2' | (Tnil, Tnil) -> () - | (Tpoly (t1, []), Tpoly (t2, [])) -> - eqtype rename type_pairs subst env t1 t2 - | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> - let old_univars = !univar_pairs in - let cl1 = List.map (fun t -> t, ref None) tl1 - and cl2 = List.map (fun t -> t, ref None) tl2 in - univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars; - begin try eqtype rename type_pairs subst env t1 t2 - with exn -> - univar_pairs := old_univars; - raise exn - end; - univar_pairs := old_univars - | (Tunivar, Tunivar) -> - unify_univar t1 t2 !univar_pairs + | (Tpoly (t1, []), Tpoly (t2, [])) -> + eqtype rename type_pairs subst env t1 t2 + | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> + let old_univars = !univar_pairs in + let cl1 = List.map (fun t -> t, ref None) tl1 + and cl2 = List.map (fun t -> t, ref None) tl2 in + univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars; + begin try eqtype rename type_pairs subst env t1 t2 + with exn -> + univar_pairs := old_univars; + raise exn + end; + univar_pairs := old_univars + | (Tunivar, Tunivar) -> + unify_univar t1 t2 !univar_pairs | (_, _) -> raise (Unify []) end @@ -2539,7 +2539,7 @@ let rec build_subtype env visited loops posi level t = (t'', Changed) | _ -> raise Not_found with Not_found -> - let (t'',c) = build_subtype env visited loops posi level' t' in + let (t'',c) = build_subtype env visited loops posi level' t' in if c > Unchanged then (t'',c) else (t, Unchanged) end @@ -2732,15 +2732,15 @@ let rec subtype_rec env trace t1 t2 cstrs = (trace, t1, t2, !univar_pairs)::cstrs end | (Tpoly (u1, []), Tpoly (u2, [])) -> - subtype_rec env trace u1 u2 cstrs + subtype_rec env trace u1 u2 cstrs | (Tpoly (t1, tl1), Tpoly (t2,tl2)) -> - let old_univars = !univar_pairs in - let cl1 = List.map (fun t -> t, ref None) tl1 - and cl2 = List.map (fun t -> t, ref None) tl2 in - univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars; - let cstrs = subtype_rec env trace t1 t2 cstrs in - univar_pairs := old_univars; - cstrs + let old_univars = !univar_pairs in + let cl1 = List.map (fun t -> t, ref None) tl1 + and cl2 = List.map (fun t -> t, ref None) tl2 in + univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars; + let cstrs = subtype_rec env trace t1 t2 cstrs in + univar_pairs := old_univars; + cstrs | (_, _) -> (trace, t1, t2, !univar_pairs)::cstrs end diff --git a/typing/printtyp.ml b/typing/printtyp.ml index bcb36f697..abe29dedd 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -181,8 +181,8 @@ let rec mark_loops_rec visited ty = | Tsubst ty -> mark_loops_rec visited ty | Tlink _ -> fatal_error "Printtyp.mark_loops_rec (2)" | Tpoly (ty, tyl) -> - List.iter (fun t -> add_alias t) tyl; - mark_loops_rec visited ty + List.iter (fun t -> add_alias t) tyl; + mark_loops_rec visited ty | Tunivar -> () let mark_loops ty = @@ -278,7 +278,7 @@ let rec tree_of_typexp sch ty = | Tlink _ | Tnil | Tfield _ -> fatal_error "Printtyp.tree_of_typexp" | Tpoly (ty, []) -> - tree_of_typexp sch ty + tree_of_typexp sch ty | Tpoly (ty, tyl) -> let tyl = List.map repr tyl in (* let tyl = List.filter is_aliased tyl in *) diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 511ae4f67..5571d1e97 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -436,26 +436,26 @@ let rec class_field cl_num self_type meths vars Ctype.filter_self_method val_env lab priv meths self_type in begin try match expr.pexp_desc with - Pexp_poly (sbody, sty) -> - begin match sty with None -> () - | Some sty -> - Ctype.unify val_env - (Typetexp.transl_simple_type val_env false sty) ty - end; - begin match (Ctype.repr ty).desc with - Tvar -> - let ty' = Ctype.newvar () in - Ctype.unify val_env (Ctype.newty (Tpoly (ty', []))) ty; - Ctype.unify val_env (type_approx val_env sbody) ty' - | Tpoly (ty1, tl) -> - let _, ty1' = Ctype.instance_poly false tl ty1 in - let ty2 = type_approx val_env sbody in - Ctype.unify val_env ty2 ty1' - | _ -> assert false - end - | _ -> assert false + Pexp_poly (sbody, sty) -> + begin match sty with None -> () + | Some sty -> + Ctype.unify val_env + (Typetexp.transl_simple_type val_env false sty) ty + end; + begin match (Ctype.repr ty).desc with + Tvar -> + let ty' = Ctype.newvar () in + Ctype.unify val_env (Ctype.newty (Tpoly (ty', []))) ty; + Ctype.unify val_env (type_approx val_env sbody) ty' + | Tpoly (ty1, tl) -> + let _, ty1' = Ctype.instance_poly false tl ty1 in + let ty2 = type_approx val_env sbody in + Ctype.unify val_env ty2 ty1' + | _ -> assert false + end + | _ -> assert false with Ctype.Unify trace -> - raise(Error(loc, Method_type_mismatch (lab, trace))) + raise(Error(loc, Method_type_mismatch (lab, trace))) end; let meth_expr = make_method cl_num expr in let vars_local = !vars in diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 1eff2f189..9040ede19 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -109,7 +109,7 @@ let rec transl_type env policy rowvar styp = if policy = Univars then new_pre_univar () else newvar () | Ptyp_var name -> begin try - List.assoc name !univars + List.assoc name !univars with Not_found -> match policy with Fixed -> @@ -130,9 +130,9 @@ let rec transl_type env policy rowvar styp = begin try instance (Tbl.find name !type_variables) with Not_found -> - let v = new_pre_univar () in + let v = new_pre_univar () in type_variables := Tbl.add name v !type_variables; - v + v end | Delayed -> begin try @@ -181,9 +181,9 @@ let rec transl_type env policy rowvar styp = cstr | Ptyp_object fields -> begin try - newobj (transl_fields env policy rowvar fields) + newobj (transl_fields env policy rowvar fields) with Error (loc, No_row_variable _) when loc = Location.none -> - raise (Error(styp.ptyp_loc, No_row_variable "object ")) + raise (Error(styp.ptyp_loc, No_row_variable "object ")) end | Ptyp_class(lid, stl, present) -> if policy = Fixed & rowvar = None then @@ -218,7 +218,7 @@ let rec transl_type env policy rowvar styp = in if List.length stl <> decl.type_arity then raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid, decl.type_arity, - List.length stl))); + List.length stl))); let args = List.map (transl_type env policy None) stl in let cstr = newty (Tconstr(path, args, ref Mnil)) in let ty = @@ -283,10 +283,10 @@ let rec transl_type env policy rowvar styp = | Ptyp_alias(st, alias) -> if List.mem_assoc alias !univars then match List.assoc alias !univars with - {desc=Tlink({desc=Tunivar} as tc)} as tr -> - let ty = transl_type env policy (Some tc) st in + {desc=Tlink({desc=Tunivar} as tc)} as tr -> + let ty = transl_type env policy (Some tc) st in tr.level <- tc.level; - tr.desc <- Tvar; + tr.desc <- Tvar; begin try unify_var env tr ty with Unify trace -> let trace = swap_list trace in raise(Error(styp.ptyp_loc, Alias_type_mismatch trace)) @@ -331,7 +331,7 @@ let rec transl_type env policy rowvar styp = end | Ptyp_variant(fields, closed, present) -> if rowvar <> None && present = None && closed then - raise (Error(styp.ptyp_loc, No_row_variable "variant ")); + raise (Error(styp.ptyp_loc, No_row_variable "variant ")); let bound = ref [] and name = ref None in let fixed = rowvar <> None || policy = Univars in let mkfield l f = @@ -429,10 +429,10 @@ let rec transl_type env policy rowvar styp = if static then row else { row with row_more = match rowvar with Some v -> v | None -> - if policy = Univars then new_pre_univar () else + if policy = Univars then new_pre_univar () else if policy = Fixed && not static then raise(Error(styp.ptyp_loc, Unbound_type_variable "[..]")) - else row.row_more + else row.row_more } in newty (Tvariant row) | Ptyp_poly(vars, st) -> @@ -453,11 +453,11 @@ and transl_fields env policy rowvar = newty Tnil | {pfield_desc = Pfield_var} as field::_ -> begin match rowvar with - None -> - if policy = Fixed then + None -> + if policy = Fixed then raise(Error(field.pfield_loc, Unbound_type_variable "..")); - if policy = Univars then new_pre_univar () else newvar () - | Some v -> v + if policy = Univars then new_pre_univar () else newvar () + | Some v -> v end | {pfield_desc = Pfield(s, e)}::l -> let ty1 = transl_type env policy None e in @@ -480,7 +480,7 @@ let transl_simple_type_univars env styp = List.fold_left (fun acc v -> let v = repr v in - if v.desc <> Tvar || v.level <> Btype.generic_level || List.memq v acc + if v.desc <> Tvar || v.level <> Btype.generic_level || List.memq v acc then acc else (v.desc <- Tunivar ; v :: acc)) [] !pre_univars diff --git a/utils/config.mli b/utils/config.mli index 52976b89c..c09e053b5 100644 --- a/utils/config.mli +++ b/utils/config.mli @@ -22,7 +22,7 @@ val standard_library: string val standard_runtime: string (* The full path to the standard bytecode interpreter ocamlrun *) val ccomp_type: string - (* The "kind" of the C compiler: one of + (* The "kind" of the C compiler: one of "cc" (for Unix-style C compilers) "msvc" (Microsoft Visual C++) "mrc" (Macintosh MPW) *) diff --git a/win32caml/inria.h b/win32caml/inria.h index 0ba73faae..afa252404 100644 --- a/win32caml/inria.h +++ b/win32caml/inria.h @@ -62,50 +62,50 @@ // In this structure should go eventually all global variables scattered // through the program. typedef struct _programParams { - HFONT hFont; // The handle of the current font - COLORREF TextColor; // The text color - char CurrentWorkingDir[MAX_PATH];// The current directory + HFONT hFont; // The handle of the current font + COLORREF TextColor; // The text color + char CurrentWorkingDir[MAX_PATH];// The current directory } PROGRAM_PARAMS; //**************** Global variables *********************** extern PROGRAM_PARAMS ProgramParams; -extern COLORREF BackColor; // The background color -extern HBRUSH BackgroundBrush; // A brush built with the background color -extern char LibDir[]; // The lib directory -extern char OcamlPath[]; // The Path to ocaml.exe -extern HANDLE hInst; // The instance handle for this application -extern HWND hwndSession; // The current session window handle -extern LOGFONT CurrentFont; // The current font characteristics +extern COLORREF BackColor; // The background color +extern HBRUSH BackgroundBrush; // A brush built with the background color +extern char LibDir[]; // The lib directory +extern char OcamlPath[]; // The Path to ocaml.exe +extern HANDLE hInst; // The instance handle for this application +extern HWND hwndSession; // The current session window handle +extern LOGFONT CurrentFont; // The current font characteristics extern HWND hwndMain,hwndMDIClient; // Window handles of frame and mdi window // ***************** Function prototypes ****************** -int WriteToPipe(char *data); // Writes to the pipe +int WriteToPipe(char *data); // Writes to the pipe int ReadFromPipe(char *data,int len);// Reads from the pipe -int AskYesOrNo(char *msg); //Ditto! +int AskYesOrNo(char *msg); //Ditto! int BrowseForFile(char *fname,char *path); -void GotoEOF(void); // Positions the cursor at the end of the text -void ShowDbgMsg(char *msg); // Shows an error message +void GotoEOF(void); // Positions the cursor at the end of the text +void ShowDbgMsg(char *msg); // Shows an error message void HandleCommand(HWND hwnd, WPARAM wParam,LPARAM lParam); -int GetOcamlPath(void); // Finds where ocaml.exe is -void ForceRepaint(void); // Ditto. +int GetOcamlPath(void); // Finds where ocaml.exe is +void ForceRepaint(void); // Ditto. void AddLineToControl(char *buf); -char *GetHistoryLine(int n); // Gets the nth history line base 1. +char *GetHistoryLine(int n); // Gets the nth history line base 1. int StartOcaml(void); // **************** User defined window messages ************* -#define WM_NEWLINE (WM_USER+6000) +#define WM_NEWLINE (WM_USER+6000) #define WM_TIMERTICK (WM_USER+6001) #define WM_QUITOCAML (WM_USER+6002) // ********************** Structures *********************** typedef struct tagPosition { - int line; - int col; + int line; + int col; } POSITION; // Simple linked list for holding the history lines typedef struct tagHistory { - struct tagHistory *Next; - char *Text; + struct tagHistory *Next; + char *Text; } HISTORYLINE; extern void *SafeMalloc(int); diff --git a/win32caml/inriares.h b/win32caml/inriares.h index 520ac3cb1..2043a37d7 100644 --- a/win32caml/inriares.h +++ b/win32caml/inriares.h @@ -1,48 +1,48 @@ /* Weditres generated include file. Do NOT edit */ -#define IDD_ABOUT 100 -#define IDM_NEW 200 -#define IDM_OPEN 210 -#define IDM_SAVE 220 -#define IDM_SAVEAS 230 -#define IDM_CLOSE 240 -#define IDM_PRINT 250 -#define IDM_PRINTSU 260 -#define IDM_PRINTPRE 265 -#define IDM_PAGESETUP 267 -#define IDM_EXIT 270 -#define IDM_HISTORY 281 -#define IDM_GC 282 -#define IDCTRLC 283 -#define IDD_HISTORY 300 -#define IDLIST 301 -#define IDM_EDITUNDO 310 -#define IDM_EDITCUT 320 -#define IDM_EDITCOPY 330 -#define IDM_EDITPASTE 340 -#define IDM_EDITCLEAR 350 -#define IDM_EDITDELETE 360 -#define IDM_EDITREPLACE 370 -#define IDM_EDITREDO 380 -#define IDM_WINDOWTILE 410 -#define IDM_WINDOWCASCADE 420 -#define IDM_WINDOWICONS 430 -#define IDM_WINDOWCLOSEALL 440 -#define IDM_PROPERTIES 450 -#define IDM_ABOUT 500 -#define IDM_HELP 510 -#define IDMAINMENU 600 -#define IDM_FIND 700 -#define IDAPPLICON 710 -#define IDI_CHILDICON 800 -#define IDAPPLCURSOR 810 -#define OCAML_ICON 1000 -#define IDS_FILEMENU 2000 -#define IDS_HELPMENU 2010 -#define IDS_SYSMENU 2030 -#define IDM_STATUSBAR 3000 -#define IDM_WINDOWCHILD 3010 -#define ID_TOOLBAR 5000 -#define IDACCEL 10000 -#define IDM_FONT 40002 -#define IDM_COLORTEXT 40004 -#define IDM_BACKCOLOR 40005 +#define IDD_ABOUT 100 +#define IDM_NEW 200 +#define IDM_OPEN 210 +#define IDM_SAVE 220 +#define IDM_SAVEAS 230 +#define IDM_CLOSE 240 +#define IDM_PRINT 250 +#define IDM_PRINTSU 260 +#define IDM_PRINTPRE 265 +#define IDM_PAGESETUP 267 +#define IDM_EXIT 270 +#define IDM_HISTORY 281 +#define IDM_GC 282 +#define IDCTRLC 283 +#define IDD_HISTORY 300 +#define IDLIST 301 +#define IDM_EDITUNDO 310 +#define IDM_EDITCUT 320 +#define IDM_EDITCOPY 330 +#define IDM_EDITPASTE 340 +#define IDM_EDITCLEAR 350 +#define IDM_EDITDELETE 360 +#define IDM_EDITREPLACE 370 +#define IDM_EDITREDO 380 +#define IDM_WINDOWTILE 410 +#define IDM_WINDOWCASCADE 420 +#define IDM_WINDOWICONS 430 +#define IDM_WINDOWCLOSEALL 440 +#define IDM_PROPERTIES 450 +#define IDM_ABOUT 500 +#define IDM_HELP 510 +#define IDMAINMENU 600 +#define IDM_FIND 700 +#define IDAPPLICON 710 +#define IDI_CHILDICON 800 +#define IDAPPLCURSOR 810 +#define OCAML_ICON 1000 +#define IDS_FILEMENU 2000 +#define IDS_HELPMENU 2010 +#define IDS_SYSMENU 2030 +#define IDM_STATUSBAR 3000 +#define IDM_WINDOWCHILD 3010 +#define ID_TOOLBAR 5000 +#define IDACCEL 10000 +#define IDM_FONT 40002 +#define IDM_COLORTEXT 40004 +#define IDM_BACKCOLOR 40005 diff --git a/win32caml/libgraph.h b/win32caml/libgraph.h index 59c1f5f9d..3bfaff301 100644 --- a/win32caml/libgraph.h +++ b/win32caml/libgraph.h @@ -29,7 +29,7 @@ extern HWND grdisplay; /* The display connection */ //extern struct canvas grbstore; /* The pixmap used for backing store */ //extern int grwhite, grblack; /* Black and white pixels for X */ //extern int grbackground; /* Background color for X -// (used for CAML color -1) */ +// (used for CAML color -1) */ extern COLORREF grbackground; extern BOOL grdisplay_mode; /* Display-mode flag */ extern BOOL grremember_mode; /* Remember-mode flag */ @@ -83,20 +83,20 @@ extern RECT WindowRect; extern int grCurrentColor; typedef struct tagWindow { - HDC gc; - HDC gcBitmap; - HWND hwnd; - HBRUSH CurrentBrush; - HPEN CurrentPen; - DWORD CurrentColor; - int width; - int height; - int grx; - int gry; - HBITMAP hBitmap; - HFONT CurrentFont; - int CurrentFontSize; - HDC tempDC; // For image operations; + HDC gc; + HDC gcBitmap; + HWND hwnd; + HBRUSH CurrentBrush; + HPEN CurrentPen; + DWORD CurrentColor; + int width; + int height; + int grx; + int gry; + HBITMAP hBitmap; + HFONT CurrentFont; + int CurrentFontSize; + HDC tempDC; // For image operations; } GR_WINDOW; extern GR_WINDOW grwindow; diff --git a/win32caml/menu.c b/win32caml/menu.c index 90581fe76..ad5cc2f6a 100644 --- a/win32caml/menu.c +++ b/win32caml/menu.c @@ -33,39 +33,39 @@ char CurrentFontName[64] = "Courier"; ------------------------------------------------------------------------*/ int OpenMlFile(char *fname,int lenbuf) { - OPENFILENAME ofn; - int r; - char *p,defext[5],tmp[512]; - - memset(&ofn,0,sizeof(OPENFILENAME)); - memset(tmp,0,sizeof(tmp)); - fname[0] = 0; - strcpy(tmp,"ocaml sources|*.ml|bytecode object files|*.cmo|All files|*.*"); - p = tmp; - while (*p) { - if (*p == '|') - *p = 0; - p++; - } - strcpy(defext,"ml"); - ofn.lStructSize = sizeof(OPENFILENAME); - ofn.hwndOwner = hwndMain; - ofn.lpstrFilter = tmp; - ofn.nFilterIndex = 1; - ofn.hInstance = hInst; - ofn.lpstrFile = fname; - ofn.lpstrTitle = "Open file"; - ofn.lpstrInitialDir = LibDir; - ofn.nMaxFile = lenbuf; - ofn.Flags = OFN_PATHMUSTEXIST | OFN_NOCHANGEDIR | OFN_LONGNAMES | - OFN_HIDEREADONLY |OFN_EXPLORER; - r = GetOpenFileName(&ofn); - if (r) { - /* Replace backslashes by forward slashes in file name */ - for (p = fname; *p != 0; p++) - if (*p == '\\') *p = '/'; - } - return r; + OPENFILENAME ofn; + int r; + char *p,defext[5],tmp[512]; + + memset(&ofn,0,sizeof(OPENFILENAME)); + memset(tmp,0,sizeof(tmp)); + fname[0] = 0; + strcpy(tmp,"ocaml sources|*.ml|bytecode object files|*.cmo|All files|*.*"); + p = tmp; + while (*p) { + if (*p == '|') + *p = 0; + p++; + } + strcpy(defext,"ml"); + ofn.lStructSize = sizeof(OPENFILENAME); + ofn.hwndOwner = hwndMain; + ofn.lpstrFilter = tmp; + ofn.nFilterIndex = 1; + ofn.hInstance = hInst; + ofn.lpstrFile = fname; + ofn.lpstrTitle = "Open file"; + ofn.lpstrInitialDir = LibDir; + ofn.nMaxFile = lenbuf; + ofn.Flags = OFN_PATHMUSTEXIST | OFN_NOCHANGEDIR | OFN_LONGNAMES | + OFN_HIDEREADONLY |OFN_EXPLORER; + r = GetOpenFileName(&ofn); + if (r) { + /* Replace backslashes by forward slashes in file name */ + for (p = fname; *p != 0; p++) + if (*p == '\\') *p = '/'; + } + return r; } /*------------------------------------------------------------------------ Procedure: GetSaveName ID:1 @@ -79,36 +79,36 @@ int OpenMlFile(char *fname,int lenbuf) ------------------------------------------------------------------------*/ int GetSaveName(char *fname,int lenbuf) { - OPENFILENAME ofn; - int r; - char *p,defext[5],tmp[512]; - - memset(&ofn,0,sizeof(OPENFILENAME)); - memset(tmp,0,sizeof(tmp)); - fname[0] = 0; - strcpy(tmp,"Text files|*.txt"); - p = tmp; - while (*p) { - if (*p == '|') - *p = 0; - p++; - } - strcpy(defext,"txt"); - ofn.lStructSize = sizeof(OPENFILENAME); - ofn.hwndOwner = hwndMain; - ofn.lpstrFilter = tmp; - ofn.nFilterIndex = 1; - ofn.hInstance = hInst; - ofn.lpstrFile = fname; - ofn.lpstrTitle = "Save as"; - ofn.lpstrInitialDir = LibDir; - ofn.nMaxFile = lenbuf; - ofn.Flags = OFN_NOCHANGEDIR | OFN_LONGNAMES | - OFN_HIDEREADONLY |OFN_EXPLORER; - r = GetSaveFileName(&ofn); - if (r == 0) - return 0; - else return 1; + OPENFILENAME ofn; + int r; + char *p,defext[5],tmp[512]; + + memset(&ofn,0,sizeof(OPENFILENAME)); + memset(tmp,0,sizeof(tmp)); + fname[0] = 0; + strcpy(tmp,"Text files|*.txt"); + p = tmp; + while (*p) { + if (*p == '|') + *p = 0; + p++; + } + strcpy(defext,"txt"); + ofn.lStructSize = sizeof(OPENFILENAME); + ofn.hwndOwner = hwndMain; + ofn.lpstrFilter = tmp; + ofn.nFilterIndex = 1; + ofn.hInstance = hInst; + ofn.lpstrFile = fname; + ofn.lpstrTitle = "Save as"; + ofn.lpstrInitialDir = LibDir; + ofn.nMaxFile = lenbuf; + ofn.Flags = OFN_NOCHANGEDIR | OFN_LONGNAMES | + OFN_HIDEREADONLY |OFN_EXPLORER; + r = GetSaveFileName(&ofn); + if (r == 0) + return 0; + else return 1; } /*------------------------------------------------------------------------ Procedure: BrowseForFile ID:1 @@ -122,36 +122,36 @@ int GetSaveName(char *fname,int lenbuf) ------------------------------------------------------------------------*/ int BrowseForFile(char *fname,char *path) { - OPENFILENAME ofn; - char *p,tmp[512],browsefor[512]; - int r; - - memset(tmp,0,sizeof(tmp)); - strncpy(tmp,fname,sizeof(tmp)-1); - p = tmp; - while (*p) { - if (*p == '|') - *p = 0; - p++; - } - memset(&ofn,0,sizeof(OPENFILENAME)); - ofn.lpstrFilter = tmp; - ofn.nFilterIndex = 1; - ofn.lStructSize = sizeof(OPENFILENAME); - ofn.hwndOwner = hwndMain; - ofn.hInstance = hInst; - ofn.lpstrFilter = tmp; - ofn.lpstrFile = path; - wsprintf(browsefor,"Open %s",fname); - ofn.lpstrTitle = browsefor; - ofn.lpstrInitialDir = "c:\\"; - ofn.nMaxFile = MAX_PATH; - ofn.Flags = OFN_PATHMUSTEXIST | OFN_NOCHANGEDIR | OFN_LONGNAMES | - OFN_HIDEREADONLY |OFN_EXPLORER; - r = GetOpenFileName(&ofn); - if (r == 0) - return 0; - else return 1; + OPENFILENAME ofn; + char *p,tmp[512],browsefor[512]; + int r; + + memset(tmp,0,sizeof(tmp)); + strncpy(tmp,fname,sizeof(tmp)-1); + p = tmp; + while (*p) { + if (*p == '|') + *p = 0; + p++; + } + memset(&ofn,0,sizeof(OPENFILENAME)); + ofn.lpstrFilter = tmp; + ofn.nFilterIndex = 1; + ofn.lStructSize = sizeof(OPENFILENAME); + ofn.hwndOwner = hwndMain; + ofn.hInstance = hInst; + ofn.lpstrFilter = tmp; + ofn.lpstrFile = path; + wsprintf(browsefor,"Open %s",fname); + ofn.lpstrTitle = browsefor; + ofn.lpstrInitialDir = "c:\\"; + ofn.nMaxFile = MAX_PATH; + ofn.Flags = OFN_PATHMUSTEXIST | OFN_NOCHANGEDIR | OFN_LONGNAMES | + OFN_HIDEREADONLY |OFN_EXPLORER; + r = GetOpenFileName(&ofn); + if (r == 0) + return 0; + else return 1; } /*------------------------------------------------------------------------ @@ -166,31 +166,31 @@ int BrowseForFile(char *fname,char *path) ------------------------------------------------------------------------*/ static int CallChangeFont(HWND hwnd) { - LOGFONT lf; - CHOOSEFONT cf; - int r; - HWND hwndChild; - - memset(&cf, 0, sizeof(CHOOSEFONT)); - memcpy(&lf, &CurrentFont, sizeof(LOGFONT)); - cf.lStructSize = sizeof(CHOOSEFONT); - cf.hwndOwner = hwnd; - cf.lpLogFont = &lf; - cf.Flags = CF_SCREENFONTS | CF_EFFECTS | CF_APPLY | CF_INITTOLOGFONTSTRUCT; - cf.nFontType = SCREEN_FONTTYPE; - r = ChooseFont(&cf); - if (!r) - return (0); - DeleteObject(ProgramParams.hFont); - memcpy(&CurrentFont, &lf, sizeof(LOGFONT)); - ProgramParams.hFont = CreateFontIndirect(&CurrentFont); - strcpy(CurrentFontName, CurrentFont.lfFaceName); - CurrentFontFamily = lf.lfPitchAndFamily; - CurrentFontStyle = lf.lfWeight; + LOGFONT lf; + CHOOSEFONT cf; + int r; + HWND hwndChild; + + memset(&cf, 0, sizeof(CHOOSEFONT)); + memcpy(&lf, &CurrentFont, sizeof(LOGFONT)); + cf.lStructSize = sizeof(CHOOSEFONT); + cf.hwndOwner = hwnd; + cf.lpLogFont = &lf; + cf.Flags = CF_SCREENFONTS | CF_EFFECTS | CF_APPLY | CF_INITTOLOGFONTSTRUCT; + cf.nFontType = SCREEN_FONTTYPE; + r = ChooseFont(&cf); + if (!r) + return (0); + DeleteObject(ProgramParams.hFont); + memcpy(&CurrentFont, &lf, sizeof(LOGFONT)); + ProgramParams.hFont = CreateFontIndirect(&CurrentFont); + strcpy(CurrentFontName, CurrentFont.lfFaceName); + CurrentFontFamily = lf.lfPitchAndFamily; + CurrentFontStyle = lf.lfWeight; hwndChild = (HWND) GetWindowLong(hwndSession, DWL_USER); - SendMessage(hwndChild,WM_SETFONT,(WPARAM)ProgramParams.hFont,0); - ForceRepaint(); - return (1); + SendMessage(hwndChild,WM_SETFONT,(WPARAM)ProgramParams.hFont,0); + ForceRepaint(); + return (1); } /*------------------------------------------------------------------------ @@ -223,29 +223,29 @@ int CallDlgProc(BOOL (CALLBACK *fn)(HWND,UINT,WPARAM,LPARAM), int id) ------------------------------------------------------------------------*/ static COLORREF CallChangeColor(COLORREF InitialColor) { - CHOOSECOLOR CC; - COLORREF CustColors[16]; - int r, g, b, i; - memset(&CC, 0, sizeof(CHOOSECOLOR)); - r = g = b = 0; - for (i = 0; i < 16; i++) { - CustColors[i] = RGB(r, g, b); - if (r < 255) - r += 127; - else if (g < 255) - g += 127; - else if (b < 255) - g += 127; - } - CC.lStructSize = sizeof(CHOOSECOLOR); - CC.hwndOwner = hwndMain; - CC.hInstance = hInst; - CC.rgbResult = InitialColor; - CC.lpCustColors = CustColors; - CC.Flags = CC_RGBINIT; - if (!ChooseColor(&CC)) - return (InitialColor); - return (CC.rgbResult); + CHOOSECOLOR CC; + COLORREF CustColors[16]; + int r, g, b, i; + memset(&CC, 0, sizeof(CHOOSECOLOR)); + r = g = b = 0; + for (i = 0; i < 16; i++) { + CustColors[i] = RGB(r, g, b); + if (r < 255) + r += 127; + else if (g < 255) + g += 127; + else if (b < 255) + g += 127; + } + CC.lStructSize = sizeof(CHOOSECOLOR); + CC.hwndOwner = hwndMain; + CC.hInstance = hInst; + CC.rgbResult = InitialColor; + CC.lpCustColors = CustColors; + CC.Flags = CC_RGBINIT; + if (!ChooseColor(&CC)) + return (InitialColor); + return (CC.rgbResult); } /*------------------------------------------------------------------------ @@ -259,18 +259,18 @@ static COLORREF CallChangeColor(COLORREF InitialColor) ------------------------------------------------------------------------*/ static int CallPrintSetup(void) { - PAGESETUPDLG sd; - int r; - - memset(&sd,0,sizeof(sd)); - sd.lStructSize = sizeof(sd); - sd.Flags = PSD_RETURNDEFAULT; - r = PageSetupDlg(&sd); - if (!r) - return 0; - sd.Flags = 0; - r = PageSetupDlg(&sd); - return r; + PAGESETUPDLG sd; + int r; + + memset(&sd,0,sizeof(sd)); + sd.lStructSize = sizeof(sd); + sd.Flags = PSD_RETURNDEFAULT; + r = PageSetupDlg(&sd); + if (!r) + return 0; + sd.Flags = 0; + r = PageSetupDlg(&sd); + return r; } @@ -283,10 +283,10 @@ static int CallPrintSetup(void) ------------------------------------------------------------------------*/ void Undo(HWND hwnd) { - HWND hEdit; + HWND hEdit; - hEdit = (HWND)GetWindowLong(hwnd,DWL_USER); - SendMessage(hEdit,EM_UNDO,0,0); + hEdit = (HWND)GetWindowLong(hwnd,DWL_USER); + SendMessage(hEdit,EM_UNDO,0,0); } /*------------------------------------------------------------------------ @@ -299,14 +299,14 @@ void Undo(HWND hwnd) ------------------------------------------------------------------------*/ void ForceRepaint(void) { - HWND hwndEdit = (HWND)GetWindowLong(hwndSession,DWL_USER); - InvalidateRect(hwndEdit,NULL,1); + HWND hwndEdit = (HWND)GetWindowLong(hwndSession,DWL_USER); + InvalidateRect(hwndEdit,NULL,1); } static void Add_Char_To_Queue(int c) { - HWND hwndEdit = (HWND)GetWindowLong(hwndSession,DWL_USER); - SendMessage(hwndEdit,WM_CHAR,c,1); + HWND hwndEdit = (HWND)GetWindowLong(hwndSession,DWL_USER); + SendMessage(hwndEdit,WM_CHAR,c,1); } /*------------------------------------------------------------------------ @@ -321,14 +321,14 @@ static void Add_Char_To_Queue(int c) ------------------------------------------------------------------------*/ void AddLineToControl(char *buf) { - HWND hEditCtrl; - - if (*buf == 0) - return; - hEditCtrl = (HWND)GetWindowLong(hwndSession,DWL_USER); - GotoEOF(); - SendMessage(hEditCtrl,EM_REPLACESEL,0,(LPARAM)buf); - SendMessage(hEditCtrl,WM_CHAR,'\r',0); + HWND hEditCtrl; + + if (*buf == 0) + return; + hEditCtrl = (HWND)GetWindowLong(hwndSession,DWL_USER); + GotoEOF(); + SendMessage(hEditCtrl,EM_REPLACESEL,0,(LPARAM)buf); + SendMessage(hEditCtrl,WM_CHAR,'\r',0); } /*------------------------------------------------------------------------ @@ -340,9 +340,9 @@ void AddLineToControl(char *buf) ------------------------------------------------------------------------*/ static BOOL CALLBACK AboutDlgProc(HWND hDlg, UINT message, WPARAM wParam, LPARAM lParam) { - if (message == WM_CLOSE) - EndDialog(hDlg,1); - return 0; + if (message == WM_CLOSE) + EndDialog(hDlg,1); + return 0; } /*------------------------------------------------------------------------ Procedure: HistoryDlgProc ID:1 @@ -357,48 +357,48 @@ static BOOL CALLBACK AboutDlgProc(HWND hDlg, UINT message, WPARAM wParam, LPARAM ------------------------------------------------------------------------*/ static BOOL CALLBACK HistoryDlgProc(HWND hDlg, UINT message, WPARAM wParam, LPARAM lParam) { - HISTORYLINE *rvp; - int idx; - RECT rc; - - switch (message) { - case WM_INITDIALOG: - SendDlgItemMessage(hDlg,IDLIST,WM_SETFONT,(WPARAM)ProgramParams.hFont,0); - rvp = History; - idx = 0; - while (rvp) { - SendDlgItemMessage(hDlg,IDLIST,LB_INSERTSTRING,0,(LPARAM)rvp->Text); - SendDlgItemMessage(hDlg,IDLIST,LB_SETITEMDATA,0,(LPARAM)idx); - rvp = rvp->Next; - idx++; - } - SendDlgItemMessage(hDlg,IDLIST,LB_SETCURSEL,(LPARAM)idx-1,0); - return 1; - case WM_COMMAND: - switch(LOWORD(wParam)) { - case IDLIST: - switch(HIWORD(wParam)) { - case LBN_DBLCLK: - idx = SendDlgItemMessage(hDlg,IDLIST,LB_GETCURSEL,0,0); - if (idx == LB_ERR) - break; - idx = SendDlgItemMessage(hDlg,IDLIST,LB_GETITEMDATA,idx,0); - EndDialog(hDlg,idx+1); - return 1; - } - break; - } - break; - case WM_SIZE: - GetClientRect(hDlg,&rc); - MoveWindow(GetDlgItem(hDlg,IDLIST),0,0,rc.right,rc.bottom,1); - break; - - case WM_CLOSE: - EndDialog(hDlg,0); - break; - } - return 0; + HISTORYLINE *rvp; + int idx; + RECT rc; + + switch (message) { + case WM_INITDIALOG: + SendDlgItemMessage(hDlg,IDLIST,WM_SETFONT,(WPARAM)ProgramParams.hFont,0); + rvp = History; + idx = 0; + while (rvp) { + SendDlgItemMessage(hDlg,IDLIST,LB_INSERTSTRING,0,(LPARAM)rvp->Text); + SendDlgItemMessage(hDlg,IDLIST,LB_SETITEMDATA,0,(LPARAM)idx); + rvp = rvp->Next; + idx++; + } + SendDlgItemMessage(hDlg,IDLIST,LB_SETCURSEL,(LPARAM)idx-1,0); + return 1; + case WM_COMMAND: + switch(LOWORD(wParam)) { + case IDLIST: + switch(HIWORD(wParam)) { + case LBN_DBLCLK: + idx = SendDlgItemMessage(hDlg,IDLIST,LB_GETCURSEL,0,0); + if (idx == LB_ERR) + break; + idx = SendDlgItemMessage(hDlg,IDLIST,LB_GETITEMDATA,idx,0); + EndDialog(hDlg,idx+1); + return 1; + } + break; + } + break; + case WM_SIZE: + GetClientRect(hDlg,&rc); + MoveWindow(GetDlgItem(hDlg,IDLIST),0,0,rc.right,rc.bottom,1); + break; + + case WM_CLOSE: + EndDialog(hDlg,0); + break; + } + return 0; } /*------------------------------------------------------------------------ Procedure: SaveText ID:1 @@ -411,27 +411,27 @@ static BOOL CALLBACK HistoryDlgProc(HWND hDlg, UINT message, WPARAM wParam, LPAR ------------------------------------------------------------------------*/ static void SaveText(char *fname) { - int i,len; - HWND hEdit = (HWND)GetWindowLong(hwndSession,DWL_USER); - int linesCount = SendMessage(hEdit,EM_GETLINECOUNT,0,0); - FILE *f; - char *buf = SafeMalloc(8192); - - f = fopen(fname,"wb"); - if (f == NULL) { - wsprintf("Impossible to open %s for writing",fname); - ShowDbgMsg(buf); - return; - } - for (i=0; i<linesCount;i++) { - *(unsigned short *)buf = 8100; - len = SendMessage(hEdit,EM_GETLINE,i,(LPARAM)buf); - buf[len] = 0; - strcat(buf,"\r\n"); - fwrite(buf,1,len+2,f); - } - fclose(f); - free(buf); + int i,len; + HWND hEdit = (HWND)GetWindowLong(hwndSession,DWL_USER); + int linesCount = SendMessage(hEdit,EM_GETLINECOUNT,0,0); + FILE *f; + char *buf = SafeMalloc(8192); + + f = fopen(fname,"wb"); + if (f == NULL) { + wsprintf("Impossible to open %s for writing",fname); + ShowDbgMsg(buf); + return; + } + for (i=0; i<linesCount;i++) { + *(unsigned short *)buf = 8100; + len = SendMessage(hEdit,EM_GETLINE,i,(LPARAM)buf); + buf[len] = 0; + strcat(buf,"\r\n"); + fwrite(buf,1,len+2,f); + } + fclose(f); + free(buf); } @@ -462,30 +462,30 @@ static void Add_Clipboard_To_Queue(void) static void CopyToClipboard(HWND hwnd) { - HWND hwndEdit = (HWND)GetWindowLong(hwndSession,DWL_USER); - SendMessage(hwndEdit,WM_COPY,0,0); + HWND hwndEdit = (HWND)GetWindowLong(hwndSession,DWL_USER); + SendMessage(hwndEdit,WM_COPY,0,0); } int ResetText(void) { - HWND hwndEdit = (HWND) GetWindowLong(hwndSession,DWL_USER); - TEXTRANGE cr; - int len = SendMessage(hwndEdit,WM_GETTEXTLENGTH,0,0); - char *tmp = malloc(len+10),*p; - - memset(tmp,0,len+10); - cr.chrg.cpMin = 0; - cr.chrg.cpMax = -1; - cr.lpstrText = tmp; - SendMessage(hwndEdit,EM_GETTEXTRANGE,0,(LPARAM)&cr); - p = tmp+len/2; - while (*p && *p != '\r') - p++; - SendMessage(hwndEdit,EM_SETSEL,0,(LPARAM)-1); - SendMessage(hwndEdit,EM_REPLACESEL,0,(LPARAM)p); - InvalidateRect(hwndEdit,0,1); - free(tmp); - return 0; + HWND hwndEdit = (HWND) GetWindowLong(hwndSession,DWL_USER); + TEXTRANGE cr; + int len = SendMessage(hwndEdit,WM_GETTEXTLENGTH,0,0); + char *tmp = malloc(len+10),*p; + + memset(tmp,0,len+10); + cr.chrg.cpMin = 0; + cr.chrg.cpMax = -1; + cr.lpstrText = tmp; + SendMessage(hwndEdit,EM_GETTEXTRANGE,0,(LPARAM)&cr); + p = tmp+len/2; + while (*p && *p != '\r') + p++; + SendMessage(hwndEdit,EM_SETSEL,0,(LPARAM)-1); + SendMessage(hwndEdit,EM_REPLACESEL,0,(LPARAM)p); + InvalidateRect(hwndEdit,0,1); + free(tmp); + return 0; } /*------------------------------------------------------------------------ @@ -497,95 +497,95 @@ int ResetText(void) ------------------------------------------------------------------------*/ void HandleCommand(HWND hwnd, WPARAM wParam,LPARAM lParam) { - char *fname; - int r; - - switch(LOWORD(wParam)) { - case IDM_OPEN: - fname = SafeMalloc(512); - if (OpenMlFile(fname,512)) { - char *buf = SafeMalloc(512); - char *p = strrchr(fname,'.'); - if (p && !stricmp(p,".ml")) { - wsprintf(buf,"#use \"%s\";;",fname); - AddLineToControl(buf); - } - else if (p && !stricmp(p,".cmo")) { - wsprintf(buf,"#load \"%s\";;",fname); - AddLineToControl(buf); - } - free(buf); - } - free(fname); - break; - case IDM_GC: - AddLineToControl("Gc.full_major();;"); - break; - case IDCTRLC: - InterruptOcaml(); - break; - case IDM_EDITPASTE: - Add_Clipboard_To_Queue(); - break; - case IDM_EDITCOPY: - CopyToClipboard(hwnd); - break; - case IDM_SAVE: - fname = SafeMalloc(512); - if (GetSaveName(fname,512)) { - SaveText(fname); - } - free(fname); - break; - case IDM_HISTORY: - r = CallDlgProc(HistoryDlgProc,IDD_HISTORY); - if (r) { - AddLineToControl(GetHistoryLine(r-1)); - } - break; - case IDM_PRINTSU: - CallPrintSetup(); - break; - case IDM_FONT: - CallChangeFont(hwndMain); - break; - case IDM_COLORTEXT: - ProgramParams.TextColor = CallChangeColor(ProgramParams.TextColor); - ForceRepaint(); - break; - case IDM_BACKCOLOR: - BackColor = CallChangeColor(BackColor); - DeleteObject(BackgroundBrush); - BackgroundBrush = CreateSolidBrush(BackColor); - ForceRepaint(); - break; - case IDM_EDITUNDO: - Undo(hwnd); - break; - case IDM_WINDOWTILE: - SendMessage(hwndMDIClient,WM_MDITILE,0,0); - break; - case IDM_WINDOWCASCADE: - SendMessage(hwndMDIClient,WM_MDICASCADE,0,0); - break; - case IDM_WINDOWICONS: - SendMessage(hwndMDIClient,WM_MDIICONARRANGE,0,0); - break; - case IDM_EXIT: - PostMessage(hwnd,WM_CLOSE,0,0); - break; - case IDM_ABOUT: - CallDlgProc(AboutDlgProc,IDD_ABOUT); - break; - default: - if (LOWORD(wParam) >= IDEDITCONTROL && LOWORD(wParam) < IDEDITCONTROL+5) { - switch (HIWORD(wParam)) { - case EN_ERRSPACE: - ResetText(); - break; - } - } - break; - } + char *fname; + int r; + + switch(LOWORD(wParam)) { + case IDM_OPEN: + fname = SafeMalloc(512); + if (OpenMlFile(fname,512)) { + char *buf = SafeMalloc(512); + char *p = strrchr(fname,'.'); + if (p && !stricmp(p,".ml")) { + wsprintf(buf,"#use \"%s\";;",fname); + AddLineToControl(buf); + } + else if (p && !stricmp(p,".cmo")) { + wsprintf(buf,"#load \"%s\";;",fname); + AddLineToControl(buf); + } + free(buf); + } + free(fname); + break; + case IDM_GC: + AddLineToControl("Gc.full_major();;"); + break; + case IDCTRLC: + InterruptOcaml(); + break; + case IDM_EDITPASTE: + Add_Clipboard_To_Queue(); + break; + case IDM_EDITCOPY: + CopyToClipboard(hwnd); + break; + case IDM_SAVE: + fname = SafeMalloc(512); + if (GetSaveName(fname,512)) { + SaveText(fname); + } + free(fname); + break; + case IDM_HISTORY: + r = CallDlgProc(HistoryDlgProc,IDD_HISTORY); + if (r) { + AddLineToControl(GetHistoryLine(r-1)); + } + break; + case IDM_PRINTSU: + CallPrintSetup(); + break; + case IDM_FONT: + CallChangeFont(hwndMain); + break; + case IDM_COLORTEXT: + ProgramParams.TextColor = CallChangeColor(ProgramParams.TextColor); + ForceRepaint(); + break; + case IDM_BACKCOLOR: + BackColor = CallChangeColor(BackColor); + DeleteObject(BackgroundBrush); + BackgroundBrush = CreateSolidBrush(BackColor); + ForceRepaint(); + break; + case IDM_EDITUNDO: + Undo(hwnd); + break; + case IDM_WINDOWTILE: + SendMessage(hwndMDIClient,WM_MDITILE,0,0); + break; + case IDM_WINDOWCASCADE: + SendMessage(hwndMDIClient,WM_MDICASCADE,0,0); + break; + case IDM_WINDOWICONS: + SendMessage(hwndMDIClient,WM_MDIICONARRANGE,0,0); + break; + case IDM_EXIT: + PostMessage(hwnd,WM_CLOSE,0,0); + break; + case IDM_ABOUT: + CallDlgProc(AboutDlgProc,IDD_ABOUT); + break; + default: + if (LOWORD(wParam) >= IDEDITCONTROL && LOWORD(wParam) < IDEDITCONTROL+5) { + switch (HIWORD(wParam)) { + case EN_ERRSPACE: + ResetText(); + break; + } + } + break; + } } diff --git a/win32caml/ocaml.c b/win32caml/ocaml.c index a72e7c3fa..65f2e02e9 100644 --- a/win32caml/ocaml.c +++ b/win32caml/ocaml.c @@ -41,10 +41,10 @@ COLORREF BackColor = RGB(255,255,255); PROGRAM_PARAMS ProgramParams; HISTORYLINE *History; /*<----------------- global variables --------------------------------------->*/ -HANDLE hInst; // Instance handle -HWND hwndMain; //Main window handle +HANDLE hInst; // Instance handle +HWND hwndMain; //Main window handle HWND hwndSession; -HWND hwndMDIClient; //Mdi client window handle +HWND hwndMDIClient; //Mdi client window handle static LRESULT CALLBACK MainWndProc(HWND hwnd,UINT msg,WPARAM wParam,LPARAM lParam); static LRESULT CALLBACK MdiChildWndProc(HWND hwnd,UINT msg,WPARAM wParam,LPARAM lParam); PROCESS_INFORMATION pi; @@ -198,32 +198,32 @@ static BOOL CreateSBar(HWND hwndParent,char *initialText,int nrOfParts) ------------------------------------------------------------------------*/ static BOOL InitApplication(void) { - WNDCLASS wc; - - memset(&wc,0,sizeof(WNDCLASS)); - wc.style = CS_HREDRAW|CS_VREDRAW |CS_DBLCLKS ; - wc.lpfnWndProc = (WNDPROC)MainWndProc; - wc.hInstance = hInst; - wc.hbrBackground = (HBRUSH)(COLOR_WINDOW+1); - wc.lpszClassName = "inriaWndClass"; - wc.lpszMenuName = MAKEINTRESOURCE(IDMAINMENU); - wc.hCursor = LoadCursor(NULL,IDC_ARROW); - wc.hIcon = LoadIcon(hInst,MAKEINTRESOURCE(OCAML_ICON)); - if (!RegisterClass(&wc)) - return 0; - wc.style = 0; - wc.lpfnWndProc = (WNDPROC)MdiChildWndProc; - wc.cbClsExtra = 0; - wc.cbWndExtra = 20; - wc.hInstance = hInst; // Owner of this class - wc.hIcon = LoadIcon(hInst, MAKEINTRESOURCE(OCAML_ICON)); - wc.hCursor = LoadCursor(NULL, IDC_ARROW); - wc.hbrBackground = (HBRUSH)(COLOR_WINDOW + 1); // Default color - wc.lpszMenuName = NULL; - wc.lpszClassName = "MdiChildWndClass"; - if (!RegisterClass((LPWNDCLASS)&wc)) - return FALSE; - return 1; + WNDCLASS wc; + + memset(&wc,0,sizeof(WNDCLASS)); + wc.style = CS_HREDRAW|CS_VREDRAW |CS_DBLCLKS ; + wc.lpfnWndProc = (WNDPROC)MainWndProc; + wc.hInstance = hInst; + wc.hbrBackground = (HBRUSH)(COLOR_WINDOW+1); + wc.lpszClassName = "inriaWndClass"; + wc.lpszMenuName = MAKEINTRESOURCE(IDMAINMENU); + wc.hCursor = LoadCursor(NULL,IDC_ARROW); + wc.hIcon = LoadIcon(hInst,MAKEINTRESOURCE(OCAML_ICON)); + if (!RegisterClass(&wc)) + return 0; + wc.style = 0; + wc.lpfnWndProc = (WNDPROC)MdiChildWndProc; + wc.cbClsExtra = 0; + wc.cbWndExtra = 20; + wc.hInstance = hInst; // Owner of this class + wc.hIcon = LoadIcon(hInst, MAKEINTRESOURCE(OCAML_ICON)); + wc.hCursor = LoadCursor(NULL, IDC_ARROW); + wc.hbrBackground = (HBRUSH)(COLOR_WINDOW + 1); // Default color + wc.lpszMenuName = NULL; + wc.lpszClassName = "MdiChildWndClass"; + if (!RegisterClass((LPWNDCLASS)&wc)) + return FALSE; + return 1; } /*------------------------------------------------------------------------ @@ -235,13 +235,13 @@ static BOOL InitApplication(void) ------------------------------------------------------------------------*/ HWND CreateinriaWndClassWnd(void) { - return CreateWindow("inriaWndClass","Ocaml", - WS_MINIMIZEBOX|WS_VISIBLE|WS_CLIPSIBLINGS|WS_CLIPCHILDREN|WS_MAXIMIZEBOX|WS_CAPTION|WS_BORDER|WS_SYSMENU|WS_THICKFRAME, - CW_USEDEFAULT,0,CW_USEDEFAULT,0, - NULL, - NULL, - hInst, - NULL); + return CreateWindow("inriaWndClass","Ocaml", + WS_MINIMIZEBOX|WS_VISIBLE|WS_CLIPSIBLINGS|WS_CLIPCHILDREN|WS_MAXIMIZEBOX|WS_CAPTION|WS_BORDER|WS_SYSMENU|WS_THICKFRAME, + CW_USEDEFAULT,0,CW_USEDEFAULT,0, + NULL, + NULL, + hInst, + NULL); } /*------------------------------------------------------------------------ @@ -254,19 +254,19 @@ HWND CreateinriaWndClassWnd(void) ------------------------------------------------------------------------*/ static HWND MDICmdFileNew(char *title, int show) { - HWND hwndChild; - char rgch[150]; - static int cUntitled; - MDICREATESTRUCT mcs; + HWND hwndChild; + char rgch[150]; + static int cUntitled; + MDICREATESTRUCT mcs; - if (title == NULL) - wsprintf(rgch,"Session%d", cUntitled++); - else { - strncpy(rgch,title,149); - rgch[149] = 0; - } + if (title == NULL) + wsprintf(rgch,"Session%d", cUntitled++); + else { + strncpy(rgch,title,149); + rgch[149] = 0; + } - // Create the MDI child window + // Create the MDI child window mcs.szClass = "MdiChildWndClass"; // window class name mcs.szTitle = rgch; // window title @@ -283,10 +283,10 @@ static HWND MDICmdFileNew(char *title, int show) 0, (LPARAM)(LPMDICREATESTRUCT) &mcs); - if (hwndChild != NULL && show) - ShowWindow(hwndChild, SW_SHOW); + if (hwndChild != NULL && show) + ShowWindow(hwndChild, SW_SHOW); - return hwndChild; + return hwndChild; } static HWND CreateMdiClient(HWND hwndparent) { @@ -316,23 +316,23 @@ static HWND CreateMdiClient(HWND hwndparent) void GotoEOF(void) { - HWND hEdit = (HWND)GetWindowLong(hwndSession,DWL_USER); - int linesCount = SendMessage(hEdit,EM_GETLINECOUNT,0,0); - int lineindex = SendMessage(hEdit,EM_LINEINDEX,linesCount-1,0); - int lastLineLength = SendMessage(hEdit,EM_LINELENGTH,linesCount-1,0); + HWND hEdit = (HWND)GetWindowLong(hwndSession,DWL_USER); + int linesCount = SendMessage(hEdit,EM_GETLINECOUNT,0,0); + int lineindex = SendMessage(hEdit,EM_LINEINDEX,linesCount-1,0); + int lastLineLength = SendMessage(hEdit,EM_LINELENGTH,linesCount-1,0); - lineindex += lastLineLength; - SendMessage(hEdit,EM_SETSEL,lineindex,lineindex); + lineindex += lastLineLength; + SendMessage(hEdit,EM_SETSEL,lineindex,lineindex); } int GetCurLineIndex(HWND hEdit) { - return SendMessage(hEdit,EM_LINEFROMCHAR,(WPARAM)-1,0); + return SendMessage(hEdit,EM_LINEFROMCHAR,(WPARAM)-1,0); } int GetNumberOfLines(HWND hEdit) { - return SendMessage(hEdit,EM_GETLINECOUNT,0,0); + return SendMessage(hEdit,EM_GETLINECOUNT,0,0); } static int GetWordUnderCursor(HWND hwndEditControl,char *buf,int len) @@ -345,7 +345,7 @@ static int GetWordUnderCursor(HWND hwndEditControl,char *buf,int len) startingChar = SendMessage(hwndEditControl,EM_LINEINDEX,lineidx,0); start -= startingChar; end -= startingChar; - lineidx = SendMessage(hwndEditControl,EM_LINEFROMCHAR,start,0); + lineidx = SendMessage(hwndEditControl,EM_LINEFROMCHAR,start,0); length = SendMessage(hwndEditControl,EM_LINELENGTH,lineidx,0); offset = SendMessage(hwndEditControl,EM_LINEINDEX,lineidx,0); line = SafeMalloc(length+1); @@ -374,7 +374,7 @@ static int GetWordUnderCursor(HWND hwndEditControl,char *buf,int len) pend--; memcpy(buf,pstart,1+pend-pstart); buf[pend-pstart] = 0; - free(line); + free(line); return 1; } @@ -382,82 +382,82 @@ void DoHelp(HWND hwnd) { char word[256]; GetWordUnderCursor(hwnd,word,sizeof(word)); - MessageBox(NULL,word,"Aide pour:",MB_OK); + MessageBox(NULL,word,"Aide pour:",MB_OK); } static LRESULT CALLBACK SubClassEdit(HWND hwnd, UINT msg, WPARAM mp1, LPARAM mp2) { - LRESULT r; - int postit=0,nl; - if (msg == WM_CHAR && mp1 == '\r') { - if (!busy) { - CallWindowProc(lpEProc,hwnd,WM_KEYDOWN,VK_END,1); - CallWindowProc(lpEProc,hwnd,WM_KEYUP,VK_END,1); - r = GetCurLineIndex(hwnd); - nl = GetNumberOfLines(hwnd); - if (r != nl-1) { - PostMessage(GetParent(hwnd),WM_NEWLINE,0,0); - return 0; - } - postit = 1; - } - - } - else if (msg == WM_KEYDOWN && mp1 == VK_F1) { - DoHelp(hwnd); - } - r = CallWindowProc(lpEProc, hwnd, msg, mp1, mp2); - if (postit) - PostMessage(GetParent(hwnd),WM_NEWLINE,0,0); - return r; + LRESULT r; + int postit=0,nl; + if (msg == WM_CHAR && mp1 == '\r') { + if (!busy) { + CallWindowProc(lpEProc,hwnd,WM_KEYDOWN,VK_END,1); + CallWindowProc(lpEProc,hwnd,WM_KEYUP,VK_END,1); + r = GetCurLineIndex(hwnd); + nl = GetNumberOfLines(hwnd); + if (r != nl-1) { + PostMessage(GetParent(hwnd),WM_NEWLINE,0,0); + return 0; + } + postit = 1; + } + + } + else if (msg == WM_KEYDOWN && mp1 == VK_F1) { + DoHelp(hwnd); + } + r = CallWindowProc(lpEProc, hwnd, msg, mp1, mp2); + if (postit) + PostMessage(GetParent(hwnd),WM_NEWLINE,0,0); + return r; } static void SubClassEditField(HWND hwnd) { - if (lpEProc == NULL) { - lpEProc = (WNDPROC) GetWindowLong(hwnd, GWL_WNDPROC); - } - SetWindowLong(hwnd, GWL_WNDPROC, (DWORD) SubClassEdit); + if (lpEProc == NULL) { + lpEProc = (WNDPROC) GetWindowLong(hwnd, GWL_WNDPROC); + } + SetWindowLong(hwnd, GWL_WNDPROC, (DWORD) SubClassEdit); } void AddToHistory(char *text) { - HISTORYLINE *newLine; - - while (*text == ' ') - text++; // skip leading blanks - if (*text == 0) - return; - if (History && !strstr(History->Text,";;")) { - char *p = History->Text; - int len = strlen(p)+strlen(text) + 1 + 1; // space and zero terminator - History->Text = SafeMalloc(len); - strcpy(History->Text,p); - strcat(History->Text," "); - strcat(History->Text,text); - free(p); - return; - } - newLine = SafeMalloc(sizeof(HISTORYLINE)); - newLine->Next = History; - newLine->Text = SafeMalloc(strlen(text)+1); - strcpy(newLine->Text,text); - History = newLine; + HISTORYLINE *newLine; + + while (*text == ' ') + text++; // skip leading blanks + if (*text == 0) + return; + if (History && !strstr(History->Text,";;")) { + char *p = History->Text; + int len = strlen(p)+strlen(text) + 1 + 1; // space and zero terminator + History->Text = SafeMalloc(len); + strcpy(History->Text,p); + strcat(History->Text," "); + strcat(History->Text,text); + free(p); + return; + } + newLine = SafeMalloc(sizeof(HISTORYLINE)); + newLine->Next = History; + newLine->Text = SafeMalloc(strlen(text)+1); + strcpy(newLine->Text,text); + History = newLine; } char *GetHistoryLine(int n) { - HISTORYLINE *rvp = History; - int i; - - for (i=0; i<n; i++) { - rvp = rvp->Next; - } - if (rvp) - return &rvp->Text[0]; - else - return ""; + HISTORYLINE *rvp = History; + int i; + + for (i=0; i<n; i++) { + rvp = rvp->Next; + } + if (rvp) + return &rvp->Text[0]; + else + return ""; } /*------------------------------------------------------------------------ @@ -471,36 +471,36 @@ char *GetHistoryLine(int n) ------------------------------------------------------------------------*/ void SendLastLine(HWND hEdit) { - int curline = GetCurLineIndex(hEdit); - char *p,linebuffer[2048]; - int n; - int linescount = GetNumberOfLines(hEdit); - - *(unsigned short *)linebuffer = sizeof(linebuffer)-1; - if (curline != linescount-1) - n = SendMessage(hEdit,EM_GETLINE,curline,(LPARAM)linebuffer); - else - n = SendMessage(hEdit,EM_GETLINE,curline-1,(LPARAM)linebuffer); - if (n >= 2 && linebuffer[0] == '#' && linebuffer[1] == ' ') { - n -= 2; - memmove(linebuffer, linebuffer+2, n); - } - linebuffer[n] = 0; - // Record user input! - AddToHistory(linebuffer); - linebuffer[n] = '\n'; - linebuffer[n+1] = 0; - WriteToPipe(linebuffer); - if (curline != linescount-1) { - // Copy the line sent to the end of the text - p = strrchr(linebuffer,'\n'); - if (p) { - *p = 0; - } - busy = 1; - AddLineToControl(linebuffer); - busy = 0; - } + int curline = GetCurLineIndex(hEdit); + char *p,linebuffer[2048]; + int n; + int linescount = GetNumberOfLines(hEdit); + + *(unsigned short *)linebuffer = sizeof(linebuffer)-1; + if (curline != linescount-1) + n = SendMessage(hEdit,EM_GETLINE,curline,(LPARAM)linebuffer); + else + n = SendMessage(hEdit,EM_GETLINE,curline-1,(LPARAM)linebuffer); + if (n >= 2 && linebuffer[0] == '#' && linebuffer[1] == ' ') { + n -= 2; + memmove(linebuffer, linebuffer+2, n); + } + linebuffer[n] = 0; + // Record user input! + AddToHistory(linebuffer); + linebuffer[n] = '\n'; + linebuffer[n+1] = 0; + WriteToPipe(linebuffer); + if (curline != linescount-1) { + // Copy the line sent to the end of the text + p = strrchr(linebuffer,'\n'); + if (p) { + *p = 0; + } + busy = 1; + AddLineToControl(linebuffer); + busy = 0; + } } /*------------------------------------------------------------------------ Procedure: SetLastPrompt ID:1 @@ -512,10 +512,10 @@ void SendLastLine(HWND hEdit) ------------------------------------------------------------------------*/ void SetLastPrompt(HWND hEdit) { - DWORD startpos,endpos; - SendMessage(hEdit,EM_GETSEL,(WPARAM)&startpos,(LPARAM)&endpos); - LastPromptPosition.line = SendMessage(hEdit,EM_LINEFROMCHAR,(WPARAM)-1,0); - LastPromptPosition.col = startpos; + DWORD startpos,endpos; + SendMessage(hEdit,EM_GETSEL,(WPARAM)&startpos,(LPARAM)&endpos); + LastPromptPosition.line = SendMessage(hEdit,EM_LINEFROMCHAR,(WPARAM)-1,0); + LastPromptPosition.col = startpos; } /*------------------------------------------------------------------------ @@ -530,11 +530,11 @@ void SetLastPrompt(HWND hEdit) ------------------------------------------------------------------------*/ static LRESULT CALLBACK MdiChildWndProc(HWND hwnd,UINT msg,WPARAM wparam,LPARAM lparam) { - HWND hwndChild; - RECT rc; - HDC hDC; + HWND hwndChild; + RECT rc; + HDC hDC; - switch(msg) { + switch(msg) { case WM_CREATE: GetClientRect(hwnd,&rc); hwndChild= CreateWindow("EDIT", @@ -603,7 +603,7 @@ static LRESULT CALLBACK MdiChildWndProc(HWND hwnd,UINT msg,WPARAM wparam,LPARAM hwndChild = (HWND) GetWindowLong(hwnd, DWL_USER); if (ReadToLineBuffer()) { char *p; - // Ok we read something. Display it. + // Ok we read something. Display it. AddLineBuffer(); p = strrchr(lineBuffer,'\r'); if (p && !strcmp(p,"\r\n# ")) { @@ -615,8 +615,8 @@ static LRESULT CALLBACK MdiChildWndProc(HWND hwnd,UINT msg,WPARAM wparam,LPARAM } break; - } - return DefMDIChildProc(hwnd, msg, wparam, lparam); + } + return DefMDIChildProc(hwnd, msg, wparam, lparam); } @@ -636,52 +636,52 @@ static LRESULT CALLBACK MdiChildWndProc(HWND hwnd,UINT msg,WPARAM wparam,LPARAM ------------------------------------------------------------------------*/ static LRESULT CALLBACK MainWndProc(HWND hwnd,UINT msg,WPARAM wParam,LPARAM lParam) { - switch (msg) { - // Create the MDI client invisible window - case WM_CREATE: - hwndMDIClient = CreateMdiClient(hwnd); + switch (msg) { + // Create the MDI client invisible window + case WM_CREATE: + hwndMDIClient = CreateMdiClient(hwnd); TimerId = SetTimer((HWND) 0, 0, 100, (TIMERPROC) TimerProc); - break; - // Move the child windows - case WM_SIZE: - SendMessage(hWndStatusbar,msg,wParam,lParam); - InitializeStatusBar(hWndStatusbar,1); - // Position the MDI client window between the tool and status bars - if (wParam != SIZE_MINIMIZED) { - RECT rc, rcClient; - - GetClientRect(hwnd, &rcClient); - GetWindowRect(hWndStatusbar, &rc); - ScreenToClient(hwnd, (LPPOINT)&rc.left); - rcClient.bottom = rc.top; - MoveWindow(hwndMDIClient,rcClient.left,rcClient.top,rcClient.right-rcClient.left, rcClient.bottom-rcClient.top, TRUE); - } - - return 0; - // Dispatch the menu commands - case WM_COMMAND: - HandleCommand(hwnd, wParam,lParam); - return 0; - // If user confirms close - case WM_CLOSE: - if (!AskYesOrNo("Quit Ocaml?")) - return 0; - break; - // End application - case WM_DESTROY: - PostQuitMessage(0); - break; - // The interpreter has exited. Force close of the application - case WM_QUITOCAML: - DestroyWindow(hwnd); - return 0; - case WM_USER+1000: - // TestGraphics(); - break; - default: - return DefFrameProc(hwnd,hwndMDIClient,msg,wParam,lParam); - } - return DefFrameProc(hwnd,hwndMDIClient,msg,wParam,lParam); + break; + // Move the child windows + case WM_SIZE: + SendMessage(hWndStatusbar,msg,wParam,lParam); + InitializeStatusBar(hWndStatusbar,1); + // Position the MDI client window between the tool and status bars + if (wParam != SIZE_MINIMIZED) { + RECT rc, rcClient; + + GetClientRect(hwnd, &rcClient); + GetWindowRect(hWndStatusbar, &rc); + ScreenToClient(hwnd, (LPPOINT)&rc.left); + rcClient.bottom = rc.top; + MoveWindow(hwndMDIClient,rcClient.left,rcClient.top,rcClient.right-rcClient.left, rcClient.bottom-rcClient.top, TRUE); + } + + return 0; + // Dispatch the menu commands + case WM_COMMAND: + HandleCommand(hwnd, wParam,lParam); + return 0; + // If user confirms close + case WM_CLOSE: + if (!AskYesOrNo("Quit Ocaml?")) + return 0; + break; + // End application + case WM_DESTROY: + PostQuitMessage(0); + break; + // The interpreter has exited. Force close of the application + case WM_QUITOCAML: + DestroyWindow(hwnd); + return 0; + case WM_USER+1000: + // TestGraphics(); + break; + default: + return DefFrameProc(hwnd,hwndMDIClient,msg,wParam,lParam); + } + return DefFrameProc(hwnd,hwndMDIClient,msg,wParam,lParam); } /*------------------------------------------------------------------------ @@ -716,8 +716,8 @@ static HFONT CreationCourier(int flag) ------------------------------------------------------------------------*/ int ReadToLineBuffer(void) { - memset(lineBuffer,0,sizeof(lineBuffer)); - return ReadFromPipe(lineBuffer,sizeof(lineBuffer)); + memset(lineBuffer,0,sizeof(lineBuffer)); + return ReadFromPipe(lineBuffer,sizeof(lineBuffer)); } /*------------------------------------------------------------------------ @@ -730,10 +730,10 @@ int ReadToLineBuffer(void) ------------------------------------------------------------------------*/ int AddLineBuffer(void) { - HWND hEditCtrl; + HWND hEditCtrl; - hEditCtrl = (HWND)GetWindowLong(hwndSession,DWL_USER); - return SendMessage(hEditCtrl,EM_REPLACESEL,0,(LPARAM)lineBuffer); + hEditCtrl = (HWND)GetWindowLong(hwndSession,DWL_USER); + return SendMessage(hEditCtrl,EM_REPLACESEL,0,(LPARAM)lineBuffer); } @@ -747,14 +747,14 @@ int AddLineBuffer(void) ------------------------------------------------------------------------*/ static int Setup(HANDLE *phAccelTable) { - if (!InitApplication()) - return 0; - ProgramParams.hFont = CreationCourier(1); - ProgramParams.TextColor = RGB(0,0,0); - GetObject(ProgramParams.hFont,sizeof(LOGFONT),&CurrentFont); - BackgroundBrush = CreateSolidBrush(BackColor); - *phAccelTable = LoadAccelerators(hInst,MAKEINTRESOURCE(IDACCEL)); - return 1; + if (!InitApplication()) + return 0; + ProgramParams.hFont = CreationCourier(1); + ProgramParams.TextColor = RGB(0,0,0); + GetObject(ProgramParams.hFont,sizeof(LOGFONT),&CurrentFont); + BackgroundBrush = CreateSolidBrush(BackColor); + *phAccelTable = LoadAccelerators(hInst,MAKEINTRESOURCE(IDACCEL)); + return 1; } @@ -767,49 +767,49 @@ static int Setup(HANDLE *phAccelTable) ------------------------------------------------------------------------*/ int WINAPI WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, INT nCmdShow) { - MSG msg; - HANDLE hAccelTable; - char consoleTitle[512]; - HWND hwndConsole; - - // Setup the hInst global - hInst = hInstance; - // Do the setup - if (!Setup(&hAccelTable)) - return 0; + MSG msg; + HANDLE hAccelTable; + char consoleTitle[512]; + HWND hwndConsole; + + // Setup the hInst global + hInst = hInstance; + // Do the setup + if (!Setup(&hAccelTable)) + return 0; // Need to set up a console so that we can send ctrl-break signal // to inferior Caml - AllocConsole(); - GetConsoleTitle(consoleTitle,sizeof(consoleTitle)); - hwndConsole = FindWindow(NULL,consoleTitle); - ShowWindow(hwndConsole,SW_HIDE); - // Create main window and exit if this fails - if ((hwndMain = CreateinriaWndClassWnd()) == (HWND)0) - return 0; - // Create the status bar - CreateSBar(hwndMain,"Ready",2); - // Show the window - ShowWindow(hwndMain,SW_SHOW); - // Create the session window - hwndSession = MDICmdFileNew("Session transcript",0); - // Get the path to ocaml.exe - GetOcamlPath(); - // Start the interpreter - StartOcaml(); - // Show the session window - ShowWindow(hwndSession, SW_SHOW); - // Maximize it + AllocConsole(); + GetConsoleTitle(consoleTitle,sizeof(consoleTitle)); + hwndConsole = FindWindow(NULL,consoleTitle); + ShowWindow(hwndConsole,SW_HIDE); + // Create main window and exit if this fails + if ((hwndMain = CreateinriaWndClassWnd()) == (HWND)0) + return 0; + // Create the status bar + CreateSBar(hwndMain,"Ready",2); + // Show the window + ShowWindow(hwndMain,SW_SHOW); + // Create the session window + hwndSession = MDICmdFileNew("Session transcript",0); + // Get the path to ocaml.exe + GetOcamlPath(); + // Start the interpreter + StartOcaml(); + // Show the session window + ShowWindow(hwndSession, SW_SHOW); + // Maximize it SendMessage(hwndMDIClient, WM_MDIMAXIMIZE, (WPARAM) hwndSession, 0); - PostMessage(hwndMain,WM_USER+1000,0,0); - while (GetMessage(&msg,NULL,0,0)) { - if (!TranslateMDISysAccel(hwndMDIClient, &msg)) - if (!TranslateAccelerator(msg.hwnd, hAccelTable, &msg)) { - TranslateMessage(&msg); // Translates virtual key codes - DispatchMessage(&msg); // Dispatches message to window - } - } - WriteToPipe("#quit;;\r\n\032"); + PostMessage(hwndMain,WM_USER+1000,0,0); + while (GetMessage(&msg,NULL,0,0)) { + if (!TranslateMDISysAccel(hwndMDIClient, &msg)) + if (!TranslateAccelerator(msg.hwnd, hAccelTable, &msg)) { + TranslateMessage(&msg); // Translates virtual key codes + DispatchMessage(&msg); // Dispatches message to window + } + } + WriteToPipe("#quit;;\r\n\032"); KillTimer((HWND) 0, TimerId); - return msg.wParam; + return msg.wParam; } diff --git a/win32caml/startocaml.c b/win32caml/startocaml.c index 6627595ab..fc88f6bad 100644 --- a/win32caml/startocaml.c +++ b/win32caml/startocaml.c @@ -32,28 +32,28 @@ STARTUPINFO startInfo; ------------------------------------------------------------------------*/ void ShowDbgMsg(char *str) { - HWND hWnd; - char p[20], message[255]; - hWnd = hwndMain; - if (IsIconic(hWnd)){ - ShowWindow(hWnd,SW_RESTORE); - } - strncpy(message, str, 254); - message[254] = 0; - strcpy(p, "Error"); - MessageBox(hWnd, message, p, MB_OK | MB_ICONHAND|MB_TASKMODAL|MB_SETFOREGROUND); + HWND hWnd; + char p[20], message[255]; + hWnd = hwndMain; + if (IsIconic(hWnd)){ + ShowWindow(hWnd,SW_RESTORE); + } + strncpy(message, str, 254); + message[254] = 0; + strcpy(p, "Error"); + MessageBox(hWnd, message, p, MB_OK | MB_ICONHAND|MB_TASKMODAL|MB_SETFOREGROUND); } int AskYesOrNo(char *msg) { - HWND hwnd; - int r; + HWND hwnd; + int r; - hwnd = hwndMain; - r = MessageBox(hwnd, msg, "Ocaml", MB_YESNO | MB_SETFOREGROUND); - if (r == IDYES) - return (TRUE); - return (FALSE); + hwnd = hwndMain; + r = MessageBox(hwnd, msg, "Ocaml", MB_YESNO | MB_SETFOREGROUND); + if (r == IDYES) + return (TRUE); + return (FALSE); } @@ -61,16 +61,16 @@ static DWORD OcamlStatus; static int RegistryError(void) { - char buf[512]; + char buf[512]; - wsprintf(buf,"Error %d writing to the registry",GetLastError()); - ShowDbgMsg(buf); - return 0; + wsprintf(buf,"Error %d writing to the registry",GetLastError()); + ShowDbgMsg(buf); + return 0; } static int ReadRegistry(HKEY hroot, - char * p1, char * p2, char * p3, - char dest[1024]) + char * p1, char * p2, char * p3, + char dest[1024]) { HKEY h1, h2; DWORD dwType; @@ -92,8 +92,8 @@ static int ReadRegistry(HKEY hroot, } static int WriteRegistry(HKEY hroot, - char * p1, char * p2, char * p3, - char data[1024]) + char * p1, char * p2, char * p3, + char data[1024]) { HKEY h1, h2; DWORD disp; @@ -116,10 +116,10 @@ static int WriteRegistry(HKEY hroot, Procedure: GetOcamlPath ID:1 Purpose: Read the registry key HKEY_LOCAL_MACHINE\Software\Objective Caml - or + or HKEY_CURRENT_USER\Software\Objective Caml, - and creates it if it doesn't exists. - If any error occurs, i.e. the + and creates it if it doesn't exists. + If any error occurs, i.e. the given path doesn't exist, or the key didn't exist, it will put up a browse dialog box to allow the user to enter the path. The path will be verified that it @@ -137,20 +137,20 @@ int GetOcamlPath(void) again: if (! ReadRegistry(HKEY_CURRENT_USER, - "Software", "Objective Caml", - "InterpreterPath", path) + "Software", "Objective Caml", + "InterpreterPath", path) && ! ReadRegistry(HKEY_LOCAL_MACHINE, - "Software", "Objective Caml", - "InterpreterPath", path)) { + "Software", "Objective Caml", + "InterpreterPath", path)) { /* Key doesn't exist? Ask user */ if (!BrowseForFile("Ocaml interpreter|ocaml.exe", path)) { ShowDbgMsg("Impossible to find ocaml.exe. I quit"); exit(0); } WriteRegistry(HKEY_CURRENT_USER, - "Software", "Objective Caml", - "InterpreterPath", path); + "Software", "Objective Caml", + "InterpreterPath", path); } /* Check if file exists */ if (_access(path, 0) != 0) { @@ -160,8 +160,8 @@ int GetOcamlPath(void) free(errormsg); path[0] = 0; WriteRegistry(HKEY_CURRENT_USER, - "Software", "Objective Caml", - "InterpreterPath", path); + "Software", "Objective Caml", + "InterpreterPath", path); goto again; } strcpy(OcamlPath, path); @@ -190,11 +190,11 @@ static HANDLE hChildStdinRd, hChildStdinWr,hChildStdoutRd, hChildStdoutWr; ------------------------------------------------------------------------*/ int IsWindowsNT(void) { - OSVERSIONINFO osv; + OSVERSIONINFO osv; - osv.dwOSVersionInfoSize = sizeof(osv); - GetVersionEx(&osv); - return(osv.dwPlatformId == VER_PLATFORM_WIN32_NT); + osv.dwOSVersionInfoSize = sizeof(osv); + GetVersionEx(&osv); + return(osv.dwPlatformId == VER_PLATFORM_WIN32_NT); } /*------------------------------------------------------------------------ @@ -219,56 +219,56 @@ int IsWindowsNT(void) ------------------------------------------------------------------------*/ int _stdcall DoStartOcaml(HWND hwndParent) { - char *cmdline; - int processStarted; - LPSECURITY_ATTRIBUTES lpsa=NULL; - SECURITY_ATTRIBUTES sa; - SECURITY_DESCRIPTOR sd; + char *cmdline; + int processStarted; + LPSECURITY_ATTRIBUTES lpsa=NULL; + SECURITY_ATTRIBUTES sa; + SECURITY_DESCRIPTOR sd; - sa.nLength = sizeof(SECURITY_ATTRIBUTES); - // Under windows NT/2000/Whistler we have to initialize the security descriptors - // This is not necessary under windows 98/95. - if (IsWindowsNT()) { - InitializeSecurityDescriptor(&sd,SECURITY_DESCRIPTOR_REVISION); - SetSecurityDescriptorDacl(&sd,TRUE,NULL,FALSE); - sa.bInheritHandle = TRUE; - sa.lpSecurityDescriptor = &sd; - lpsa = &sa; - } - memset(&startInfo,0,sizeof(STARTUPINFO)); - startInfo.cb = sizeof(STARTUPINFO); - // Create a pipe for the child process's STDOUT. - if (! CreatePipe(&hChildStdoutRd, &hChildStdoutWr, &sa, 0)) - return 0; - // Create a pipe for the child process's STDIN. - if (! CreatePipe(&hChildStdinRd, &hChildStdinWr, &sa, 0)) - return 0; - // Setup the start info structure - startInfo.dwFlags = STARTF_USESTDHANDLES|STARTF_USESHOWWINDOW; - startInfo.wShowWindow = SW_HIDE; - startInfo.hStdOutput = hChildStdoutWr; - startInfo.hStdError = hChildStdoutWr; - startInfo.hStdInput = hChildStdinRd; - cmdline = OcamlPath; - // Set the OCAMLLIB environment variable - SetEnvironmentVariable("OCAMLLIB", LibDir); - // Let's go: start the ocaml interpreter - processStarted = CreateProcess(NULL,cmdline,lpsa,lpsa,1, - CREATE_NEW_PROCESS_GROUP|NORMAL_PRIORITY_CLASS, - NULL,ProgramParams.CurrentWorkingDir,&startInfo,&pi); - if (processStarted) { - WaitForSingleObject(pi.hProcess,INFINITE); - GetExitCodeProcess(pi.hProcess,(unsigned long *)&OcamlStatus); - CloseHandle(pi.hProcess); - PostMessage(hwndMain,WM_QUITOCAML,0,0); - } - else { - char *msg = malloc(1024); - wsprintf(msg,"Impossible to start ocaml.exe in:\n%s",cmdline); - ShowDbgMsg(msg); - free(msg); - } - return 0; + sa.nLength = sizeof(SECURITY_ATTRIBUTES); + // Under windows NT/2000/Whistler we have to initialize the security descriptors + // This is not necessary under windows 98/95. + if (IsWindowsNT()) { + InitializeSecurityDescriptor(&sd,SECURITY_DESCRIPTOR_REVISION); + SetSecurityDescriptorDacl(&sd,TRUE,NULL,FALSE); + sa.bInheritHandle = TRUE; + sa.lpSecurityDescriptor = &sd; + lpsa = &sa; + } + memset(&startInfo,0,sizeof(STARTUPINFO)); + startInfo.cb = sizeof(STARTUPINFO); + // Create a pipe for the child process's STDOUT. + if (! CreatePipe(&hChildStdoutRd, &hChildStdoutWr, &sa, 0)) + return 0; + // Create a pipe for the child process's STDIN. + if (! CreatePipe(&hChildStdinRd, &hChildStdinWr, &sa, 0)) + return 0; + // Setup the start info structure + startInfo.dwFlags = STARTF_USESTDHANDLES|STARTF_USESHOWWINDOW; + startInfo.wShowWindow = SW_HIDE; + startInfo.hStdOutput = hChildStdoutWr; + startInfo.hStdError = hChildStdoutWr; + startInfo.hStdInput = hChildStdinRd; + cmdline = OcamlPath; + // Set the OCAMLLIB environment variable + SetEnvironmentVariable("OCAMLLIB", LibDir); + // Let's go: start the ocaml interpreter + processStarted = CreateProcess(NULL,cmdline,lpsa,lpsa,1, + CREATE_NEW_PROCESS_GROUP|NORMAL_PRIORITY_CLASS, + NULL,ProgramParams.CurrentWorkingDir,&startInfo,&pi); + if (processStarted) { + WaitForSingleObject(pi.hProcess,INFINITE); + GetExitCodeProcess(pi.hProcess,(unsigned long *)&OcamlStatus); + CloseHandle(pi.hProcess); + PostMessage(hwndMain,WM_QUITOCAML,0,0); + } + else { + char *msg = malloc(1024); + wsprintf(msg,"Impossible to start ocaml.exe in:\n%s",cmdline); + ShowDbgMsg(msg); + free(msg); + } + return 0; } /*------------------------------------------------------------------------ @@ -282,11 +282,11 @@ int _stdcall DoStartOcaml(HWND hwndParent) ------------------------------------------------------------------------*/ int WriteToPipe(char *data) { - DWORD dwWritten; - if (! WriteFile(hChildStdinWr, data, strlen(data), - &dwWritten, NULL)) - return 0; - return dwWritten; + DWORD dwWritten; + if (! WriteFile(hChildStdinWr, data, strlen(data), + &dwWritten, NULL)) + return 0; + return dwWritten; } @@ -303,17 +303,17 @@ int WriteToPipe(char *data) ------------------------------------------------------------------------*/ int ReadFromPipe(char *data,int len) { - DWORD dwRead; + DWORD dwRead; - PeekNamedPipe(hChildStdoutRd,data,len,NULL,&dwRead,NULL); - if (dwRead == 0) - return 0; + PeekNamedPipe(hChildStdoutRd,data,len,NULL,&dwRead,NULL); + if (dwRead == 0) + return 0; - // Read output from the child process, and write to parent's STDOUT. - if( !ReadFile( hChildStdoutRd, data, len, &dwRead, - NULL) || dwRead == 0) - return 0; - return dwRead; + // Read output from the child process, and write to parent's STDOUT. + if( !ReadFile( hChildStdoutRd, data, len, &dwRead, + NULL) || dwRead == 0) + return 0; + return dwRead; } static DWORD tid; @@ -327,28 +327,28 @@ static DWORD tid; ------------------------------------------------------------------------*/ int StartOcaml(void) { - getcwd(ProgramParams.CurrentWorkingDir,sizeof(ProgramParams.CurrentWorkingDir)); - CreateThread(NULL,0,DoStartOcaml,hwndMain,0,&tid); - return 1; + getcwd(ProgramParams.CurrentWorkingDir,sizeof(ProgramParams.CurrentWorkingDir)); + CreateThread(NULL,0,DoStartOcaml,hwndMain,0,&tid); + return 1; } void *SafeMalloc(int size) { - void *result; + void *result; - if (size < 0) { - char message[1024]; + if (size < 0) { + char message[1024]; error: - sprintf(message,"Can't allocate %d bytes",size); - MessageBox(NULL,message,"Ocaml",MB_OK); - exit(-1); - } - result = malloc(size); - if (result == NULL) - goto error; - return result; + sprintf(message,"Can't allocate %d bytes",size); + MessageBox(NULL,message,"Ocaml",MB_OK); + exit(-1); + } + result = malloc(size); + if (result == NULL) + goto error; + return result; } |