ocamlcompopt.sh
package-macosx
.DS_Store
+*.annot
+Objective Caml 3.09.1:
+----------------------
+
+Bug fixes:
+- compilers: raise not_found with -principal PR#3855
+- compilers: assert failure in typeclass.cml PR#3856
+- compilers: assert failure in typing/ctype.ml PR#3909
+- compilers: fatal error exception Ctype.Unify PR#3918
+- compilers: spurious warning Y PR#3868
+- compilers: spurious warning Z on loop index PR#3907
+- compilers: error message that emacs cannot parse
+- ocamlopt: problems with -for-pack/-pack PR#3825, PR#3826, PR#3919
+- ocamlopt: can't produce shared libraries on x86_64 PR#3869, PR#3924
+- ocamlopt: float alignment problem on SPARC PR#3944
+- ocamlopt: can't compile on MIPS PR#3936
+- runtime: missing dependence for ld.conf
+- runtime: missing dependence for .depend.nt PR#3880
+- runtime: memory leak in caml_register_named_value PR#3940
+- runtime: crash in Marshal.to_buffer PR#3879
+- stdlib: Sys.time giving wrong results on Mac OS X PR#3850
+- stdlib: Weak.get_copy causing random crashes in rare cases
+- stdlib, debugger, labltk: use TMPDIR if set PR#3895
+- stdlib: scanf bug on int32 and nativeint PR#3932
+- camlp4: mkcamlp4 option parsing problem PR#3941
+- camlp4: bug in pretty-printing of lazy/assert/new
+- camlp4: update the unmaintained makefile for _loc name
+- ocamldoc: several fixes see ocamldoc/Changes.txt
+- otherlibs/str: bug in long sequences of alternatives PR#3783
+- otherlibs/systhreads: deadlock in Windows PR#3910
+- tools: update dumpobj to handle new event format PR#3873
+- toplevel: activate warning Y in toplevel PR#3832
+
+New features:
+- otherlibs/labltk: browser uses menu bars instead of menu buttons
+
Objective Caml 3.09.0:
----------------------
Both compilers:
- Added warnings 'Y' and 'Z' for local variables that are bound but
never used.
-- Added warning for some uses non-returning functions (e.g. raise), when they are
- passed extra arguments, or followed by extra statements.
+- Added warning for some uses non-returning functions (e.g. raise), when they
+ are passed extra arguments, or followed by extra statements.
- Pattern matching: more prudent compilation in case of guards; fixed PR#3780.
- Compilation of classes: reduction in size of generated code.
- Compilation of "module rec" definitions: fixed a bad interaction with
* First public release.
-$Id: Changes,v 1.156 2005/10/26 15:11:29 xleroy Exp $
+$Id: Changes,v 1.156.2.3 2006/01/04 13:05:49 doligez Exp $
limit stacksize 64M # if your shell is zsh or tcsh
ulimit -s 65536 # if your shell is bash
+* If you do not have write access to /tmp, you should set the environment
+ variable TMPDIR to the name of some other temporary directory.
+
INSTALLATION INSTRUCTIONS
(* *)
(***********************************************************************)
-(* $Id: emit.mlp,v 1.10 2005/10/13 03:53:52 xleroy Exp $ *)
+(* $Id: emit.mlp,v 1.10.2.1 2005/12/17 16:23:09 xleroy Exp $ *)
(* Emission of x86-64 (AMD 64) assembly code *)
end
| Lswitch jumptbl ->
let lbl = new_label() in
- ` jmp *{emit_label lbl}(, {emit_reg i.arg.(0)}, 8)\n`;
+ if !pic_code then begin
+ ` leaq {emit_label lbl}(%rip), %r11\n`;
+ ` jmp *(%r11, {emit_reg i.arg.(0)}, 8)\n`
+ end else begin
+ ` jmp *{emit_label lbl}(, {emit_reg i.arg.(0)}, 8)\n`
+ end;
` .section .rodata\n`;
emit_align 8;
`{emit_label lbl}:`;
(* *)
(***********************************************************************)
-(* $Id: proc.ml,v 1.1 2003/06/30 08:28:44 xleroy Exp $ *)
+(* $Id: proc.ml,v 1.1.18.1 2005/12/17 16:23:09 xleroy Exp $ *)
(* Description of the AMD64 processor *)
let rax = phys_reg 0
let rcx = phys_reg 5
let rdx = phys_reg 4
+let r11 = phys_reg 9
let rxmm15 = phys_reg 115
let stack_slot slot ty =
| Iop(Istore(Single, _)) -> [| rxmm15 |]
| Iop(Ialloc _ | Iintop(Icomp _) | Iintop_imm((Idiv|Imod|Icomp _), _))
-> [| rax |]
+ | Iswitch(_, _) when !pic_code -> [| r11 |]
| _ -> [||]
let destroyed_at_raise = all_phys_regs
(* *)
(***********************************************************************)
-(* $Id: asmpackager.ml,v 1.19 2005/08/01 15:51:09 xleroy Exp $ *)
+(* $Id: asmpackager.ml,v 1.19.2.2 2005/12/17 16:49:57 xleroy Exp $ *)
(* "Package" a set of .cmx/.o files into one .cmx/.o file having the
original compilation units as sub-modules. *)
(List.filter (fun m -> m.pm_kind <> PM_intf) members) in
let ld_cmd =
sprintf "%s -o %s %s %s"
- Config.native_pack_linker
+ Config.native_pack_linker
(Filename.quote targetobj)
(Filename.quote objtemp)
(Ccomp.quote_files objfiles) in
(fun accu n -> if List.mem n accu then accu else n :: accu))
[] lst in
let units =
- List.fold_left
- (fun accu m ->
+ List.fold_right
+ (fun m accu ->
match m.pm_kind with PM_intf -> accu | PM_impl info -> info :: accu)
- [] members in
+ members [] in
let ui = Compilenv.current_unit_infos() in
let pkg_infos =
{ ui_name = ui.ui_name;
ui_symbol = ui.ui_symbol;
ui_defines =
- ui.ui_symbol ::
- union (List.map (fun info -> info.ui_defines) units);
+ List.flatten (List.map (fun info -> info.ui_defines) units) @
+ [ui.ui_symbol];
ui_imports_cmi =
(ui.ui_name, Env.crc_of_unit ui.ui_name) ::
filter(Asmlink.extract_crc_interfaces());
(* Make the .cmx and the .o for the package *)
-let package_object_files ppf files targetcmx
+let package_object_files ppf files targetcmx
targetobj targetname coercion =
let pack_path =
match !Clflags.for_package with
| Forward_reference(file, ident) ->
fprintf ppf "Forward reference to %s in file %s" ident file
| Wrong_for_pack(file, path) ->
- fprintf ppf "File %s@ was not compiled with the `-pack %s' option"
+ fprintf ppf "File %s@ was not compiled with the `-for-pack %s' option"
file path
| File_not_found file ->
fprintf ppf "File %s not found" file
(* *)
(***********************************************************************)
-(* $Id: clambda.ml,v 1.16 2004/05/26 11:10:27 garrigue Exp $ *)
+(* $Id: clambda.ml,v 1.16.8.2 2005/12/11 10:21:12 xleroy Exp $ *)
(* A variant of the "lambda" code with direct / indirect calls explicit
and closures explicit too *)
(* *)
(***********************************************************************)
-(* $Id: clambda.mli,v 1.16 2004/05/26 11:10:27 garrigue Exp $ *)
+(* $Id: clambda.mli,v 1.16.8.2 2005/12/11 10:21:12 xleroy Exp $ *)
(* A variant of the "lambda" code with direct / indirect calls explicit
and closures explicit too *)
(* *)
(***********************************************************************)
-(* $Id: closure.ml,v 1.48 2005/10/24 09:05:27 xleroy Exp $ *)
+(* $Id: closure.ml,v 1.48.2.2 2005/12/11 10:21:12 xleroy Exp $ *)
(* Introduction of closures, uncurrying, recognition of direct calls *)
let rec build_closure_env env_param pos = function
[] -> Tbl.empty
| id :: rem ->
- Tbl.add id (Uprim(Pfield pos, [Uvar env_param]))
+ Tbl.add id (Uprim(Pfield pos, [Uvar env_param]))
(build_closure_env env_param (pos+1) rem)
+(* Auxiliary for accessing globals. We change the name of the global
+ to the name of the corresponding asm symbol. This is done here
+ and no longer in Cmmgen so that approximations stored in .cmx files
+ contain the right names if the -for-pack option is active. *)
+
+let getglobal id =
+ Uprim(Pgetglobal (Ident.create_persistent (Compilenv.symbol_for_global id)),
+ [])
+
(* Check if a variable occurs in a [clambda] term. *)
let occurs_var var u =
| Uwhile(cond, body) -> occurs cond || occurs body
| Ufor(id, lo, hi, dir, body) -> occurs lo || occurs hi || occurs body
| Uassign(id, u) -> id = var || occurs u
- | Usend(_, met, obj, args) ->
+ | Usend(_, met, obj, args) ->
occurs met || occurs obj || List.exists occurs args
and occurs_array a =
try
| _ -> 2 (* arithmetic and comparisons *)
(* Very raw approximation of switch cost *)
-
+
let lambda_smaller lam threshold =
let size = ref 0 in
let rec lambda_size lam =
let bindings1 =
List.map (fun (id, rhs) -> (id, Ident.rename id, rhs)) bindings in
let sb' =
- List.fold_right
+ List.fold_right
(fun (id, id', _) s -> Tbl.add id (Uvar id') s)
bindings1 sb in
Uletrec(
end
| Lprim(Pgetglobal id, []) as lam ->
check_constant_result lam
- (Uprim(Pgetglobal id, [])) (Compilenv.global_approx id)
+ (getglobal id)
+ (Compilenv.global_approx id)
| Lprim(Pmakeblock(tag, mut) as prim, lams) ->
let (ulams, approxs) = List.split (List.map (close fenv cenv) lams) in
(Uprim(prim, ulams),
| Lprim(Psetfield(n, _), [Lprim(Pgetglobal id, []); lam]) ->
let (ulam, approx) = close fenv cenv lam in
(!global_approx).(n) <- approx;
- (Uprim(Psetfield(n, false), [Uprim(Pgetglobal id, []); ulam]),
+ (Uprim(Psetfield(n, false), [getglobal id; ulam]),
Value_unknown)
| Lprim(p, args) ->
simplif_prim p (close_list_approx fenv cenv args)
close_switch fenv cenv sw.sw_consts sw.sw_numconsts sw.sw_failaction
and block_index, block_actions =
close_switch fenv cenv sw.sw_blocks sw.sw_numblocks sw.sw_failaction in
- (Uswitch(uarg,
+ (Uswitch(uarg,
{us_index_consts = const_index;
us_actions_consts = const_actions;
us_index_blocks = block_index;
(uarg, Value_constptr n) ->
sequence_constant_expr arg uarg
(close fenv cenv (if n = 0 then ifnot else ifso))
- | (uarg, _ ) ->
+ | (uarg, _ ) ->
let (uifso, _) = close fenv cenv ifso in
let (uifnot, _) = close fenv cenv ifnot in
(Uifthenelse(uarg, uifso, uifnot), Value_unknown)
(* *)
(***********************************************************************)
-(* $Id: cmmgen.ml,v 1.103 2005/08/01 15:51:09 xleroy Exp $ *)
+(* $Id: cmmgen.ml,v 1.103.2.2 2005/12/11 10:21:12 xleroy Exp $ *)
(* Translation from closed lambda to C-- *)
let bind name arg fn =
match arg with
- Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_symbol _
+ Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_symbol _
| Cconst_pointer _ | Cconst_natpointer _ -> fn arg
| _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id))
[] -> Cvar id
| e1::el -> Csequence(set_fn (Cvar id) (Cconst_int idx) e1,
fill_fields (idx + 2) el) in
- Clet(id,
+ Clet(id,
Cop(Cextcall("caml_alloc", typ_addr, true),
[Cconst_int wordsize; Cconst_int tag]),
fill_fields 1 args)
int_const n
| Const_base(Const_char c) ->
Cconst_int(((Char.code c) lsl 1) + 1)
- | Const_pointer n ->
+ | Const_pointer n ->
if n <= max_repr_int && n >= min_repr_int
then Cconst_pointer((n lsl 1) + 1)
else Cconst_natpointer
when bi = Pint32 && size_int = 8 && not big_endian ->
(* Force sign-extension of low 32 bits *)
Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32]); Cconst_int 32])
- | Cop(Calloc, [hdr; ops; contents]) ->
+ | Cop(Calloc, [hdr; ops; contents]) ->
contents
| _ ->
Cop(Cload(if bi = Pint32 then Thirtytwo_signed else Word),
let lcases = Array.length cases in
let new_cases = Array.create lcases 0 in
let store = Switch.mk_store (=) in
-
+
for i = 0 to Array.length cases-1 do
let act = cases.(i) in
let new_act = store.Switch.act_store act in
Cvar id as e ->
if Ident.same id boxed_id then need_boxed := true; e
| Clet(id, arg, body) -> Clet(id, subst arg, subst body)
- | Cassign(id, arg) ->
+ | Cassign(id, arg) ->
if Ident.same id boxed_id then begin
assigned := true;
Cassign(unboxed_id, subst(unbox_fn arg))
Cswitch(subst arg, index, Array.map subst cases)
| Cloop e -> Cloop(subst e)
| Ccatch(nfail, ids, e1, e2) -> Ccatch(nfail, ids, subst e1, subst e2)
- | Cexit (nfail, el) -> Cexit (nfail, List.map subst el)
+ | Cexit (nfail, el) -> Cexit (nfail, List.map subst el)
| Ctrywith(e1, id, e2) -> Ctrywith(subst e1, id, subst e2)
| e -> e in
let res = subst exp in
- (res, !need_boxed, !assigned)
+ (res, !need_boxed, !assigned)
(* Translate an expression *)
Cop(Capply typ_addr, cargs)
| Usend(kind, met, obj, args) ->
let call_met obj args clos =
- if args = [] then Cop(Capply typ_addr,[get_field clos 0;obj;clos]) else
- let arity = List.length args + 1 in
+ if args = [] then Cop(Capply typ_addr,[get_field clos 0;obj;clos]) else
+ let arity = List.length args + 1 in
let cargs = Cconst_symbol(apply_function arity) :: obj ::
- (List.map transl args) @ [clos] in
+ (List.map transl args) @ [clos] in
Cop(Capply typ_addr, cargs)
in
bind "obj" (transl obj) (fun obj ->
- match kind, args with
- Self, _ ->
+ match kind, args with
+ Self, _ ->
bind "met" (lookup_label obj (transl met)) (call_met obj args)
- | Cached, cache :: pos :: args ->
+ | Cached, cache :: pos :: args ->
call_cached_method obj (transl met) (transl cache) (transl pos)
(List.map transl args)
- | _ ->
+ | _ ->
bind "met" (lookup_tag obj (transl met)) (call_met obj args))
| Ulet(id, exp, body) ->
begin match is_unboxed_number exp with
| Uprim(prim, args) ->
begin match (simplif_primitive prim, args) with
(Pgetglobal id, []) ->
- Cconst_symbol (Compilenv.symbol_for_global id)
+ Cconst_symbol (Ident.name id)
| (Pmakeblock(tag, mut), []) ->
transl_constant(Const_block(tag, []))
| (Pmakeblock(tag, mut), args) ->
(exit_if_false cond (transl ifso) raise_num)
(transl ifnot)
| Uifthenelse(Uprim(Psequor, _) as cond, ifso, ifnot) ->
- let raise_num = next_raise_count () in
+ let raise_num = next_raise_count () in
make_catch
raise_num
(exit_if_true cond raise_num (transl ifnot))
(remove_unit(transl body),
Clet(id_prev, Cvar id,
Csequence
- (Cassign(id,
+ (Cassign(id,
Cop(inc, [Cvar id; Cconst_int 2])),
Cifthenelse
(Cop(Ccmpi Ceq, [Cvar id_prev; high]),
| Pintcomp cmp ->
tag_int(Cop(Ccmpi(transl_comparison cmp), [transl arg1; transl arg2]))
| Pisout ->
- transl_isout (transl arg1) (transl arg2)
+ transl_isout (transl arg1) (transl arg2)
(* Float operations *)
| Paddfloat ->
box_float(Cop(Caddf,
box_float(
bind "index" (transl arg2) (fun idx ->
bind "arr" (transl arg1) (fun arr ->
- Csequence(Cop(Ccheckbound,
+ Csequence(Cop(Ccheckbound,
[float_array_length(header arr); idx]),
unboxed_float_array_ref arr idx))))
end
box_int bi (Cop(Csubi,
[transl_unbox_int bi arg1; transl_unbox_int bi arg2]))
| Pmulbint bi ->
- box_int bi (Cop(Cmuli,
+ box_int bi (Cop(Cmuli,
[transl_unbox_int bi arg1; transl_unbox_int bi arg2]))
| Pdivbint bi ->
box_int bi (safe_divmod Cdivi
and make_catch ncatch body handler = match body with
| Cexit (nexit,[]) when nexit=ncatch -> handler
-| _ -> Ccatch (ncatch, [], body, handler)
+| _ -> Ccatch (ncatch, [], body, handler)
and make_catch2 mk_body handler = match handler with
| Cexit (_,[])|Ctuple []|Cconst_int _|Cconst_pointer _ ->
nfail
(mk_body (Cexit (nfail,[])))
handler
-
+
and exit_if_true cond nfail otherwise =
match cond with
| Uconst (Const_pointer 0) -> otherwise
| Uprim(Psequand, _) ->
begin match otherwise with
| Cexit (raise_num,[]) ->
- exit_if_false cond (Cexit (nfail,[])) raise_num
+ exit_if_false cond (Cexit (nfail,[])) raise_num
| _ ->
let raise_num = next_raise_count () in
make_catch
raise_num
(exit_if_false cond (Cexit (nfail,[])) raise_num)
otherwise
- end
+ end
| Uprim(Pnot, [arg]) ->
exit_if_false arg otherwise nfail
| Uifthenelse (cond, ifso, ifnot) ->
| _ ->
let n_index = Array.length index in
let actions = Array.map transl cases in
-
+
let inters = ref []
and this_high = ref (n_index-1)
and this_low = ref (n_index-1)
| Const_base(Const_string s) ->
let lbl = new_const_label() in
(Clabel_address lbl,
- Cint(string_header (String.length s)) :: Cdefine_label lbl ::
+ Cint(string_header (String.length s)) :: Cdefine_label lbl ::
emit_string_constant s cont)
| Const_immstring s ->
begin try
- (Clabel_address (Hashtbl.find immstrings s), cont)
+ (Clabel_address (Hashtbl.find immstrings s), cont)
with Not_found ->
- let lbl = new_const_label() in
- Hashtbl.add immstrings s lbl;
- (Clabel_address lbl,
- Cint(string_header (String.length s)) :: Cdefine_label lbl ::
- emit_string_constant s cont)
+ let lbl = new_const_label() in
+ Hashtbl.add immstrings s lbl;
+ (Clabel_address lbl,
+ Cint(string_header (String.length s)) :: Cdefine_label lbl ::
+ emit_string_constant s cont)
end
| Const_base(Const_int32 n) ->
let lbl = new_const_label() in
(raise_num, [],
Cloop
(Clet(
- mi,
- Cop(Cor,
- [Cop(Clsr, [Cop(Caddi, [Cvar li; Cvar hi]); Cconst_int 1]);
- Cconst_int 1]),
- Csequence(
- Cifthenelse
- (Cop (Ccmpi Clt,
- [tag;
- Cop(Cload Word,
- [Cop(Cadda,
- [meths; lsl_const (Cvar mi) log2_size_addr])])]),
- Cassign(hi, Cop(Csubi, [Cvar mi; Cconst_int 2])),
- Cassign(li, Cvar mi)),
- Cifthenelse
- (Cop(Ccmpi Cge, [Cvar li; Cvar hi]), Cexit (raise_num, []),
- Ctuple [])))),
+ mi,
+ Cop(Cor,
+ [Cop(Clsr, [Cop(Caddi, [Cvar li; Cvar hi]); Cconst_int 1]);
+ Cconst_int 1]),
+ Csequence(
+ Cifthenelse
+ (Cop (Ccmpi Clt,
+ [tag;
+ Cop(Cload Word,
+ [Cop(Cadda,
+ [meths; lsl_const (Cvar mi) log2_size_addr])])]),
+ Cassign(hi, Cop(Csubi, [Cvar mi; Cconst_int 2])),
+ Cassign(li, Cvar mi)),
+ Cifthenelse
+ (Cop(Ccmpi Cge, [Cvar li; Cvar hi]), Cexit (raise_num, []),
+ Ctuple [])))),
Ctuple []),
Clet (
tagged, Cop(Cadda, [lsl_const (Cvar li) log2_size_addr;
Clet (
cached, Cop(Cand, [Cop(Cload Word, [cache]); mask]),
Clet (
- real,
+ real,
Cifthenelse(Cop(Ccmpa Cne, [tag'; tag]),
- cache_public_method (Cvar meths) tag cache,
+ cache_public_method (Cvar meths) tag cache,
cached_pos),
Cop(Cload Word, [Cop(Cadda, [Cop (Cadda, [Cvar real; Cvar meths]);
Cconst_int(2*size_addr-1)])]))))
-
+
in
let body = Clet(clos', clos, body) in
let fun_args =
{fun_name = name2;
fun_args = [arg, typ_addr; clos, typ_addr];
fun_body = Cop(Calloc,
- [alloc_closure_header 4;
+ [alloc_closure_header 4;
Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1));
int_const 1; Cvar arg; Cvar clos]);
fun_fast = true}
:: intermediate_curry_functions arity (num+1)
end
-
+
let curry_function arity =
if arity >= 0
then intermediate_curry_functions arity 0
/* */
/***********************************************************************/
-/* $Id: amd64.S,v 1.9 2004/07/13 12:18:53 xleroy Exp $ */
+/* $Id: amd64.S,v 1.9.4.1 2005/12/18 15:42:06 xleroy Exp $ */
/* Asm part of the runtime system, AMD64 processor */
/* Must be preprocessed by cpp */
pushq %rdi
pushq %rbx
pushq %rax
- movq %rsp, caml_gc_regs
+ movq %rsp, caml_gc_regs(%rip)
/* Save floating-point registers */
subq $(16*8), %rsp
movlpd %xmm0, 0*8(%rsp)
/* */
/***********************************************************************/
-/* $Id: signals_osdep.h,v 1.3 2005/10/14 16:41:30 xleroy Exp $ */
+/* $Id: signals_osdep.h,v 1.3.2.1 2005/12/30 08:40:56 xleroy Exp $ */
/* Processor- and OS-dependent signal interface */
typedef int context_reg;
#define CONTEXT_PC (context->sc_pc)
#define CONTEXT_EXCEPTION_POINTER (context->sc_regs[30])
- #define CONTEXT_YOUNG_LIMIT (context->sc_regs[22]
+ #define CONTEXT_YOUNG_LIMIT (context->sc_regs[22])
#define CONTEXT_YOUNG_PTR (context->sc_regs[23])
/****************** PowerPC, MacOS X */
# #
#########################################################################
-# $Id: Makefile,v 1.52 2005/10/18 14:03:52 xleroy Exp $
+# $Id: Makefile,v 1.52.2.1 2005/11/29 11:57:49 doligez Exp $
include ../config/Makefile
done
cp ld.conf $(LIBDIR)/ld.conf
-ld.conf:
+ld.conf: ../config/Makefile
echo "$(STUBLIBDIR)" >ld.conf
echo "$(LIBDIR)" >>ld.conf
# #
#########################################################################
-# $Id: Makefile.nt,v 1.38 2005/02/02 15:51:23 xleroy Exp $
+# $Id: Makefile.nt,v 1.38.4.1 2005/12/30 09:58:40 xleroy Exp $
include ../config/Makefile
$(CC) $(CFLAGS) $(BYTECCCOMPOPTS) -c $<
mv $*.$(O) $*.$(SO)
-.depend.nt:
+.depend.nt: .depend
sed -e '/\.d\.o/q' -e 's/^\(.*\)\.o:/\1.$$(DO) \1.$$(SO):/' .depend > .depend.nt
include .depend.nt
/* */
/***********************************************************************/
-/* $Id: callback.c,v 1.22 2004/04/26 12:02:07 basile Exp $ */
+/* $Id: callback.c,v 1.22.10.1 2005/12/30 09:57:09 xleroy Exp $ */
/* Callbacks from C to Caml */
char * name = String_val(vname);
unsigned int h = hash_value_name(name);
+ for (nv = named_value_table[h]; nv != NULL; nv = nv->next) {
+ if (strcmp(name, nv->name) == 0) {
+ nv->val = val;
+ return Val_unit;
+ }
+ }
nv = (struct named_value *)
caml_stat_alloc(sizeof(struct named_value) + strlen(name));
strcpy(nv->name, name);
/* */
/***********************************************************************/
-/* $Id: extern.c,v 1.58 2005/09/22 14:21:50 xleroy Exp $ */
+/* $Id: extern.c,v 1.58.2.1 2005/11/22 11:50:34 doligez Exp $ */
/* Structured output */
extern_limit = extern_output_block->data + SIZE_EXTERN_OUTPUT_BLOCK;
}
+static void close_extern_output(void)
+{
+ if (extern_userprovided_output == NULL){
+ extern_output_block->end = extern_ptr;
+ }
+}
+
static void free_extern_output(void)
{
struct output_block * blk, * nextblk;
/* Marshal the object */
extern_rec(v);
/* Record end of output */
- extern_output_block->end = extern_ptr;
+ close_extern_output();
/* Undo the modifications done on externed blocks */
extern_replay_trail();
/* Write the sizes */
/* */
/***********************************************************************/
-/* $Id: sys.c,v 1.78 2005/10/13 14:47:05 xleroy Exp $ */
+/* $Id: sys.c,v 1.78.2.1 2005/11/09 15:58:03 doligez Exp $ */
/* Basic system calls */
#ifdef HAS_TIMES
#include <sys/times.h>
#endif
+#ifdef HAS_GETRUSAGE
+#include <sys/time.h>
+#include <sys/resource.h>
+#endif
#ifdef HAS_GETTIMEOFDAY
#include <sys/time.h>
#endif
CAMLprim value caml_sys_time(value unit)
{
-#ifdef HAS_TIMES
-#ifndef CLK_TCK
-#ifdef HZ
-#define CLK_TCK HZ
-#else
-#define CLK_TCK 60
-#endif
-#endif
- struct tms t;
- times(&t);
- return caml_copy_double((double)(t.tms_utime + t.tms_stime) / CLK_TCK);
+#ifdef HAS_GETRUSAGE
+ struct rusage ru;
+
+ getrusage (RUSAGE_SELF, &ru);
+ return caml_copy_double (ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6
+ + ru.ru_stime.tv_sec + ru.ru_stime.tv_usec / 1e6);
#else
- /* clock() is standard ANSI C */
- return caml_copy_double((double)clock() / CLOCKS_PER_SEC);
+ #ifdef HAS_TIMES
+ #ifndef CLK_TCK
+ #ifdef HZ
+ #define CLK_TCK HZ
+ #else
+ #define CLK_TCK 60
+ #endif
+ #endif
+ struct tms t;
+ times(&t);
+ return caml_copy_double((double)(t.tms_utime + t.tms_stime) / CLK_TCK);
+ #else
+ /* clock() is standard ANSI C */
+ return caml_copy_double((double)clock() / CLOCKS_PER_SEC);
+ #endif
#endif
}
/* */
/***********************************************************************/
-/* $Id: weak.c,v 1.24 2004/01/01 16:42:38 doligez Exp $ */
+/* $Id: weak.c,v 1.24.12.1 2005/12/05 13:37:43 doligez Exp $ */
/* Operations on weak arrays */
#include "alloc.h"
#include "fail.h"
+#include "major_gc.h"
#include "memory.h"
#include "mlvalues.h"
if (Tag_val (v) < No_scan_tag){
mlsize_t i;
for (i = 0; i < Wosize_val (v); i++){
- Modify (&Field (elt, i), Field (v, i));
+ value f = Field (v, i);
+ if (caml_gc_phase == Phase_mark && Is_block (f) && Is_in_heap (f)){
+ caml_darken (f, NULL);
+ }
+ Modify (&Field (elt, i), f);
}
}else{
memmove (Bp_val (elt), Bp_val (v), Bosize_val (v));
#!/bin/sh
-# $Id: mkcamlp4.sh.tpl,v 1.8 2004/11/27 01:04:19 doligez Exp $
+# $Id: mkcamlp4.sh.tpl,v 1.8.4.1 2006/01/03 17:12:25 mauny Exp $
OLIB="`ocamlc -where`"
LIB="LIBDIR/camlp4"
case "$1" in
-I) INCL="$INCL -I $2"; shift;;
-version) echo "mkcamlp4, version $VERSION"; exit;;
- *)
+ [a-zA-Z]*.cmi)
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;;
+ first="`expr "$j" : '\(.\)' | tr 'a-z' 'A-Z'`"
+ rest="`expr "$j" : '.\(.*\)'`"
+ INTERFACES="$INTERFACES $first$rest"
+ ;;
+ *) OPTS="$OPTS $1";;
esac
shift
done
(* *)
(***********************************************************************)
-(* $Id: pr_o.ml,v 1.49 2005/08/13 20:59:37 doligez Exp $ *)
+(* $Id: pr_o.ml,v 1.49.2.1 2006/01/03 18:12:30 mauny Exp $ *)
open Pcaml;
open Spretty;
<:expr< for $_$ = $_$ $to:_$ $_$ do { $list:_$ } >> |
<:expr< while $_$ do { $list:_$ } >> | <:expr< ($list: _$) >> |
<:expr< let $opt:_$ $list:_$ in $_$ >> |
- <:expr< let module $_$ = $_$ in $_$ >> as e ->
+ <:expr< let module $_$ = $_$ in $_$ >> |
+ <:expr< new $list:_$ >> |
+ <:expr< assert $_$ >> | <:expr< lazy $_$ >> as e ->
fun curr next dg k ->
[: `S LO "("; `expr e "" [: `HVbox [: `S RO ")"; k :] :] :]
| e -> fun curr next _ k -> [: `not_impl "expr" e :] ]}];
(* *)
(***********************************************************************)
-(* $Id: pr_r.ml,v 1.53 2005/08/13 20:59:37 doligez Exp $ *)
+(* $Id: pr_r.ml,v 1.53.2.1 2006/01/03 18:12:30 mauny Exp $ *)
open Pcaml;
open Spretty;
<:expr< while $_$ do { $list:_$ } >> |
<:expr< let $opt:_$ $list:_$ in $_$ >> |
<:expr< let module $_$ = $_$ in $_$ >> |
- <:expr< new $list:_$ >> as e ->
+ <:expr< new $list:_$ >> |
+ <:expr< assert $_$ >> | <:expr< lazy $_$ >> as e ->
fun curr next _ k ->
[: `S LO "("; `expr e [: `HVbox [: `S RO ")"; k :] :] :]
| e -> fun curr next _ k -> [: `not_impl "expr" e :] ]}];
.ml.cmo:
- $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $<
+ $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<` -loc loc" -c $<
.ml.cmx:
- $(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $<
+ $(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<` -loc loc" -c $<
include .depend
and minus kwt =
parser
[ [: `'.' :] -> identifier kwt ("-.", False)
- | [: `('0'..'9' as c); n = number (Buff.store (Buff.store 0 '-') c) :] ep ->
+ | [: `('0'..'9' as c); n = number (Buff.store (Buff.store 0 '-') c) :] ->
n
| [: id = ident (Buff.store 0 '-') :] -> identifier kwt id ]
and less kwt =
(* ../../../LICENSE. *)
(* *)
(***********************************************************************)
-(* $Id: pr_scheme.ml,v 1.2 2004/07/13 12:25:08 xleroy Exp $ *)
+(* $Id: pr_scheme.ml,v 1.2.6.1 2005/12/19 16:49:53 verlyck Exp $ *)
open Pcaml;
open Format;
pr_box ppf f x = fprintf ppf "@[%t@]" f;
pr_rules =
extfun Extfun.empty with
- [ (loc, c, []) as x ->
+ [ (loc, c, []) ->
fun ppf curr next dg k -> fprintf ppf "(@[<hv>%s%t@]" c (ks ")" k)
| (loc, c, tl) ->
fun ppf curr next dg k ->
# #
#########################################################################
-# $Id: configure,v 1.228 2005/09/24 09:19:09 xleroy Exp $
+# $Id: configure,v 1.228.2.3 2006/01/04 09:26:42 xleroy Exp $
configure_options="$*"
prefix=/usr/local
gcc*,x86_64-*-linux*)
bytecccompopts="-fno-defer-pop $gcc_warnings"
# Tell gcc that we can use 32-bit code addresses for threaded code
- echo "#define ARCH_CODE32" >> m.h;;
+ # unless we are compiled for a shared library (-fPIC option)
+ echo "#ifndef __PIC__" >> m.h
+ echo "# define ARCH_CODE32" >> m.h
+ echo "#endif" >> m.h;;
gcc*)
bytecccompopts="-fno-defer-pop $gcc_warnings";;
esac
# Determine alignment constraints
case "$host" in
- sparc-*-*|hppa*-*-*)
+ sparc*-*-*|hppa*-*-*)
# On Sparc V9 with certain versions of gcc, determination of double
# alignment is not reliable (PR#1521), hence force it.
# Same goes for hppa.
if $int64_native; then
case "$host" in
- hppa*-*-*)
+ sparc*-*-*|hppa*-*-*)
if test $2 = 8; then
echo "64-bit integers can be word-aligned."
echo "#undef ARCH_ALIGN_INT64" >> m.h
# For the sys module
+if sh ./hasgot getrusage; then
+ echo "getrusage() found."
+ echo "#define HAS_GETRUSAGE" >> s.h
+fi
+
if sh ./hasgot times; then
echo "times() found."
echo "#define HAS_TIMES" >> s.h
(* *)
(***********************************************************************)
-(* $Id: main.ml,v 1.16 2004/11/27 01:04:19 doligez Exp $ *)
+(* $Id: main.ml,v 1.16.4.1 2005/11/29 12:17:27 doligez Exp $ *)
open Primitives
open Misc
let main () =
try
- socket_name := "/tmp/camldebug" ^ (string_of_int (Unix.getpid ()));
+ socket_name := Filename.concat Filename.temp_dir_name
+ ("camldebug" ^ (string_of_int (Unix.getpid ())));
begin try
Arg.parse speclist anonymous "";
Arg.usage speclist
toplevel_loop (); (* Toplevel. *)
kill_program ();
exit 0
- with
+ with
Toplevel ->
exit 2
- | Env.Error e ->
+ | Env.Error e ->
eprintf "Debugger [version %s] environment error:@ @[@;" Config.version;
Env.report_error err_formatter e;
eprintf "@]@.";
(* *)
(***********************************************************************)
-(* $Id: errors.ml,v 1.25 2003/06/19 15:53:49 xleroy Exp $ *)
+(* $Id: errors.ml,v 1.25.10.1 2005/11/09 15:58:47 doligez Exp $ *)
(* WARNING: if you change something in this file, you must look at
opterrors.ml to see if you need to make the same changes there.
| Sys_error msg ->
fprintf ppf "I/O error: %s" msg
| Warnings.Errors (n) ->
- fprintf ppf "@.Error: %d error-enabled warnings occurred." n
+ fprintf ppf "@.Error: error-enabled warnings (%d occurrences)" n
| x -> fprintf ppf "@]"; raise x in
fprintf ppf "@[%a@]@." report exn
(* *)
(***********************************************************************)
-(* $Id: main_args.ml,v 1.47 2005/08/01 15:51:09 xleroy Exp $ *)
+(* $Id: main_args.ml,v 1.47.2.2 2005/12/28 17:27:03 doligez Exp $ *)
module Make_options (F :
sig
"-version", Arg.Unit F._version, " Print compiler version and exit";
"-verbose", Arg.Unit F._verbose, " Print calls to external commands";
"-vmthread", Arg.Unit F._vmthread,
- " Generate code that supports the threads library with VM-level scheduling";
+ " Generate code that supports the threads library with VM-level\n\
+ \ scheduling";
"-w", Arg.String F._w,
"<flags> Enable or disable warnings according to <flags>:\n\
- \032 A/a enable/disable all warnings\n\
\032 C/c enable/disable suspicious comment\n\
\032 D/d enable/disable deprecated features\n\
\032 E/e enable/disable fragile match\n\
\032 Y/y enable/disable suspicious unused variables\n\
\032 Z/z enable/disable all other unused variables\n\
\032 X/x enable/disable all other warnings\n\
+ \032 A/a enable/disable all warnings\n\
\032 default setting is \"Aelz\"";
"-warn-error" , Arg.String F._warn_error,
- "<flags> Treat the warnings of <flags> as errors, if they are enabled.\n\
- \032 See option -w for the list of flags.\n\
- \032 Default setting is \"a\" (warnings are not errors)";
+ "<flags> Treat the warnings of <flags> as errors, if they are\n\
+ \ enabled. See option -w for the list of flags.\n\
+ \ Default setting is \"a\" (warnings are not errors)";
"-where", Arg.Unit F._where,
" Print location of standard library and exit";
"-nopervasives", Arg.Unit F._nopervasives, " (undocumented)";
(* *)
(***********************************************************************)
-(* $Id: optmain.ml,v 1.86 2005/08/01 15:51:09 xleroy Exp $ *)
+(* $Id: optmain.ml,v 1.86.2.2 2005/12/28 17:27:03 doligez Exp $ *)
open Config
open Clflags
"-dtypes", Arg.Set save_types,
" Save type information in <filename>.annot";
"-for-pack", Arg.String (fun s -> for_package := Some s),
- "<ident> Generate code that can later be `packed' with\n
- \t\t\tocamlopt -pack -o <ident>.cmx";
+ "<ident> Generate code that can later be `packed' with\n\
+ \ ocamlopt -pack -o <ident>.cmx";
"-i", Arg.Unit (fun () -> print_types := true; compile_only := true),
" Print inferred interface";
"-I", Arg.String(fun dir -> include_dirs := dir :: !include_dirs),
" Output a C object file instead of an executable";
"-p", Arg.Set gprofile,
" Compile and link with profiling support for \"gprof\"\n\
- \t(not supported on all platforms)";
+ \ (not supported on all platforms)";
"-pack", Arg.Set make_package,
" Package the given .cmx files into one .cmx";
"-pp", Arg.String(fun s -> preprocessor := Some s),
"-verbose", Arg.Set verbose, " Print calls to external commands";
"-w", Arg.String (Warnings.parse_options false),
"<flags> Enable or disable warnings according to <flags>:\n\
- \032 A/a enable/disable all warnings\n\
\032 C/c enable/disable suspicious comment\n\
\032 D/d enable/disable deprecated features\n\
\032 E/e enable/disable fragile match\n\
\032 Y/y enable/disable suspicious unused variables\n\
\032 Z/z enable/disable all other unused variables\n\
\032 X/x enable/disable all other warnings\n\
+ \032 A/a enable/disable all warnings\n\
\032 default setting is \"Aelz\"";
"-warn-error" , Arg.String (Warnings.parse_options true),
- "<flags> Treat the warnings of <flags> as errors, if they are enabled.\n\
- \032 See option -w for the list of flags.\n\
- \032 Default setting is \"a\" (warnings are not errors)";
+ "<flags> Treat the warnings of <flags> as errors, if they are\n\
+ \ enabled. See option -w for the list of flags.\n\
+ \ Default setting is \"a\" (warnings are not errors)";
"-where", Arg.Unit print_standard_library,
" Print location of standard library and exit";
odoc_dot.cmx odoc_config.cmx odoc_args.cmx odoc_analyse.cmx \
../utils/misc.cmx ../utils/config.cmx ../utils/clflags.cmx
odoc_analyse.cmo: ../utils/warnings.cmi ../typing/typetexp.cmi \
- ../typing/typemod.cmi ../typing/typedtree.cmi ../typing/typedecl.cmi \
- ../typing/typecore.cmi ../typing/typeclass.cmi ../bytecomp/translcore.cmi \
- ../bytecomp/translclass.cmi ../parsing/syntaxerr.cmi ../parsing/parse.cmi \
- odoc_types.cmi odoc_sig.cmi odoc_module.cmo odoc_misc.cmi \
+ ../typing/types.cmi ../typing/typemod.cmi ../typing/typedtree.cmi \
+ ../typing/typedecl.cmi ../typing/typecore.cmi ../typing/typeclass.cmi \
+ ../bytecomp/translcore.cmi ../bytecomp/translclass.cmi \
+ ../parsing/syntaxerr.cmi ../parsing/parse.cmi odoc_types.cmi \
+ odoc_text.cmi odoc_sig.cmi odoc_module.cmo odoc_misc.cmi \
odoc_messages.cmo odoc_merge.cmi odoc_global.cmi odoc_dep.cmo \
odoc_cross.cmi odoc_comments.cmi odoc_class.cmo odoc_ast.cmi \
odoc_args.cmi ../utils/misc.cmi ../parsing/location.cmi \
../typing/ctype.cmi ../utils/config.cmi ../utils/clflags.cmo \
../utils/ccomp.cmi odoc_analyse.cmi
odoc_analyse.cmx: ../utils/warnings.cmx ../typing/typetexp.cmx \
- ../typing/typemod.cmx ../typing/typedtree.cmx ../typing/typedecl.cmx \
- ../typing/typecore.cmx ../typing/typeclass.cmx ../bytecomp/translcore.cmx \
- ../bytecomp/translclass.cmx ../parsing/syntaxerr.cmx ../parsing/parse.cmx \
- odoc_types.cmx odoc_sig.cmx odoc_module.cmx odoc_misc.cmx \
+ ../typing/types.cmx ../typing/typemod.cmx ../typing/typedtree.cmx \
+ ../typing/typedecl.cmx ../typing/typecore.cmx ../typing/typeclass.cmx \
+ ../bytecomp/translcore.cmx ../bytecomp/translclass.cmx \
+ ../parsing/syntaxerr.cmx ../parsing/parse.cmx odoc_types.cmx \
+ odoc_text.cmx odoc_sig.cmx odoc_module.cmx odoc_misc.cmx \
odoc_messages.cmx odoc_merge.cmx odoc_global.cmx odoc_dep.cmx \
odoc_cross.cmx odoc_comments.cmx odoc_class.cmx odoc_ast.cmx \
odoc_args.cmx ../utils/misc.cmx ../parsing/location.cmx \
odoc_class.cmx: ../typing/types.cmx odoc_value.cmx odoc_types.cmx \
odoc_parameter.cmx odoc_name.cmx
odoc_comments.cmo: odoc_types.cmi odoc_text.cmi odoc_see_lexer.cmo \
- odoc_parser.cmi odoc_messages.cmo odoc_lexer.cmo odoc_global.cmi \
- odoc_comments_global.cmi odoc_comments.cmi
+ odoc_parser.cmi odoc_misc.cmi odoc_messages.cmo odoc_lexer.cmo \
+ odoc_global.cmi odoc_comments_global.cmi odoc_comments.cmi
odoc_comments.cmx: odoc_types.cmx odoc_text.cmx odoc_see_lexer.cmx \
- odoc_parser.cmx odoc_messages.cmx odoc_lexer.cmx odoc_global.cmx \
- odoc_comments_global.cmx odoc_comments.cmi
+ odoc_parser.cmx odoc_misc.cmx odoc_messages.cmx odoc_lexer.cmx \
+ odoc_global.cmx odoc_comments_global.cmx odoc_comments.cmi
odoc_comments_global.cmo: odoc_comments_global.cmi
odoc_comments_global.cmx: odoc_comments_global.cmi
odoc_config.cmo: ../utils/config.cmi odoc_config.cmi
odoc_global.cmo: ../utils/clflags.cmo odoc_global.cmi
odoc_global.cmx: ../utils/clflags.cmx odoc_global.cmi
odoc_html.cmo: odoc_text.cmi odoc_ocamlhtml.cmo odoc_messages.cmo \
- odoc_info.cmi odoc_dag2html.cmi
+ odoc_info.cmi odoc_dag2html.cmi odoc_args.cmi
odoc_html.cmx: odoc_text.cmx odoc_ocamlhtml.cmx odoc_messages.cmx \
- odoc_info.cmx odoc_dag2html.cmx
+ odoc_info.cmx odoc_dag2html.cmx odoc_args.cmx
odoc_info.cmo: ../typing/printtyp.cmi odoc_value.cmo odoc_types.cmi \
odoc_type.cmo odoc_text.cmi odoc_str.cmi odoc_search.cmi odoc_scan.cmo \
odoc_print.cmi odoc_parameter.cmo odoc_name.cmi odoc_module.cmo \
odoc_text.cmi
odoc_text.cmx: odoc_types.cmx odoc_text_parser.cmx odoc_text_lexer.cmx \
odoc_text.cmi
-odoc_text_lexer.cmo: odoc_text_parser.cmi
-odoc_text_lexer.cmx: odoc_text_parser.cmx
+odoc_text_lexer.cmo: odoc_text_parser.cmi odoc_misc.cmi
+odoc_text_lexer.cmx: odoc_text_parser.cmx odoc_misc.cmx
odoc_text_parser.cmo: odoc_types.cmi odoc_misc.cmi odoc_text_parser.cmi
odoc_text_parser.cmx: odoc_types.cmx odoc_misc.cmx odoc_text_parser.cmi
odoc_to_text.cmo: odoc_messages.cmo odoc_info.cmi
- need to fix display of type parameters for inherited classes/class types
- latex: types variant polymorphes dépassent de la page quand ils sont trop longs
- utilisation nouvelles infos de Xavier: "début de rec", etc.
+ - xml generator
=====
-Next release:
+Release 3.09.1:
+ - fix: remove .TP for generated man pages, use .sp instead
+ (.TP caused a lot of odd margins)
+ - fix: html generator now output DOCTYPE and character encoding information.
+ - add: m_text_only field in Module.t_module, to separate real modules
+ from text files handled as modules.
+ - fix: display only text for "text modules"
+ - extensible {foo } syntax
+ - user can give .txt files on the command line, containing ocamldoc formatted
+ text, to be able to include bigger texts out of source files
+ - -o option is now used by the html generator to indicate the prefix
+ of generated index files (to avoid conflict when a Index module exists
+ on case-insensitive file systems).
+
+=====
+Release 3.08.4:
- some improvements in html display
- better error messages for misplaced variant constructors comments
- some fixes in man page generation (escaping characters)
#(* *)
#(***********************************************************************)
-# $Id: Makefile,v 1.60 2005/05/31 11:48:03 habouzit Exp $
+# $Id: Makefile,v 1.60.2.2 2005/11/10 14:44:36 guesdon Exp $
include ../config/Makefile
###########
test: dummy
$(MKDIR) $@
- $(OCAMLDOC_RUN) -html -colorize-code -sort -d $@ $(INCLUDES) -dump $@/ocamldoc.odoc odoc*.ml odoc*.mli
+ $(OCAMLDOC_RUN) -html -colorize-code -sort -d $@ $(INCLUDES) -dump $@/ocamldoc.odoc test.txt test2.txt odoc*.ml odoc*.mli -v
test_stdlib: dummy
$(MKDIR) $@
test_latex: dummy
$(MKDIR) $@
- $(OCAMLDOC_RUN) -latex -sort -o $@/test.tex -d $@ $(INCLUDES) odoc*.ml odoc*.mli ../stdlib/*.mli ../otherlibs/unix/unix.mli
+ $(OCAMLDOC_RUN) -latex -sort -o $@/test.tex -d $@ $(INCLUDES) odoc*.ml odoc*.mli test2.txt ../stdlib/*.mli ../otherlibs/unix/unix.mli
test_latex_simple: dummy
$(MKDIR) $@
(* *)
(***********************************************************************)
-(* $Id: odoc_analyse.ml,v 1.12 2005/08/13 20:59:37 doligez Exp $ *)
+(* $Id: odoc_analyse.ml,v 1.12.2.2 2005/11/10 14:44:36 guesdon Exp $ *)
-(** Analysis of source files. This module is strongly inspired from driver/main.ml :-) *)
+(** Analysis of source files. This module is strongly inspired from
+ driver/main.ml :-) *)
let print_DEBUG s = print_string s ; print_newline ()
driver/error.ml file. We do this because there are
some differences between the possibly raised exceptions
in the bytecode (error.ml) and opt (opterros.ml) compilers
- and we don't want to take care of this. Besisdes, this
+ and we don't want to take care of this. Besises, these
differences only concern code generation (i believe).*)
let process_error exn =
let report ppf = function
let process_file ppf sourcefile =
if !Odoc_args.verbose then
(
- let f = match sourcefile with Odoc_args.Impl_file f | Odoc_args.Intf_file f -> f in
+ let f = match sourcefile with
+ Odoc_args.Impl_file f
+ | Odoc_args.Intf_file f -> f
+ | Odoc_args.Text_file f -> f
+ in
print_string (Odoc_messages.analysing f) ;
print_newline ();
);
Odoc_args.Impl_file file ->
(
try
- let (parsetree_typedtree_opt, input_file) = process_implementation_file ppf file in
- match parsetree_typedtree_opt with
+ let (parsetree_typedtree_opt, input_file) = process_implementation_file ppf file in
+ match parsetree_typedtree_opt with
None ->
None
- | Some (parsetree, typedtree) ->
+ | Some (parsetree, typedtree) ->
let file_module = Ast_analyser.analyse_typed_tree file
- !Location.input_name parsetree typedtree
- in
+ !Location.input_name parsetree typedtree
+ in
file_module.Odoc_module.m_top_deps <- Odoc_dep.impl_dependencies parsetree ;
if !Odoc_args.verbose then
(
- print_string Odoc_messages.ok;
- print_newline ()
+ print_string Odoc_messages.ok;
+ print_newline ()
);
remove_preprocessed input_file;
Some file_module
try
let (ast, signat, input_file) = process_interface_file ppf file in
let file_module = Sig_analyser.analyse_signature file
- !Location.input_name ast signat
- in
+ !Location.input_name ast signat
+ in
file_module.Odoc_module.m_top_deps <- Odoc_dep.intf_dependencies ast ;
incr Odoc_global.errors ;
None
)
+ | Odoc_args.Text_file file ->
+ try
+ let mod_name =
+ String.capitalize (Filename.basename (Filename.chop_extension file))
+ in
+ let txt =
+ try Odoc_text.Texter.text_of_string (Odoc_misc.input_file_as_string file)
+ with Odoc_text.Text_syntax (l, c, s) ->
+ raise (Failure (Odoc_messages.text_parse_error l c s))
+ in
+ let m =
+ {
+ Odoc_module.m_name = mod_name ;
+ Odoc_module.m_type = Types.Tmty_signature [] ;
+ Odoc_module.m_info = None ;
+ Odoc_module.m_is_interface = true ;
+ Odoc_module.m_file = file ;
+ Odoc_module.m_kind = Odoc_module.Module_struct
+ [Odoc_module.Element_module_comment txt] ;
+ Odoc_module.m_loc =
+ { Odoc_types.loc_impl = None ;
+ Odoc_types.loc_inter = Some (file, 0) } ;
+ Odoc_module.m_top_deps = [] ;
+ Odoc_module.m_code = None ;
+ Odoc_module.m_code_intf = None ;
+ Odoc_module.m_text_only = true ;
+ }
+ in
+ Some m
+ with
+ | Sys_error s
+ | Failure s ->
+ prerr_endline s;
+ incr Odoc_global.errors ;
+ None
+ | e ->
+ process_error e ;
+ incr Odoc_global.errors ;
+ None
(** Remove the class elements between the stop special comments. *)
let rec remove_class_elements_between_stop keep eles =
with
Sys_error s ->
raise (Failure s)
-
-
-(* eof $Id: odoc_analyse.ml,v 1.12 2005/08/13 20:59:37 doligez Exp $ *)
(* *)
(***********************************************************************)
-(* cvsid $Id: odoc_args.ml,v 1.18 2005/03/24 17:20:53 doligez Exp $ *)
+(* cvsid $Id: odoc_args.ml,v 1.18.4.1 2005/11/07 15:59:04 doligez Exp $ *)
(** Command-line arguments. *)
type source_file =
Impl_file of string
| Intf_file of string
+ | Text_file of string
let include_dirs = Clflags.include_dirs
"-pp", Arg.String (fun s -> preprocessor := Some s), M.preprocess ;
"-impl", Arg.String (fun s -> files := !files @ [Impl_file s]), M.option_impl ;
"-intf", Arg.String (fun s -> files := !files @ [Intf_file s]), M.option_intf ;
+ "-text", Arg.String (fun s -> files := !files @ [Text_file s]), M.option_text ;
"-rectypes", Arg.Set recursive_types, M.rectypes ;
"-nolabels", Arg.Unit (fun () -> classic := true), M.nolabels ;
"-warn-error", Arg.Set Odoc_global.warn_error, M.werr ;
let anonymous f =
let sf =
if Filename.check_suffix f "ml" then
- Impl_file f
+ Impl_file f
else
- if Filename.check_suffix f "mli" then
- Intf_file f
- else
- failwith (Odoc_messages.unknown_extension f)
+ if Filename.check_suffix f "mli" then
+ Intf_file f
+ else
+ if Filename.check_suffix f "txt" then
+ Text_file f
+ else
+ failwith (Odoc_messages.unknown_extension f)
in
files := !files @ [sf]
in
(* *)
(***********************************************************************)
-(* $Id: odoc_args.mli,v 1.14 2005/03/24 17:20:53 doligez Exp $ *)
+(* $Id: odoc_args.mli,v 1.14.4.1 2005/11/07 15:59:04 doligez Exp $ *)
(** Analysis of the command line arguments. *)
type source_file =
Impl_file of string
| Intf_file of string
+ | Text_file of string
(** The include_dirs in the OCaml compiler. *)
val include_dirs : string list ref
(* *)
(***********************************************************************)
-(* $Id: odoc_ast.ml,v 1.26 2004/12/03 14:42:09 guesdon Exp $ *)
+(* $Id: odoc_ast.ml,v 1.26.4.1 2005/11/10 14:44:36 guesdon Exp $ *)
(** Analysis of implementation files. *)
open Misc
m_top_deps = [] ;
m_code = None ; (* code is set by the caller, after the module is created *)
m_code_intf = m_code_intf ;
+ m_text_only = false ;
}
in
match (p_module_expr.Parsetree.pmod_desc, tt_module_expr.Typedtree.mod_desc) with
m_top_deps = [] ;
m_code = (if !Odoc_args.keep_code then Some !file else None) ;
m_code_intf = None ;
+ m_text_only = false ;
}
end
-(* eof $Id: odoc_ast.ml,v 1.26 2004/12/03 14:42:09 guesdon Exp $ *)
+(* eof $Id: odoc_ast.ml,v 1.26.4.1 2005/11/10 14:44:36 guesdon Exp $ *)
(* *)
(***********************************************************************)
-(* $Id: odoc_comments.ml,v 1.4 2003/11/24 10:39:29 starynke Exp $ *)
+(* $Id: odoc_comments.ml,v 1.4.12.1 2005/11/07 15:59:04 doligez Exp $ *)
(** Analysis of comments. *)
(** This variable contains the regular expression representing a blank but not a '\n'.*)
let simple_blank = "[ \013\009\012]"
-module type Texter =
+module type Texter =
sig
(** Return a text structure from a string. *)
val text_of_string : string -> text
(0, None)
| Some (desc, remain_opt) ->
let mem_nb_chars = !Odoc_comments_global.nb_chars in
- let _ =
+ let _ =
match remain_opt with
None ->
()
let lexbuf2 = Lexing.from_string s in
Odoc_parser.info_part2 Odoc_lexer.elements lexbuf2
in
- (mem_nb_chars,
+ (mem_nb_chars,
Some
{
i_desc = (match desc with "" -> None | _ -> Some (MyTexter.text_of_string desc));
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
+ 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) ->
+ i_params =
+ (List.map (fun (n, s) ->
(n, MyTexter.text_of_string s)) !Odoc_comments_global.params);
- i_raised_exceptions =
+ 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
+ (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))
+ (fun (tag, s) -> (tag, MyTexter.text_of_string s))
!Odoc_comments_global.customs)
- }
+ }
)
with
Failure s ->
with
Not_found ->
false
-
+
let retrieve_info_special file (s : string) =
retrieve_info Odoc_lexer.main file s
let retrieve_last_info_simple file (s : string) =
print_DEBUG ("retrieve_last_info_simple:"^s);
let rec f cur_len cur_d =
- try
+ 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
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
+ 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
(* 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
+ if blank_line (String.sub s 0 pos) or
d.Odoc_types.i_desc = Some [Odoc_types.Raw "/*"]
then
(0, None)
(* 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
+ 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
[] ->
module Basic_info_retriever = Info_retriever (Odoc_text.Texter)
-(* eof $Id: odoc_comments.ml,v 1.4 2003/11/24 10:39:29 starynke Exp $ *)
+let info_of_string s =
+ let dummy =
+ {
+ i_desc = None ;
+ i_authors = [] ;
+ i_version = None ;
+ i_sees = [] ;
+ i_since = None ;
+ i_deprecated = None ;
+ i_params = [] ;
+ i_raised_exceptions = [] ;
+ i_return_value = None ;
+ i_custom = [] ;
+ }
+ in
+ let s2 = Printf.sprintf "(** %s *)" s in
+ let (_, i_opt) = Basic_info_retriever.first_special "-" s2 in
+ match i_opt with
+ None -> dummy
+ | Some i -> i
+
+let info_of_comment_file f =
+ try
+ let s = Odoc_misc.input_file_as_string f in
+ info_of_string s
+ with
+ Sys_error s ->
+ failwith s
+
+(* eof $Id: odoc_comments.ml,v 1.4.12.1 2005/11/07 15:59:04 doligez Exp $ *)
(* *)
(***********************************************************************)
-(* $Id: odoc_comments.mli,v 1.3 2003/11/24 10:39:30 starynke Exp $ *)
+(* $Id: odoc_comments.mli,v 1.3.12.1 2005/11/07 15:59:04 doligez Exp $ *)
(** Analysis of comments. *)
val simple_blank : string
(** The type of modules in argument to Info_retriever *)
-module type Texter =
+module type Texter =
sig
(** Return a text structure from a string. *)
val text_of_string : string -> Odoc_types.text
val all_special : string -> string -> int * Odoc_types.info list
(** [just_after_special file str] return the pair ([length], [info_opt])
- where [info_opt] is the first optional special comment found
+ where [info_opt] is the first optional special comment found
in [str], without any blank line before. [length] is the number
of chars from the beginning of [str] to the end of the special comment. *)
val just_after_special :
string -> string -> int * Odoc_types.info option
(** [first_special file str] return the pair ([length], [info_opt])
- where [info_opt] is the first optional special comment found
+ where [info_opt] is the first optional special comment found
in [str]. [length] is the number of chars from the beginning of
[str] to the end of the special comment. *)
val first_special :
string -> string -> int * Odoc_types.info option
(** Return a pair [(comment_opt, element_comment_list)], where [comment_opt] is the last special
- comment found in the given string and not followed by a blank line,
+ 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 :
string -> string -> Odoc_types.info option * 'a list
end
+
+(** [info_of_string s] parses the given string
+ like a regular ocamldoc comment and return an
+ {!Odoc_types.info} structure.
+ @return an empty structure if there was a syntax error. TODO: change this
+*)
+val info_of_string : string -> Odoc_types.info
+
+(** [info_of_comment_file file] parses the given file
+ and return an {!Odoc_types.info} structure. The content of the
+ file must have the same syntax as the content of a special comment.
+ @raise Failure is the file could not be opened or there is a
+ syntax error.
+*)
+val info_of_comment_file : string -> Odoc_types.info
(* *)
(***********************************************************************)
-(* $Id: odoc_cross.ml,v 1.15 2004/05/23 10:41:49 guesdon Exp $ *)
+(* $Id: odoc_cross.ml,v 1.15.10.1 2005/11/07 15:59:04 doligez Exp $ *)
(** Cross referencing. *)
open Odoc_types
open Odoc_value
open Odoc_type
-open Odoc_parameter
+open Odoc_parameter
-(*** Replacements of aliases : if e1 = e2 and e2 = e3, then replace e2 by e3 to have e1 = e3,
+(*** Replacements of aliases : if e1 = e2 and e2 = e3, then replace e2 by e3 to have e1 = e3,
in order to associate the element with complete information. *)
(** The module used to keep what refs were modified. *)
-module S = Set.Make
+module S = Set.Make
(
struct type t = string * ref_kind option
let compare = Pervasives.compare
struct
type t = int
- let p_module m _ =
+ let p_module m _ =
(true,
match m.m_kind with
Module_alias _ -> true
| (Odoc_search.Res_module m) :: q ->
(
match m.m_kind with
- Module_alias ma ->
+ Module_alias ma ->
Hashtbl.add module_aliases m.m_name (ma.ma_name, Alias_to_resolve);
Hashtbl.add module_and_modtype_aliases m.m_name (ma.ma_name, Alias_to_resolve)
| _ -> ()
| (Odoc_search.Res_module_type mt) :: q ->
(
match mt.mt_kind with
- Some (Module_type_alias mta) ->
- Hashtbl.add module_and_modtype_aliases
+ Some (Module_type_alias mta) ->
+ Hashtbl.add module_and_modtype_aliases
mt.mt_name (mta.mta_name, Alias_to_resolve)
| _ -> ()
);
(
match e.ex_alias with
None -> ()
- | Some ea ->
- Hashtbl.add exception_aliases
+ | Some ea ->
+ Hashtbl.add exception_aliases
e.ex_name (ea.ea_name,Alias_to_resolve)
);
build_alias_list q
| _ :: q ->
build_alias_list q
-(** Retrieve the aliases for modules, module types and exceptions
+(** Retrieve the aliases for modules, module types and exceptions
and put them in global hash tables. *)
let get_alias_names module_list =
Hashtbl.clear module_aliases;
Hashtbl.clear module_and_modtype_aliases;
Hashtbl.clear exception_aliases;
build_alias_list (Search_alias.search module_list 0)
-
+
exception Found of string
let name_alias =
let rec f t name =
module Map_ord =
struct
- type t = string
+ type t = string
let compare = Pervasives.compare
end
module Ele_map = Map.Make (Map_ord)
let known_elements = ref Ele_map.empty
-let add_known_element name k =
+let add_known_element name k =
try
let l = Ele_map.find name !known_elements in
let s = Ele_map.remove name !known_elements in
with Not_found -> []
let kind_name_exists kind =
- let pred =
+ let pred =
match kind with
RK_module -> (fun e -> match e with Odoc_search.Res_module _ -> true | _ -> false)
| RK_module_type -> (fun e -> match e with Odoc_search.Res_module_type _ -> true | _ -> false)
let lookup_module name =
match List.find
- (fun k -> match k with Odoc_search.Res_module _ -> true | _ -> false)
+ (fun k -> match k with Odoc_search.Res_module _ -> true | _ -> false)
(get_known_elements name)
with
| Odoc_search.Res_module m -> m
let lookup_module_type name =
match List.find
- (fun k -> match k with Odoc_search.Res_module_type _ -> true | _ -> false)
+ (fun k -> match k with Odoc_search.Res_module_type _ -> true | _ -> false)
(get_known_elements name)
with
| Odoc_search.Res_module_type m -> m
let lookup_class name =
match List.find
- (fun k -> match k with Odoc_search.Res_class _ -> true | _ -> false)
+ (fun k -> match k with Odoc_search.Res_class _ -> true | _ -> false)
(get_known_elements name)
with
| Odoc_search.Res_class c -> c
let lookup_class_type name =
match List.find
- (fun k -> match k with Odoc_search.Res_class_type _ -> true | _ -> false)
+ (fun k -> match k with Odoc_search.Res_class_type _ -> true | _ -> false)
(get_known_elements name)
with
| Odoc_search.Res_class_type c -> c
let lookup_exception name =
match List.find
- (fun k -> match k with Odoc_search.Res_exception _ -> true | _ -> false)
+ (fun k -> match k with Odoc_search.Res_exception _ -> true | _ -> false)
(get_known_elements name)
with
| Odoc_search.Res_exception e -> e
class scan =
object
inherit Odoc_scan.scanner
- method scan_value v =
+ method scan_value v =
add_known_element v.val_name (Odoc_search.Res_value v)
- method scan_type t =
+ method scan_type t =
add_known_element t.ty_name (Odoc_search.Res_type t)
method scan_exception e =
add_known_element e.ex_name (Odoc_search.Res_exception e)
(** The type to describe the names not found. *)
-type not_found_name =
+type not_found_name =
NF_m of Name.t
| NF_mt of Name.t
| NF_mmt of Name.t
(associate_in_module_element module_list m.m_name)
(acc_b, acc_inc, acc_names)
elements
-
+
| Module_alias ma ->
(
match ma.ma_module with
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
+ 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
+ (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 ->
+ | Some mmt ->
ma.ma_module <- Some mmt ;
(true, 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
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
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
+ 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
+ (if mta.mta_name = Odoc_messages.struct_end or
mta.mta_name = Odoc_messages.sig_end then
- acc_names
- else
+ acc_names
+ else
(NF_mt mta.mta_name) :: acc_names)
)
- | Some mt ->
+ | Some mt ->
mta.mta_module <- Some mt ;
(true, acc_inc, acc_names)
in
match mt.mt_kind with
None -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found)
| Some k -> iter_kind (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) k
-
+
and associate_in_module_element module_list m_name (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) element =
match element with
Element_module m -> associate_in_module module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) m
| Element_module_type mt -> associate_in_module_type module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) mt
- | Element_included_module im ->
+ | Element_included_module im ->
(
match im.im_module with
Some _ -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found)
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
+ 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
+ (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 ->
+ | Some mmt ->
im.im_module <- Some mmt ;
(true, acc_incomplete_top_module_names, acc_names_not_found)
)
None -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found)
| Some ea ->
match ea.ea_ex with
- Some _ ->
+ Some _ ->
(acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found)
- | None ->
+ | None ->
let ex_opt =
try Some (lookup_exception ea.ea_name)
with Not_found -> None
| Element_module_comment _ -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found)
and associate_in_class module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) c =
- let rec iter_kind (acc_b, acc_inc, acc_names) k =
+ 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 =
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 ->
+ | Some cct ->
ic.ic_class <- Some cct ;
(true, acc_inc2, acc_names2)
in
(
match capp.capp_class with
Some _ -> (acc_b, acc_inc, acc_names)
- | None ->
+ | None ->
let cl_opt =
try Some (lookup_class capp.capp_name)
with Not_found -> None
in
match cl_opt with
- None -> (acc_b, (Name.head c.cl_name) :: acc_inc,
+ 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 ->
(
match cco.cco_class with
Some _ -> (acc_b, acc_inc, acc_names)
- | None ->
+ | None ->
let cl_opt =
try Some (lookup_class cco.cco_name)
with Not_found -> None
in
match cl_opt with
- None ->
+ None ->
(
let clt_opt =
try Some (lookup_class_type cco.cco_name)
in
match clt_opt with
None ->
- (acc_b, (Name.head c.cl_name) :: acc_inc,
+ (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 ->
iter_kind (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) c.cl_kind
and associate_in_class_type module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) ct =
- let rec iter_kind (acc_b, acc_inc, acc_names) k =
+ 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 =
with Not_found -> None
in
match cct_opt with
- None -> (acc_b2, (Name.head ct.clt_name) :: acc_inc2,
+ 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 ->
+ | Some cct ->
ic.ic_class <- Some cct ;
(true, acc_inc2, acc_names2)
in
(
match cta.cta_class with
Some _ -> (acc_b, acc_inc, acc_names)
- | None ->
+ | None ->
let cct_opt =
try Some (Cltype (lookup_class_type cta.cta_name, []))
- with Not_found ->
+ with Not_found ->
try Some (Cl (lookup_class cta.cta_name))
with Not_found -> None
in
match cct_opt with
- None -> (acc_b, (Name.head ct.clt_name) :: acc_inc,
+ 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 ->
(*************************************************************)
(** Association of types to elements referenced in comments .*)
-let ao = Odoc_misc.apply_opt
+let ao = Odoc_misc.apply_opt
let rec assoc_comments_text_elements module_list t_ele =
match t_ele with
)
| ele :: _ ->
(* we look for the first element with this name *)
- let kind =
+ let kind =
match ele with
Odoc_search.Res_module _ -> RK_module
| Odoc_search.Res_module_type _ -> RK_module_type
add_verified (name, Some kind) ;
Ref (name, Some kind)
)
- | Ref (name, Some kind) ->
+ | Ref (name, Some kind) ->
(
let v = (name, Some kind) in
if was_verified v then
Ref (name, None)
)
| _ ->
- let (f,f_mes) =
+ let (f,f_mes) =
match kind with
RK_module -> module_exists, Odoc_messages.cross_module_not_found
| RK_module_type -> module_type_exists, Odoc_messages.cross_module_type_not_found
Ref (name, None)
)
)
- | Module_list l ->
+ | Module_list l ->
Module_list l
| Index_list ->
Index_list
+ | Custom (s,t) -> Custom (s, (assoc_comments_text module_list t))
and assoc_comments_text module_list text =
List.map (assoc_comments_text_elements module_list) text
i_raised_exceptions = List.map (fun (name, t) -> (name, ft t)) i.i_raised_exceptions;
i_return_value = ao ft i.i_return_value ;
i_custom = List.map (fun (tag, t) -> (tag, ft t)) i.i_custom ;
- }
-
+ }
+
let rec assoc_comments_module_element module_list m_ele =
match m_ele with
and assoc_comments_module_kind module_list mk =
match mk with
- | Module_struct eles ->
+ | Module_struct eles ->
Module_struct (List.map (assoc_comments_module_element module_list) eles)
- | Module_alias _
- | Module_functor _ ->
+ | Module_alias _
+ | Module_functor _ ->
mk
- | Module_apply (mk1, mk2) ->
+ | Module_apply (mk1, mk2) ->
Module_apply (assoc_comments_module_kind module_list mk1,
assoc_comments_module_kind module_list mk2)
- | Module_with (mtk, s) ->
+ | Module_with (mtk, s) ->
Module_with (assoc_comments_module_type_kind module_list mtk, s)
- | Module_constraint (mk1, mtk) ->
+ | Module_constraint (mk1, mtk) ->
Module_constraint (assoc_comments_module_kind module_list mk1,
assoc_comments_module_type_kind module_list mtk)
match mtk with
| Module_type_struct eles ->
Module_type_struct (List.map (assoc_comments_module_element module_list) eles)
- | Module_type_functor (params, mtk1) ->
+ | Module_type_functor (params, mtk1) ->
Module_type_functor (params, assoc_comments_module_type_kind module_list mtk1)
| Module_type_alias _ ->
mtk
and assoc_comments_class_kind module_list ck =
match ck with
Class_structure (inher, eles) ->
- let inher2 =
- List.map
- (fun ic -> { ic with
+ let inher2 =
+ List.map
+ (fun ic -> { ic with
ic_text = ao (assoc_comments_text module_list) ic.ic_text })
inher
in
and assoc_comments_class_type_kind module_list ctk =
match ctk with
Class_signature (inher, eles) ->
- let inher2 =
- List.map
- (fun ic -> { ic with
+ let inher2 =
+ List.map
+ (fun ic -> { ic with
ic_text = ao (assoc_comments_text module_list) ic.ic_text })
inher
in
mt.mt_kind <- ao (assoc_comments_module_type_kind module_list) mt.mt_kind ;
mt
-and assoc_comments_class module_list c =
+and assoc_comments_class module_list c =
c.cl_info <- ao (assoc_comments_info module_list) c.cl_info ;
c.cl_kind <- assoc_comments_class_kind module_list c.cl_kind ;
assoc_comments_parameter_list module_list c.cl_parameters;
and assoc_comments_parameter module_list p =
match p with
- Simple_name sn ->
+ Simple_name sn ->
sn.sn_text <- ao (assoc_comments_text module_list) sn.sn_text
| Tuple (l, t) ->
List.iter (assoc_comments_parameter module_list) l
(match t.ty_kind with
Type_abstract -> ()
| Type_variant (vl, _) ->
- List.iter
+ List.iter
(fun vc -> vc.vc_text <- ao (assoc_comments_text module_list) vc.vc_text)
- vl
+ vl
| Type_record (fl, _) ->
- List.iter
+ List.iter
(fun rf -> rf.rf_text <- ao (assoc_comments_text module_list) rf.rf_text)
fl
);
else remove_doubles (h :: acc) q
in
let rec iter incomplete_modules =
- let (b_modif, remaining_inc_modules, acc_names_not_found) =
+ let (b_modif, remaining_inc_modules, acc_names_not_found) =
List.fold_left (associate_in_module module_list) (false, [], []) incomplete_modules
in
let remaining_no_doubles = remove_doubles [] remaining_inc_modules in
[] ->
()
| l ->
- List.iter
+ List.iter
(fun nf ->
Odoc_messages.pwarning
(
(* Find a type for each name of element which is referenced in comments. *)
ignore (associate_type_of_elements_in_comments module_list)
-
-(* eof $Id: odoc_cross.ml,v 1.15 2004/05/23 10:41:49 guesdon Exp $ *)
+
+(* eof $Id: odoc_cross.ml,v 1.15.10.1 2005/11/07 15:59:04 doligez Exp $ *)
(* *)
(***********************************************************************)
-(* $Id: odoc_html.ml,v 1.58 2005/08/16 00:48:56 garrigue Exp $ *)
+(* $Id: odoc_html.ml,v 1.58.2.3 2005/11/10 14:44:36 guesdon Exp $ *)
-(** Generation of html documentation. *)
+(** Generation of html documentation.*)
let print_DEBUG s = print_string s ; print_newline ()
let ch c = Buffer.add_char buf c in
let st s = Buffer.add_string buf s in
for i = 0 to len - 1 do
- match name.[i] with
- | '|' -> st "_pipe_"
+ match name.[i] with
+ | '|' -> st "_pipe_"
| '<' -> st "_lt_"
| '>' -> st "_gt_"
| '@' -> st "_at_"
| ':' -> st "_column_"
| '~' -> st "_tilde_"
| '!' -> st "_bang_"
- | c -> ch c
+ | c -> ch c
done;
Buffer.contents buf
| Odoc_info.Ref (name, ref_opt) -> self#html_of_Ref b name ref_opt
| Odoc_info.Superscript t -> self#html_of_Superscript b t
| Odoc_info.Subscript t -> self#html_of_Subscript b t
- | Odoc_info.Module_list l -> self#html_of_Module_list b l
- | Odoc_info.Index_list -> self#html_of_Index_list b
+ | Odoc_info.Module_list l -> self#html_of_Module_list b l
+ | Odoc_info.Index_list -> self#html_of_Index_list b
+ | Odoc_info.Custom (s,t) -> self#html_of_custom_text b s t
+
+ method html_of_custom_text b s t = ()
method html_of_Raw b s = bs b (self#escape s)
if !Args.colorize_code then
self#html_of_code b ~with_pre: false s
else
- (
- bs b "<code class=\"";
- bs b Odoc_ocamlhtml.code_class ;
- bs b "\">";
- bs b (self#escape s);
- bs b "</code>"
- )
+ (
+ bs b "<code class=\"";
+ bs b Odoc_ocamlhtml.code_class ;
+ bs b "\">";
+ bs b (self#escape s);
+ bs b "</code>"
+ )
method html_of_CodePre =
- let remove_useless_newlines s =
- let len = String.length s in
- let rec iter_first n =
- if n >= len then
- None
- else
- match s.[n] with
- | '\n' -> iter_first (n+1)
- | _ -> Some n
- in
- match iter_first 0 with
- None -> ""
- | Some first ->
- let rec iter_last n =
- if n <= first then
- None
- else
- match s.[n] with
- '\t' -> iter_last (n-1)
- | _ -> Some n
- in
- match iter_last (len-1) with
- None -> String.sub s first 1
- | Some last -> String.sub s first ((last-first)+1)
- in
- fun b s ->
+ let remove_useless_newlines s =
+ let len = String.length s in
+ let rec iter_first n =
+ if n >= len then
+ None
+ else
+ match s.[n] with
+ | '\n' -> iter_first (n+1)
+ | _ -> Some n
+ in
+ match iter_first 0 with
+ None -> ""
+ | Some first ->
+ let rec iter_last n =
+ if n <= first then
+ None
+ else
+ match s.[n] with
+ '\t' -> iter_last (n-1)
+ | _ -> Some n
+ in
+ match iter_last (len-1) with
+ None -> String.sub s first 1
+ | Some last -> String.sub s first ((last-first)+1)
+ in
+ fun b s ->
if !Args.colorize_code then
- (
+ (
bs b "<pre></pre>";
- self#html_of_code b (remove_useless_newlines s);
- bs b "<pre></pre>"
- )
+ self#html_of_code b (remove_useless_newlines s);
+ )
else
(
- bs b "<pre><code class=\"";
- bs b Odoc_ocamlhtml.code_class;
- bs b "\">" ;
- bs b (self#escape (remove_useless_newlines s));
- bs b "</code></pre>"
- )
+
bs b "<pre><code class=\"";
+ bs b Odoc_ocamlhtml.code_class;
+ bs b "\">" ;
+ bs b (self#escape (remove_useless_newlines s));
+ bs b "</code></pre>"
+ )
method html_of_Verbatim b s =
bs b "<pre>";
method html_of_List b tl =
bs b "<ul>\n";
List.iter
- (fun t -> bs b "<li>"; self#html_of_text b t; bs b "</li>\n")
- tl;
+ (fun t -> bs b "<li>"; self#html_of_text b t; bs b "</li>\n")
+ tl;
bs b "</ul>\n"
method html_of_Enum b tl =
bs b "<OL>\n";
List.iter
- (fun t -> bs b "<li>"; self#html_of_text b t; bs b"</li>\n")
- tl;
+ (fun t -> bs b "<li>"; self#html_of_text b t; bs b"</li>\n")
+ tl;
bs b "</OL>\n"
method html_of_Newline b = bs b "\n<p>\n"
bs b (Naming.label_target label1);
bs b "\"></a>\n";
let (tag_o, tag_c) =
- if n > 6 then
- (Printf.sprintf "div class=\"h%d\"" n, "div")
- else
- let t = Printf.sprintf "h%d" n in (t, t)
+ if n > 6 then
+ (Printf.sprintf "div class=\"h%d\"" n, "div")
+ else
+ let t = Printf.sprintf "h%d" n in (t, t)
in
bs b "<";
bs b tag_o;
None ->
self#html_of_text_element b (Odoc_info.Code name)
| Some kind ->
- let h name = Odoc_info.Code (Odoc_info.use_hidden_modules name) in
+ let h name = Odoc_info.Code (Odoc_info.use_hidden_modules name) in
let (target, text) =
match kind with
Odoc_info.RK_module
| Odoc_info.RK_attribute -> (Naming.complete_target Naming.mark_attribute name, h name)
| Odoc_info.RK_method -> (Naming.complete_target Naming.mark_method name, h name)
| Odoc_info.RK_section t -> (Naming.complete_label_target name,
- Odoc_info.Italic [Raw (Odoc_info.string_of_text t)])
+ Odoc_info.Italic [Raw (Odoc_info.string_of_text t)])
in
bs b ("<a href=\""^target^"\">");
self#html_of_text_element b text;
- bs b "</a>"
+ bs b "</a>"
method html_of_Superscript b t =
bs b "<sup class=\"superscript\">";
bs b "<br>\n<table class=\"indextable\">\n";
List.iter
(fun name ->
- bs b "<tr><td>";
- (
- try
- let m =
- List.find (fun m -> m.m_name = name) self#list_modules
- in
- let (html, _) = Naming.html_files m.m_name in
- bp b "<a href=\"%s\">%s</a></td>" html m.m_name;
- bs b "<td>";
- self#html_of_info_first_sentence b m.m_info;
- with
- Not_found ->
- Odoc_messages.pwarning (Odoc_messages.cross_module_not_found name);
- bp b "%s</td><td>" name
- );
- bs b "</td></tr>\n"
- )
+ bs b "<tr><td>";
+ (
+ try
+ let m =
+ List.find (fun m -> m.m_name = name) self#list_modules
+ in
+ let (html, _) = Naming.html_files m.m_name in
+
bp b "<a href=\"%s\">%s</a></td>" html m.m_name;
+ bs b "<td>";
+ self#html_of_info_first_sentence b m.m_info;
+ with
+ Not_found ->
+ Odoc_messages.pwarning (Odoc_messages.cross_module_not_found name);
+ bp b "%s</td><td>" name
+ );
+ bs b "</td></tr>\n"
+ )
l;
- bs b "</table>\n</body>\n</html>";
+ bs b "</table>\n"
method html_of_Index_list b =
let index_if_not_empty l url m =
[] -> ()
| _ ->
bp b "<b>%s:</b> %s<br>\n"
- Odoc_messages.authors
+ Odoc_messages.authors
(String.concat ", " l)
(** Print html code for the given optional version information.*)
match v_opt with
None -> ()
| Some v ->
- bp b "<b>%s:</b> %s<br>\n" Odoc_messages.version v
+ bp b "<b>%s:</b> %s<br>\n" Odoc_messages.version v
(** Print html code for the given optional since information.*)
method html_of_since_opt b s_opt =
match s_opt with
None -> ()
| Some s ->
- bp b "<b>%s</b> %s<br>\n" Odoc_messages.since s
+ bp b "<b>%s</b> %s<br>\n" Odoc_messages.since s
(** Print html code for the given list of raised exceptions.*)
method html_of_raised_exceptions b l =
match l with
[] -> ()
| (s, t) :: [] ->
- bp b "<b>%s</b> <code>%s</code> "
- Odoc_messages.raises
- s;
- self#html_of_text b t;
- bs b "<br>\n"
+ bp b "<b>%s</b> <code>%s</code> "
+ Odoc_messages.raises
+ s;
+ self#html_of_text b t;
+ bs b "<br>\n"
| _ ->
bp b "<b>%s</b><ul>" Odoc_messages.raises;
- List.iter
+ List.iter
(fun (ex, desc) ->
- bp b "<li><code>%s</code> " ex ;
- self#html_of_text b desc;
- bs b "</li>\n"
- )
+ bp b "<li><code>%s</code> " ex ;
+ self#html_of_text b desc;
+ bs b "</li>\n"
+ )
l;
bs b "</ul>\n"
match l with
[] -> ()
| see :: [] ->
- bp b "<b>%s</b> " Odoc_messages.see_also;
- self#html_of_see b see;
- bs b "<br>\n"
+ bp b "<b>%s</b> " Odoc_messages.see_also;
+ self#html_of_see b see;
+ bs b "<br>\n"
| _ ->
bp b "<b>%s</b><ul>" Odoc_messages.see_also;
List.iter
(fun see ->
- bs b "<li>" ;
- self#html_of_see b see;
- bs b "</li>\n"
- )
+ bs b "<li>" ;
+ self#html_of_see b see;
+ bs b "</li>\n"
+ )
l;
bs b "</ul>\n"
match return_opt with
None -> ()
| Some s ->
- bp b "<b>%s</b> " Odoc_messages.returns;
- self#html_of_text b s;
- bs b "<br>\n"
+ bp b "<b>%s</b> " Odoc_messages.returns;
+ self#html_of_text b s;
+ bs b "<br>\n"
(** Print html code for the given list of custom tagged texts. *)
method html_of_custom b l =
let module M = Odoc_info in
if indent then bs b "<div class=\"info\">\n";
(
- match info.M.i_deprecated with
+ match info.M.i_deprecated with
None -> ()
| Some d ->
bs b "<span class=\"warning\">";
- bs b Odoc_messages.deprecated ;
- bs b "</span>" ;
- self#html_of_text b d;
+ bs b Odoc_messages.deprecated ;
+ bs b "</span>" ;
+ self#html_of_text b d;
bs b "<br>\n"
);
(
- match info.M.i_desc with
+ match info.M.i_desc with
None -> ()
| Some d when d = [Odoc_info.Raw ""] -> ()
| Some d -> self#html_of_text b d; bs b "<br>\n"
bs b "<div class=\"info\">\n";
if dep then bs b "<font color=\"#CCCCCC\">";
(
- match info.M.i_desc with
+ match info.M.i_desc with
None -> ()
| Some d when d = [Odoc_info.Raw ""] -> ()
| Some d ->
- self#html_of_text b
+ self#html_of_text b
(Odoc_info.text_no_title_no_list
(Odoc_info.first_sentence_of_text d));
- bs b "\n"
+ bs b "\n"
);
if dep then bs b "</font>";
bs b "</div>\n"
[] -> ()
| [c] -> f c
| c :: q ->
- f c;
- bs b sep;
- iter q
+ f c;
+ bs b sep;
+ iter q
in
iter
inherit text
inherit info
+ val mutable doctype =
+ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">\n"
+ val mutable character_encoding =
+ "<meta content=\"text/html; charset=iso-8859-1\" http-equiv=\"Content-Type\">\n"
+
(** The default style options. *)
val mutable default_style_options =
["a:visited {color : #416DFF; text-decoration : none; }" ;
".code { color : #465F91 ; }" ;
"h1 { font-size : 20pt ; text-align: center; }" ;
- "h2 { font-size : 20pt ; border: 1px solid #000000; "^
- "margin-top: 5px; margin-bottom: 2px;"^
- "text-align: center; background-color: #90BDFF ;"^
- "padding: 2px; }" ;
-
- "h3 { font-size : 20pt ; border: 1px solid #000000; "^
- "margin-top: 5px; margin-bottom: 2px;"^
- "text-align: center; background-color: #90DDFF ;"^
- "padding: 2px; }" ;
-
- "h4 { font-size : 20pt ; border: 1px solid #000000; "^
- "margin-top: 5px; margin-bottom: 2px;"^
- "text-align: center; background-color: #90EDFF ;"^
- "padding: 2px; }" ;
-
- "h5 { font-size : 20pt ; border: 1px solid #000000; "^
- "margin-top: 5px; margin-bottom: 2px;"^
- "text-align: center; background-color: #90FDFF ;"^
- "padding: 2px; }" ;
-
- "h6 { font-size : 20pt ; border: 1px solid #000000; "^
- "margin-top: 5px; margin-bottom: 2px;"^
- "text-align: center; background-color: #C0FFFF ; "^
- "padding: 2px; }" ;
-
- "div.h7 { font-size : 20pt ; border: 1px solid #000000; "^
- "margin-top: 5px; margin-bottom: 2px;"^
- "text-align: center; background-color: #E0FFFF ; "^
- "padding: 2px; }" ;
-
- "div.h8 { font-size : 20pt ; border: 1px solid #000000; "^
- "margin-top: 5px; margin-bottom: 2px;"^
- "text-align: center; background-color: #F0FFFF ; "^
- "padding: 2px; }" ;
-
- "div.h9 { font-size : 20pt ; border: 1px solid #000000; "^
- "margin-top: 5px; margin-bottom: 2px;"^
- "text-align: center; background-color: #FFFFFF ; "^
- "padding: 2px; }" ;
-
- ".typetable { border-style : hidden }" ;
- ".indextable { border-style : hidden }" ;
- ".paramstable { border-style : hidden ; padding: 5pt 5pt}" ;
+ "h2 { font-size : 20pt ; border: 1px solid #000000; "^
+ "margin-top: 5px; margin-bottom: 2px;"^
+ "text-align: center; background-color: #90BDFF ;"^
+ "padding: 2px; }" ;
+
+ "h3 { font-size : 20pt ; border: 1px solid #000000; "^
+ "margin-top: 5px; margin-bottom: 2px;"^
+ "text-align: center; background-color: #90DDFF ;"^
+ "padding: 2px; }" ;
+
+ "h4 { font-size : 20pt ; border: 1px solid #000000; "^
+ "margin-top: 5px; margin-bottom: 2px;"^
+ "text-align: center; background-color: #90EDFF ;"^
+ "padding: 2px; }" ;
+
+ "h5 { font-size : 20pt ; border: 1px solid #000000; "^
+ "margin-top: 5px; margin-bottom: 2px;"^
+ "text-align: center; background-color: #90FDFF ;"^
+ "padding: 2px; }" ;
+
+ "h6 { font-size : 20pt ; border: 1px solid #000000; "^
+ "margin-top: 5px; margin-bottom: 2px;"^
+ "text-align: center; background-color: #C0FFFF ; "^
+ "padding: 2px; }" ;
+
+ "div.h7 { font-size : 20pt ; border: 1px solid #000000; "^
+ "margin-top: 5px; margin-bottom: 2px;"^
+ "text-align: center; background-color: #E0FFFF ; "^
+ "padding: 2px; }" ;
+
+ "div.h8 { font-size : 20pt ; border: 1px solid #000000; "^
+ "margin-top: 5px; margin-bottom: 2px;"^
+ "text-align: center; background-color: #F0FFFF ; "^
+ "padding: 2px; }" ;
+
+ "div.h9 { font-size : 20pt ; border: 1px solid #000000; "^
+ "margin-top: 5px; margin-bottom: 2px;"^
+ "text-align: center; background-color: #FFFFFF ; "^
+ "padding: 2px; }" ;
+
+ ".typetable { border-style : hidden }" ;
+ ".indextable { border-style : hidden }" ;
+ ".paramstable { border-style : hidden ; padding: 5pt 5pt}" ;
"body { background-color : White }" ;
"tr { background-color : White }" ;
- "td.typefieldcomment { background-color : #FFFFFF ; font-size: smaller ;}" ;
- "pre { margin-bottom: 4px }" ;
+ "td.typefieldcomment { background-color : #FFFFFF ; font-size: smaller ;}" ;
+ "pre { margin-bottom: 4px }" ;
- "div.sig_block {margin-left: 2em}" ;
+ "div.sig_block {margin-left: 2em}" ;
]
(** The style file for all pages. *)
when printing a module type. *)
val mutable known_modules_names = StringSet.empty
+ method index_prefix =
+ if !Odoc_args.out_file = Odoc_messages.default_out_file then
+ "index"
+ else
+ Filename.basename !Odoc_args.out_file
+
(** The main file. *)
- method index = "index.html"
+ method index =
+ let p = self#index_prefix in
+ Printf.sprintf "%s.html" p
+
(** The file for the index of values. *)
- method index_values = "index_values.html"
+ method index_values = Printf.sprintf "%s_values.html" self#index_prefix
(** The file for the index of types. *)
- method index_types = "index_types.html"
+ method index_types = Printf.sprintf "%s_types.html" self#index_prefix
(** The file for the index of exceptions. *)
- method index_exceptions = "index_exceptions.html"
+ method index_exceptions = Printf.sprintf "%s_exceptions.html" self#index_prefix
(** The file for the index of attributes. *)
- method index_attributes = "index_attributes.html"
+ method index_attributes = Printf.sprintf "%s_attributes.html" self#index_prefix
(** The file for the index of methods. *)
- method index_methods = "index_methods.html"
+ method index_methods = Printf.sprintf "%s_methods.html" self#index_prefix
(** The file for the index of classes. *)
- method index_classes = "index_classes.html"
+ method index_classes = Printf.sprintf "%s_classes.html" self#index_prefix
(** The file for the index of class types. *)
- method index_class_types = "index_class_types.html"
+ method index_class_types = Printf.sprintf "%s_class_types.html" self#index_prefix
(** The file for the index of modules. *)
- method index_modules = "index_modules.html"
+ method index_modules = Printf.sprintf "%s_modules.html" self#index_prefix
(** The file for the index of module types. *)
- method index_module_types = "index_module_types.html"
+ method index_module_types = Printf.sprintf "%s_module_types.html" self#index_prefix
(** The list of attributes. Filled in the [generate] method. *)
let default_style = String.concat "\n" default_style_options in
(
try
- let file = Filename.concat !Args.target_dir style_file in
- if Sys.file_exists file then
- Odoc_info.verbose (Odoc_messages.file_exists_dont_generate file)
- else
- (
- let chanout = open_out file in
- output_string chanout default_style ;
- flush chanout ;
- close_out chanout;
- Odoc_info.verbose (Odoc_messages.file_generated file)
- )
+ let file = Filename.concat !Args.target_dir style_file in
+ if Sys.file_exists file then
+ Odoc_info.verbose (Odoc_messages.file_exists_dont_generate file)
+ else
+ (
+ let chanout = open_out file in
+ output_string chanout default_style ;
+ flush chanout ;
+ close_out chanout;
+ Odoc_info.verbose (Odoc_messages.file_generated file)
+ )
with
Sys_error s ->
prerr_endline s ;
match l with
[] -> ()
| _ ->
- bp b "<link title=\"%s\" rel=Appendix href=\"%s\">\n" m url
+ bp b "<link title=\"%s\" rel=Appendix href=\"%s\">\n" m url
in
bs b "<head>\n";
- bs b style;
+ bs b style;
+ bs b character_encoding ;
bs b "<link rel=\"Start\" href=\"";
- bs b self#index;
- bs b "\">\n" ;
+ bs b self#index;
+ bs b "\">\n" ;
(
match nav with
None -> ()
None -> ()
| Some name ->
bp b "<link rel=\"previous\" href=\"%s\">\n"
- (fst (Naming.html_files name));
+ (fst (Naming.html_files name));
);
(match post_opt with
None -> ()
| Some name ->
bp b "<link rel=\"next\" href=\"%s\">\n"
- (fst (Naming.html_files name));
+ (fst (Naming.html_files name));
);
(
let father = Name.father name in
link_if_not_empty self#list_class_types Odoc_messages.index_of_class_types self#index_class_types;
link_if_not_empty self#list_modules Odoc_messages.index_of_modules self#index_modules;
link_if_not_empty self#list_module_types Odoc_messages.index_of_module_types self#index_module_types;
- let print_one m =
- let html_file = fst (Naming.html_files m.m_name) in
+ let print_one m =
+ let html_file = fst (Naming.html_files m.m_name) in
bp b "<link title=\"%s\" rel=\"Chapter\" href=\"%s\">"
- m.m_name html_file
+ m.m_name html_file
in
- print_concat b "\n" print_one module_list;
+ print_concat b "\n" print_one module_list;
self#html_sections_links b comments;
bs b "<title>";
- bs b t ;
- bs b "</title>\n</head>\n"
+ bs b t ;
+ bs b "</title>\n</head>\n"
in
header <- f
let s = Odoc_info.string_of_text t in
let label = self#create_title_label (n,lopt,t) in
bp b "<link title=\"%s\" rel=\"%s\" href=\"#%s\">\n" s s_rel label
- )
+ )
titles
in
print_lines "Section" section_titles ;
None -> ()
| Some name ->
bp b "<a href=\"%s\">%s</a>\n"
- (fst (Naming.html_files name))
- Odoc_messages.previous
+ (fst (Naming.html_files name))
+ Odoc_messages.previous
);
bs b " ";
let father = Name.father name in
None -> ()
| Some name ->
bp b "<a href=\"%s\">%s</a>\n"
- (fst (Naming.html_files name))
- Odoc_messages.next
+ (fst (Naming.html_files name))
+ Odoc_messages.next
);
bs b "</div>\n"
method private output_code in_title file code =
try
let chanout = open_out file in
- let b = new_buf () in
+ let b = new_buf () in
bs b "<html>";
- self#print_header b (self#inner_title in_title);
- bs b"<body>\n";
+ self#print_header b (self#inner_title in_title);
+ bs b"<body>\n";
self#html_of_code b code;
bs b "</body></html>";
- Buffer.output_buffer chanout b;
+ Buffer.output_buffer chanout b;
close_out chanout
with
Sys_error s ->
method create_fully_qualified_module_idents_links m_name s =
let f str_t =
let match_s = Str.matched_string str_t in
- let rel = Name.get_relative m_name match_s in
- let s_final = Odoc_info.apply_if_equal
+ 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
(** Print html code to display the given module kind. *)
method html_of_module_kind b father ?modu kind =
match kind with
- Module_struct eles ->
- self#html_of_text b [Code "sig"];
- (
- match modu with
- None ->
- bs b "<div class=\"sig_block\">";
- List.iter (self#html_of_module_element b father) eles;
- bs b "</div>"
- | Some m ->
- let (html_file, _) = Naming.html_files m.m_name in
- bp b " <a href=\"%s\">..</a> " html_file
- );
- self#html_of_text b [Code "end"]
+ Module_struct eles ->
+ self#html_of_text b [Code "sig"];
+ (
+ match modu with
+ None ->
+
bs b "<div class=\"sig_block\">";
+ List.iter (self#html_of_module_element b father) eles;
+ bs b "</div>"
+ | Some m ->
+ let (html_file, _) = Naming.html_files m.m_name in
+
bp b " <a href=\"%s\">..</a> " html_file
+ );
+ self#html_of_text b [Code "end"]
| Module_alias a ->
- bs b "<code class=\"type\">";
- bs b (self#create_fully_qualified_module_idents_links father a.ma_name);
- bs b "</code>"
+ bs b "<code class=\"type\">";
+ bs b (self#create_fully_qualified_module_idents_links father a.ma_name);
+ bs b "</code>"
| Module_functor (p, k) ->
- bs b "<div class=\"sig_block\">";
- self#html_of_module_parameter b father p;
- self#html_of_module_kind b father ?modu k;
- bs b "</div>"
+
bs b "<div class=\"sig_block\">";
+ self#html_of_module_parameter b father p;
+ self#html_of_module_kind b father ?modu k;
+ bs b "</div>"
| Module_apply (k1, k2) ->
- (* TODO: l'application n'est pas correcte dans un .mli.
- Que faire ? -> afficher le module_type du typedtree *)
- self#html_of_module_kind b father k1;
- self#html_of_text b [Code "("];
- self#html_of_module_kind b father k2;
- self#html_of_text b [Code ")"]
+ (* TODO: l'application n'est pas correcte dans un .mli.
+ Que faire ? -> afficher le module_type du typedtree *)
+ self#html_of_module_kind b father k1;
+ self#html_of_text b [Code "("];
+ self#html_of_module_kind b father k2;
+ self#html_of_text b [Code ")"]
| Module_with (k, s) ->
- (* TODO: à modifier quand Module_with sera plus détaillé *)
- self#html_of_module_type_kind b father ?modu k;
- bs b "<code class=\"type\"> ";
- bs b (self#create_fully_qualified_module_idents_links father s);
- bs b "</code>"
+ (* TODO: à modifier quand Module_with sera plus détaillé *)
+ self#html_of_module_type_kind b father ?modu k;
+ bs b "<code class=\"type\"> ";
+ bs b (self#create_fully_qualified_module_idents_links father s);
+ bs b "</code>"
| Module_constraint (k, tk) ->
- (* TODO: on affiche quoi ? *)
- self#html_of_module_kind b father ?modu k
+ (* TODO: on affiche quoi ? *)
+ self#html_of_module_kind b father ?modu k
method html_of_module_parameter b father p =
self#html_of_text b
- [
- Code "functor (";
- Code p.mp_name ;
- Code " : ";
- ] ;
+ [
+ Code "functor (";
+ Code p.mp_name ;
+ Code " : ";
+ ] ;
self#html_of_module_type_kind b father p.mp_kind;
self#html_of_text b [ Code ") -> "]
(** Print html code to display the given module type kind. *)
method html_of_module_type_kind b father ?modu ?mt kind =
match kind with
- Module_type_struct eles ->
- self#html_of_text b [Code "sig"];
- (
- match mt with
- None ->
- (
- match modu with
- None ->
- bs b "<div class=\"sig_block\">";
- List.iter (self#html_of_module_element b father) eles;
- bs b "</div>"
- | Some m ->
- let (html_file, _) = Naming.html_files m.m_name in
- bp b " <a href=\"%s\">..</a> " html_file
- )
- | Some mt ->
- let (html_file, _) = Naming.html_files mt.mt_name in
- bp b " <a href=\"%s\">..</a> " html_file
- );
- self#html_of_text b [Code "end"]
+ Module_type_struct eles ->
+ self#html_of_text b [Code "sig"];
+ (
+ match mt with
+ None ->
+ (
+ match modu with
+ None ->
+
bs b "<div class=\"sig_block\">";
+ List.iter (self#html_of_module_element b father) eles;
+ bs b "</div>"
+ | Some m ->
+ let (html_file, _) = Naming.html_files m.m_name in
+
bp b " <a href=\"%s\">..</a> " html_file
+ )
+ | Some mt ->
+ let (html_file, _) = Naming.html_files mt.mt_name in
+
bp b " <a href=\"%s\">..</a> " html_file
+ );
+ self#html_of_text b [Code "end"]
| Module_type_functor (p, k) ->
- self#html_of_module_parameter b father p;
- self#html_of_module_type_kind b father ?modu ?mt k
+ self#html_of_module_parameter b father p;
+ self#html_of_module_type_kind b father ?modu ?mt k
| Module_type_alias a ->
- bs b "<code class=\"type\">";
- bs b (self#create_fully_qualified_module_idents_links father a.mta_name);
- bs b "</code>"
+ bs b "<code class=\"type\">";
+ bs b (self#create_fully_qualified_module_idents_links father a.mta_name);
+ bs b "</code>"
| Module_type_with (k, s) ->
- self#html_of_module_type_kind b father ?modu ?mt k;
- bs b "<code class=\"type\"> ";
- bs b (self#create_fully_qualified_module_idents_links father s);
- bs b "</code>"
+ self#html_of_module_type_kind b father ?modu ?mt k;
+ bs b "<code class=\"type\"> ";
+ bs b (self#create_fully_qualified_module_idents_links father s);
+ bs b "</code>"
(** Print html code to display the type of a module parameter.. *)
method html_of_module_parameter_type b m_name p =
bp b "<a name=\"%s\"></a>" (Naming.value_target v);
(
match v.val_code with
- None -> bs b (Name.simple v.val_name)
+ None -> bs b (self#escape (Name.simple v.val_name))
| Some c ->
let file = Naming.file_code_value_complete_target v in
self#output_code v.val_name (Filename.concat !Args.target_dir file) c;
- bp b "<a href=\"%s\">%s</a>" file (Name.simple v.val_name)
+ bp b "<a href=\"%s\">%s</a>" file (self#escape (Name.simple v.val_name))
);
bs b " : ";
self#html_of_type_expr b (Name.father v.val_name) v.val_type;
bs b " ";
(* html mark *)
bp b "<a name=\"%s\"></a>%s"
- (Naming.exception_target e)
- (Name.simple e.ex_name);
+ (Naming.exception_target e)
+ (Name.simple e.ex_name);
(
match e.ex_args with
[] -> ()
| _ ->
bs b (" "^(self#keyword "of")^" ");
self#html_of_type_expr_list
- ~par: false b (Name.father e.ex_name) " * " e.ex_args
+ ~par: false b (Name.father e.ex_name) " * " e.ex_args
);
(
match e.ex_alias with
None -> ()
| Some ea ->
- bs b " = ";
+ bs b " = ";
(
match ea.ea_ex with
None -> bs b ea.ea_name
| Some e ->
- bp b "<a href=\"%s\">%s</a>" (Naming.complete_exception_target e) e.ex_name
+
bp b "<a href=\"%s\">%s</a>" (Naming.complete_exception_target e) e.ex_name
)
);
bs b "</pre>\n";
Odoc_info.reset_type_names ();
let father = Name.father t.ty_name in
bs b
- (match t.ty_manifest, t.ty_kind with
- None, Type_abstract -> "<pre>"
- | None, Type_variant _
- | None, Type_record _ -> "<br><code>"
- | Some _, Type_abstract -> "<pre>"
- | Some _, Type_variant _
- | Some _, Type_record _ -> "<pre>"
- );
+ (match t.ty_manifest, t.ty_kind with
+
None, Type_abstract -> "<pre>"
+ | None, Type_variant _
+ | None, Type_record _ -> "<br><code>"
+
| Some _, Type_abstract -> "<pre>"
+ | Some _, Type_variant _
+
| Some _, Type_record _ -> "<pre>"
+ );
bs b ((self#keyword "type")^" ");
(* html mark *)
bp b "<a name=\"%s\"></a>" (Naming.type_target t);
bs b ((Name.simple t.ty_name)^" ");
(
match t.ty_manifest with
- None -> ()
+ None -> ()
| Some typ ->
- bs b "= ";
- self#html_of_type_expr b father typ;
- bs b " "
+ bs b "= ";
+ self#html_of_type_expr b father typ;
+ bs b " "
);
(match t.ty_kind with
Type_abstract -> bs b "</pre>"
| Type_variant (l, priv) ->
bs b "= ";
- if priv then bs b "private" ;
- bs b
- (
- match t.ty_manifest with
- None -> "</code>"
- | Some _ -> "</pre>"
- );
+ if priv then bs b "private" ;
+ bs b
+ (
+ match t.ty_manifest with
+ None -> "</code>"
+ | Some _ -> "</pre>"
+ );
bs b "<table class=\"typetable\">\n";
- let print_one constr =
+ let print_one constr =
bs b "<tr>\n<td align=\"left\" valign=\"top\" >\n";
bs b "<code>";
- bs b (self#keyword "|");
+ bs b (self#keyword "|");
bs b "</code></td>\n<td align=\"left\" valign=\"top\" >\n";
bs b "<code>";
- bs b (self#constructor constr.vc_name);
+ bs b (self#constructor constr.vc_name);
(
- match constr.vc_args with
+ match constr.vc_args with
[] -> ()
| l ->
- bs b (" " ^ (self#keyword "of") ^ " ");
- self#html_of_type_expr_list ~par: false b father " * " l;
+ bs b (" " ^ (self#keyword "of") ^ " ");
+ self#html_of_type_expr_list ~par: false b father " * " l;
);
bs b "</code></td>\n";
(
- match constr.vc_text with
+ match constr.vc_text with
None -> ()
| Some t ->
- bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >";
- bs b "<code>";
- bs b "(*";
- bs b "</code></td>";
- bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >";
- self#html_of_text b t;
- bs b "</td>";
- bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"bottom\" >";
- bs b "<code>";
- bs b "*)";
- bs b "</code></td>";
+ bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >";
+ bs b "<code>";
+ bs b "(*";
+ bs b "</code></td>";
+ bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >";
+ self#html_of_text b t;
+ bs b "</td>";
+ bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"bottom\" >";
+ bs b "<code>";
+ bs b "*)";
+ bs b "</code></td>";
);
bs b "\n</tr>"
- in
- print_concat b "\n" print_one l;
+ in
+ print_concat b "\n" print_one l;
bs b "</table>\n"
| Type_record (l, priv) ->
bs b "= ";
- if priv then bs b "private " ;
- bs b "{";
- bs b
- (
- match t.ty_manifest with
- None -> "</code>"
- | Some _ -> "</pre>"
- );
+ if priv then bs b "private " ;
+ bs b "{";
+ bs b
+ (
+ match t.ty_manifest with
+ None -> "</code>"
+ | Some _ -> "</pre>"
+ );
bs b "<table class=\"typetable\">\n" ;
- let print_one r =
+ let print_one r =
bs b "<tr>\n<td align=\"left\" valign=\"top\" >\n";
bs b "<code> </code>";
bs b "</td>\n<td align=\"left\" valign=\"top\" >\n";
bs b "<code>";
- if r.rf_mutable then bs b (self#keyword "mutable ") ;
+ if r.rf_mutable then bs b (self#keyword "mutable ") ;
bs b (r.rf_name ^ " : ") ;
- self#html_of_type_expr b father r.rf_type;
+ self#html_of_type_expr b father r.rf_type;
bs b ";</code></td>\n";
(
- match r.rf_text with
+ match r.rf_text with
None -> ()
| Some t ->
bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >";
bs b "(*";
bs b "</code></td>";
bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >";
- self#html_of_text b t;
+ self#html_of_text b t;
bs b "</td><td class=\"typefieldcomment\" align=\"left\" valign=\"bottom\" >";
bs b "<code>*)</code></td>";
- );
+ );
bs b "\n</tr>"
- in
- print_concat b "\n" print_one l;
+ in
+ print_concat b "\n" print_one l;
bs b "</table>\n}\n"
);
bs b "\n";
bp b "<a name=\"%s\"></a>" (Naming.attribute_target a);
(
if a.att_mutable then
- bs b ((self#keyword Odoc_messages.mutab)^ " ")
+ bs b ((self#keyword Odoc_messages.mutab)^ " ")
else
- ()
+ ()
);
(
match a.att_value.val_code with
(
if !Args.with_parameter_list then
self#html_of_parameter_list b
- module_name m.met_value.val_parameters
+ module_name m.met_value.val_parameters
else
self#html_of_described_parameter_list b
- module_name m.met_value.val_parameters
+ module_name m.met_value.val_parameters
)
(** Print html code for the description of a function parameter. *)
| l ->
(* A list of names, we display those with a description. *)
let l2 = List.filter
- (fun n -> (Parameter.desc_by_name p n) <> None)
- l
- in
- let print_one n =
- match Parameter.desc_by_name p n with
+ (fun n -> (Parameter.desc_by_name p n) <> None)
+ l
+ in
+ let print_one n =
+ match Parameter.desc_by_name p n with
None -> ()
| Some t ->
- bs b "<code>";
- bs b n;
- bs b "</code> : ";
- self#html_of_text b t
- in
- print_concat b "<br>\n" print_one l2
+ bs b "<code>";
+ bs b n;
+ bs b "</code> : ";
+ self#html_of_text b t
+ in
+ print_concat b "<br>\n" print_one l2
(** Print html code for a list of parameters. *)
method html_of_parameter_list b m_name l =
bs b "<div class=\"param_info\">";
bs b "<table border=\"0\" cellpadding=\"3\" width=\"100%\">\n";
bs b "<tr>\n<td align=\"left\" valign=\"top\" width=\"1%\">";
- bs b "<b>";
- bs b Odoc_messages.parameters;
- bs b ": </b></td>\n" ;
+ bs b "<b>";
+ bs b Odoc_messages.parameters;
+ bs b ": </b></td>\n" ;
bs b "<td>\n<table class=\"paramstable\">\n";
- let print_one p =
+ let print_one p =
bs b "<tr>\n<td align=\"center\" valign=\"top\" width=\"15%\" class=\"code\">\n";
bs b
- (
- match Parameter.complete_name p with
- "" -> "?"
+ (
+ match Parameter.complete_name p with
+ "" -> "?"
| s -> s
);
- bs b "</td>\n<td align=\"center\" valign=\"top\">:</td>\n";
+ bs b "</td>\n<td align=\"center\" valign=\"top\">:</td>\n";
bs b "<td>";
- self#html_of_type_expr b m_name (Parameter.typ p);
- bs b "<br>\n";
+ self#html_of_type_expr b m_name (Parameter.typ p);
+ bs b "<br>\n";
self#html_of_parameter_description b p;
- bs b "\n</tr>\n";
- in
+ bs b "\n</tr>\n";
+ in
List.iter print_one l;
bs b "</table>\n</td>\n</tr>\n</table></div>\n"
in
let f p =
bs b "<div class=\"param_info\"><code class=\"code\">";
- bs b (Parameter.complete_name p);
- bs b "</code> : " ;
+ bs b (Parameter.complete_name p);
+ bs b "</code> : " ;
self#html_of_parameter_description b p;
- bs b "</div>\n"
+ bs b "</div>\n"
in
List.iter f l2
bs b "<table border=\"0\" cellpadding=\"3\" width=\"100%\">\n";
bs b "<tr>\n";
bs b "<td align=\"left\" valign=\"top\" width=\"1%%\"><b>";
- bs b Odoc_messages.parameters ;
- bs b ": </b></td>\n<td>\n";
+ bs b Odoc_messages.parameters ;
+ bs b ": </b></td>\n<td>\n";
bs b "<table class=\"paramstable\">\n";
- List.iter
+ List.iter
(fun (p, desc_opt) ->
bs b "<tr>\n";
bs b "<td align=\"center\" valign=\"top\" width=\"15%\">\n<code>" ;
- bs b p.mp_name;
+ bs b p.mp_name;
bs b "</code></td>\n" ;
bs b "<td align=\"center\" valign=\"top\">:</td>\n";
bs b "<td>" ;
- self#html_of_module_parameter_type b m_name p;
- bs b "\n";
+ self#html_of_module_parameter_type b m_name p;
+ bs b "\n";
(
- match desc_opt with
+ match desc_opt with
None -> ()
| Some t ->
- bs b "<br>";
- self#html_of_text b t;
- bs b "\n</tr>\n" ;
+ bs b "<br>";
+ self#html_of_text b t;
+ bs b "\n</tr>\n" ;
)
- )
+ )
l;
bs b "</table>\n</td>\n</tr>\n</table>\n"
bs b "</pre>";
if info then
(
- if complete then
- self#html_of_info ~indent: false
- else
- self#html_of_info_first_sentence
- ) b m.m_info
+ if complete then
+ self#html_of_info ~indent: false
+ else
+ self#html_of_info_first_sentence
+ ) b m.m_info
else
()
(match mt.mt_kind with
None -> ()
| Some k ->
- bs b " = ";
- self#html_of_module_type_kind b father ~mt k
+ bs b " = ";
+ self#html_of_module_type_kind b father ~mt k
);
bs b "</pre>";
if info then
(
- if complete then
- self#html_of_info ~indent: false
- else
- self#html_of_info_first_sentence
- ) b mt.mt_info
+ if complete then
+ self#html_of_info ~indent: false
+ else
+ self#html_of_info_first_sentence
+ ) b mt.mt_info
else
()
method html_of_class_kind b father ?cl kind =
match kind with
Class_structure (inh, eles) ->
- self#html_of_text b [Code "object"];
- (
- match cl with
- None ->
- bs b "\n";
- (
- match inh with
- [] -> ()
- | _ ->
- self#generate_inheritance_info b inh
- );
- List.iter (self#html_of_class_element b) eles;
- | Some cl ->
- let (html_file, _) = Naming.html_files cl.cl_name in
- bp b " <a href=\"%s\">..</a> " html_file
- );
- self#html_of_text b [Code "end"]
+ self#html_of_text b [Code "object"];
+ (
+ match cl with
+ None ->
+ bs b "\n";
+ (
+ match inh with
+ [] -> ()
+ | _ ->
+ self#generate_inheritance_info b inh
+ );
+ List.iter (self#html_of_class_element b) eles;
+ | Some cl ->
+ let (html_file, _) = Naming.html_files cl.cl_name in
+
bp b " <a href=\"%s\">..</a> " html_file
+ );
+ self#html_of_text b [Code "end"]
| Class_apply capp ->
- (* TODO: afficher le type final à partir du typedtree *)
- self#html_of_text b [Raw "class application not handled yet"]
+ (* TODO: afficher le type final à partir du typedtree *)
+ self#html_of_text b [Raw "class application not handled yet"]
| Class_constr cco ->
- (
+ (
match cco.cco_type_parameters with
[] -> ()
| l ->
self#html_of_class_type_param_expr_list b father l;
- bs b " "
- );
- bs b "<code class=\"type\">";
- bs b (self#create_fully_qualified_idents_links father cco.cco_name);
- bs b "</code>"
+ bs b " "
+ );
+ bs b "<code class=\"type\">";
+ bs b (self#create_fully_qualified_idents_links father cco.cco_name);
+ bs b "</code>"
| Class_constraint (ck, ctk) ->
self#html_of_text b [Code "( "] ;
match cta.cta_type_parameters with
[] -> ()
| l ->
- self#html_of_class_type_param_expr_list b father l;
- bs b " "
+ self#html_of_class_type_param_expr_list b father l;
+ bs b " "
);
bs b "<code class=\"type\">";
- bs b (self#create_fully_qualified_idents_links father cta.cta_name);
- bs b "</code>"
+ bs b (self#create_fully_qualified_idents_links father cta.cta_name);
+ bs b "</code>"
| Class_signature (inh, eles) ->
- self#html_of_text b [Code "object"];
- (
- match ct with
- None ->
- bs b "\n";
- (
- match inh with
- [] -> ()
- | _ -> self#generate_inheritance_info b inh
- );
- List.iter (self#html_of_class_element b) eles
- | Some ct ->
- let (html_file, _) = Naming.html_files ct.clt_name in
- bp b " <a href=\"%s\">..</a> " html_file
- );
- self#html_of_text b [Code "end"]
+ self#html_of_text b [Code "object"];
+ (
+ match ct with
+ None ->
+ bs b "\n";
+ (
+ match inh with
+ [] -> ()
+ | _ -> self#generate_inheritance_info b inh
+ );
+ List.iter (self#html_of_class_element b) eles
+ | Some ct ->
+ let (html_file, _) = Naming.html_files ct.clt_name in
+
bp b " <a href=\"%s\">..</a> " html_file
+ );
+ self#html_of_text b [Code "end"]
(** Print html code for a class. *)
method html_of_class b ?(complete=true) ?(with_link=true) c =
ty_info = None ; ty_parameters = [] ;
ty_kind = Type_abstract ; ty_manifest = None ;
ty_loc = Odoc_info.dummy_loc ;
- ty_code = None ;
- }
- );
+ ty_code = None ;
+ }
+ );
print_DEBUG "html#html_of_class : virtual or not" ;
if c.cl_virtual then bs b ((self#keyword "virtual")^" ");
(
[] -> ()
| l ->
self#html_of_class_type_param_expr_list b father l;
- bs b " "
+ bs b " "
);
print_DEBUG "html#html_of_class : with link or not" ;
(
print_DEBUG "html#html_of_class : info" ;
(
if complete then
- self#html_of_info ~indent: false
+ self#html_of_info ~indent: false
else
- self#html_of_info_first_sentence
+ self#html_of_info_first_sentence
) b c.cl_info
(** Print html code for a class type. *)
ty_info = None ; ty_parameters = [] ;
ty_kind = Type_abstract ; ty_manifest = None ;
ty_loc = Odoc_info.dummy_loc ;
- ty_code = None ;
- }
- );
+ ty_code = None ;
+ }
+ );
if ct.clt_virtual then bs b ((self#keyword "virtual")^" ");
(
match ct.clt_type_parameters with
[] -> ()
| l ->
- self#html_of_class_type_param_expr_list b father l;
- bs b " "
+ self#html_of_class_type_param_expr_list b father l;
+ bs b " "
);
if with_link then
bs b "</pre>";
(
if complete then
- self#html_of_info ~indent: false
+ self#html_of_info ~indent: false
else
- self#html_of_info_first_sentence
+ self#html_of_info_first_sentence
) b ct.clt_info
(** Return html code to represent a dag, represented as in Odoc_dag2html. *)
fun elements name info target title simple_file ->
try
let chanout = open_out (Filename.concat !Args.target_dir simple_file) in
- let b = new_buf () in
- bs b "<html>\n";
+ let b = new_buf () in
+ bs b "<html>\n";
self#print_header b (self#inner_title title);
- bs b "<body>\n<center><h1>";
- bs b title;
- bs b "</h1></center>\n" ;
+ bs b "<body>\n<center><h1>";
+ bs b title;
+ bs b "</h1></center>\n" ;
let sorted_elements = List.sort
(fun e1 e2 -> compare (Name.simple (name e1)) (Name.simple (name e2)))
let f_ele e =
let simple_name = Name.simple (name e) in
let father_name = Name.father (name e) in
- bp b "<tr><td><a href=\"%s\">%s</a> " (target e) simple_name;
+ bp b "<tr><td><a href=\"%s\">%s</a> " (target e) (self#escape simple_name);
if simple_name <> father_name && father_name <> "" then
bp b "[<a href=\"%s\">%s</a>]" (fst (Naming.html_files father_name)) father_name;
bs b "</td>\n<td>";
- self#html_of_info_first_sentence b (info e);
- bs b "</td></tr>\n";
+ self#html_of_info_first_sentence b (info e);
+ bs b "</td></tr>\n";
in
let f_group l =
match l with
| _ -> ""
in
bs b "<tr><td align=\"left\"><br>";
- bs b s ;
- bs b "</td></tr>\n" ;
+ bs b s ;
+ bs b "</td></tr>\n" ;
List.iter f_ele l
in
bs b "<table>\n";
List.iter f_group groups ;
bs b "</table><br>\n" ;
bs b "</body>\n</html>";
- Buffer.output_buffer chanout b;
+ Buffer.output_buffer chanout b;
close_out chanout
with
Sys_error s ->
let type_file = Naming.file_type_class_complete_target cl.cl_name in
try
let chanout = open_out (Filename.concat !Args.target_dir html_file) in
- let b = new_buf () in
+ let b = new_buf () in
let pre_name = opt (fun c -> c.cl_name) pre in
let post_name = opt (fun c -> c.cl_name) post in
- bs b "<html>\n";
+ bs b doctype ;
+ bs b "<html>\n";
self#print_header b
~nav: (Some (pre_name, post_name, cl.cl_name))
~comments: (Class.class_comments cl)
(self#inner_title cl.cl_name);
- bs b "<body>\n";
+ bs b "<body>\n";
self#print_navbar b pre_name post_name cl.cl_name;
bs b "<center><h1>";
- bs b (Odoc_messages.clas^" ");
+ bs b (Odoc_messages.clas^" ");
if cl.cl_virtual then bs b "virtual " ;
bp b "<a href=\"%s\">%s</a>" type_file cl.cl_name;
bs b "</h1></center>\n<br>\n";
self#html_of_class b ~with_link: false cl;
(* parameters *)
self#html_of_described_parameter_list b
- (Name.father cl.cl_name) cl.cl_parameters;
+ (Name.father cl.cl_name) cl.cl_parameters;
(* class inheritance *)
- self#generate_class_inheritance_info b cl;
+ self#generate_class_inheritance_info b cl;
(* a horizontal line *)
bs b "<hr width=\"100%\">\n";
(* the various elements *)
List.iter (self#html_of_class_element b)
(Class.class_elements ~trans:false cl);
bs b "</body></html>";
- Buffer.output_buffer chanout b;
+ Buffer.output_buffer chanout b;
close_out chanout;
(* generate the file with the complete class type *)
let type_file = Naming.file_type_class_complete_target clt.clt_name in
try
let chanout = open_out (Filename.concat !Args.target_dir html_file) in
- let b = new_buf () in
+ let b = new_buf () in
let pre_name = opt (fun ct -> ct.clt_name) pre in
let post_name = opt (fun ct -> ct.clt_name) post in
- bs b "<html>\n";
+ bs b doctype ;
+ bs b "<html>\n";
self#print_header b
~nav: (Some (pre_name, post_name, clt.clt_name))
~comments: (Class.class_type_comments clt)
bs b "<body>\n";
self#print_navbar b pre_name post_name clt.clt_name;
bs b "<center><h1>";
- bs b (Odoc_messages.class_type^" ");
+ bs b (Odoc_messages.class_type^" ");
if clt.clt_virtual then bs b "virtual ";
bp b "<a href=\"%s\">%s</a>" type_file clt.clt_name;
bs b "</h1></center>\n<br>\n";
List.iter (self#html_of_class_element b)
(Class.class_type_elements ~trans: false clt);
bs b "</body></html>";
- Buffer.output_buffer chanout b;
+ Buffer.output_buffer chanout b;
close_out chanout;
(* generate the file with the complete class type *)
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 !Args.target_dir html_file) in
- let b = new_buf () in
+ let b = new_buf () in
let pre_name = opt (fun mt -> mt.mt_name) pre in
let post_name = opt (fun mt -> mt.mt_name) post in
- bs b "<html>\n";
+ bs b doctype ;
+ bs b "<html>\n";
self#print_header b
~nav: (Some (pre_name, post_name, mt.mt_name))
~comments: (Module.module_type_comments mt)
bs b "<body>\n";
self#print_navbar b pre_name post_name mt.mt_name;
bp b "<center><h1>";
- bs b (Odoc_messages.module_type^" ");
+ bs b (Odoc_messages.module_type^" ");
(
- match mt.mt_type with
+ match mt.mt_type with
Some _ -> bp b "<a href=\"%s\">%s</a>" type_file mt.mt_name
| None-> bs b mt.mt_name
);
(* parameters for functors *)
self#html_of_module_parameter_list b
- (Name.father mt.mt_name)
- (Module.module_type_parameters mt);
+ (Name.father mt.mt_name)
+ (Module.module_type_parameters mt);
(* a horizontal line *)
bs b "<hr width=\"100%\">\n";
(* module elements *)
List.iter
- (self#html_of_module_element b (Name.father mt.mt_name))
+ (self#html_of_module_element b (Name.father mt.mt_name))
(Module.module_type_elements mt);
bs b "</body></html>";
- Buffer.output_buffer chanout b;
+ Buffer.output_buffer chanout b;
close_out chanout;
(* generate html files for submodules *)
match mt.mt_type with
None -> ()
| Some mty ->
- self#output_module_type
+ self#output_module_type
mt.mt_name
(Filename.concat !Args.target_dir type_file)
mty
let type_file = Naming.file_type_module_complete_target modu.m_name in
let code_file = Naming.file_code_module_complete_target modu.m_name in
let chanout = open_out (Filename.concat !Args.target_dir html_file) in
- let b = new_buf () in
+ let b = new_buf () in
let pre_name = opt (fun m -> m.m_name) pre in
let post_name = opt (fun m -> m.m_name) post in
- bs b "<html>\n";
+ bs b doctype ;
+ bs b "<html>\n";
self#print_header b
~nav: (Some (pre_name, post_name, modu.m_name))
~comments: (Module.module_comments modu)
(self#inner_title modu.m_name);
- bs b "<body>\n" ;
+ bs b "<body>\n" ;
self#print_navbar b pre_name post_name modu.m_name ;
bs b "<center><h1>";
- bs b
+ if modu.m_text_only then
+ bs b modu.m_name
+ else
(
- if Module.module_is_functor modu then
- Odoc_messages.functo
- else
- Odoc_messages.modul
+ bs b
+ (
+ if Module.module_is_functor modu then
+ Odoc_messages.functo
+ else
+ Odoc_messages.modul
+ );
+ bp b " <a href=\"%s\">%s</a>" type_file modu.m_name;
+ (
+ match modu.m_code with
+ None -> ()
+ | Some _ -> bp b " (<a href=\"%s\">.ml</a>)" code_file
+ )
);
- bp b " <a href=\"%s\">%s</a>" type_file modu.m_name;
- (
- match modu.m_code with
- None -> ()
- | Some _ -> bp b " (<a href=\"%s\">.ml</a>)" code_file
- );
bs b "</h1></center>\n<br>\n";
- self#html_of_module b ~with_link: false modu;
+ if not modu.m_text_only then self#html_of_module b ~with_link: false modu;
(* parameters for functors *)
self#html_of_module_parameter_list b
- (Name.father modu.m_name)
- (Module.module_parameters modu);
+ (Name.father modu.m_name)
+ (Module.module_parameters modu);
(* a horizontal line *)
- bs b "<hr width=\"100%\">\n";
+ if not modu.m_text_only then bs b "<hr width=\"100%\">\n";
(* module elements *)
List.iter
(Module.module_elements modu);
bs b "</body></html>";
- Buffer.output_buffer chanout b;
+ Buffer.output_buffer chanout b;
close_out chanout;
(* generate html files for submodules *)
(Filename.concat !Args.target_dir type_file)
modu.m_type;
- match modu.m_code with
- None -> ()
- | Some code ->
- self#output_code
- modu.m_name
- (Filename.concat !Args.target_dir code_file)
- code
+ match modu.m_code with
+ None -> ()
+ | Some code ->
+ self#output_code
+ modu.m_name
+ (Filename.concat !Args.target_dir code_file)
+ code
with
Sys_error s ->
raise (Failure s)
- (** Generate the [index.html] file corresponding to the given module list.
+ (** Generate the [<index_prefix>.html] file corresponding to the given module list.
@raise Failure if an error occurs.*)
method generate_index module_list =
try
let chanout = open_out (Filename.concat !Args.target_dir self#index) in
- let b = new_buf () in
+ let b = new_buf () in
let title = match !Args.title with None -> "" | Some t -> self#escape t in
- bs b "<html>\n";
+ bs b doctype ;
+ bs b "<html>\n";
self#print_header b self#title;
bs b "<body>\n";
bs b "<center><h1>";
- bs b title;
- bs b "</h1></center>\n" ;
- let info = Odoc_info.apply_opt
- Odoc_info.info_of_comment_file !Odoc_info.Args.intro_file
- in
- (
- match info with
- None ->
- self#html_of_Index_list b;
- bs b "<br/>";
- self#html_of_Module_list b
- (List.map (fun m -> m.m_name) module_list)
- | Some i -> self#html_of_info ~indent: false b info
- );
- Buffer.output_buffer chanout b;
+ bs b title;
+ bs b "</h1></center>\n" ;
+ let info = Odoc_info.apply_opt
+ Odoc_info.info_of_comment_file !Odoc_info.Args.intro_file
+ in
+ (
+ match info with
+ None ->
+ self#html_of_Index_list b;
+ bs b "<br/>";
+ self#html_of_Module_list b
+ (List.map (fun m -> m.m_name) module_list);
+ bs b "</body>\n</html>"
+ | Some i -> self#html_of_info ~indent: false b info
+ );
+ Buffer.output_buffer chanout b;
close_out chanout
with
Sys_error s ->
self#index_module_types
(** Generate all the html files from a module list. The main
- file is [index.html]. *)
+ file is [<index_prefix>.html]. *)
method generate module_list =
(* init the style *)
self#init_style ;
(* Get the names of all known types. *)
let types = Odoc_info.Search.types module_list in
known_types_names <-
- List.fold_left
- (fun acc t -> StringSet.add t.ty_name acc)
- known_types_names
- types ;
+ List.fold_left
+ (fun acc t -> StringSet.add t.ty_name acc)
+ known_types_names
+ types ;
(* Get the names of all class and class types. *)
let classes = Odoc_info.Search.classes module_list in
let class_types = Odoc_info.Search.class_types module_list in
known_classes_names <-
- List.fold_left
- (fun acc c -> StringSet.add c.cl_name acc)
- known_classes_names
- classes ;
+ List.fold_left
+ (fun acc c -> StringSet.add c.cl_name acc)
+ known_classes_names
+ classes ;
known_classes_names <-
- List.fold_left
- (fun acc ct -> StringSet.add ct.clt_name acc)
- known_classes_names
- class_types ;
+ List.fold_left
+ (fun acc ct -> StringSet.add ct.clt_name acc)
+ known_classes_names
+ class_types ;
(* Get the names of all known modules and module types. *)
let module_types = Odoc_info.Search.module_types module_list in
let modules = Odoc_info.Search.modules module_list in
known_modules_names <-
- List.fold_left
- (fun acc m -> StringSet.add m.m_name acc)
- known_modules_names
- modules ;
+ List.fold_left
+ (fun acc m -> StringSet.add m.m_name acc)
+ known_modules_names
+ modules ;
known_modules_names <-
- List.fold_left
- (fun acc mt -> StringSet.add mt.mt_name acc)
- known_modules_names
- module_types ;
+ List.fold_left
+ (fun acc mt -> StringSet.add mt.mt_name acc)
+ known_modules_names
+ module_types ;
(* generate html for each module *)
if not !Args.index_only then
self#generate_elements self#generate_for_module module_list ;
initializer
Odoc_ocamlhtml.html_of_comment :=
(fun s ->
- let b = new_buf () in
- self#html_of_text b (Odoc_text.Texter.text_of_string s);
- Buffer.contents b
- )
+ let b = new_buf () in
+ self#html_of_text b (Odoc_text.Texter.text_of_string s);
+ Buffer.contents b
+ )
end
-
-(* eof $Id: odoc_html.ml,v 1.58 2005/08/16 00:48:56 garrigue Exp $ *)
(* *)
(***********************************************************************)
-(* $Id: odoc_info.ml,v 1.22 2005/08/13 20:59:37 doligez Exp $ *)
+(* $Id: odoc_info.ml,v 1.22.2.1 2005/11/07 15:59:04 doligez Exp $ *)
(** Interface for analysing documented OCaml source files and to the collected information. *)
| Subscript of text
| Module_list of string list
| Index_list
+ | Custom of string * text
and text = text_element list
List.iter
(fun (sref, t) ->
p b "\n@see %s %s"
- (escape_arobas (f_see_ref sref))
- (escape_arobas (text_string_of_text t))
+ (escape_arobas (f_see_ref sref))
+ (escape_arobas (text_string_of_text t))
)
i.i_sees
);
None -> ()
| Some t ->
p b "\n@deprecated %s"
- (escape_arobas (text_string_of_text t))
+ (escape_arobas (text_string_of_text t))
);
List.iter
(fun (s, t) ->
p b "\n@param %s %s"
- (escape_arobas s)
- (escape_arobas (text_string_of_text t))
+ (escape_arobas s)
+ (escape_arobas (text_string_of_text t))
)
i.i_params;
List.iter
(fun (s, t) ->
p b "\n@raise %s %s"
- (escape_arobas s)
- (escape_arobas (text_string_of_text t))
+ (escape_arobas s)
+ (escape_arobas (text_string_of_text t))
)
i.i_raised_exceptions;
(
None -> ()
| Some t ->
p b "\n@return %s"
- (escape_arobas (text_string_of_text t))
+ (escape_arobas (text_string_of_text t))
);
List.iter
(fun (s, t) ->
p b "\n@%s %s" s
- (escape_arobas (text_string_of_text t))
+ (escape_arobas (text_string_of_text t))
)
i.i_custom;
Buffer.contents b
-let info_of_string s =
- let dummy =
- {
- i_desc = None ;
- i_authors = [] ;
- i_version = None ;
- i_sees = [] ;
- i_since = None ;
- i_deprecated = None ;
- i_params = [] ;
- i_raised_exceptions = [] ;
- i_return_value = None ;
- i_custom = [] ;
- }
- in
- let s2 = Printf.sprintf "(** %s *)" s in
- let (_, i_opt) = Odoc_comments.Basic_info_retriever.first_special "-" s2 in
- match i_opt with
- None -> dummy
- | Some i -> i
-
-let info_of_comment_file f =
- try
- let s = Odoc_misc.input_file_as_string f in
- info_of_string s
- with
- Sys_error s ->
- failwith s
+let info_of_string = Odoc_comments.info_of_string
+let info_of_comment_file = Odoc_comments.info_of_comment_file
module Search =
struct
(* *)
(***********************************************************************)
-(* $Id: odoc_info.mli,v 1.38 2005/03/24 17:20:53 doligez Exp $ *)
+(* $Id: odoc_info.mli,v 1.38.4.2 2005/11/10 14:44:36 guesdon Exp $ *)
(** Interface to the information collected in source files. *)
| Module_list of string list
(** The table of the given modules with their abstract. *)
| Index_list (** The links to the various indexes (values, types, ...) *)
+ | Custom of string * text (** to extend \{foo syntax *)
(** A text is a list of [text_element]. The order matters. *)
and text = text_element list
mutable m_top_deps : Name.t list ; (** The toplevels module names this module depends on. *)
mutable m_code : string option ; (** The whole code of the module *)
mutable m_code_intf : string option ; (** The whole code of the interface of the module *)
+ m_text_only : bool ; (** [true] if the module comes from a text file *)
}
and module_type_alias = Odoc_module.module_type_alias =
type source_file =
Impl_file of string
| Intf_file of string
+ | Text_file of string
(** The class type of documentation generators. *)
class type doc_generator =
(* *)
(***********************************************************************)
-(* $Id: odoc_latex.ml,v 1.38 2004/08/20 17:04:35 doligez Exp $ *)
+(* $Id: odoc_latex.ml,v 1.38.4.2 2005/11/10 14:44:36 guesdon Exp $ *)
(** Generation of LaTeX documentation. *)
let print_DEBUG s = print_string s ; print_newline ()
-open Odoc_info
+open Odoc_info
open Parameter
open Value
open Type
open Exception
-open Class
+open Class
open Module
let new_buf () = Buffer.create 1024
let b = new_buf () in
let fmt = Format.formatter_of_buffer b in
(fmt,
- fun () ->
+ fun () ->
Format.pp_print_flush fmt ();
let s = Buffer.contents b in
Buffer.reset b;
[] -> ()
| [c] -> f c
| c :: q ->
- f c;
- ps fmt sep;
- iter q
+ f c;
+ ps fmt sep;
+ iter q
in
iter
(** Return latex code to make a sectionning according to the given level,
and with the given latex code. *)
method section_style level s =
- try
+ try
let sec = List.assoc level !Args.latex_titles in
"\\"^sec^"{"^s^"}\n"
with Not_found -> s
("\\\\", "MAXENCE"^"XXX") ;
("&", "MAXENCE"^"YYY") ;
("\\$", "MAXENCE"^"ZZZ")
- ]
+ ]
- val mutable subst_strings_simple =
- [
+ val mutable subst_strings_simple =
+ [
("MAXENCE"^"XXX", "{\\textbackslash}") ;
"}", "\\}" ;
"{", "\\{" ;
("\\\\", "MAXENCE"^"XXX") ;
- ]
+ ]
val mutable subst_strings_code = [
("MAXENCE"^"ZZZ", "\\$");
("&", "MAXENCE"^"YYY") ;
("\\$", "MAXENCE"^"ZZZ") ;
("\\\\", "MAXENCE"^"XXX") ;
- ]
+ ]
method subst l s =
List.fold_right
(** Escape some characters for the code style. *)
method escape_code s = self#subst subst_strings_code s
-
+
(** Make a correct latex label from a name. *)
(* The following characters are forbidden in LaTeX \index:
\ { } $ & # ^ _ % ~ ! " @ | (" to close the double quote)
let buf = Buffer.create len in
for i = 0 to len - 1 do
let (s_no_, s) =
- match name.[i] with
+ match name.[i] with
'_' -> ("-underscore", "_")
| '~' -> ("-tilde", "~")
- | '%' -> ("-percent", "%")
+ | '%' -> ("-percent", "%")
| '@' -> ("-at", "\"@")
| '!' -> ("-bang", "\"!")
| '|' -> ("-pipe", "\"|")
- | '<' -> ("-lt", "<")
+ | '<' -> ("-lt", "<")
| '>' -> ("-gt", ">")
| '^' -> ("-exp", "^")
| '&' -> ("-ampersand", "&")
| '=' -> ("-equal", "=")
| ':' -> ("-colon", ":")
| c -> (String.make 1 c, String.make 1 c)
- in
- Buffer.add_string buf (if no_ then s_no_ else s)
+ in
+ Buffer.add_string buf (if no_ then s_no_ else s)
done;
Buffer.contents buf
method make_ref label = "\\ref{"^label^"}"
(** Print the LaTeX code corresponding to the [text] parameter.*)
- method latex_of_text fmt t =
+ method latex_of_text fmt t =
List.iter (self#latex_of_text_element fmt) t
-
+
(** Print the LaTeX code for the [text_element] in parameter. *)
method latex_of_text_element fmt te =
match te with
| Odoc_info.CodePre s -> self#latex_of_CodePre fmt s
| Odoc_info.Verbatim s -> self#latex_of_Verbatim fmt s
| Odoc_info.Bold t -> self#latex_of_Bold fmt t
- | Odoc_info.Italic t -> self#latex_of_Italic fmt t
+ | Odoc_info.Italic t -> self#latex_of_Italic fmt t
| Odoc_info.Emphasize t -> self#latex_of_Emphasize fmt t
| Odoc_info.Center t -> self#latex_of_Center fmt t
| Odoc_info.Left t -> self#latex_of_Left fmt t
| Odoc_info.Ref (name, ref_opt) -> self#latex_of_Ref fmt name ref_opt
| Odoc_info.Superscript t -> self#latex_of_Superscript fmt t
| Odoc_info.Subscript t -> self#latex_of_Subscript fmt t
- | Odoc_info.Module_list _ -> ()
- | Odoc_info.Index_list -> ()
+ | Odoc_info.Module_list _ -> ()
+ | Odoc_info.Index_list -> ()
+ | Odoc_info.Custom (s,t) -> self#latex_of_custom_text fmt s t
+
+ method latex_of_custom_text fmt s t = ()
- method latex_of_Raw fmt s =
+ method latex_of_Raw fmt s =
ps fmt (self#escape s)
- method latex_of_Code fmt s =
+ method latex_of_Code fmt s =
let s2 = self#escape_code s in
let s3 = Str.global_replace (Str.regexp "\n") ("\\\\\n") s2 in
p fmt "{\\tt{%s}}" s3
ps fmt (self#escape_simple s);
ps fmt "\n\\end{ocamldoccode}\n"
- method latex_of_Verbatim fmt s =
+ method latex_of_Verbatim fmt s =
ps fmt "\\begin{verbatim}";
ps fmt s;
ps fmt "\\end{verbatim}"
self#latex_of_text fmt t;
ps fmt "}"
- method latex_of_Italic fmt t =
+ method latex_of_Italic fmt t =
ps fmt "{\\it ";
self#latex_of_text fmt t;
ps fmt "}"
method latex_of_List fmt tl =
ps fmt "\\begin{itemize}\n";
- List.iter
- (fun t ->
- ps fmt "\\item ";
- self#latex_of_text fmt t;
- ps fmt "\n"
- )
- tl;
+ List.iter
+ (fun t ->
+ ps fmt "\\item ";
+ self#latex_of_text fmt t;
+ ps fmt "\n"
+ )
+ tl;
ps fmt "\\end{itemize}\n"
method latex_of_Enum fmt tl =
ps fmt "\\begin{enumerate}\n";
- List.iter
- (fun t ->
- ps fmt "\\item ";
- self#latex_of_text fmt t;
- ps fmt "\n"
- )
- tl;
+ List.iter
+ (fun t ->
+ ps fmt "\\item ";
+ self#latex_of_text fmt t;
+ ps fmt "\n"
+ )
+ tl;
ps fmt "\\end{enumerate}\n"
method latex_of_Newline fmt = ps fmt "\n\n"
match label_opt with
None -> ()
| Some l ->
- ps fmt (self#make_label (self#label ~no_: false l))
+ ps fmt (self#make_label (self#label ~no_: false l))
)
method latex_of_Latex fmt s = ps fmt s
method latex_of_Ref fmt name ref_opt =
match ref_opt with
- None ->
+ None ->
self#latex_of_text_element fmt
(Odoc_info.Code (Odoc_info.use_hidden_modules name))
- | Some (RK_section _) ->
+ | Some (RK_section _) ->
self#latex_of_text_element fmt
(Latex ("["^(self#make_ref (self#label ~no_:false (Name.simple name)))^"]"))
| Some kind ->
- let f_label =
+ let f_label =
match kind with
Odoc_info.RK_module -> self#module_label
| Odoc_info.RK_module_type -> self#module_type_label
[
Odoc_info.Code (Odoc_info.use_hidden_modules name) ;
Latex ("["^(self#make_ref (f_label name))^"]")
- ]
+ ]
- method latex_of_Superscript fmt t =
+ method latex_of_Superscript fmt t =
ps fmt "$^{";
self#latex_of_text fmt t;
ps fmt "}$"
- method latex_of_Subscript fmt t =
+ method latex_of_Subscript fmt t =
ps fmt "$_{";
self#latex_of_text fmt t;
ps fmt "}$"
method virtual latex_of_text : Format.formatter -> Odoc_info.text -> unit
(** The method used to get a [text] from an optionel info structure. *)
- method virtual text_of_info : ?block: bool -> Odoc_info.info option -> Odoc_info.text
+ method virtual text_of_info : ?block: bool -> Odoc_info.info option -> Odoc_info.text
(** Print LaTeX code for a description, except for the [i_params] field. *)
- method latex_of_info fmt ?(block=false) info_opt =
- self#latex_of_text fmt
+ method latex_of_info fmt ?(block=false) info_opt =
+ self#latex_of_text fmt
(self#text_of_info ~block info_opt)
end
method first_and_rest_of_info i_opt =
match i_opt with
None -> ([], [])
- | Some i ->
+ | Some i ->
match i.Odoc_info.i_desc with
None -> ([], self#text_of_info ~block: true i_opt)
- | Some t ->
+ | Some t ->
let (first,_) = Odoc_info.first_sentence_and_rest_of_text t in
let (_, rest) = Odoc_info.first_sentence_and_rest_of_text (self#text_of_info ~block: false i_opt) in
(Odoc_info.text_no_title_no_list first, rest)
(** Print LaTeX code for a value. *)
- method latex_of_value fmt v =
+ method latex_of_value fmt v =
Odoc_info.reset_type_names () ;
let label = self#value_label v.val_name in
let latex = self#make_label label in
self#latex_of_text fmt
- ((Latex latex) ::
+ ((Latex latex) ::
(to_text#text_of_value v))
(** Print LaTeX code for a class attribute. *)
method latex_of_attribute fmt a =
self#latex_of_text fmt
- ((Latex (self#make_label (self#attribute_label a.att_value.val_name))) ::
+ ((Latex (self#make_label (self#attribute_label a.att_value.val_name))) ::
(to_text#text_of_attribute a))
(** Print LaTeX code for a class method. *)
- method latex_of_method fmt m =
+ method latex_of_method fmt m =
self#latex_of_text fmt
- ((Latex (self#make_label (self#method_label m.met_value.val_name))) ::
+ ((Latex (self#make_label (self#method_label m.met_value.val_name))) ::
(to_text#text_of_method m))
(** Print LaTeX code for the parameters of a type. *)
method latex_of_type_params fmt m_name t =
let print_one (p, co, cn) =
- ps fmt (Odoc_info.string_of_variance t (co,cn));
- ps fmt (self#normal_type m_name p)
+ ps fmt (Odoc_info.string_of_variance t (co,cn));
+ ps fmt (self#normal_type m_name p)
in
match t.ty_parameters with
[] -> ()
| [(p,co,cn)] -> print_one (p, co, cn)
- | l ->
- ps fmt "(";
- print_concat fmt ", " print_one t.ty_parameters;
- ps fmt ")"
+ | l ->
+ ps fmt "(";
+ print_concat fmt ", " print_one t.ty_parameters;
+ ps fmt ")"
method latex_of_class_parameter_list fmt father c =
- self#latex_of_text fmt
- (self#text_of_class_params father c)
+ self#latex_of_text fmt
+ (self#text_of_class_params father c)
(** Print LaTeX code for a type. *)
method latex_of_type fmt t =
let s_name = Name.simple t.ty_name in
- let text =
- let (fmt2, flush2) = new_fmt () in
+ let text =
+ let (fmt2, flush2) = new_fmt () in
Odoc_info.reset_type_names () ;
let mod_name = Name.father t.ty_name in
Format.fprintf fmt2 "@[<h 2>type ";
- self#latex_of_type_params fmt2 mod_name t;
- (match t.ty_parameters with [] -> () | _ -> ps fmt2 " ");
+ self#latex_of_type_params fmt2 mod_name t;
+ (match t.ty_parameters with [] -> () | _ -> ps fmt2 " ");
ps fmt2 s_name;
- (
+ (
match t.ty_manifest with
None -> ()
- | Some typ ->
+ | Some typ ->
p fmt2 " = %s" (self#normal_type mod_name typ)
- );
- let s_type3 =
+ );
+ let s_type3 =
p fmt2
" %s"
(
- match t.ty_kind with
+ match t.ty_kind with
Type_abstract -> ""
| Type_variant (_, priv) -> "="^(if priv then " private" else "")
- | Type_record (_, priv) -> "= "^(if priv then "private " else "")^"{"
- ) ;
+ | Type_record (_, priv) -> "= "^(if priv then "private " else "")^"{"
+ ) ;
flush2 ()
in
-
- let defs =
+
+ let defs =
match t.ty_kind with
Type_abstract -> []
| Type_variant (l, _) ->
(List.flatten
(List.map
(fun constr ->
- let s_cons =
+ let s_cons =
p fmt2 "@[<h 6> | %s" constr.vc_name;
(
- match constr.vc_args with
+ match constr.vc_args with
[] -> ()
- | l ->
- p fmt2 " %s@ %s"
- "of"
+ | l ->
+ p fmt2 " %s@ %s"
+ "of"
(self#normal_type_list ~par: false mod_name " * " l)
- );
- flush2 ()
+ );
+ flush2 ()
in
[ CodePre s_cons ] @
(match constr.vc_text with
None -> []
- | Some t ->
- let s =
- ps fmt2 "\\begin{ocamldoccomment}\n";
- self#latex_of_text fmt2 t;
- ps fmt2 "\n\\end{ocamldoccomment}\n";
- flush2 ()
- in
+ | Some t ->
+ let s =
+ ps fmt2 "\\begin{ocamldoccomment}\n";
+ self#latex_of_text fmt2 t;
+ ps fmt2 "\n\\end{ocamldoccomment}\n";
+ flush2 ()
+ in
[ Latex s]
)
)
(List.flatten
(List.map
(fun r ->
- let s_field =
+ let s_field =
p fmt2
- "@[<h 6> %s%s :@ %s ;"
+ "@[<h 6> %s%s :@ %s ;"
(if r.rf_mutable then "mutable " else "")
r.rf_name
(self#normal_type mod_name r.rf_type);
- flush2 ()
+ flush2 ()
in
[ CodePre s_field ] @
(match r.rf_text with
None -> []
- | Some t ->
- let s =
- ps fmt2 "\\begin{ocamldoccomment}\n";
- self#latex_of_text fmt2 t;
- ps fmt2 "\n\\end{ocamldoccomment}\n";
- flush2 ()
- in
+ | Some t ->
+ let s =
+ ps fmt2 "\\begin{ocamldoccomment}\n";
+ self#latex_of_text fmt2 t;
+ ps fmt2 "\n\\end{ocamldoccomment}\n";
+ flush2 ()
+ in
[ Latex s]
)
)
method latex_of_exception fmt e =
Odoc_info.reset_type_names () ;
self#latex_of_text fmt
- ((Latex (self#make_label (self#exception_label e.ex_name))) ::
+ ((Latex (self#make_label (self#exception_label e.ex_name))) ::
(to_text#text_of_exception e))
method latex_of_module_parameter fmt m_name p =
- self#latex_of_text fmt
- [
- Code "functor (";
- Code p.mp_name ;
- Code " : ";
- ] ;
+ self#latex_of_text fmt
+ [
+ Code "functor (";
+ Code p.mp_name ;
+ Code " : ";
+ ] ;
self#latex_of_module_type_kind fmt m_name p.mp_kind;
self#latex_of_text fmt [ Code ") -> "]
method latex_of_module_type_kind fmt father kind =
match kind with
- Module_type_struct eles ->
- self#latex_of_text fmt [Latex "\\begin{ocamldocsigend}\n"];
- List.iter (self#latex_of_module_element fmt father) eles;
- self#latex_of_text fmt [Latex "\\end{ocamldocsigend}\n"]
+ Module_type_struct eles ->
+ self#latex_of_text fmt [Latex "\\begin{ocamldocsigend}\n"];
+ List.iter (self#latex_of_module_element fmt father) eles;
+ self#latex_of_text fmt [Latex "\\end{ocamldocsigend}\n"]
| Module_type_functor (p, k) ->
- self#latex_of_module_parameter fmt father p;
- self#latex_of_module_type_kind fmt father k
+ self#latex_of_module_parameter fmt father p;
+ self#latex_of_module_type_kind fmt father k
| Module_type_alias a ->
- self#latex_of_text fmt
- [Code (self#relative_module_idents father a.mta_name)]
+ self#latex_of_text fmt
+ [Code (self#relative_module_idents father a.mta_name)]
| Module_type_with (k, s) ->
- self#latex_of_module_type_kind fmt father k;
- self#latex_of_text fmt
- [ Code " ";
- Code (self#relative_idents father s);
- ]
-
+ self#latex_of_module_type_kind fmt father k;
+ self#latex_of_text fmt
+ [ Code " ";
+ Code (self#relative_idents father s);
+ ]
+
method latex_of_module_kind fmt father kind =
match kind with
- Module_struct eles ->
- self#latex_of_text fmt [Latex "\\begin{ocamldocsigend}\n"];
- List.iter (self#latex_of_module_element fmt father) eles;
- self#latex_of_text fmt [Latex "\\end{ocamldocsigend}\n"]
+ Module_struct eles ->
+ self#latex_of_text fmt [Latex "\\begin{ocamldocsigend}\n"];
+ List.iter (self#latex_of_module_element fmt father) eles;
+ self#latex_of_text fmt [Latex "\\end{ocamldocsigend}\n"]
| Module_alias a ->
- self#latex_of_text fmt
- [Code (self#relative_module_idents father a.ma_name)]
+ self#latex_of_text fmt
+ [Code (self#relative_module_idents father a.ma_name)]
| Module_functor (p, k) ->
- self#latex_of_module_parameter fmt father p;
- self#latex_of_module_kind fmt father k
+ self#latex_of_module_parameter fmt father p;
+ self#latex_of_module_kind fmt father k
| Module_apply (k1, k2) ->
- (* TODO: l'application n'est pas correcte dans un .mli.
- Que faire ? -> afficher le module_type du typedtree *)
- self#latex_of_module_kind fmt father k1;
- self#latex_of_text fmt [Code "("];
- self#latex_of_module_kind fmt father k2;
- self#latex_of_text fmt [Code ")"]
+ (* TODO: l'application n'est pas correcte dans un .mli.
+ Que faire ? -> afficher le module_type du typedtree *)
+ self#latex_of_module_kind fmt father k1;
+ self#latex_of_text fmt [Code "("];
+ self#latex_of_module_kind fmt father k2;
+ self#latex_of_text fmt [Code ")"]
| Module_with (k, s) ->
- (* TODO: à modifier quand Module_with sera plus détaillé *)
- self#latex_of_module_type_kind fmt father k;
- self#latex_of_text fmt
- [ Code " ";
- Code (self#relative_idents father s) ;
- ]
+ (* TODO: à modifier quand Module_with sera plus détaillé *)
+ self#latex_of_module_type_kind fmt father k;
+ self#latex_of_text fmt
+ [ Code " ";
+ Code (self#relative_idents father s) ;
+ ]
| Module_constraint (k, tk) ->
- (* TODO: on affiche quoi ? *)
- self#latex_of_module_kind fmt father k
+ (* TODO: on affiche quoi ? *)
+ self#latex_of_module_kind fmt father k
method latex_of_class_kind fmt father kind =
match kind with
- Class_structure (inh, eles) ->
- self#latex_of_text fmt [Latex "\\begin{ocamldocobjectend}\n"];
- self#generate_inheritance_info fmt inh;
- List.iter (self#latex_of_class_element fmt father) eles;
- self#latex_of_text fmt [Latex "\\end{ocamldocobjectend}\n"]
+ Class_structure (inh, eles) ->
+ self#latex_of_text fmt [Latex "\\begin{ocamldocobjectend}\n"];
+ self#generate_inheritance_info fmt inh;
+ List.iter (self#latex_of_class_element fmt father) eles;
+ self#latex_of_text fmt [Latex "\\end{ocamldocobjectend}\n"]
| Class_apply capp ->
- (* TODO: afficher le type final à partir du typedtree *)
- self#latex_of_text fmt [Raw "class application not handled yet"]
-
+ (* TODO: afficher le type final à partir du typedtree *)
+ self#latex_of_text fmt [Raw "class application not handled yet"]
+
| Class_constr cco ->
- (
+ (
match cco.cco_type_parameters with
[] -> ()
- | l ->
+ | l ->
self#latex_of_text fmt
- (
- Code "[" ::
- (self#text_of_class_type_param_expr_list father l) @
- [Code "] "]
- )
- );
- self#latex_of_text fmt
- [Code (self#relative_idents father cco.cco_name)]
+ (
+ Code "[" ::
+ (self#text_of_class_type_param_expr_list father l) @
+ [Code "] "]
+ )
+ );
+ self#latex_of_text fmt
+ [Code (self#relative_idents father cco.cco_name)]
| Class_constraint (ck, ctk) ->
self#latex_of_text fmt [Code "( "] ;
method latex_of_class_type_kind fmt father kind =
match kind with
- Class_type cta ->
+ Class_type cta ->
(
match cta.cta_type_parameters with
[] -> ()
- | l ->
- self#latex_of_text fmt
- (Code "[" ::
- (self#text_of_class_type_param_expr_list father l) @
- [Code "] "]
- )
+ | l ->
+ self#latex_of_text fmt
+ (Code "[" ::
+ (self#text_of_class_type_param_expr_list father l) @
+ [Code "] "]
+ )
);
self#latex_of_text fmt
- [Code (self#relative_idents father cta.cta_name)]
+ [Code (self#relative_idents father cta.cta_name)]
- | Class_signature (inh, eles) ->
- self#latex_of_text fmt [Latex "\\begin{ocamldocobjectend}\n"];
- self#generate_inheritance_info fmt inh;
- List.iter (self#latex_of_class_element fmt father) eles;
- self#latex_of_text fmt [Latex "\\end{ocamldocobjectend}\n"]
+ | Class_signature (inh, eles) ->
+ self#latex_of_text fmt [Latex "\\begin{ocamldocobjectend}\n"];
+ self#generate_inheritance_info fmt inh;
+ List.iter (self#latex_of_class_element fmt father) eles;
+ self#latex_of_text fmt [Latex "\\end{ocamldocobjectend}\n"]
method latex_for_module_index fmt m =
let s_name = Name.simple m.m_name in
- self#latex_of_text fmt
- [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^
- (self#label ~no_:false s_name)^"`}\n"
- )
- ]
+ self#latex_of_text fmt
+ [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^
+ (self#label ~no_:false s_name)^"`}\n"
+ )
+ ]
method latex_for_module_type_index fmt mt =
let s_name = Name.simple mt.mt_name in
- self#latex_of_text fmt
- [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^
- (self#label ~no_:false (Name.simple s_name))^"`}\n"
- )
- ]
+ self#latex_of_text fmt
+ [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^
+ (self#label ~no_:false (Name.simple s_name))^"`}\n"
+ )
+ ]
method latex_for_module_label fmt m =
ps fmt (self#make_label (self#module_label m.m_name))
method latex_for_class_index fmt c =
let s_name = Name.simple c.cl_name in
- self#latex_of_text fmt
- [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^
- (self#label ~no_:false s_name)^"`}\n"
- )
- ]
+ self#latex_of_text fmt
+ [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^
+ (self#label ~no_:false s_name)^"`}\n"
+ )
+ ]
method latex_for_class_type_index fmt ct =
let s_name = Name.simple ct.clt_name in
- self#latex_of_text fmt
- [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^
- (self#label ~no_:false s_name)^"`}\n"
- )
- ]
+ self#latex_of_text fmt
+ [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^
+ (self#label ~no_:false s_name)^"`}\n"
+ )
+ ]
method latex_for_class_label fmt c =
ps fmt (self#make_label (self#class_label c.cl_name))
(** Print the LaTeX code for the given module. *)
method latex_of_module fmt m =
let father = Name.father m.m_name in
- let t =
+ let t =
[
- Latex "\\begin{ocamldoccode}\n" ;
- Code "module ";
- Code (Name.simple m.m_name);
+ Latex "\\begin{ocamldoccode}\n" ;
+ Code "module ";
+ Code (Name.simple m.m_name);
Code " : ";
- ]
+ ]
in
self#latex_of_text fmt t;
self#latex_of_text fmt [ Latex "\\end{ocamldoccode}\n" ];
self#latex_of_module_kind fmt father m.m_kind;
(
match Module.module_is_functor m with
- false -> ()
+ false -> ()
| true ->
- self#latex_of_text fmt [Newline];
- (
- match List.filter (fun (_,d) -> d <> None)
- (module_parameters ~trans: false m)
- with
- [] -> ()
- | l ->
- let t =
- [ Bold [Raw "Parameters: "];
- List
- (List.map
- (fun (p,text_opt) ->
- let t = match text_opt with None -> [] | Some t -> t in
- ( Raw p.mp_name :: Raw ": " :: t)
- )
- l
- )
- ]
- in
- self#latex_of_text fmt t
- );
+ self#latex_of_text fmt [Newline];
+ (
+ match List.filter (fun (_,d) -> d <> None)
+ (module_parameters ~trans: false m)
+ with
+ [] -> ()
+ | l ->
+ let t =
+ [ Bold [Raw "Parameters: "];
+ List
+ (List.map
+ (fun (p,text_opt) ->
+ let t = match text_opt with None -> [] | Some t -> t in
+ ( Raw p.mp_name :: Raw ": " :: t)
+ )
+ l
+ )
+ ]
+ in
+ self#latex_of_text fmt t
+ );
);
self#latex_of_text fmt [Newline];
self#latex_of_info fmt ~block: true m.m_info;
(** Print the LaTeX code for the given module type. *)
method latex_of_module_type fmt mt =
let father = Name.father mt.mt_name in
- let t =
+ let t =
[
- Latex "\\begin{ocamldoccode}\n" ;
- Code "module type " ;
- Code (Name.simple mt.mt_name);
- ]
+ Latex "\\begin{ocamldoccode}\n" ;
+ Code "module type " ;
+ Code (Name.simple mt.mt_name);
+ ]
in
self#latex_of_text fmt t;
(
match mt.mt_type, mt.mt_kind with
- | Some mtyp, Some kind ->
+ | Some mtyp, Some kind ->
self#latex_of_text fmt [ Code " = " ];
- self#latex_of_text fmt [ Latex "\\end{ocamldoccode}\n" ];
- self#latex_for_module_type_label fmt mt;
- self#latex_for_module_type_index fmt mt;
- p fmt "@[<h 4>";
- self#latex_of_module_type_kind fmt father kind
+ self#latex_of_text fmt [ Latex "\\end{ocamldoccode}\n" ];
+ self#latex_for_module_type_label fmt mt;
+ self#latex_for_module_type_index fmt mt;
+ p fmt "@[<h 4>";
+ self#latex_of_module_type_kind fmt father kind
| _ ->
- self#latex_of_text fmt [ Latex "\\end{ocamldoccode}\n" ];
- self#latex_for_module_type_index fmt mt;
- p fmt "@[<h 4>";
+ self#latex_of_text fmt [ Latex "\\end{ocamldoccode}\n" ];
+ self#latex_for_module_type_index fmt mt;
+ p fmt "@[<h 4>";
);
(
match Module.module_type_is_functor mt with
- false -> ()
+ false -> ()
| true ->
- self#latex_of_text fmt [Newline];
- (
- match List.filter (fun (_,d) -> d <> None)
- (module_type_parameters ~trans: false mt)
- with
- [] -> ()
- | l ->
- let t =
- [ Bold [Raw "Parameters: "];
- List
- (List.map
- (fun (p,text_opt) ->
- let t = match text_opt with None -> [] | Some t -> t in
- ( Raw p.mp_name :: Raw ": " :: t)
- )
- l
- )
- ]
- in
- self#latex_of_text fmt t
- );
+ self#latex_of_text fmt [Newline];
+ (
+ match List.filter (fun (_,d) -> d <> None)
+ (module_type_parameters ~trans: false mt)
+ with
+ [] -> ()
+ | l ->
+ let t =
+ [ Bold [Raw "Parameters: "];
+ List
+ (List.map
+ (fun (p,text_opt) ->
+ let t = match text_opt with None -> [] | Some t -> t in
+ ( Raw p.mp_name :: Raw ": " :: t)
+ )
+ l
+ )
+ ]
+ in
+ self#latex_of_text fmt t
+ );
);
self#latex_of_text fmt [Newline];
self#latex_of_info fmt ~block: true mt.mt_info;
(** Print the LaTeX code for the given included module. *)
method latex_of_included_module fmt im =
self#latex_of_text fmt
- ((Code "include ") ::
- (Code
+ ((Code "include ") ::
+ (Code
(match im.im_module with
None -> im.im_name
| Some (Mod m) -> m.m_name
| Some (Modtype mt) -> mt.mt_name)
- ) ::
- (self#text_of_info im.im_info)
+ ) ::
+ (self#text_of_info im.im_info)
)
(** Print the LaTeX code for the given class. *)
[] -> ""
| l -> (self#normal_class_type_param_list father l)^" "
in
- let t =
- [
- Latex "\\begin{ocamldoccode}\n" ;
- Code (Printf.sprintf
- "class %s%s%s : "
- (if c.cl_virtual then "virtual " else "")
- type_params
- (Name.simple c.cl_name)
- )
- ]
+ let t =
+ [
+ Latex "\\begin{ocamldoccode}\n" ;
+ Code (Printf.sprintf
+ "class %s%s%s : "
+ (if c.cl_virtual then "virtual " else "")
+ type_params
+ (Name.simple c.cl_name)
+ )
+ ]
in
self#latex_of_text fmt t;
self#latex_of_class_parameter_list fmt father c;
(* avoid a big gap if the kind is a consrt *)
(
match c.cl_kind with
- Class.Class_constr _ ->
- self#latex_of_class_kind fmt father c.cl_kind
+ Class.Class_constr _ ->
+ self#latex_of_class_kind fmt father c.cl_kind
| _ ->
- ()
+ ()
);
self#latex_of_text fmt [ Latex "\\end{ocamldoccode}\n" ];
self#latex_for_class_label fmt c;
self#latex_for_class_index fmt c;
p fmt "@[<h 4>";
(match c.cl_kind with
- Class.Class_constr _ -> ()
- | _ -> self#latex_of_class_kind fmt father c.cl_kind
+ Class.Class_constr _ -> ()
+ | _ -> self#latex_of_class_kind fmt father c.cl_kind
);
self#latex_of_text fmt [Newline];
self#latex_of_info fmt ~block: true c.cl_info;
[] -> ""
| l -> (self#normal_class_type_param_list father l)^" "
in
- let t =
- [
- Latex "\\begin{ocamldoccode}\n" ;
- Code (Printf.sprintf
- "class type %s%s%s = "
- (if ct.clt_virtual then "virtual " else "")
- type_params
- (Name.simple ct.clt_name)
- )
- ]
+ let t =
+ [
+ Latex "\\begin{ocamldoccode}\n" ;
+ Code (Printf.sprintf
+ "class type %s%s%s = "
+ (if ct.clt_virtual then "virtual " else "")
+ type_params
+ (Name.simple ct.clt_name)
+ )
+ ]
in
self#latex_of_text fmt t;
let f inh =
match inh.ic_class with
None -> (* we can't make the reference *)
- Newline ::
+ Newline ::
Code ("inherit "^inh.ic_name) ::
(match inh.ic_text with
None -> []
| Some t -> Newline :: t
)
| Some cct ->
- let label =
+ let label =
match cct with
Cl _ -> self#class_label inh.ic_name
| Cltype _ -> self#class_type_label inh.ic_name
in
(* we can create the reference *)
- Newline ::
+ Newline ::
Odoc_info.Code ("inherit "^inh.ic_name) ::
- (Odoc_info.Latex (" ["^(self#make_ref label)^"]")) ::
+ (Odoc_info.Latex (" ["^(self#make_ref label)^"]")) ::
(match inh.ic_text with
None -> []
| Some t -> Newline :: t
(** Generate the LaTeX code for the inherited classes of the given class. *)
method generate_class_inheritance_info fmt cl =
- let rec iter_kind k =
+ let rec iter_kind k =
match k with
Class_structure ([], _) ->
()
(** Generate the LaTeX code for the given top module, in the given buffer. *)
method generate_for_top_module fmt m =
let (first_t, rest_t) = self#first_and_rest_of_info m.m_info in
- let text = [ Title (1, None,
- [ Raw (Odoc_messages.modul^" ") ; Code m.m_name ] @
- (match first_t with
- [] -> []
- | t -> (Raw " : ") :: t)) ;
- ]
+ let text =
+ if m.m_text_only then
+ [ Title (1, None, [Raw m.m_name] @
+ (match first_t with
+ [] -> []
+ | t -> (Raw " : ") :: t)
+ ) ;
+ ]
+ else
+ [ Title (1, None,
+ [ Raw (Odoc_messages.modul^" ") ; Code m.m_name ] @
+ (match first_t with
+ [] -> []
+ | t -> (Raw " : ") :: t)) ;
+ ]
in
self#latex_of_text fmt text;
self#latex_for_module_label fmt m;
self#latex_of_text fmt rest_t ;
self#latex_of_text fmt [ Newline ] ;
- ps fmt "\\ocamldocvspace{0.5cm}\n\n";
- List.iter
- (fun ele ->
- self#latex_of_module_element fmt m.m_name ele;
- ps fmt "\n\n"
- )
+ if not m.m_text_only then ps fmt "\\ocamldocvspace{0.5cm}\n\n";
+ List.iter
+ (fun ele ->
+ self#latex_of_module_element fmt m.m_name ele;
+ ps fmt "\n\n"
+ )
(Module.module_elements ~trans: false m)
(** Print the header of the TeX document. *)
ps fmt "\\usepackage{url} \n";
ps fmt "\\usepackage{ocamldoc}\n";
(
- match !Args.title with
+ match !Args.title with
None -> ()
- | Some s ->
- ps fmt "\\title{";
- ps fmt (self#escape s);
- ps fmt "}\n"
+ | Some s ->
+ ps fmt "\\title{";
+ ps fmt (self#escape s);
+ ps fmt "}\n"
);
ps fmt "\\begin{document}\n";
- (match !Args.title with
- None -> () |
- Some _ -> ps fmt "\\maketitle\n"
+ (match !Args.title with
+ None -> () |
+ Some _ -> ps fmt "\\maketitle\n"
);
if !Args.with_toc then ps fmt "\\tableofcontents\n";
(
let info = Odoc_info.apply_opt
- Odoc_info.info_of_comment_file !Odoc_info.Args.intro_file
+ Odoc_info.info_of_comment_file !Odoc_info.Args.intro_file
in
(match info with None -> () | Some _ -> ps fmt "\\vspace{0.2cm}");
self#latex_of_info fmt info;
(match info with None -> () | Some _ -> ps fmt "\n\n")
)
-
+
(** Generate the LaTeX style file, if it does not exists. *)
method generate_style_file =
try
- let dir = Filename.dirname !Args.out_file in
- let file = Filename.concat dir "ocamldoc.sty" in
- if Sys.file_exists file then
- Odoc_info.verbose (Odoc_messages.file_exists_dont_generate file)
- else
- (
- let chanout = open_out file in
- output_string chanout Odoc_latex_style.content ;
- flush chanout ;
- close_out chanout;
- Odoc_info.verbose (Odoc_messages.file_generated file)
- )
+ let dir = Filename.dirname !Args.out_file in
+ let file = Filename.concat dir "ocamldoc.sty" in
+ if Sys.file_exists file then
+ Odoc_info.verbose (Odoc_messages.file_exists_dont_generate file)
+ else
+ (
+ let chanout = open_out file in
+ output_string chanout Odoc_latex_style.content ;
+ flush chanout ;
+ close_out chanout;
+ Odoc_info.verbose (Odoc_messages.file_generated file)
+ )
with
Sys_error s ->
prerr_endline s ;
(
let f m =
try
- let chanout =
+ let chanout =
open_out ((Filename.concat dir (Name.simple m.m_name))^".tex")
in
- let fmt = Format.formatter_of_out_channel chanout in
+ let fmt = Format.formatter_of_out_channel chanout in
self#generate_for_top_module fmt m ;
- Format.pp_print_flush fmt ();
+ Format.pp_print_flush fmt ();
close_out chanout
with
Failure s
| Sys_error s ->
prerr_endline s ;
- incr Odoc_info.errors
+ incr Odoc_info.errors
in
List.iter f module_list
);
-
+
try
let chanout = open_out main_file in
- let fmt = Format.formatter_of_out_channel chanout in
+ let fmt = Format.formatter_of_out_channel chanout in
if !Args.with_header then self#latex_header fmt;
- List.iter
- (fun m ->
- if !Args.separate_files then
+ List.iter
+ (fun m ->
+ if !Args.separate_files then
ps fmt ("\\input{"^((Name.simple m.m_name))^".tex}\n")
else
self#generate_for_top_module fmt m
- )
+ )
module_list ;
if !Args.with_trailer then ps fmt "\\end{document}";
- Format.pp_print_flush fmt ();
+ Format.pp_print_flush fmt ();
close_out chanout
with
Failure s
| Sys_error s ->
prerr_endline s ;
- incr Odoc_info.errors
+ incr Odoc_info.errors
end
(* *)
(***********************************************************************)
-(* $Id: odoc_man.ml,v 1.25 2005/08/13 20:59:37 doligez Exp $ *)
+(* $Id: odoc_man.ml,v 1.25.2.2 2005/11/10 10:28:50 guesdon Exp $ *)
(** The man pages generator. *)
open Odoc_info
[] -> ()
| _ ->
bs b ".B \"";
- bs b Odoc_messages.authors;
- bs b "\"\n:\n";
+ bs b Odoc_messages.authors;
+ bs b "\"\n:\n";
bs b (String.concat ", " l);
bs b "\n.sp\n"
match v_opt with
None -> ()
| Some v ->
- bs b ".B \"";
- bs b Odoc_messages.version;
- bs b "\"\n:\n";
- bs b v;
- bs b "\n.sp\n"
+ bs b ".B \"";
+ bs b Odoc_messages.version;
+ bs b "\"\n:\n";
+ bs b v;
+ bs b "\n.sp\n"
(** Print groff string for the given optional since information.*)
method man_of_since_opt b s_opt =
match s_opt with
None -> ()
| Some s ->
- bs b ".B \"";
- bs b Odoc_messages.since;
- bs b "\"\n";
- bs b s;
- bs b "\n.sp\n"
+ bs b ".B \"";
+ bs b Odoc_messages.since;
+ bs b "\"\n";
+ bs b s;
+ bs b "\n.sp\n"
(** Print groff string for the given list of raised exceptions.*)
method man_of_raised_exceptions b l =
match l with
[] -> ()
| (s, t) :: [] ->
- bs b ".B \"";
- bs b Odoc_messages.raises;
- bs b (" "^s^"\"\n");
- self#man_of_text b t;
- bs b "\n.sp\n"
+ bs b ".B \"";
+ bs b Odoc_messages.raises;
+ bs b (" "^s^"\"\n");
+ self#man_of_text b t;
+ bs b "\n.sp\n"
| _ ->
bs b ".B \"";
- bs b Odoc_messages.raises;
- bs b "\"\n";
+ bs b Odoc_messages.raises;
+ bs b "\"\n";
List.iter
(fun (ex, desc) ->
- bs b ".TP\n.B \"";
- bs b ex;
- bs b "\"\n";
- self#man_of_text b desc;
- bs b "\n"
- )
+ bs b ".sp\n.B \"";
+ bs b ex;
+ bs b "\"\n";
+ self#man_of_text b desc;
+ bs b "\n"
+ )
l;
- bs b "\n.sp\n"
+ bs b "\n.sp\n"
(** Print groff string for the given "see also" reference. *)
method man_of_see b (see_ref, t) =
match l with
[] -> ()
| see :: [] ->
- bs b ".B \"";
- bs b Odoc_messages.see_also;
- bs b "\"\n";
- self#man_of_see b see;
- bs b "\n.sp\n"
+ bs b ".B \"";
+ bs b Odoc_messages.see_also;
+ bs b "\"\n";
+ self#man_of_see b see;
+ bs b "\n.sp\n"
| _ ->
bs b ".B \"";
- bs b Odoc_messages.see_also;
- bs b "\"\n";
- List.iter
+ bs b Odoc_messages.see_also;
+ bs b "\"\n";
+ List.iter
(fun see ->
- bs b ".TP\n \"\"\n";
- self#man_of_see b see;
- bs b "\n"
- )
+ bs b ".sp\n";
+ self#man_of_see b see;
+ bs b "\n"
+ )
l;
bs b "\n.sp\n"
match return_opt with
None -> ()
| Some s ->
- bs b ".B ";
- bs b Odoc_messages.returns;
- bs b "\n";
- self#man_of_text b s;
- bs b "\n.sp\n"
+ bs b ".B ";
+ bs b Odoc_messages.returns;
+ bs b "\n";
+ self#man_of_text b s;
+ bs b "\n.sp\n"
(** Print man code for the given list of custom tagged texts. *)
method man_of_custom b l =
| Some info ->
let module M = Odoc_info in
(
- match info.M.i_deprecated with
+ match info.M.i_deprecated with
None -> ()
| Some d ->
- bs b ".B \"";
- bs b Odoc_messages.deprecated;
- bs b "\"\n";
- self#man_of_text b d;
- bs b "\n.sp\n"
- );
+ bs b ".B \"";
+ bs b Odoc_messages.deprecated;
+ bs b "\"\n";
+ self#man_of_text b d;
+ bs b "\n.sp\n"
+ );
(
- match info.M.i_desc with
+ match info.M.i_desc with
None -> ()
| Some d when d = [Odoc_info.Raw ""] -> ()
| Some d ->
- self#man_of_text b d;
- bs b "\n.sp\n"
+ self#man_of_text b d;
+ bs b "\n.sp\n"
);
self#man_of_author_list b info.M.i_authors;
self#man_of_version_opt b info.M.i_version;
let len = String.length s in
let b = Buffer.create len in
for i = 0 to len - 1 do
- match s.[i] with
- '\\' -> Buffer.add_string b "\\(rs"
- | '.' -> Buffer.add_string b "\\&."
- | c -> Buffer.add_char b c
+ match s.[i] with
+ '\\' -> Buffer.add_string b "\\(rs"
+ | '.' -> Buffer.add_string b "\\&."
+ | c -> Buffer.add_char b c
done;
Buffer.contents b
| Odoc_info.Raw s -> bs b (self#escape s)
| Odoc_info.Code s ->
bs b "\n.B ";
- bs b ((Str.global_replace (Str.regexp "\n") "\n.B " (self#escape s))^"\n")
+ bs b ((Str.global_replace (Str.regexp "\n") "\n.B " (self#escape s))^"\n")
| Odoc_info.CodePre s ->
bs b "\n.B ";
- bs b ((Str.global_replace (Str.regexp "\n") "\n.B " (self#escape s))^"\n")
+ bs b ((Str.global_replace (Str.regexp "\n") "\n.B " (self#escape s))^"\n")
| Odoc_info.Verbatim s ->
- bs b (self#escape s)
+ bs b (self#escape s)
| Odoc_info.Bold t
| Odoc_info.Italic t
| Odoc_info.Emphasize t
| Odoc_info.Center t
| Odoc_info.Left t
| Odoc_info.Right t ->
- self#man_of_text2 b t
+ self#man_of_text2 b t
| Odoc_info.List tl ->
List.iter
- (fun t -> bs b ".TP\n \"\"\n"; self#man_of_text2 b t; bs b "\n")
+ (fun t -> bs b "\n.sp\n \\-"; self#man_of_text2 b t; bs b "\n")
tl;
bs b "\n"
| Odoc_info.Enum tl ->
List.iter
- (fun t -> bs b ".TP\n \"\"\n"; self#man_of_text2 b t; bs b "\n")
+ (fun t -> bs b "\n.sp\n \\-"; self#man_of_text2 b t; bs b "\n")
tl;
bs b "\n"
| Odoc_info.Newline ->
bs b "\n.sp\n"
| Odoc_info.Block t ->
bs b "\n.sp\n";
- self#man_of_text2 b t;
- bs b "\n.sp\n"
+ self#man_of_text2 b t;
+ bs b "\n.sp\n"
| Odoc_info.Title (n, l_opt, t) ->
self#man_of_text2 b [Odoc_info.Code (Odoc_info.string_of_text t)]
| Odoc_info.Latex _ ->
bs b "^{"; self#man_of_text2 b t
| Odoc_info.Subscript t ->
bs b "_{"; self#man_of_text2 b t
- | Odoc_info.Module_list _ ->
- ()
- | Odoc_info.Index_list ->
- ()
+ | Odoc_info.Module_list _ ->
+ ()
+ | Odoc_info.Index_list ->
+ ()
+ | Odoc_info.Custom (s,t) -> self#man_of_custom_text b s t
+
+ method man_of_custom_text b s t = ()
(** Print groff string to display code. *)
method man_of_code b s = self#man_of_text b [ Code s ]
match t.ty_parameters with
[] -> ()
| l ->
- let s = Odoc_str.string_of_type_param_list t in
- let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in
- bs b "\n.B ";
- bs b (self#relative_idents m_name s2);
- bs b "\n"
+ let s = Odoc_str.string_of_type_param_list t in
+ let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in
+ bs b "\n.B ";
+ bs b (self#relative_idents m_name s2);
+ bs b "\n"
(** Print groff string to display a [Types.module_type]. *)
method man_of_module_type b m_name t =
| _ ->
bs b ".B of ";
self#man_of_type_expr_list
- ~par: false
- b (Name.father e.ex_name) " * " e.ex_args
+ ~par: false
+ b (Name.father e.ex_name) " * " e.ex_args
);
(
match e.ex_alias with
None -> ()
| Some ea ->
- bs b " = ";
+ bs b " = ";
bs b
- (
+ (
match ea.ea_ex with
- None -> ea.ea_name
+ None -> ea.ea_name
| Some e -> e.ex_name
)
);
self#man_of_type_expr_param_list b father t;
(
match t.ty_parameters with
- [] -> ()
+ [] -> ()
| _ -> bs b ".I "
);
bs b (Name.simple t.ty_name);
bs b " \n";
(
match t.ty_manifest with
- None -> ()
+ None -> ()
| Some typ ->
- bs b "= ";
- self#man_of_type_expr b father typ
+ bs b "= ";
+ self#man_of_type_expr b father typ
);
(
match t.ty_kind with
Type_abstract -> ()
| Type_variant (l, priv) ->
bs b "=";
- if priv then bs b " private";
- bs b "\n ";
+ if priv then bs b " private";
+ bs b "\n ";
List.iter
(fun constr ->
bs b ("| "^constr.vc_name);
(
- match constr.vc_args, constr.vc_text with
+ match constr.vc_args, constr.vc_text with
[], None -> bs b "\n "
| [], (Some t) ->
- bs b " (* ";
- self#man_of_text b t;
- bs b " *)\n "
+ bs b " (* ";
+ self#man_of_text b t;
+ bs b " *)\n "
| l, None ->
bs b "\n.B of ";
- self#man_of_type_expr_list ~par: false b father " * " l;
- bs b " "
+ self#man_of_type_expr_list ~par: false b father " * " l;
+ bs b " "
| l, (Some t) ->
bs b "\n.B of ";
- self#man_of_type_expr_list ~par: false b father " * " l;
+ self#man_of_type_expr_list ~par: false b father " * " l;
bs b ".I \" \"\n";
bs b "(* ";
- self#man_of_text b t;
- bs b " *)\n "
+ self#man_of_text b t;
+ bs b " *)\n "
)
- )
+ )
l
| Type_record (l, priv) ->
bs b "= ";
- if priv then bs b "private ";
- bs b "{";
+ if priv then bs b "private ";
+ bs b "{";
List.iter
(fun r ->
bs b (if r.rf_mutable then "\n\n.B mutable \n" else "\n ");
bs b (r.rf_name^" : ");
- self#man_of_type_expr b father r.rf_type;
- bs b ";";
+ self#man_of_type_expr b father r.rf_type;
+ bs b ";";
(
- match r.rf_text with
+ match r.rf_text with
None -> ()
| Some t ->
bs b " (* ";
- self#man_of_text b t;
- bs b " *) "
+ self#man_of_text b t;
+ bs b " *) "
);
)
l;
if m.met_virtual then bs b "virtual ";
bs b ((Name.simple m.met_value.val_name)^" : ");
self#man_of_type_expr b
- (Name.father m.met_value.val_name) m.met_value.val_type;
+ (Name.father m.met_value.val_name) m.met_value.val_type;
bs b "\n.sp\n";
self#man_of_info b m.met_value.val_info;
bs b "\n.sp\n"
[] -> ()
| _ ->
bs b "\n.B ";
- bs b Odoc_messages.parameters;
- bs b ": \n";
- List.iter
+ bs b Odoc_messages.parameters;
+ bs b ": \n";
+ List.iter
(fun p ->
- bs b ".TP\n";
+ bs b ".sp\n";
bs b "\"";
- bs b (Parameter.complete_name p);
- bs b "\"\n";
+ bs b (Parameter.complete_name p);
+ bs b "\"\n";
self#man_of_type_expr b m_name (Parameter.typ p);
- bs b "\n";
+ bs b "\n";
self#man_of_parameter_description b p;
- bs b "\n"
+ bs b "\n"
)
l;
bs b "\n"
)
| l ->
(* A list of names, we display those with a description. *)
- List.iter
+ List.iter
(fun n ->
match Parameter.desc_by_name p n with
None -> ()
| Some t ->
- self#man_of_code b (n^" : ");
- self#man_of_text b t
+ self#man_of_code b (n^" : ");
+ self#man_of_text b t
)
l
[] -> ()
| _ ->
bs b ".B \"";
- bs b Odoc_messages.parameters;
- bs b ":\"\n";
+ bs b Odoc_messages.parameters;
+ bs b ":\"\n";
List.iter
(fun (p, desc_opt) ->
- bs b ".TP\n";
+ bs b ".sp\n";
bs b ("\""^p.mp_name^"\"\n");
self#man_of_module_type b m_name p.mp_type;
- bs b "\n";
+ bs b "\n";
(
- match desc_opt with
+ match desc_opt with
None -> ()
| Some t -> self#man_of_text b t
- );
+ );
bs b "\n"
)
l;
match c.cl_type_parameters with
[] -> ()
| l ->
- bs b (Odoc_str.string_of_class_type_param_list l);
- bs b " "
+ bs b (Odoc_str.string_of_class_type_param_list l);
+ bs b " "
);
bs b (Name.simple c.cl_name);
bs b " : " ;
match ct.clt_type_parameters with
[] -> ()
| l ->
- bs b (Odoc_str.string_of_class_type_param_list l);
- bs b " "
+ bs b (Odoc_str.string_of_class_type_param_list l);
+ bs b " "
);
bs b (Name.simple ct.clt_name);
bs b " = " ;
(match mt.mt_type with
None -> ()
| Some t ->
- self#man_of_module_type b (Name.father mt.mt_name) t
+ self#man_of_module_type b (Name.father mt.mt_name) t
);
bs b "\n.sp\n";
self#man_of_info b mt.mt_info;
let file = self#file_name cl.cl_name in
try
let chanout = self#open_out file in
- let b = new_buf () in
- bs b (".TH \""^cl.cl_name^"\" ");
+ let b = new_buf () in
+ bs b (".TH \""^cl.cl_name^"\" ");
bs b !Odoc_args.man_section ;
- bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^"\" ");
+ bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^" ");
bs b "OCamldoc ";
bs b ("\""^(match !Args.title with Some t -> t | None -> "")^"\"\n");
- let abstract =
- match cl.cl_info with
- None | Some { i_desc = None } -> "no description"
- | Some { i_desc = Some t } ->
- let s = Odoc_info.string_of_text (Odoc_info.first_sentence_of_text t) in
- self#remove_newlines s
- in
+ let abstract =
+ match cl.cl_info with
+ None | Some { i_desc = None } -> "no description"
+ | Some { i_desc = Some t } ->
+ let s = Odoc_info.string_of_text (Odoc_info.first_sentence_of_text t) in
+ self#remove_newlines s
+ in
- bs b ".SH NAME\n";
- bs b (cl.cl_name^" \\- "^abstract^"\n");
+ bs b ".SH NAME\n";
+ bs b (cl.cl_name^" \\- "^abstract^"\n");
bs b (".SH "^Odoc_messages.clas^"\n");
bs b (Odoc_messages.clas^" "^cl.cl_name^"\n");
bs b (".SH "^Odoc_messages.documentation^"\n");
)
(Class.class_elements cl);
- Buffer.output_buffer chanout b;
+ Buffer.output_buffer chanout b;
close_out chanout
with
Sys_error s ->
let file = self#file_name ct.clt_name in
try
let chanout = self#open_out file in
- let b = new_buf () in
- bs b (".TH \""^ct.clt_name^"\" ");
+ let b = new_buf () in
+ bs b (".TH \""^ct.clt_name^"\" ");
bs b !Odoc_args.man_section ;
- bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^"\" ");
+ bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^" ");
bs b "OCamldoc ";
bs b ("\""^(match !Args.title with Some t -> t | None -> "")^"\"\n");
- let abstract =
- match ct.clt_info with
- None | Some { i_desc = None } -> "no description"
- | Some { i_desc = Some t } ->
- let s = Odoc_info.string_of_text (Odoc_info.first_sentence_of_text t) in
- self#remove_newlines s
- in
+ let abstract =
+ match ct.clt_info with
+ None | Some { i_desc = None } -> "no description"
+ | Some { i_desc = Some t } ->
+ let s = Odoc_info.string_of_text (Odoc_info.first_sentence_of_text t) in
+ self#remove_newlines s
+ in
bs b ".SH NAME\n";
- bs b (ct.clt_name^" \\- "^abstract^"\n");
+ bs b (ct.clt_name^" \\- "^abstract^"\n");
bs b (".SH "^Odoc_messages.class_type^"\n");
bs b (Odoc_messages.class_type^" "^ct.clt_name^"\n");
bs b (".SH "^Odoc_messages.documentation^"\n");
bs b ".sp\n";
- self#man_of_class_type b ct;
+ self#man_of_class_type b ct;
(* a large blank *)
bs b "\n.sp\n.sp\n";
)
(Class.class_type_elements ct);
- Buffer.output_buffer chanout b;
+ Buffer.output_buffer chanout b;
close_out chanout
with
Sys_error s ->
let file = self#file_name mt.mt_name in
try
let chanout = self#open_out file in
- let b = new_buf () in
- bs b (".TH \""^mt.mt_name^"\" ");
+ let b = new_buf () in
+ bs b (".TH \""^mt.mt_name^"\" ");
bs b !Odoc_args.man_section ;
- bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^"\" ");
+ bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^" ");
bs b "OCamldoc ";
bs b ("\""^(match !Args.title with Some t -> t | None -> "")^"\"\n");
- let abstract =
- match mt.mt_info with
- None | Some { i_desc = None } -> "no description"
- | Some { i_desc = Some t } ->
- let s = Odoc_info.string_of_text (Odoc_info.first_sentence_of_text t) in
- self#remove_newlines s
- in
- bs b ".SH NAME\n";
- bs b (mt.mt_name^" \\- "^abstract^"\n");
+ let abstract =
+ match mt.mt_info with
+ None | Some { i_desc = None } -> "no description"
+ | Some { i_desc = Some t } ->
+ let s = Odoc_info.string_of_text (Odoc_info.first_sentence_of_text t) in
+ self#remove_newlines s
+ in
+ bs b ".SH NAME\n";
+ bs b (mt.mt_name^" \\- "^abstract^"\n");
bs b (".SH "^Odoc_messages.module_type^"\n");
bs b (Odoc_messages.module_type^" "^mt.mt_name^"\n");
bs b (".SH "^Odoc_messages.documentation^"\n");
bs b (".BI \""^(Name.simple mt.mt_name)^"\"\n");
bs b " = ";
(
- match mt.mt_type with
+ match mt.mt_type with
None -> ()
| Some t ->
- self#man_of_module_type b (Name.father mt.mt_name) t
+ self#man_of_module_type b (Name.father mt.mt_name) t
);
bs b "\n.sp\n";
self#man_of_info b mt.mt_info;
- bs b "\n.sp\n";
+ bs b "\n.sp\n";
(* parameters for functors *)
self#man_of_module_parameter_list b "" (Module.module_type_parameters mt);
)
(Module.module_type_elements mt);
- Buffer.output_buffer chanout b;
+ Buffer.output_buffer chanout b;
close_out chanout
with
let file = self#file_name m.m_name in
try
let chanout = self#open_out file in
- let b = new_buf () in
- bs b (".TH \""^m.m_name^"\" ");
+ let b = new_buf () in
+ bs b (".TH \""^m.m_name^"\" ");
bs b !Odoc_args.man_section ;
- bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^"\" ");
+ bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^" ");
bs b "OCamldoc ";
bs b ("\""^(match !Args.title with Some t -> t | None -> "")^"\"\n");
- let abstract =
- match m.m_info with
- None | Some { i_desc = None } -> "no description"
- | Some { i_desc = Some t } ->
- let s = Odoc_info.string_of_text (Odoc_info.first_sentence_of_text t) in
- self#remove_newlines s
- in
+ let abstract =
+ match m.m_info with
+ None | Some { i_desc = None } -> "no description"
+ | Some { i_desc = Some t } ->
+ let s = Odoc_info.string_of_text (Odoc_info.first_sentence_of_text t) in
+ self#remove_newlines s
+ in
- bs b ".SH NAME\n";
- bs b (m.m_name^" \\- "^abstract^"\n");
+ bs b ".SH NAME\n";
+ bs b (m.m_name^" \\- "^abstract^"\n");
bs b (".SH "^Odoc_messages.modul^"\n");
bs b (Odoc_messages.modul^" "^m.m_name^"\n");
bs b (".SH "^Odoc_messages.documentation^"\n");
bs b (Odoc_messages.modul^"\n");
bs b (".BI \""^(Name.simple m.m_name)^"\"\n");
bs b " : ";
- self#man_of_module_type b (Name.father m.m_name) m.m_type;
+ self#man_of_module_type b (Name.father m.m_name) m.m_type;
bs b "\n.sp\n";
self#man_of_info b m.m_info;
- bs b "\n.sp\n";
+ bs b "\n.sp\n";
(* parameters for functors *)
self#man_of_module_parameter_list b "" (Module.module_parameters m);
)
(Module.module_elements m);
- Buffer.output_buffer chanout b;
+ Buffer.output_buffer chanout b;
close_out chanout
with
let file = self#file_name name in
try
let chanout = self#open_out file in
- let b = new_buf () in
- bs b (".TH \""^name^"\" ");
+ let b = new_buf () in
+ bs b (".TH \""^name^"\" ");
bs b !Odoc_args.man_section ;
- bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^"\" ");
+ bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^" ");
bs b "OCamldoc ";
bs b ("\""^(match !Args.title with Some t -> t | None -> "")^"\"\n");
- bs b ".SH NAME\n";
- bs b (name^" \\- all "^name^" elements\n\n");
+ bs b ".SH NAME\n";
+ bs b (name^" \\- all "^name^" elements\n\n");
let f ele =
match ele with
()
in
List.iter f l;
- Buffer.output_buffer chanout b;
+ Buffer.output_buffer chanout b;
close_out chanout
with
Sys_error s ->
(* *)
(***********************************************************************)
-(* $Id: odoc_messages.ml,v 1.28 2005/08/13 20:59:37 doligez Exp $ *)
+(* $Id: odoc_messages.ml,v 1.28.2.1 2005/11/07 15:59:04 doligez Exp $ *)
(** The messages of the application. *)
let preprocess = "<command>\tPipe sources through preprocessor <command>"
let option_impl ="<file>\tConsider <file> as a .ml file"
let option_intf ="<file>\tConsider <file> as a .mli file"
+let option_text ="<file>\tConsider <file> as a .txt file"
let display_custom_generators_dir = "\tDisplay custom generators standard directory and exit"
let add_load_dir = "<dir>\tAdd the given directory to the search path for custom\n"^
"\t\tgenerators "^bytecode_only
let default_out_file = "ocamldoc.out"
let out_file =
"<file>\tSet the ouput file name, used by texi, latex and dot generators\n"^
- "\t\t(default is "^default_out_file^")"
+ "\t\t(default is "^default_out_file^")\n"^
+ "\t\tor the prefix of index files for the HTML generator\n"^
+ "\t\t(default is index)"
let dot_include_all =
"\n\t\tInclude all modules in the dot output, not only the\n"^
(* *)
(***********************************************************************)
-(* $Id: odoc_misc.ml,v 1.19 2005/03/24 17:20:53 doligez Exp $ *)
+(* $Id: odoc_misc.ml,v 1.19.4.1 2005/11/07 15:59:04 doligez Exp $ *)
+
+let no_blanks s =
+ let len = String.length s in
+ let buf = Buffer.create len in
+ for i = 0 to len - 1 do
+ match s.[i] with
+ ' ' | '\n' | '\t' | '\r' -> ()
+ | c -> Buffer.add_char buf c
+ done;
+ Buffer.contents buf
let input_file_as_string nom =
let chanin = open_in_bin nom in
let rec iter acc pos =
if pos >= len then
match acc with
- "" -> []
- | _ -> [acc]
+ "" -> []
+ | _ -> [acc]
else
if List.mem s.[pos] chars then
- match acc with
- "" -> iter "" (pos + 1)
- | _ -> acc :: (iter "" (pos + 1))
+ match acc with
+ "" -> iter "" (pos + 1)
+ | _ -> acc :: (iter "" (pos + 1))
else
- iter (Printf.sprintf "%s%c" acc s.[pos]) (pos + 1)
+ iter (Printf.sprintf "%s%c" acc s.[pos]) (pos + 1)
in
iter "" 0
"^{"^(string_of_text t)^"}"
| Odoc_types.Subscript t ->
"^{"^(string_of_text t)^"}"
- | Odoc_types.Module_list l ->
- string_of_text
- (list_concat (Odoc_types.Raw ", ")
- (List.map (fun s -> Odoc_types.Code s) l)
- )
- | Odoc_types.Index_list ->
- ""
+ | Odoc_types.Module_list l ->
+ string_of_text
+ (list_concat (Odoc_types.Raw ", ")
+ (List.map (fun s -> Odoc_types.Code s) l)
+ )
+ | Odoc_types.Index_list ->
+ ""
+ | Odoc_types.Custom (_, t) -> string_of_text t
in
String.concat "" (List.map iter t)
| Odoc_types.Superscript t -> [Odoc_types.Superscript (text_no_title_no_list t)]
| Odoc_types.Subscript t -> [Odoc_types.Subscript (text_no_title_no_list t)]
| Odoc_types.Module_list l ->
- list_concat (Odoc_types.Raw ", ")
- (List.map
- (fun s -> Odoc_types.Ref (s, Some Odoc_types.RK_module))
- l
- )
+ list_concat (Odoc_types.Raw ", ")
+ (List.map
+ (fun s -> Odoc_types.Ref (s, Some Odoc_types.RK_module))
+ l
+ )
| Odoc_types.Index_list -> []
+ | Odoc_types.Custom (s,t) -> [Odoc_types.Custom (s, text_no_title_no_list t)]
in
List.flatten (List.map iter t)
| Odoc_types.Subscript t -> iter_text t
| Odoc_types.Module_list _ -> ()
| Odoc_types.Index_list -> ()
+ | Odoc_types.Custom (_, t) -> iter_text t
and iter_text te =
List.iter iter_ele te
in
| Odoc_types.Subscript _
| Odoc_types.Module_list _
| Odoc_types.Index_list -> (false, text_ele, None)
+ | Odoc_types.Custom _ -> (false, text_ele, None)
let first_sentence_of_text t =
let (_,t2,_) = first_sentence_text t in
-1 -> raise Not_found
| 0 -> if pat = s then 0 else raise Not_found
| _ ->
- let pos = len - lenp in
- let s2 = String.sub s pos lenp in
- if s2 = pat then
- pos
- else
- iter (String.sub s 0 pos)
+ let pos = len - lenp in
+ let s2 = String.sub s pos lenp in
+ if s2 = pat then
+ pos
+ else
+ iter (String.sub s 0 pos)
in
fun ~s -> iter s
| Types.Tsubst t2 -> iter t2.Types.desc
in
{ typ with Types.desc = iter typ.Types.desc }
-
-(* eof $Id: odoc_misc.ml,v 1.19 2005/03/24 17:20:53 doligez Exp $ *)
(* *)
(***********************************************************************)
-(* $Id: odoc_misc.mli,v 1.12 2005/03/24 17:20:53 doligez Exp $ *)
+(* $Id: odoc_misc.mli,v 1.12.4.1 2005/11/07 15:59:04 doligez Exp $ *)
(** Miscelaneous functions *)
+(** [no_blanks s] returns the given string without any blank
+ characters, i.e. '\n' '\r' ' ' '\t'.
+*)
+val no_blanks : string -> string
+
(** This function returns a file in the form of one string.*)
val input_file_as_string : string -> string
(* *)
(***********************************************************************)
-(* $Id: odoc_module.ml,v 1.10 2004/07/13 12:25:12 xleroy Exp $ *)
+(* $Id: odoc_module.ml,v 1.10.4.1 2005/11/10 14:44:36 guesdon Exp $ *)
(** Representation and manipulation of modules and module types. *)
im_name : Name.t ; (** the name of the included module *)
mutable im_module : mmt option ; (** the included module or module type *)
mutable im_info : Odoc_types.info option ; (** comment associated to the includ directive *)
- }
+ }
and module_alias = {
ma_name : Name.t ;
mutable ma_module : mmt option ; (** the real module or module type if we could associate it *)
- }
+ }
and module_parameter = {
mp_name : string ; (** the name *)
mp_type : Types.module_type ; (** the type *)
mp_type_code : string ; (** the original code *)
mp_kind : module_type_kind ; (** the way the parameter was built *)
- }
+ }
(** Different kinds of module. *)
and module_kind =
- | Module_struct of module_element list
+ | Module_struct of module_element list
| Module_alias of module_alias (** complete name and corresponding module if we found it *)
| Module_functor of module_parameter * module_kind
| Module_apply of module_kind * module_kind
| Module_with of module_type_kind * string
| Module_constraint of module_kind * module_type_kind
-
+
(** Representation of a module. *)
and t_module = {
- m_name : Name.t ;
- m_type : Types.module_type ;
+ m_name : Name.t ;
+ m_type : Types.module_type ;
mutable m_info : Odoc_types.info option ;
m_is_interface : bool ; (** true for modules read from interface files *)
m_file : string ; (** the file the module is defined in. *)
mutable m_top_deps : Name.t list ; (** The toplevels module names this module depends on. *)
mutable m_code : string option ; (** The whole code of the module *)
mutable m_code_intf : string option ; (** The whole code of the interface of the module *)
- }
+ m_text_only : bool ; (** [true] if the module comes from a text file *)
+ }
and module_type_alias = {
mta_name : Name.t ;
mutable mta_module : t_module_type option ; (** the real module type if we could associate it *)
- }
+ }
(** Different kinds of module type. *)
and module_type_kind =
- | Module_type_struct of module_element list
+ | Module_type_struct of module_element list
| Module_type_functor of module_parameter * module_type_kind
| Module_type_alias of module_type_alias (** complete name and corresponding module type if we found it *)
| Module_type_with of module_type_kind * string (** the module type kind and the code of the with constraint *)
(** Representation of a module type. *)
and t_module_type = {
- mt_name : Name.t ;
+ mt_name : Name.t ;
mutable mt_info : Odoc_types.info option ;
mt_type : Types.module_type option ; (** [None] = abstract module type *)
mt_is_interface : bool ; (** true for modules read from interface files *)
mt_file : string ; (** the file the module type is defined in. *)
mutable mt_kind : module_type_kind option ; (** [None] = abstract module type if mt_type = None ;
Always [None] when the module type was extracted from the implementation file. *)
- mutable mt_loc : Odoc_types.location ;
- }
+ mutable mt_loc : Odoc_types.location ;
+ }
(** {2 Functions} *)
(** Returns the list of values from a list of module_element. *)
let values l =
- List.fold_left
+ List.fold_left
(fun acc -> fun ele ->
- match ele with
+ match ele with
Element_value v -> acc @ [v]
| _ -> acc
)
(** Returns the list of types from a list of module_element. *)
let types l =
- List.fold_left
+ List.fold_left
(fun acc -> fun ele ->
- match ele with
+ match ele with
Element_type t -> acc @ [t]
| _ -> acc
)
(** Returns the list of exceptions from a list of module_element. *)
let exceptions l =
- List.fold_left
+ List.fold_left
(fun acc -> fun ele ->
- match ele with
+ match ele with
Element_exception e -> acc @ [e]
| _ -> acc
)
(** Returns the list of classes from a list of module_element. *)
let classes l =
- List.fold_left
+ List.fold_left
(fun acc -> fun ele ->
- match ele with
+ match ele with
Element_class c -> acc @ [c]
| _ -> acc
)
(** Returns the list of class types from a list of module_element. *)
let class_types l =
- List.fold_left
+ List.fold_left
(fun acc -> fun ele ->
- match ele with
+ match ele with
Element_class_type ct -> acc @ [ct]
| _ -> acc
)
(** Returns the list of modules from a list of module_element. *)
let modules l =
- List.fold_left
+ List.fold_left
(fun acc -> fun ele ->
- match ele with
+ match ele with
Element_module m -> acc @ [m]
| _ -> acc
)
(** Returns the list of module types from a list of module_element. *)
let mod_types l =
- List.fold_left
+ List.fold_left
(fun acc -> fun ele ->
- match ele with
+ match ele with
Element_module_type mt -> acc @ [mt]
| _ -> acc
)
(** Returns the list of module comment from a list of module_element. *)
let comments l =
- List.fold_left
+ List.fold_left
(fun acc -> fun ele ->
- match ele with
+ match ele with
Element_module_comment t -> acc @ [t]
| _ -> acc
)
(** Returns the list of included modules from a list of module_element. *)
let included_modules l =
- List.fold_left
+ List.fold_left
(fun acc -> fun ele ->
- match ele with
+ match ele with
Element_included_module m -> acc @ [m]
| _ -> acc
)
[]
l
-(** Returns the list of elements of a module.
+(** Returns the list of elements of a module.
@param trans indicates if, for aliased modules, we must perform a transitive search.*)
let rec module_elements ?(trans=true) m =
let rec iter_kind = function
- Module_struct l ->
+ Module_struct l ->
print_DEBUG "Odoc_module.module_element: Module_struct";
l
- | Module_alias ma ->
+ | Module_alias ma ->
print_DEBUG "Odoc_module.module_element: Module_alias";
if trans then
match ma.ma_module with
| Some (Modtype mt) -> module_type_elements mt
else
[]
- | Module_functor (_, k)
- | Module_apply (k, _) ->
+ | Module_functor (_, k)
+ | Module_apply (k, _) ->
print_DEBUG "Odoc_module.module_element: Module_functor ou Module_apply";
iter_kind k
| Module_with (tk,_) ->
print_DEBUG "Odoc_module.module_element: Module_constraint";
(* A VOIR : utiliser k ou tk ? *)
module_elements ~trans: trans
- { m_name = "" ;
- m_info = None ;
+ { m_name = "" ;
+ m_info = None ;
m_type = Types.Tmty_signature [] ;
m_is_interface = false ; m_file = "" ; m_kind = k ;
m_loc = Odoc_types.dummy_loc ;
m_top_deps = [] ;
m_code = None ;
m_code_intf = None ;
+ m_text_only = false ;
}
(*
module_type_elements ~trans: trans
mt_loc = Odoc_types.dummy_loc }
*)
in
- iter_kind m.m_kind
+ iter_kind m.m_kind
-(** Returns the list of elements of a module type.
+(** Returns the list of elements of a module type.
@param trans indicates if, for aliased modules, we must perform a transitive search.*)
and module_type_elements ?(trans=true) mt =
let rec iter_kind = function
iter_kind (Some k)
else
[]
- | Some (Module_type_alias mta) ->
+ | Some (Module_type_alias mta) ->
if trans then
match mta.mta_module with
None -> []
@param trans indicates if, for aliased modules, we must perform a transitive search.*)
let module_functions ?(trans=true) m =
List.filter
- (fun v -> Odoc_value.is_function v)
+ (fun v -> Odoc_value.is_function v)
(values (module_elements ~trans m))
(** Returns the list of non-functional values of a module.
@param trans indicates if, for aliased modules, we must perform a transitive search.*)
let module_simple_values ?(trans=true) m =
List.filter
- (fun v -> not (Odoc_value.is_function v))
+ (fun v -> not (Odoc_value.is_function v))
(values (module_elements ~trans m))
-
+
(** Returns the list of types of a module.
@param trans indicates if, for aliased modules, we must perform a transitive search.*)
let module_types ?(trans=true) m = types (module_elements ~trans m)
-(** Returns the list of excptions of a module.
+(** Returns the list of excptions of a module.
@param trans indicates if, for aliased modules, we must perform a transitive search.*)
let module_exceptions ?(trans=true) m = exceptions (module_elements ~trans m)
@param trans indicates if, for aliased modules, we must perform a transitive search.*)
let module_class_types ?(trans=true) m = class_types (module_elements ~trans m)
-(** Returns the list of modules of a module.
+(** Returns the list of modules of a module.
@param trans indicates if, for aliased modules, we must perform a transitive search.*)
let module_modules ?(trans=true) m = modules (module_elements ~trans m)
@param trans indicates if, for aliased modules, we must perform a transitive search.*)
let module_comments ?(trans=true) m = comments (module_elements ~trans m)
-(** Access to the parameters, for a functor type.
+(** Access to the parameters, for a functor type.
@param trans indicates if, for aliased modules, we must perform a transitive search.*)
let rec module_type_parameters ?(trans=true) mt =
let rec iter k =
match k with
- Some (Module_type_functor (p, k2)) ->
+ Some (Module_type_functor (p, k2)) ->
let param =
(* we create the couple (parameter, description opt), using
the description of the parameter if we can find it in the comment.*)
[]
| None ->
[]
- in
+ in
iter mt.mt_kind
(** Access to the parameters, for a functor.
@param trans indicates if, for aliased modules, we must perform a transitive search.*)
and module_parameters ?(trans=true) m =
let rec iter = function
- Module_functor (p, k) ->
- let param =
+ Module_functor (p, k) ->
+ let param =
(* we create the couple (parameter, description opt), using
the description of the parameter if we can find it in the comment.*)
match m.m_info with
{ 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_struct _
+ | Module_apply _
| Module_with _ ->
[]
in
l
(** The module type is a functor if is defined as a functor or if it is an alias for a functor. *)
-let rec module_type_is_functor mt =
+let rec module_type_is_functor mt =
let rec iter k =
match k with
Some (Module_type_functor _) -> true
| Some (Module_type_alias mta) ->
(
match mta.mta_module with
- None -> false
+ None -> false
| Some mtyp -> module_type_is_functor mtyp
)
| Some (Module_type_with (k, _)) ->
iter (Some k)
- | Some (Module_type_struct _)
+ | Some (Module_type_struct _)
| None -> false
in
iter mt.mt_kind
(** The module is a functor if is defined as a functor or if it is an alias for a functor. *)
-let module_is_functor m =
+let module_is_functor m =
let rec iter = function
Module_functor _ -> true
| Module_alias ma ->
(
match ma.ma_module with
- None -> false
+ None -> false
| Some (Mod mo) -> iter mo.m_kind
| Some (Modtype mt) -> module_type_is_functor mt
)
in
iter m.m_kind
-(** Returns the list of values of a module type.
+(** Returns the list of values of a module type.
@param trans indicates if, for aliased modules, we must perform a transitive search.*)
let module_type_values ?(trans=true) m = values (module_type_elements ~trans m)
-
-(** Returns the list of types of a module.
+
+(** Returns the list of types of a module.
@param trans indicates if, for aliased modules, we must perform a transitive search.*)
let module_type_types ?(trans=true) m = types (module_type_elements ~trans m)
@param trans indicates if, for aliased modules, we must perform a transitive search.*)
let module_type_included_modules ?(trans=true) m = included_modules (module_type_elements ~trans m)
-(** Returns the list of comments of a module.
+(** Returns the list of comments of a module.
@param trans indicates if, for aliased modules, we must perform a transitive search.*)
let module_type_comments ?(trans=true) m = comments (module_type_elements ~trans m)
@param trans indicates if, for aliased modules, we must perform a transitive search.*)
let module_type_functions ?(trans=true) mt =
List.filter
- (fun v -> Odoc_value.is_function v)
+ (fun v -> Odoc_value.is_function v)
(values (module_type_elements ~trans mt))
-(** Returns the list of non-functional values of a module type.
+(** Returns the list of non-functional values of a module type.
@param trans indicates if, for aliased modules, we must perform a transitive search.*)
let module_type_simple_values ?(trans=true) mt =
List.filter
- (fun v -> not (Odoc_value.is_function v))
+ (fun v -> not (Odoc_value.is_function v))
(values (module_type_elements ~trans mt))
(** {2 Functions for modules and module types} *)
-(** The list of classes defined in this module and all its modules, functors, ....
+(** The list of classes defined in this module and all its modules, functors, ....
@param trans indicates if, for aliased modules, we must perform a transitive search.*)
-let rec module_all_classes ?(trans=true) m =
+let rec module_all_classes ?(trans=true) m =
List.fold_left
(fun acc -> fun m -> acc @ (module_all_classes ~trans m))
(
)
(module_modules ~trans m)
-(** The list of classes defined in this module type and all its modules, functors, ....
+(** The list of classes defined in this module type and all its modules, functors, ....
@param trans indicates if, for aliased modules, we must perform a transitive search.*)
and module_type_all_classes ?(trans=true) mt =
List.fold_left
(* *)
(***********************************************************************)
-(* $Id: odoc_search.ml,v 1.6 2004/05/23 10:41:50 guesdon Exp $ *)
+(* $Id: odoc_search.ml,v 1.6.10.1 2005/11/07 15:59:04 doligez Exp $ *)
(** Research of elements through modules. *)
val p_class : t_class -> t -> bool * bool
val p_class_type : t_class_type -> t -> bool * bool
val p_value : t_value -> t -> bool
- val p_type : t_type -> t -> bool
+ val p_type : t_type -> t -> bool
val p_exception : t_exception -> t -> bool
val p_attribute : t_attribute -> t -> bool
val p_method : t_method -> t -> bool
| T.Code _
| T.CodePre _
| T.Latex _
- | T.Verbatim _
+ | T.Verbatim _
| T.Ref (_, _) -> []
| T.Bold t
| T.Italic t
| T.Block t
| T.Superscript t
| T.Subscript t
+ | T.Custom (_,t)
| T.Link (_, t) -> search_text root t v
- | T.List l
+ | T.List l
| T.Enum l -> List.flatten (List.map (fun t -> search_text root t v) l)
- | T.Newline
+ | T.Newline
| T.Module_list _
| T.Index_list -> []
- | T.Title (n, l_opt, t) ->
+ | T.Title (n, l_opt, t) ->
(match l_opt with
None -> []
| Some s -> search_section t (Name.concat root s) v) @
let search_class c v =
let (go_deeper, ok) = P.p_class c v in
- let l =
+ let l =
if go_deeper then
- let res_att =
+ let res_att =
List.fold_left
(fun acc -> fun att -> acc @ (search_attribute att v))
[]
(Odoc_class.class_attributes c)
in
- let res_met =
+ let res_met =
List.fold_left
(fun acc -> fun m -> acc @ (search_method m v))
[]
(Odoc_class.class_methods c)
in
- let res_sec =
+ let res_sec =
List.fold_left
(fun acc -> fun t -> acc @ (search_text c.cl_name t v))
[]
let search_class_type ct v =
let (go_deeper, ok) = P.p_class_type ct v in
- let l =
+ let l =
if go_deeper then
- let res_att =
+ 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 =
+ 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 =
+ let res_sec =
List.fold_left
(fun acc -> fun t -> acc @ (search_text ct.clt_name t v))
[]
let (go_deeper, ok) = P.p_module_type mt v in
let l =
if go_deeper then
- let res_val =
+ 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 =
+ 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 =
+ 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 =
+ 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 =
+ 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 =
+ 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 =
+ 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
+ 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
+ if ok then
(Res_module_type mt) :: l
else
l
let (go_deeper, ok) = P.p_module m v in
let l =
if go_deeper then
- let res_val =
+ let res_val =
List.fold_left
(fun acc -> fun va -> acc @ (search_value va v))
[]
(Odoc_module.module_values m)
in
- let res_typ =
+ let res_typ =
List.fold_left
(fun acc -> fun t -> acc @ (search_type t v))
[]
(Odoc_module.module_types m)
in
- let res_exc =
+ 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 =
+ 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 =
+ let res_cl =
List.fold_left
(fun acc -> fun cl -> acc @ (search_class cl v))
[]
(Odoc_module.module_classes m)
in
- let res_cltyp =
+ 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 =
+ 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 @
+ 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
+ if ok then
(Res_module m) :: l
else
l
and search module_list v =
List.fold_left
- (fun acc -> fun m ->
+ (fun acc -> fun m ->
List.fold_left
(fun acc2 -> fun ele ->
if List.mem ele acc2 then acc2 else acc2 @ [ele]
module_list
end
-module P_name =
- struct
+module P_name =
+ struct
type t = Str.regexp
let (=~) name regexp = Str.string_match regexp name 0
let p_module m r = (true, m.m_name =~ r)
let p_method m r = m.met_value.val_name =~ r
let p_section s r = s =~ r
end
-
+
module Search_by_name = Search ( P_name )
module P_values =
- struct
+ struct
type t = unit
let p_module _ _ = (true, false)
let p_module_type _ _ = (true, false)
let p_section _ _ = false
end
module Search_values = Search ( P_values )
-let values l =
+let values l =
let l_ele = Search_values.search l () in
let p v1 v2 = v1.val_name = v2.val_name in
let rec iter acc = function
| [] -> acc
in
iter [] l_ele
-
+
module P_exceptions =
- struct
+ struct
type t = unit
let p_module _ _ = (true, false)
let p_module_type _ _ = (true, false)
let p_section _ _ = false
end
module Search_exceptions = Search ( P_exceptions )
-let exceptions l =
+let exceptions l =
let l_ele = Search_exceptions.search l () in
let p e1 e2 = e1.ex_name = e2.ex_name in
let rec iter acc = function
| [] -> acc
in
iter [] l_ele
-
+
module P_types =
- struct
+ struct
type t = unit
let p_module _ _ = (true, false)
let p_module_type _ _ = (true, false)
let p_section _ _ = false
end
module Search_types = Search ( P_types )
-let types l =
+let types l =
let l_ele = Search_types.search l () in
let p t1 t2 = t1.ty_name = t2.ty_name in
let rec iter acc = function
| [] -> acc
in
iter [] l_ele
-
+
module P_attributes =
- struct
+ struct
type t = unit
let p_module _ _ = (true, false)
let p_module_type _ _ = (true, false)
let p_section _ _ = false
end
module Search_attributes = Search ( P_attributes )
-let attributes l =
+let attributes l =
let l_ele = Search_attributes.search l () in
let p a1 a2 = a1.att_value.val_name = a2.att_value.val_name in
let rec iter acc = function
iter [] l_ele
module P_methods =
- struct
+ struct
type t = unit
let p_module _ _ = (true, false)
let p_module_type _ _ = (true, false)
let p_section _ _ = true
end
module Search_methods = Search ( P_methods )
-let methods l =
+let methods l =
let l_ele = Search_methods.search l () in
let p m1 m2 = m1.met_value.val_name = m2.met_value.val_name in
let rec iter acc = function
iter [] l_ele
module P_classes =
- struct
+ struct
type t = unit
let p_module _ _ = (true, false)
let p_module_type _ _ = (true, false)
let p_section _ _ = false
end
module Search_classes = Search ( P_classes )
-let classes l =
+let classes l =
let l_ele = Search_classes.search l () in
let p c1 c2 = c1.cl_name = c2.cl_name in
let rec iter acc = function
iter [] l_ele
module P_class_types =
- struct
+ struct
type t = unit
let p_module _ _ = (true, false)
let p_module_type _ _ = (true, false)
let p_section _ _ = false
end
module Search_class_types = Search ( P_class_types )
-let class_types l =
+let class_types l =
let l_ele = Search_class_types.search l () in
let p c1 c2 = c1.clt_name = c2.clt_name in
let rec iter acc = function
iter [] l_ele
module P_modules =
- struct
+ struct
type t = unit
let p_module _ _ = (true, true)
let p_module_type _ _ = (true, false)
let p_section _ _ = false
end
module Search_modules = Search ( P_modules )
-let modules l =
+let modules l =
let l_ele = Search_modules.search l () in
let p m1 m2 = m1.m_name = m2.m_name in
let rec iter acc = function
iter [] l_ele
module P_module_types =
- struct
+ struct
type t = unit
let p_module _ _ = (true, false)
let p_module_type _ _ = (true, true)
let p_section _ _ = false
end
module Search_module_types = Search ( P_module_types )
-let module_types l =
+let module_types l =
let l_ele = Search_module_types.search l () in
let p m1 m2 = m1.mt_name = m2.mt_name in
let rec iter acc = function
let find_section mods regexp =
let l = Search_by_name.search mods regexp in
- match
+ match
List.find
(function
Res_section _ -> true
Res_section (_,t) -> t
| _ -> assert false
-(* eof $Id: odoc_search.ml,v 1.6 2004/05/23 10:41:50 guesdon Exp $ *)
+(* eof $Id: odoc_search.ml,v 1.6.10.1 2005/11/07 15:59:04 doligez Exp $ *)
(* *)
(***********************************************************************)
-(* $Id: odoc_sig.ml,v 1.36 2005/08/13 20:59:37 doligez Exp $ *)
+(* $Id: odoc_sig.ml,v 1.36.2.1 2005/11/10 14:44:36 guesdon Exp $ *)
(** Analysis of interface files. *)
m_top_deps = [] ;
m_code = None ;
m_code_intf = code_intf ;
+ m_text_only = false ;
}
in
let (maybe_more, info_after_opt) =
m_top_deps = [] ;
m_code = None ;
m_code_intf = code_intf ;
+ m_text_only = false ;
}
in
let (maybe_more, info_after_opt) =
m_top_deps = [] ;
m_code = None ;
m_code_intf = code_intf ;
+ m_text_only = false ;
}
end
(* under the terms of the Q Public License version 1.0. *)
(***********************************************************************)
-(* $Id: odoc_texi.ml,v 1.19 2004/11/29 02:27:25 garrigue Exp $ *)
+(* $Id: odoc_texi.ml,v 1.19.4.2 2005/11/10 14:44:36 guesdon Exp $ *)
(** Generation of Texinfo documentation. *)
-open Odoc_info
+open Odoc_info
open Parameter
open Value
open Type
open Exception
-open Class
+open Class
open Module
(** {2 Some small helper functions} *)
-let puts_nl chan s =
+let puts_nl chan s =
output_string chan s ;
output_char chan '\n'
-let puts chan s =
+let puts chan s =
output_string chan s
-let nl chan =
+let nl chan =
output_char chan '\n'
let is = function
| None -> false
| Some _ -> true
-let pad_to n s =
+let pad_to n s =
let len = String.length s in
if len < n
then
String.blit s 0 s' 0 len ; s'
else s
-let indent nb_sp s =
+let indent nb_sp s =
let c = ref 0 in
let len = pred (String.length s) in
for i = 0 to len do if s.[i] = '\n' then incr c done ;
let s' = String.make (succ len + (succ !c) * nb_sp ) ' ' in
c := nb_sp ;
- for i = 0 to len do
- s'.[!c] <- s.[i] ;
+ for i = 0 to len do
+ s'.[!c] <- s.[i] ;
if s.[i] = '\n' then c := !c + nb_sp ;
incr c
done ;
s'
-type subparts = [
+type subparts = [
| `Module of Odoc_info.Module.t_module
| `Module_type of Odoc_info.Module.t_module_type
| `Class of Odoc_info.Class.t_class
| `Class_type of Odoc_info.Class.t_class_type
]
-type menu_data = [
- | subparts
+type menu_data = [
+ | subparts
| `Blank
| `Comment of string
| `Texi of string
let nothing = Verbatim ""
-let module_subparts =
+let module_subparts =
let rec iter acc = function
| [] -> List.rev acc
- (* skip aliases *)
- | Element_module { m_kind = Module_alias _ } :: n ->
+ (* skip aliases *)
+ | Element_module { m_kind = Module_alias _ } :: n ->
iter acc n
- | Element_module_type { mt_kind = Some (Module_type_alias _) } :: n ->
+ | Element_module_type { mt_kind = Some (Module_type_alias _) } :: n ->
iter acc n
(* keep modules, module types, classes and class types *)
- | Element_module m :: n ->
- iter (`Module m :: acc) n
- | Element_module_type mt :: n ->
+ | Element_module m :: n ->
+ iter (`Module m :: acc) n
+ | Element_module_type mt :: n ->
iter (`Module_type mt :: acc) n
- | Element_class c :: n ->
+ | Element_class c :: n ->
iter (`Class c :: acc) n
- | Element_class_type ct :: n ->
+ | Element_class_type ct :: n ->
iter (`Class_type ct :: acc) n
(* forget the rest *)
| _ :: n -> iter acc n
iter []
type indices = [
- | `Type
- | `Exception
- | `Value
- | `Class_att
- | `Method
- | `Class
- | `Class_type
- | `Module
+ | `Type
+ | `Exception
+ | `Value
+ | `Class_att
+ | `Method
+ | `Class
+ | `Class_type
+ | `Module
| `Module_type
]
-(** Module for generating various Texinfo things (menus, xrefs, ...) *)
-module Texi =
+(** Module for generating various Texinfo things (menus, xrefs, ...) *)
+module Texi =
struct
(** Associations of strings to subsitute in Texinfo code. *)
let subst_strings = [
(Str.regexp "}", "@}") ;
(Str.regexp "\\.\\.\\.", "@dots{}") ;
] @
- (if !Args.esc_8bits
+ (if !Args.esc_8bits
then [
(Str.regexp "à", "@`a") ;
(Str.regexp "â", "@^a") ;
(Str.regexp "é", "@'e") ;
- (Str.regexp "è", "@`e") ;
+ (Str.regexp "è", "@`e") ;
(Str.regexp "ê", "@^e") ;
(Str.regexp "ë", "@\"e") ;
(Str.regexp "ç", "@,{c}") ;
else [])
(** Escape the strings which would clash with Texinfo syntax. *)
- let escape s =
+ let escape s =
List.fold_left
(fun acc (p, r) -> Str.global_replace p r acc)
s subst_strings
(** Removes dots (no good for a node name). *)
- let fix_nodename s =
+ let fix_nodename s =
Str.global_replace (Str.regexp "\\.") "/" (escape s)
(** Generates a Texinfo menu. *)
- let generate_menu chan subpart_list =
+ let generate_menu chan subpart_list =
if subpart_list <> []
then begin
- let menu_line part_qual name =
+ let menu_line part_qual name =
let sname = Name.simple name in
if sname = name
then (
- puts chan (pad_to 35
+ puts chan (pad_to 35
("* " ^ sname ^ ":: ")) ;
puts_nl chan part_qual )
else (
- puts chan (pad_to 35
+ 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 } ->
+ | `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
+ 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)
(** cross reference to node [name] *)
let xref ?xname name =
- "@xref{" ^ (fix_nodename name) ^
- (match xname with | None -> "" | Some s -> "," ^ s) ^
+ "@xref{" ^ (fix_nodename name) ^
+ (match xname with | None -> "" | Some s -> "," ^ s) ^
"}."
(** enclose the string between [\@ifinfo] tags *)
- let ifinfo s =
+ let ifinfo s =
String.concat "\n"
[ "@ifinfo" ; s ; "@end ifinfo" ; "" ]
- (** [install-info] informations *)
+ (** [install-info] informations *)
let dirsection sec =
"@dircategory " ^ (escape sec)
let direntry ent =
- [ "@direntry" ] @
- (List.map escape ent) @
+ [ "@direntry" ] @
+ (List.map escape ent) @
[ "@end direntry" ]
end
(** {2 Generation of Texinfo code} *)
(** This class generates Texinfo code from text structures *)
-class text =
+class text =
object(self)
(** Associations between a title number and texinfo code. *)
4, "@subsubsection " ;
]
- val fallback_title =
+ val fallback_title =
"@unnumberedsubsubsec "
val headings = [
2, "@heading " ;
3, "@subheading " ;
4, "@subsubheading " ;
- ]
-
- val fallback_heading =
- "@subsubheading "
+ ]
+
+ val fallback_heading =
+ "@subsubheading "
- method escape =
- Texi.escape
+ method escape =
+ Texi.escape
(** this method is not used here but is virtual
in a class we will inherit later *)
- method label ?(no_ : bool option) (_ : string) : string =
+ method label ?(no_ : bool option) (_ : string) : string =
failwith "gni"
(** Return the Texinfo code corresponding to the [text] parameter.*)
method texi_of_text t =
String.concat ""
(List.map self#texi_of_text_element t)
-
+
(** {3 Conversion methods}
[texi_of_????] converts a [text_element] to a Texinfo string. *)
| Ref (name, kind) ->self#texi_of_Ref name kind
| Superscript t -> self#texi_of_Superscript t
| Subscript t -> self#texi_of_Subscript t
- | Odoc_info.Module_list _ -> ""
- | Odoc_info.Index_list -> ""
+ | Odoc_info.Module_list _ -> ""
+ | Odoc_info.Index_list -> ""
+ | Odoc_info.Custom (s,t) -> self#texi_of_custom_text s t
+
+ method texi_of_custom_text s t = ""
method texi_of_Verbatim s = s
method texi_of_Raw s = self#escape s
method texi_of_Code s = "@code{" ^ (self#escape s) ^ "}"
- method texi_of_CodePre s =
+ method texi_of_CodePre s =
String.concat "\n"
[ "" ; "@example" ; self#escape s ; "@end example" ; "" ]
method texi_of_Bold t = "@strong{" ^ (self#texi_of_text t) ^ "}"
method texi_of_Italic t = "@i{" ^ (self#texi_of_text t) ^ "}"
method texi_of_Emphasize t = "@emph{" ^ (self#texi_of_text t) ^ "}"
- method texi_of_Center t =
+ method texi_of_Center t =
let sl = Str.split (Str.regexp "\n") (self#texi_of_text t) in
String.concat ""
((List.map (fun s -> "\n@center "^s) sl) @ [ "\n" ])
method texi_of_Left t =
- String.concat "\n"
+ String.concat "\n"
[ "" ; "@flushleft" ; self#texi_of_text t ; "@end flushleft" ; "" ]
- method texi_of_Right t =
- String.concat "\n"
+ method texi_of_Right t =
+ String.concat "\n"
[ "" ; "@flushright" ; self#texi_of_text t ; "@end flushright"; "" ]
- method texi_of_List tl =
+ method texi_of_List tl =
String.concat "\n"
- ( [ "" ; "@itemize" ] @
+ ( [ "" ; "@itemize" ] @
(List.map (fun t -> "@item\n" ^ (self#texi_of_text t)) tl) @
[ "@end itemize"; "" ] )
- method texi_of_Enum tl =
+ method texi_of_Enum tl =
String.concat "\n"
- ( [ "" ; "@enumerate" ] @
+ ( [ "" ; "@enumerate" ] @
(List.map (fun t -> "@item\n" ^ (self#texi_of_text t)) tl) @
[ "@end enumerate"; "" ] )
method texi_of_Newline = "\n"
String.concat "\n"
[ "@format" ; self#texi_of_text t ; "@end format" ; "" ]
method texi_of_Title n t =
- let t_begin =
- try List.assoc n titles
+ let t_begin =
+ try List.assoc n titles
with Not_found -> fallback_title in
t_begin ^ (self#texi_of_text t) ^ "\n"
method texi_of_Link s t =
String.concat ""
[ "@uref{" ; s ; "," ; self#texi_of_text t ; "}" ]
method texi_of_Ref name kind =
- let xname =
+ let xname =
match kind with
- | Some RK_module ->
+ | Some RK_module ->
Odoc_messages.modul ^ " " ^ (Name.simple name)
- | Some RK_module_type ->
+ | Some RK_module_type ->
Odoc_messages.module_type ^ " " ^ (Name.simple name)
- | Some RK_class ->
+ | Some RK_class ->
Odoc_messages.clas ^ " " ^ (Name.simple name)
- | Some RK_class_type ->
+ | Some RK_class_type ->
Odoc_messages.class_type ^ " " ^ (Name.simple name)
| _ -> ""
in
"_@{" ^ (self#texi_of_text t) ^ "@}"
method heading n t =
- let f =
+ let f =
try List.assoc n headings
with Not_found -> fallback_heading
in
f ^ (self#texi_of_text t) ^ "\n"
- method fixedblock t =
+ method fixedblock t =
Block ( ( Verbatim "@t{" :: t ) @ [ Verbatim "}" ] )
end
don't do it, just link to the previous one *)
val node_tbl = Hashtbl.create 37
- method node depth name =
+ method node depth name =
if Hashtbl.mem node_tbl name
then raise Aliased_node ;
Hashtbl.add node_tbl name () ;
- if depth <= maxdepth
+ if depth <= maxdepth
then Verbatim ("@node " ^ (Texi.fix_nodename name) ^ ",\n")
else nothing
- method index (ind : indices) ent =
- Verbatim
- (if !Args.with_index
+ method index (ind : indices) ent =
+ Verbatim
+ (if !Args.with_index
then (assert(List.mem ind indices_to_build) ;
- String.concat ""
- [ "@" ; indices ind ; "index " ;
- Texi.escape (Name.simple ent) ; "\n" ])
+ String.concat ""
+ [ "@" ; indices ind ; "index " ;
+ Texi.escape (Name.simple ent) ; "\n" ])
else "")
-
+
(** Two hacks to fix linebreaks in the descriptions.*)
- method private fix_linebreaks =
+ method private fix_linebreaks =
let re = Str.regexp "\n[ \t]*" in
fun t ->
- List.map
+ List.map
(function
| Newline -> Raw "\n"
| Raw s -> Raw (Str.global_replace re "\n" s)
| Enum tel -> Enum (List.map self#fix_linebreaks tel)
| te -> te) t
- method private soft_fix_linebreaks =
+ method private soft_fix_linebreaks =
let re = Str.regexp "\n[ \t]*" in
fun ind t ->
let rep = String.make (succ ind) ' ' in
method text_of_desc = function
| None -> []
| Some [ Raw "" ] -> []
- | Some t -> (self#fix_linebreaks t) @ [ Newline ]
+ | Some t -> (self#fix_linebreaks t) @ [ Newline ]
- method text_of_sees_opt see_l =
+ 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_file s, t)
| (See_doc s, t) ->
[ linebreak ; Bold [ Raw Odoc_messages.see_also ] ;
Raw " " ; Raw s ] @ t @ [ Newline ])
List.concat
(List.map
(fun (s, t) ->
- [ linebreak ;
+ [ linebreak ;
Bold [ Raw Odoc_messages.parameters ] ;
Raw " " ; Raw s ; Raw ": " ] @ t @ [ Newline ] )
params_list)
method text_of_raised_exceptions = function
| [] -> []
- | (s, t) :: [] ->
+ | (s, t) :: [] ->
[ linebreak ;
Bold [ Raw Odoc_messages.raises ] ;
- Raw " " ; Code s ; Raw " " ]
+ Raw " " ; Code s ; Raw " " ]
@ t @ [ Newline ]
| l ->
[ linebreak ;
List
(List.map
(fun (ex, desc) ->(Code ex) :: (Raw " ") :: desc ) l ) ;
- Newline ]
+ Newline ]
method text_of_return_opt = function
| None -> []
- | Some t ->
+ | Some t ->
(Bold [Raw Odoc_messages.returns ]) :: Raw " " :: t @ [ Newline ]
method text_of_custom c_l =
- List.flatten
- (List.rev
- (List.fold_left
+ List.flatten
+ (List.rev
+ (List.fold_left
(fun acc -> fun (tag, text) ->
try
let f = List.assoc tag tag_functions in
method text_of_info ?(block=false) = function
| None -> []
- | Some info ->
- let t =
+ | Some info ->
+ let t =
List.concat
[ ( match info.i_deprecated with
| None -> []
- | Some t ->
- (Raw (Odoc_messages.deprecated ^ " ")) ::
- (self#fix_linebreaks t)
+ | Some t ->
+ (Raw (Odoc_messages.deprecated ^ " ")) ::
+ (self#fix_linebreaks t)
@ [ Newline ; Newline ] ) ;
self#text_of_desc info.i_desc ;
- if info.i_authors <> []
+ if info.i_authors <> []
then ( linebreak ::
self#text_of_author_list info.i_authors )
else [] ;
- if is info.i_version
- then ( linebreak ::
+ if is info.i_version
+ then ( linebreak ::
self#text_of_version_opt info.i_version )
else [] ;
self#text_of_sees_opt info.i_sees ;
self#text_of_params info.i_params ;
self#text_of_raised_exceptions info.i_raised_exceptions ;
if is info.i_return_value
- then ( linebreak ::
+ 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 ]
+ if block
+ then [ Block t ]
else (t @ [ Newline ] )
method texi_of_info i =
self#texi_of_text (self#text_of_info i)
(** {3 Conversion of [module_elements] into Texinfo strings}
- The following functions convert [module_elements] and their
+ The following functions convert [module_elements] and their
description to [text] values then to Texinfo strings using the
functions above. *)
- method text_el_of_type_expr m_name typ =
+ method text_el_of_type_expr m_name typ =
Raw (indent 5
- (self#relative_idents m_name
+ (self#relative_idents m_name
(Odoc_info.string_of_type_expr typ)))
method text_of_short_type_expr m_name typ =
[ Raw (self#normal_type m_name typ) ]
(** Return Texinfo code for a value. *)
- method texi_of_value v =
+ 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
+ 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
method texi_of_attribute a =
Odoc_info.reset_type_names () ;
let t = [ self#fixedblock
- [ Newline ; minus ;
+ [ 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)
+ 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
(** Return Texinfo code for a class method. *)
- method texi_of_method m =
+ 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
+ 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#texi_of_text t
- method string_of_type_parameters t =
+ method string_of_type_parameters t =
let f (tp, co, cn) =
- Printf.sprintf "%s%s"
- (Odoc_info.string_of_variance t (co, cn))
- (Odoc_info.string_of_type_expr tp)
+ Printf.sprintf "%s%s"
+ (Odoc_info.string_of_variance t (co, cn))
+ (Odoc_info.string_of_type_expr tp)
in
match t.ty_parameters with
| [] -> ""
- | [ (tp, co, cn) ] ->
- (f (tp, co, cn))^" "
- | l ->
- Printf.sprintf "(%s) "
- (String.concat ", " (List.map f l))
+ | [ (tp, co, cn) ] ->
+ (f (tp, co, cn))^" "
+ | l ->
+ Printf.sprintf "(%s) "
+ (String.concat ", " (List.map f l))
method string_of_type_args = function
| [] -> ""
| args -> " of " ^ (Odoc_info.string_of_type_list " * " args)
(** Return Texinfo code for a type. *)
- method texi_of_type ty =
+ method texi_of_type ty =
Odoc_info.reset_type_names () ;
- let t =
- [ self#fixedblock (
+ let t =
+ [ self#fixedblock (
[ Newline ; minus ; Raw "type " ;
Raw (self#string_of_type_parameters ty) ;
Raw (Name.simple ty.ty_name) ] @
( match ty.ty_manifest with
- | None -> []
- | Some typ ->
- (Raw " = ") :: (self#text_of_short_type_expr
+ | None -> []
+ | Some typ ->
+ (Raw " = ") :: (self#text_of_short_type_expr
(Name.father ty.ty_name) typ) ) @
- (
- match ty.ty_kind with
+ (
+ match ty.ty_kind with
| Type_abstract -> [ Newline ]
| Type_variant (l, priv) ->
(Raw (" ="^(if priv then " private" else "")^"\n")) ::
- (List.flatten
- (List.map
+ (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)) @
+ | Some t ->
+ ((Raw (indent 5 "\n(* ")) :: (self#soft_fix_linebreaks 8 t)) @
[ Raw " *)" ; Newline ]
) ) l ) )
| Type_record (l, priv) ->
(Raw (" = "^(if priv then "private " else "")^"{\n")) ::
- (List.flatten
- (List.map
- (fun r ->
+ (List.flatten
+ (List.map
+ (fun r ->
[ Raw (" " ^ r.rf_name ^ " : ") ] @
- (self#text_of_short_type_expr
+ (self#text_of_short_type_expr
(Name.father r.rf_name)
- r.rf_type) @
+ 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 ] ) )
+ | Some t ->
+ ((Raw (indent 5 "\n(* ")) :: (self#soft_fix_linebreaks 8 t)) @
+ [ Raw " *)" ; Newline ] ) )
l ) )
- @ [ Raw " }" ]
- ) ) ;
+ @ [ 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 =
+ method texi_of_exception e =
Odoc_info.reset_type_names () ;
- let t =
+ let t =
[ self#fixedblock
- ( [ Newline ; minus ; Raw "exception " ;
+ ( [ Newline ; minus ; Raw "exception " ;
Raw (Name.simple e.ex_name) ;
Raw (self#string_of_type_args e.ex_args) ] @
(match e.ex_alias with
let resolve_alias_name = function
| { m_kind = Module_alias { ma_name = name } } -> name
| { m_name = name } -> name in
- let t =
- [ [ self#fixedblock
- [ Newline ; minus ; Raw "module " ;
+ let t =
+ [ [ self#fixedblock
+ [ Newline ; minus ; Raw "module " ;
Raw (Name.simple m.m_name) ;
- Raw (if is_alias m
- then " = " ^ (resolve_alias_name m)
+ 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) ;
+ then [ Ref (resolve_alias_name m, Some RK_module) ;
Newline ; ]
else [] ) ;
- ( if is_alias m
+ ( if is_alias m
then [ self#index `Module m.m_name ; Newline ]
else [ Newline ] ) ;
self#text_of_info m.m_info ]
let resolve_alias_name = function
| { mt_kind = Some (Module_type_alias { mta_name = name }) } -> name
| { mt_name = name } -> name in
- let t =
- [ [ self#fixedblock
- [ Newline ; minus ; Raw "module type" ;
+ 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)
+ then " = " ^ (resolve_alias_name mt)
else "" ) ] ] ;
( if is_alias_there mt
- then [ Ref (resolve_alias_name mt, Some RK_module_type) ;
+ then [ Ref (resolve_alias_name mt, Some RK_module_type) ;
Newline ; ]
else [] ) ;
( if is_alias mt
let t = [ self#fixedblock
( Newline :: minus :: (Raw "include ") ::
( match im.im_module with
- | None ->
+ | None ->
[ Raw im.im_name ]
- | Some (Mod { m_name = name }) ->
- [ Raw name ; Raw "\n " ;
+ | Some (Mod { m_name = name }) ->
+ [ Raw name ; Raw "\n " ;
Ref (name, Some RK_module) ]
| Some (Modtype { mt_name = name }) ->
- [ Raw name ; Raw "\n " ;
+ [ Raw name ; Raw "\n " ;
Ref (name, Some RK_module_type) ]
- ) @
- [ Newline ] @
- (self#text_of_info im.im_info)
- )
- ]
+ ) @
+ [ Newline ] @
+ (self#text_of_info im.im_info)
+ )
+ ]
in
self#texi_of_text t
(** Return the Texinfo code for the given class. *)
method texi_of_class c =
Odoc_info.reset_type_names () ;
- let t = [ self#fixedblock
- [ Newline ; minus ; Raw "class " ;
- Raw (Name.simple c.cl_name) ] ;
+ 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
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) ] ;
+ 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
self#texi_of_text t
| Element_value v -> self#texi_of_value v
| Element_exception e -> self#texi_of_exception e
| Element_type t -> self#texi_of_type t
- | Element_module_comment t ->
+ | Element_module_comment t ->
self#texi_of_text (Newline :: t @ [Newline])
)
| None -> []
| Some t -> Newline :: t)
| Some cct -> (* we can create the reference *)
- let kind =
+ let kind =
match cct with
- | Cl _ -> Some RK_class
+ | Cl _ -> Some RK_class
| Cltype _ -> Some RK_class_type in
(Code inh.ic_name) ::
(Ref (inh.ic_name, kind)) ::
in
let text = [
Bold [ Raw Odoc_messages.inherits ] ;
- List (List.map f inher_l) ; Newline ]
+ List (List.map f inher_l) ; Newline ]
in
puts chanout (self#texi_of_text text)
- (** Generate the Texinfo code for the inherited classes
+ (** Generate the Texinfo code for the inherited classes
of the given class. *)
method generate_class_inheritance_info chanout cl =
let rec iter_kind = function
- (** Generate the Texinfo code for the inherited classes
+ (** Generate the Texinfo code for the inherited classes
of the given class type. *)
method generate_class_type_inheritance_info chanout clt =
match clt.clt_kind with
| Class_type _ ->
()
- (** Generate the Texinfo code for the given class,
+ (** Generate the Texinfo code for the given class,
in the given out channel. *)
method generate_for_class chanout c =
try
Odoc_info.reset_type_names () ;
let depth = Name.depth c.cl_name in
- let title = [
+ let title = [
self#node depth c.cl_name ;
Title (depth, None, [ Raw (Odoc_messages.clas ^ " ") ;
- Code c.cl_name ]) ;
+ Code c.cl_name ]) ;
self#index `Class c.cl_name ] in
puts chanout (self#texi_of_text title) ;
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)
+ puts chanout (self#texi_of_info c.cl_info)
end ;
-
- let intf = [ Title (succ depth, None,
+
+ let intf = [ Title (succ depth, None,
[ Raw Odoc_messages.interface]) ] in
puts chanout (self#texi_of_text intf);
self#generate_class_inheritance_info chanout c ;
with Aliased_node -> ()
- (** Generate the Texinfo code for the given class type,
+ (** Generate the Texinfo code for the given class type,
in the given out channel. *)
method generate_for_class_type chanout ct =
try
Odoc_info.reset_type_names () ;
let depth = Name.depth ct.clt_name in
- let title = [
+ let title = [
self#node depth ct.clt_name ;
- Title (depth, None, [ Raw (Odoc_messages.class_type ^ " ") ;
- Code 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,
puts chanout (self#texi_of_info ct.clt_info)
end ;
- let intf = [ Title (succ depth, None,
+ let intf = [ Title (succ depth, None,
[ Raw Odoc_messages.interface ]) ] in
puts chanout (self#texi_of_text intf) ;
self#generate_class_type_inheritance_info chanout ct;
- List.iter
+ List.iter
(fun ele -> puts chanout
(self#texi_of_class_element ct.clt_name ele))
(Class.class_type_elements ~trans:false ct)
with Aliased_node -> ()
- (** Generate the Texinfo code for the given module type,
+ (** Generate the Texinfo code for the given module type,
in the given out channel. *)
method generate_for_module_type chanout mt =
try
let depth = Name.depth mt.mt_name in
- let title = [
+ let title = [
self#node depth mt.mt_name ;
- Title (depth, None, [ Raw (Odoc_messages.module_type ^ " ") ;
- Code 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,
let subparts = module_subparts mt_ele in
if depth < maxdepth && subparts <> []
then begin
- let menu = Texi.ifinfo
+ let menu = Texi.ifinfo
( self#heading (succ depth) [ Raw "Subparts" ]) in
puts chanout menu ;
Texi.generate_menu chanout (subparts :> menu_data)
end ;
- let intf = [ Title (succ depth, None,
+ let intf = [ Title (succ depth, None,
[ Raw Odoc_messages.interface ]) ] in
puts chanout (self#texi_of_text intf) ;
List.iter
subparts
with Aliased_node -> ()
- (** Generate the Texinfo code for the given module,
+ (** Generate the Texinfo code for the given module,
in the given out channel. *)
method generate_for_module chanout m =
try
Odoc_info.verbose ("Generate for module " ^ m.m_name) ;
let depth = Name.depth m.m_name in
- let title = [
+ let title = [
self#node depth m.m_name ;
- Title (depth, None, [ Raw (Odoc_messages.modul ^ " ") ;
- Code m.m_name ]) ;
+ Title (depth, None,
+ if m.m_text_only then
+ [ Raw m.m_name ]
+ else
+ [ Raw (Odoc_messages.modul ^ " ") ;
+ Code m.m_name ]
+ ) ;
self#index `Module m.m_name ; Newline ] in
puts chanout (self#texi_of_text title) ;
-
+
if is m.m_info
then begin
let descr = [ Title (succ depth, None,
puts chanout (self#texi_of_text descr) ;
puts chanout (self#texi_of_info m.m_info)
end ;
-
+
let m_ele = Module.module_elements ~trans:true m in
let subparts = module_subparts m_ele in
if depth < maxdepth && subparts <> []
then begin
- let menu = Texi.ifinfo
+ let menu = Texi.ifinfo
( self#heading (succ depth) [ Raw "Subparts" ]) in
puts chanout menu ;
Texi.generate_menu chanout (subparts :> menu_data)
end ;
- let intf = [ Title (succ depth, None,
+ let intf = [ Title (succ depth, None,
[ Raw Odoc_messages.interface]) ] in
puts chanout (self#texi_of_text intf) ;
| None -> ""
| Some s -> self#escape s in
let filename =
- if texi_filename <> "ocamldoc.texi"
- then
- let fn = Filename.basename texi_filename in
- (if Filename.check_suffix fn ".texi"
- then Filename.chop_suffix fn ".texi"
- else fn) ^ ".info"
- else
- if title <> ""
- then title ^ ".info"
- else "doc.info"
+ if texi_filename <> "ocamldoc.texi"
+ then
+ let fn = Filename.basename texi_filename in
+ (if Filename.check_suffix fn ".texi"
+ then Filename.chop_suffix fn ".texi"
+ else fn) ^ ".info"
+ else
+ if title <> ""
+ then title ^ ".info"
+ else "doc.info"
in
(* write a standard Texinfo header *)
List.iter
(puts_nl chan)
- (List.flatten
+ (List.flatten
[ [ "\\input texinfo @c -*-texinfo-*-" ;
"@c %**start of header" ;
"@setfilename " ^ filename ;
"@settitle " ^ title ;
"@c %**end of header" ; ] ;
-
+
(if !Args.with_index then
- List.map
+ List.map
(fun ind ->
"@defcodeindex " ^ (indices ind))
indices_to_build
else []) ;
- [ Texi.dirsection !Args.info_section ] ;
+ [ Texi.dirsection !Args.info_section ] ;
- Texi.direntry
- (if !Args.info_entry <> []
- then !Args.info_entry
- else [ Printf.sprintf "* %s: (%s)."
- title
- (Filename.chop_suffix filename ".info") ]) ;
+ Texi.direntry
+ (if !Args.info_entry <> []
+ then !Args.info_entry
+ else [ Printf.sprintf "* %s: (%s)."
+ title
+ (Filename.chop_suffix filename ".info") ]) ;
[ "@ifinfo" ;
"This file was generated by Ocamldoc using the Texinfo generator." ;
"@end ifinfo" ;
-
+
"@c no titlepage." ;
"@node Top, , , (dir)" ;
(* insert the intro file *)
begin
- match !Odoc_info.Args.intro_file with
- | None when title <> "" ->
- puts_nl chan "@ifinfo" ;
- puts_nl chan ("Documentation for " ^ title) ;
+ match !Odoc_info.Args.intro_file with
+ | None when title <> "" ->
+ puts_nl chan "@ifinfo" ;
+ puts_nl chan ("Documentation for " ^ title) ;
puts_nl chan "@end ifinfo"
- | None ->
- puts_nl chan "@c no title given"
- | Some f ->
- nl chan ;
- puts_nl chan
- (self#texi_of_info (Some (Odoc_info.info_of_comment_file f)))
+ | None ->
+ puts_nl chan "@c no title given"
+ | Some f ->
+ nl chan ;
+ puts_nl chan
+ (self#texi_of_info (Some (Odoc_info.info_of_comment_file f)))
end ;
(* write a top menu *)
- Texi.generate_menu chan
+ Texi.generate_menu chan
((List.map (fun m -> `Module m) m_list) @
(if !Args.with_index then
- let indices_names_to_build = List.map indices indices_to_build in
- List.rev
- (List.fold_left
- (fun acc ->
- function (longname, shortname)
- when List.mem shortname indices_names_to_build ->
- (`Index (longname ^ " index")) :: acc
- | _ -> acc)
- [ `Comment "Indices :" ; `Blank ]
+ let indices_names_to_build = List.map indices indices_to_build in
+ List.rev
+ (List.fold_left
+ (fun acc ->
+ function (longname, shortname)
+ when List.mem shortname indices_names_to_build ->
+ (`Index (longname ^ " index")) :: acc
+ | _ -> acc)
+ [ `Comment "Indices :" ; `Blank ]
indices_names )
else [] ))
-
+
(** Writes the trailer of the TeXinfo document. *)
- method generate_texi_trailer chan =
- nl chan ;
+ method generate_texi_trailer chan =
+ nl chan ;
if !Args.with_index
- then
- let indices_names_to_build = List.map indices indices_to_build in
+ then
+ let indices_names_to_build = List.map indices indices_to_build in
List.iter (puts_nl chan)
(List.flatten
- (List.map
+ (List.map
(fun (longname, shortname) ->
- if List.mem shortname indices_names_to_build
- then [ "@node " ^ longname ^ " index," ;
- "@unnumbered " ^ longname ^ " index" ;
- "@printindex " ^ shortname ; ]
- else [])
+ if List.mem shortname indices_names_to_build
+ then [ "@node " ^ longname ^ " index," ;
+ "@unnumbered " ^ longname ^ " index" ;
+ "@printindex " ^ shortname ; ]
+ else [])
indices_names )) ;
- if !Args.with_toc
+ if !Args.with_toc
then puts_nl chan "@contents" ;
puts_nl chan "@bye"
method do_index it =
if not (List.mem it indices_to_build)
then indices_to_build <- it :: indices_to_build
-
+
(** Scan the whole module information to know which indices need to be build *)
method scan_for_index : subparts -> unit = function
| `Module m ->
let m_ele = Module.module_elements ~trans:true m in
- List.iter self#scan_for_index_in_mod m_ele
- | `Module_type mt ->
+ List.iter self#scan_for_index_in_mod m_ele
+ | `Module_type mt ->
let m_ele = Module.module_type_elements ~trans:true mt in
- List.iter self#scan_for_index_in_mod m_ele
+ List.iter self#scan_for_index_in_mod m_ele
| `Class c ->
let c_ele = Class.class_elements ~trans:true c in
- List.iter self#scan_for_index_in_class c_ele
+ List.iter self#scan_for_index_in_class c_ele
| `Class_type ct ->
let c_ele = Class.class_type_elements ~trans:true ct in
- List.iter self#scan_for_index_in_class c_ele
-
+ List.iter self#scan_for_index_in_class c_ele
+
method scan_for_index_in_mod = function
- (* no recursion *)
+ (* no recursion *)
| Element_value _ -> self#do_index `Value
| Element_exception _ -> self#do_index `Exception
| Element_type _ -> self#do_index `Type
| Element_included_module _
| Element_module_comment _ -> ()
- (* recursion *)
+ (* recursion *)
| Element_module m -> self#do_index `Module ;
- self#scan_for_index (`Module m)
+ self#scan_for_index (`Module m)
| Element_module_type mt -> self#do_index `Module_type ;
- self#scan_for_index (`Module_type mt)
+ self#scan_for_index (`Module_type mt)
| Element_class c -> self#do_index `Class ;
- self#scan_for_index (`Class c)
+ self#scan_for_index (`Class c)
| Element_class_type ct -> self#do_index `Class_type ;
- self#scan_for_index (`Class_type ct)
+ self#scan_for_index (`Class_type ct)
method scan_for_index_in_class = function
| Class_attribute _ -> self#do_index `Class_att
| Class_comment _ -> ()
- (** Generate the Texinfo file from a module list,
+ (** Generate the Texinfo file from a module list,
in the {!Odoc_info.Args.out_file} file. *)
method generate module_list =
Hashtbl.clear node_tbl ;
- let filename =
- if !Args.out_file = Odoc_messages.default_out_file
- then "ocamldoc.texi"
- else !Args.out_file in
+ let filename =
+ if !Args.out_file = Odoc_messages.default_out_file
+ then "ocamldoc.texi"
+ else !Args.out_file in
if !Args.with_index
- then List.iter self#scan_for_index
- (List.map (fun m -> `Module m) module_list) ;
+ then List.iter self#scan_for_index
+ (List.map (fun m -> `Module m) module_list) ;
try
- let chanout = open_out
+ let chanout = open_out
(Filename.concat !Args.target_dir filename) in
- if !Args.with_header
+ if !Args.with_header
then self#generate_texi_header chanout filename module_list ;
- List.iter
- (self#generate_for_module chanout)
+ List.iter
+ (self#generate_for_module chanout)
module_list ;
- if !Args.with_trailer
+ if !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
+ incr Odoc_info.errors
end
(* *)
(***********************************************************************)
-(* $Id: odoc_text.ml,v 1.5 2004/05/23 10:41:50 guesdon Exp $ *)
+(* $Id: odoc_text.ml,v 1.5.10.1 2005/11/07 15:59:04 doligez Exp $ *)
exception Text_syntax of int * int * string (* line, char, string *)
Odoc_text_parser.main Odoc_text_lexer.main lexbuf
with
_ ->
- raise (Text_syntax (!Odoc_text_lexer.line_number,
- !Odoc_text_lexer.char_number,
+ raise (Text_syntax (!Odoc_text_lexer.line_number,
+ !Odoc_text_lexer.char_number,
s)
)
escape_n s '[' (open_brackets - close_brackets)
else
if close_brackets > open_brackets then
- escape_n s ']' (close_brackets - open_brackets)
+ escape_n s ']' (close_brackets - open_brackets)
else
s
| Right t -> p b "{R " ; p_text b t ; p b "}"
| List l -> p b "{ul\n"; p_list b l; p b "}"
| Enum l -> p b "{ol\n"; p_list b l; p b "}"
- | Newline -> p b "\n"
+ | Newline -> p b "\n"
| Block t -> p_text b t
| Title (n, l_opt, t) ->
- p b "{%d%s "
+ p b "{%d%s "
n
(match l_opt with
None -> ""
| Some s -> ":"^s
);
- p_text b t ;
+ p_text b t ;
p b "}"
| Latex s -> p b "{%% %s%%}" s
| Link (s,t) ->
| RK_method -> "method"
| RK_section _ -> "section"
in
- p b "{!%s:%s}" sk s
+ p b "{!%s:%s}" sk s
)
| Superscript t -> p b "{^" ; p_text b t ; p b "}"
| Subscript t -> p b "{_" ; p_text b t ; p b "}"
- | Module_list l ->
+ | Module_list l ->
p b "{!modules:";
List.iter (fun s -> p b " %s" s) l;
p b "}"
| Index_list ->
p b "{!indexlist}"
-
+ | Custom (s,t) ->
+ p b "{%s " s;
+ p_text b t;
+ p b "}"
+
let string_of_text s =
let b = Buffer.create 256 in
p_text b s;
Buffer.contents b
-
+
end
-
(* *)
(***********************************************************************)
-(* $Id: odoc_text_lexer.mll,v 1.8 2004/05/23 10:41:50 guesdon Exp $ *)
+(* $Id: odoc_text_lexer.mll,v 1.8.10.1 2005/11/07 15:59:04 doligez Exp $ *)
(** The lexer for string to build text structures. *)
let lecture_string () = Buffer.contents string_buffer
-(** the variable which will contain the description string.
+(** the variable which will contain the description string.
Is initialized when we encounter the start of a special comment. *)
let description = ref ""
let print_DEBUG s = print_string s; print_newline ()
-(** this flag indicates whether we're in a string between begin_code and end_code tokens, to
+(** this flag indicates whether we're in a string between begin_code and end_code tokens, to
remember the number of open '[' and handle ']' correctly. *)
let open_brackets = ref 0
let l = Str.split_delim (Str.regexp_string "\n") s in
match List.rev l with
[] -> () (* should not occur *)
- | [s2] -> (* no newline *)
+ | [s2] -> (* no newline *)
char_number := !char_number + (String.length s2)
| s2 :: _ ->
line_number := !line_number + ((List.length l) - 1) ;
char_number := String.length s2
-}
+}
(** html marks, to use as alternative possible special strings *)
(** special strings *)
-let end = "}"
- | html_end_bold
+let end = "}"
+ | html_end_bold
| html_end_italic
- | html_end_title
+ | html_end_title
| html_end_list
| html_end_enum
| html_end_item
| html_end_center
-let begin_title =
+let begin_title =
("{" ['0'-'9']+(":"label)? blank_nl)
| html_title
let begin_left = "{L"blank_nl
let begin_right = "{R"blank_nl
let begin_italic = "{i"blank_nl | html_italic
-let begin_list = "{ul" | html_list
-let begin_enum = "{ol" | html_enum
+let begin_list = "{ul"blank_nl? | html_list
+let begin_enum = "{ol"blank_nl? | html_enum
let begin_item = "{li"blank_nl | "{- " | html_item
-let begin_link = "{{:"
+let begin_link = "{{:"
let begin_latex = "{%"blank_nl
let end_latex = "%}"
let begin_code = "[" | html_code
let end_code = "]" | html_end_code
let begin_code_pre = "{["
-let end_code_pre = "]}"
+let end_code_pre = "]}"
let begin_verb = "{v"blank_nl
let end_verb = blank_nl"v}"
let begin_sec_ref = "{!section:"blank_nl | "{!section:"
let begin_mod_list_ref = "{!modules:"blank_nl | "{!modules:"
let index_list = "{!indexlist}"
+let begin_custom = "{"['a'-'z''A'-'Z']['a'-'z''A'-'Z''0'-'9']*
let begin_superscript = "{^"blank_nl | "{^"
let begin_subscript = "{_"blank_nl | "{_"
let end_shortcut_list = '\n'(blank*'\n')+
rule main = parse
-| "\\{"
-| "\\}"
-| "\\["
+| "\\{"
+| "\\}"
+| "\\["
| "\\]"
- {
+ {
incr_cpts lexbuf ;
let s = Lexing.lexeme lexbuf in
- Char (String.sub s 1 1)
+ Char (String.sub s 1 1)
}
| end
{
+ print_DEBUG "end";
incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode or
+ if !verb_mode or !latex_mode or !code_pre_mode or
(!open_brackets >= 1) then
Char (Lexing.lexeme lexbuf)
else
- let _ =
+ let _ =
if !ele_ref_mode then
- ele_ref_mode := false
+ ele_ref_mode := false
in
END
}
| begin_title
{
+ print_DEBUG "begin_title";
incr_cpts lexbuf ;
if !verb_mode or !latex_mode or !code_pre_mode or
(!open_brackets >= 1) or !ele_ref_mode then
else
let (n, l) = (1, (String.length s - 2)) in
let s2 = String.sub s n l in
- try
+ 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
with
_ ->
Title (1, None)
- }
+ }
| begin_bold
- {
+ {
incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode or
+ if !verb_mode or !latex_mode or !code_pre_mode or
(!open_brackets >= 1) or !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
- BOLD
- }
+ BOLD
+ }
| begin_italic
- {
+ {
incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode or
+ if !verb_mode or !latex_mode or !code_pre_mode or
(!open_brackets >= 1) or !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
ITALIC
- }
+ }
| begin_link
- {
+ {
incr_cpts lexbuf ;
if !verb_mode or !latex_mode or !code_pre_mode or
(!open_brackets >= 1) or !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
- LINK
- }
+ LINK
+ }
| begin_emp
{
incr_cpts lexbuf ;
(!open_brackets >= 1) or !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
- EMP
+ EMP
}
| begin_superscript
{
(!open_brackets >= 1) or !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
- SUPERSCRIPT
+ SUPERSCRIPT
}
| begin_subscript
{
(!open_brackets >= 1) or !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
- SUBSCRIPT
+ SUBSCRIPT
}
| begin_center
{
| begin_right
{
incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode
+ if !verb_mode or !latex_mode or !code_pre_mode
or (!open_brackets >= 1) or !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
RIGHT
}
| begin_list
- {
+ {
+ print_DEBUG "LIST";
incr_cpts lexbuf ;
if !verb_mode or !latex_mode or !code_pre_mode or
(!open_brackets >= 1) or !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
- LIST
+ LIST
}
| begin_enum
- {
+ {
incr_cpts lexbuf ;
if !verb_mode or !latex_mode or !code_pre_mode or
(!open_brackets >= 1) or !ele_ref_mode then
}
| begin_item
{
+ print_DEBUG "ITEM";
incr_cpts lexbuf ;
if !verb_mode or !latex_mode or !code_pre_mode or
(!open_brackets >= 1) or !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
- ITEM
+ ITEM
}
| begin_latex
{
{
incr_cpts lexbuf ;
Char (Lexing.lexeme lexbuf)
- }
+ }
| begin_code
{
if !open_brackets <= 0 then
(
open_brackets := 1;
- CODE
+ CODE
)
else
(
)
}
| end_code
- {
+ {
incr_cpts lexbuf ;
if !verb_mode or !latex_mode or !code_pre_mode or !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
(
open_brackets := 0;
- END_CODE
+ END_CODE
)
}
{
incr_cpts lexbuf ;
Char (Lexing.lexeme lexbuf)
- }
-
+ }
+
| begin_code_pre
{
incr_cpts lexbuf ;
if !open_brackets >= 1 then
(
lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1;
- lexbuf.Lexing.lex_curr_p <-
+ lexbuf.Lexing.lex_curr_p <-
{ lexbuf.Lexing.lex_curr_p with
pos_cnum = lexbuf.Lexing.lex_curr_p.pos_cnum - 1
} ;
else
(
open_brackets := 0;
- END_CODE
+ END_CODE
)
)
else
- if !code_pre_mode then
+ if !code_pre_mode then
(
code_pre_mode := false;
- END_CODE_PRE
+ END_CODE_PRE
)
else
Char (Lexing.lexeme lexbuf)
{
incr_cpts lexbuf ;
Char (Lexing.lexeme lexbuf)
- }
+ }
-| begin_ele_ref
+| begin_ele_ref
{
incr_cpts lexbuf ;
if !verb_mode or !latex_mode or !code_pre_mode or !open_brackets >= 1 then
Char (Lexing.lexeme lexbuf)
)
}
-
-| begin_val_ref
+
+| begin_val_ref
{
incr_cpts lexbuf ;
if !verb_mode or !latex_mode or !code_pre_mode or !open_brackets >= 1 then
)
}
-| begin_typ_ref
+| begin_typ_ref
{
incr_cpts lexbuf ;
if !verb_mode or !latex_mode or !code_pre_mode or !open_brackets >= 1 then
)
}
-| begin_exc_ref
+| begin_exc_ref
{
incr_cpts lexbuf ;
if !verb_mode or !latex_mode or !code_pre_mode or !open_brackets >= 1 then
)
}
-| begin_mod_ref
+| begin_mod_ref
{
incr_cpts lexbuf ;
if !verb_mode or !latex_mode or !code_pre_mode or !open_brackets >= 1 then
)
}
-| begin_modt_ref
+| begin_modt_ref
{
incr_cpts lexbuf ;
if !verb_mode or !latex_mode or !code_pre_mode or !open_brackets >= 1 then
)
}
-| begin_cla_ref
+| begin_cla_ref
{
incr_cpts lexbuf ;
if !verb_mode or !latex_mode or !code_pre_mode or !open_brackets >= 1 then
)
}
-| begin_clt_ref
+| begin_clt_ref
{
incr_cpts lexbuf ;
if !verb_mode or !latex_mode or !code_pre_mode or !open_brackets >= 1 then
)
}
-| begin_att_ref
+| begin_att_ref
{
incr_cpts lexbuf ;
if !verb_mode or !latex_mode or !code_pre_mode or !open_brackets >= 1 then
)
}
-| begin_met_ref
+| begin_met_ref
{
incr_cpts lexbuf ;
if !verb_mode or !latex_mode or !code_pre_mode or !open_brackets >= 1 then
)
}
-| begin_sec_ref
+| begin_sec_ref
{
incr_cpts lexbuf ;
if !verb_mode or !latex_mode or !code_pre_mode or !open_brackets >= 1 then
INDEX_LIST
else
Char (Lexing.lexeme lexbuf)
- }
+ }
-| begin_verb
+| begin_verb
{
incr_cpts lexbuf ;
if !latex_mode or (!open_brackets >= 1) or !code_pre_mode or !ele_ref_mode then
)
}
-| shortcut_list_item
+| shortcut_list_item
{
incr_cpts lexbuf ;
if !shortcut_list_mode then
{
incr_cpts lexbuf ;
lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1;
- lexbuf.Lexing.lex_curr_p <-
+ lexbuf.Lexing.lex_curr_p <-
{ lexbuf.Lexing.lex_curr_p with
pos_cnum = lexbuf.Lexing.lex_curr_p.pos_cnum - 1 ;
} ;
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,
+ (* 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
)
Char (Lexing.lexeme lexbuf)
else
BLANK_LINE
- }
-
+ }
+
| eof { EOF }
-| "{"
- {
+| begin_custom
+ {
+ print_DEBUG "begin_custom";
+ incr_cpts lexbuf ;
+ if !verb_mode or !latex_mode or !code_pre_mode or
+ (!open_brackets >= 1) or !ele_ref_mode then
+ Char (Lexing.lexeme lexbuf)
+ else
+ let s = Lexing.lexeme lexbuf in
+ let tag = Odoc_misc.no_blanks s in
+ CUSTOM tag
+ }
+
+| "{"
+ {
incr_cpts lexbuf ;
if !latex_mode or (!open_brackets >= 1) or !code_pre_mode or !ele_ref_mode then
Char (Lexing.lexeme lexbuf)
else
- ERROR
+ ERROR
}
| _
- {
+ {
incr_cpts lexbuf ;
Char (Lexing.lexeme lexbuf)
}
-
-
(* *)
(***********************************************************************)
-(* $Id: odoc_text_parser.mly,v 1.4 2004/05/23 10:41:50 guesdon Exp $ *)
+(* $Id: odoc_text_parser.mly,v 1.4.10.1 2005/11/07 15:59:04 doligez Exp $ *)
open Odoc_types
-let identchar =
+let identchar =
"[A-Z a-z_\192-\214\216-\246\248-\255'0-9]"
let blank = "[ \010\013\009\012]"
%token LEFT
%token RIGHT
%token ITALIC
+%token <string> CUSTOM
%token LIST
%token ENUM
%token ITEM
%token <string> Char
/* Start Symbols */
-%start main
+%start main
%type <Odoc_types.text> main
%%
Title text END { let n, l_opt = $1 in Title (n, l_opt, $2) }
| BOLD text END { Bold $2 }
| ITALIC text END { Italic $2 }
+| CUSTOM text END { Custom ($1, $2) }
| EMP text END { Emphasize $2 }
| SUPERSCRIPT text END { Superscript $2 }
| SUBSCRIPT text END { Subscript $2 }
| ENUM list END { Enum $2 }
| CODE string END_CODE { Code $2 }
| CODE_PRE string END_CODE_PRE { CodePre $2 }
-| ELE_REF string END {
+| ELE_REF string END {
let s2 = remove_beginning_blanks $2 in
let s3 = remove_trailing_blanks s2 in
- Ref (s3, None)
+ Ref (s3, None)
}
-| VAL_REF string END {
+| VAL_REF string END {
let s2 = remove_beginning_blanks $2 in
let s3 = remove_trailing_blanks s2 in
- Ref (s3, Some RK_value)
+ Ref (s3, Some RK_value)
}
-| TYP_REF string END {
+| TYP_REF string END {
let s2 = remove_beginning_blanks $2 in
let s3 = remove_trailing_blanks s2 in
- Ref (s3, Some RK_type)
+ Ref (s3, Some RK_type)
}
-| EXC_REF string END {
+| EXC_REF string END {
let s2 = remove_beginning_blanks $2 in
let s3 = remove_trailing_blanks s2 in
- Ref (s3, Some RK_exception)
+ Ref (s3, Some RK_exception)
}
-| MOD_REF string END {
+| MOD_REF string END {
let s2 = remove_beginning_blanks $2 in
let s3 = remove_trailing_blanks s2 in
- Ref (s3, Some RK_module)
+ Ref (s3, Some RK_module)
}
-| MODT_REF string END {
+| MODT_REF string END {
let s2 = remove_beginning_blanks $2 in
let s3 = remove_trailing_blanks s2 in
- Ref (s3, Some RK_module_type)
+ Ref (s3, Some RK_module_type)
}
-| CLA_REF string END {
+| CLA_REF string END {
let s2 = remove_beginning_blanks $2 in
let s3 = remove_trailing_blanks s2 in
- Ref (s3, Some RK_class)
+ Ref (s3, Some RK_class)
}
-| CLT_REF string END {
+| CLT_REF string END {
let s2 = remove_beginning_blanks $2 in
let s3 = remove_trailing_blanks s2 in
- Ref (s3, Some RK_class_type)
+ Ref (s3, Some RK_class_type)
}
-| ATT_REF string END {
+| ATT_REF string END {
let s2 = remove_beginning_blanks $2 in
let s3 = remove_trailing_blanks s2 in
- Ref (s3, Some RK_attribute)
+ Ref (s3, Some RK_attribute)
}
-| MET_REF string END {
+| MET_REF string END {
let s2 = remove_beginning_blanks $2 in
let s3 = remove_trailing_blanks s2 in
- Ref (s3, Some RK_method)
+ Ref (s3, Some RK_method)
}
-| SEC_REF string END {
+| SEC_REF string END {
let s2 = remove_beginning_blanks $2 in
let s3 = remove_trailing_blanks s2 in
Ref (s3, Some (RK_section []))
}
-| MOD_LIST_REF string END {
+| MOD_LIST_REF string END {
let s2 = remove_beginning_blanks $2 in
let s3 = remove_trailing_blanks s2 in
let l = Odoc_misc.split_with_blanks s3 in
Module_list l
}
-| INDEX_LIST { Index_list }
+| INDEX_LIST { Index_list }
| VERB string END_VERB { Verbatim $2 }
| LATEX string END_LATEX { Latex $2 }
| LINK string END text END { Link ($2, $4) }
;
list:
-| string { [] (* A VOIR : un test pour voir qu'il n'y a que des blancs *) }
+| string { [] (* A VOIR : un test pour voir qu'il n'y a que des blancs *) }
| string list { $2 }
| list string { $1 }
| item { [ $1 ] }
| Char string { $1^$2 }
;
-%%
+%%
(* *)
(***********************************************************************)
-(* $Id: odoc_types.ml,v 1.8 2005/08/13 20:59:37 doligez Exp $ *)
+(* $Id: odoc_types.ml,v 1.8.2.1 2005/11/07 15:59:04 doligez Exp $ *)
type ref_kind =
RK_module
| Subscript of text
| Module_list of string list
| Index_list
+ | Custom of string * text
and text = text_element list
(* *)
(***********************************************************************)
-(* $Id: odoc_types.mli,v 1.5 2004/05/23 10:41:51 guesdon Exp $ *)
+(* $Id: odoc_types.mli,v 1.5.10.1 2005/11/07 15:59:04 doligez Exp $ *)
(** Types for the information collected in comments. *)
(** The differents kinds of element references. *)
-type ref_kind =
+type ref_kind =
RK_module
| RK_module_type
| RK_class
| RK_method
| RK_section of text
-and text_element =
+and text_element =
| Raw of string (** Raw text. *)
| Code of string (** The string is source code. *)
| CodePre of string (** The string is pre-formatted source code. *)
(** A reference to an element. Complete name and kind. *)
| Superscript of text (** Superscripts. *)
| Subscript of text (** Subscripts. *)
- | Module_list of string list
+ | Module_list of string list
(** The table of the given modules with their abstract; *)
| Index_list (** The links to the various indexes (values, types, ...) *)
+ | Custom of string * text (** to extend \{foo syntax *)
(** [text] is a list of text_elements. The order matters. *)
and text = text_element list
(** The different forms of references in \@see tags. *)
-type see_ref =
+type see_ref =
See_url of string
| See_file of string
| See_doc of string
i_raised_exceptions : raised_exception list; (** The list of raised exceptions. *)
i_return_value : text option ; (** The description text of the return value. *)
i_custom : (string * text) list ; (** A text associated to a custom @-tag. *)
- }
+ }
(** An empty info structure. *)
val dummy_info : info
type location = {
loc_impl : (string * int) option ; (** implementation file name and position *)
loc_inter : (string * int) option ; (** interface file name and position *)
- }
+ }
(** A dummy location. *)
val dummy_loc : location
and all raised exceptions are kept. *)
| Merge_return_value (** Information on return value are concatenated. *)
| Merge_custom (** Merge custom tags (all pairs (tag, text) are kept). *)
-
+
(** The list with all merge options. *)
val all_merge_options : merge_option list
(** Verify that a dump has the correct magic number
and return its content. *)
val open_dump : 'a dump -> 'a
-
(* *)
(*************************************************************************)
-(* $Id: editor.ml,v 1.40 2003/04/02 06:56:05 garrigue Exp $ *)
+(* $Id: editor.ml,v 1.40.14.2 2005/12/09 12:40:56 garrigue Exp $ *)
open StdLabels
open Tk
val compiler_menu = new Jg_menu.c "Compiler" ~parent:menus
val module_menu = new Jg_menu.c "Modules" ~parent:menus
val window_menu = new Jg_menu.c "Windows" ~parent:menus
- val label =
- Checkbutton.create menus ~state:`Disabled
+ initializer
+ Menu.add_checkbutton menus ~state:`Disabled
~onvalue:"modified" ~offvalue:"unchanged"
val mutable current_dir = Unix.getcwd ()
val mutable error_messages = []
~command:(fun () -> self#set_edit txt)
end
+ method set_file_name txt =
+ Menu.configure_checkbutton menus `Last
+ ~label:(Filename.basename txt.name)
+ ~variable:txt.modified
+
method set_edit txt =
if windows <> [] then
Pack.forget [(List.hd windows).frame];
windows <- txt :: exclude txt windows;
self#reset_window_menu;
current_tw <- txt.tw;
- Checkbutton.configure label ~text:(Filename.basename txt.name)
- ~variable:txt.modified;
+ self#set_file_name txt;
Textvariable.set vwindow txt.number;
Text.yview txt.tw ~scroll:(`Page 0);
pack [txt.frame] ~fill:`Both ~expand:true ~side:`Bottom
pack [sb] ~fill:`Y ~side:`Right;
pack [tw] ~fill:`Both ~expand:true ~side:`Left;
self#set_edit txt;
- Checkbutton.deselect label;
+ Textvariable.set txt.modified "unchanged";
Lexical.init_tags txt.tw
method clear_errors () =
let text = Text.get txt.tw ~start:tstart ~stop:(tposend 1) in
output_string file text;
close_out file;
- Checkbutton.configure label ~text:(Filename.basename name);
- Checkbutton.deselect label;
- txt.name <- name
+ txt.name <- name;
+ self#set_file_name txt
with
Sys_error _ ->
Jg_message.info ~master:top ~title:"Error"
| `No -> ()
| `Cancel -> raise Exit
end;
- Checkbutton.deselect label;
+ Textvariable.set txt.modified "unchanged";
(Text.index current_tw ~index:(`Mark"insert", []), [])
with Not_found -> self#new_window name; tstart
in
~command:Viewer.search_symbol;
module_menu#add_command "Close all"
~command:Viewer.close_all_views;
-
- (* pack everything *)
- pack (List.map ~f:(fun m -> coe m#button)
- [file_menu; edit_menu; compiler_menu; module_menu; window_menu]
- @ [coe label])
- ~side:`Left ~ipadx:5 ~anchor:`W;
- pack [menus] ~before:(List.hd windows).frame ~side:`Top ~fill:`X
end
(* The main function starts here ! *)
false
then () else
let top = Jg_toplevel.titled "OCamlBrowser Editor" in
- let menus = Frame.create top ~name:"menubar" in
+ let menus = Jg_menu.menubar top in
let ed = new editor ~top ~menus in
already_open := !already_open @ [ed];
if file <> None then ed#reopen ~file ~pos
(* *)
(*************************************************************************)
-(* $Id: jg_menu.ml,v 1.8 2001/12/07 13:39:59 xleroy Exp $ *)
+(* $Id: jg_menu.ml,v 1.8.18.1 2005/12/09 12:29:55 garrigue Exp $ *)
open Tk
-class c ~parent ?underline:(n=0) text = object (self)
- val pair =
- let button =
- Menubutton.create parent ~text ~underline:n in
- let menu = Menu.create button in
- Menubutton.configure button ~menu;
- button, menu
- method button = fst pair
- method menu = snd pair
+class c ~parent ?(underline=0) label = object (self)
+ val menu =
+ let menu = Menu.create parent in
+ Menu.add_cascade parent ~menu ~label ~underline;
+ menu
+ method menu = menu
method virtual add_command :
?underline:int ->
?accelerator:string -> ?activebackground:color ->
?font:string -> ?foreground:color ->
?image:image -> ?state:state ->
string -> unit
- method add_command ?underline:(n=0) ?accelerator ?activebackground
+ method add_command ?(underline=0) ?accelerator ?activebackground
?activeforeground ?background ?bitmap ?command ?font ?foreground
?image ?state label =
- Menu.add_command (self#menu) ~label ~underline:n ?accelerator
+ Menu.add_command menu ~label ~underline ?accelerator
?activebackground ?activeforeground ?background ?bitmap
?command ?font ?foreground ?image ?state
end
+
+let menubar tl =
+ let menu = Menu.create tl ~name:"menubar" ~typ:`Menubar in
+ Toplevel.configure tl ~menu;
+ menu
(* *)
(*************************************************************************)
-(* $Id: main.ml,v 1.31 2004/11/27 01:04:19 doligez Exp $ *)
+(* $Id: main.ml,v 1.31.4.2 2005/12/09 13:48:07 garrigue Exp $ *)
open StdLabels
module Unix = UnixLabels
let path = ref [] in
let st = ref true in
- let spec =
+ (*let spec =
[ "-I", Arg.String (fun s -> path := s :: !path),
"<dir> Add <dir> to the list of include directories";
"-labels", Arg.Clear Clflags.classic, " <obsolete>";
if not (check ~spec Sys.argv) then fatal_error (usage ~spec errmsg);
Arg.parse spec
(fun name -> raise(Arg.Bad("don't know what to do with " ^ name)))
- errmsg;
+ errmsg;*)
Config.load_path :=
Sys.getcwd ()
:: List.rev_map ~f:(Misc.expand_directory Config.standard_library) !path
try
if is_win32 then mainLoop ()
else Printexc.print mainLoop ()
- with Protocol.TkError _ -> ()
+ with Protocol.TkError _ ->
+ if not is_win32 then flush stderr
done
(* *)
(*************************************************************************)
-(* $Id: shell.ml,v 1.39 2002/08/06 03:03:09 garrigue Exp $ *)
+(* $Id: shell.ml,v 1.39.16.1 2005/12/09 12:29:55 garrigue Exp $ *)
open StdLabels
module Unix = UnixLabels
if res = "" then may_exec (Filename.concat dir prog) else res) in
if progpath = "" then program_not_found prog else
let tl = Jg_toplevel.titled title in
- let menus = Frame.create tl ~name:"menubar" in
+ let menus = Menu.create tl ~name:"menubar" ~typ:`Menubar in
+ Toplevel.configure tl ~menu:menus;
let file_menu = new Jg_menu.c "File" ~parent:menus
and history_menu = new Jg_menu.c "History" ~parent:menus
and signal_menu = new Jg_menu.c "Signal" ~parent:menus in
- pack [menus] ~side:`Top ~fill:`X;
- pack [file_menu#button; history_menu#button; signal_menu#button]
- ~side:`Left ~ipadx:5 ~anchor:`W;
let frame, tw, sb = Jg_text.create_with_scrollbar tl in
Text.configure tw ~background:`White;
pack [sb] ~fill:`Y ~side:`Right;
(* *)
(*************************************************************************)
-(* $Id: viewer.ml,v 1.32 2005/03/23 03:08:37 garrigue Exp $ *)
+(* $Id: viewer.ml,v 1.32.4.1 2005/12/09 12:29:55 garrigue Exp $ *)
open StdLabels
open Tk
(* Launch the classical viewer *)
let f ?(dir=Unix.getcwd()) ?on () =
- let tl = match on with
+ let (top, tl) = match on with
None ->
let tl = Jg_toplevel.titled "Module viewer" in
- ignore (Jg_bind.escape_destroy tl); coe tl
+ ignore (Jg_bind.escape_destroy tl); (tl, coe tl)
| Some top ->
Wm.title_set top "OCamlBrowser";
Wm.iconname_set top "OCamlBrowser";
let tl = Frame.create top in
bind tl ~events:[`Destroy] ~action:(fun _ -> exit 0);
pack [tl] ~expand:true ~fill:`Both;
- coe tl
+ (top, coe tl)
in
- let menus = Frame.create tl ~name:"menubar" in
+ let menus = Jg_menu.menubar top in
let filemenu = new Jg_menu.c "File" ~parent:menus
and modmenu = new Jg_menu.c "Modules" ~parent:menus in
let fmbox, mbox, msb = Jg_box.create_with_scrollbar tl in
~command:(fun () -> reset_modules mbox; Env.reset_cache ());
modmenu#add_command "Search symbol..." ~command:search_symbol;
- pack [filemenu#button; modmenu#button] ~side:`Left ~ipadx:5 ~anchor:`W;
- pack [menus] ~side:`Top ~fill:`X;
pack [close; search] ~fill:`X ~side:`Right ~expand:true;
pack [coe buttons; coe ew] ~fill:`X ~side:`Bottom;
pack [msb] ~side:`Right ~fill:`Y;
(* Smalltalk-like version *)
class st_viewer ?(dir=Unix.getcwd()) ?on () =
- let tl = match on with
+ let (top, tl) = match on with
None ->
let tl = Jg_toplevel.titled "Module viewer" in
- ignore (Jg_bind.escape_destroy tl); coe tl
+ ignore (Jg_bind.escape_destroy tl); (tl, coe tl)
| Some top ->
Wm.title_set top "OCamlBrowser";
Wm.iconname_set top "OCamlBrowser";
let tl = Frame.create top in
bind tl ~events:[`Destroy] ~action:(fun _ -> exit 0);
- pack [tl] ~expand:true ~fill:`Both;
- coe tl
+ pack [tl] ~side:`Bottom ~expand:true ~fill:`Both;
+ (top, coe tl)
in
- let menus = Frame.create tl ~name:"menubar" in
+ let menus = Menu.create top ~name:"menubar" ~typ:`Menubar in
+ let () = Toplevel.configure top ~menu:menus in
let filemenu = new Jg_menu.c "File" ~parent:menus
and modmenu = new Jg_menu.c "Modules" ~parent:menus
and viewmenu = new Jg_menu.c "View" ~parent:menus
(* Help menu *)
helpmenu#add_command "Manual..." ~command:show_help;
- pack [filemenu#button; viewmenu#button; modmenu#button]
- ~side:`Left ~ipadx:5 ~anchor:`W;
- pack [helpmenu#button] ~side:`Right ~anchor:`E ~ipadx:5;
- pack [menus] ~fill:`X;
pack [search_frame] ~fill:`X;
pack [boxes_frame] ~fill:`Both ~expand:true;
pack [buttons] ~fill:`X ~side:`Bottom;
Button.create cvs
[Text "Save";
Command
- (function _ ->
+ (function _ ->
let s =
getSaveFile
[Title "SAVE FILE TEST";
FileTypes [ { typename= "just test";
extensions= [".foo"; ".test"];
mactypes= ["FOOO"; "BARR"] } ];
- InitialDir "/tmp";
+ InitialDir Filename.temp_dir_name;
InitialFile "hogehoge" ] in
Label.configure t [Text s])];;
(* check Tkanim package is in the interpreter *)
let available () =
- let packages =
+ let packages =
splitlist (Protocol.tkEval [| TkToken "package";
TkToken "names" |])
in
(* But just do some operation. And sometimes it causes Seg-fault. *)
(* So, before using Imagephoto.copy, I should check the source image *)
(* really exists. *)
- try ignore (Imagephoto.height img) with
+ try ignore (Imagephoto.height img) with
TkError s -> prerr_endline ("tkanim: " ^ s); raise (TkError s)
let imagephoto_copy dst src opts =
image_existence_check src;
Imagephoto.copy dst src opts
-let animate_gen w i anim =
+let animate_gen w i anim =
let length = List.length anim.frames in
let frames = Array.of_list anim.frames in
let current = ref 0 in
let loop = ref anim.loop in
let f = frames.(!current) in
- imagephoto_copy i f.imagephoto
- [ImgTo (f.left, f.top, f.left + f.frameWidth,
- f.top + f.frameHeight)];
+ imagephoto_copy i f.imagephoto
+ [ImgTo (f.left, f.top, f.left + f.frameWidth,
+ f.top + f.frameHeight)];
let visible = ref true in
let animated = ref false in
let timer = ref None in
animate_gen canvas i anim
let gifdata s =
- let tmp_dir = ref "/tmp" in
+ let tmp_dir = ref Filename.temp_dir_name in
let mktemp =
- let cnter = ref 0
+ let cnter = ref 0
and pid = Unix.getpid() in
(function prefx ->
incr cnter;
anim
with
e -> begin Unix.unlink fname; raise e end
-
+
(* *)
(***********************************************************************)
-(* $Id: str.ml,v 1.19 2004/02/17 10:13:50 xleroy Exp $ *)
+(* $Id: str.ml,v 1.19.10.1 2005/11/07 15:59:04 doligez Exp $ *)
(** String utilities *)
(* Add a new instruction *)
let emit_instr opc arg =
if !progpos >= Array.length !prog then begin
- let nprog = Array.make (2 * Array.length !prog) 0 in
+ let newlen = ref (Array.length !prog) in
+ while !progpos >= !newlen do newlen := !newlen * 2 done;
+ let nprog = Array.make !newlen 0 in
Array.blit !prog 0 nprog 0 (Array.length !prog);
prog := nprog
end;
/* */
/***********************************************************************/
-/* $Id: win32.c,v 1.42 2005/09/22 14:21:50 xleroy Exp $ */
+/* $Id: win32.c,v 1.42.2.1 2005/12/07 12:30:59 xleroy Exp $ */
/* Thread interface for Win32 threads */
/* The "tick" thread fakes a signal at regular intervals. */
-static void caml_thread_tick(void * arg)
+static DWORD WINAPI caml_thread_tick(void * arg)
{
while(1) {
Sleep(Thread_timeout);
value vthread = Val_unit;
value descr;
HANDLE tick_thread;
- uintnat tick_id;
+ DWORD th_id;
/* Protect against repeated initialization (PR#1325) */
if (curr_thread != NULL) return Val_unit;
caml_channel_mutex_unlock = caml_io_mutex_unlock;
caml_channel_mutex_unlock_exn = caml_io_mutex_unlock_exn;
/* Fork the tick thread */
- tick_thread = (HANDLE) _beginthread(caml_thread_tick, 0, NULL);
- if (tick_thread == (HANDLE)(-1)) caml_wthread_error("Thread.init");
+ tick_thread = CreateThread(NULL, 0, caml_thread_tick, NULL, 0, &th_id);
+ if (tick_thread == NULL) caml_wthread_error("Thread.init");
CloseHandle(tick_thread);
End_roots();
return Val_unit;
/* Create a thread */
-static void caml_thread_start(void * arg)
+static DWORD WINAPI caml_thread_start(void * arg)
{
caml_thread_t th = (caml_thread_t) arg;
value clos;
/* Free the thread descriptor */
stat_free(th);
/* The thread now stops running */
+ return 0;
}
CAMLprim value caml_thread_new(value clos)
caml_thread_t th;
value vthread = Val_unit;
value descr;
- uintnat th_id;
+ DWORD th_id;
Begin_roots2 (clos, vthread)
/* Create a finalized value to hold thread handle */
curr_thread->next->prev = th;
curr_thread->next = th;
/* Fork the new thread */
-#if 0
th->wthread =
- CreateThread(NULL,0, (LPTHREAD_START_ROUTINE) caml_thread_start,
- (void *) th, 0, &th_id);
+ CreateThread(NULL, 0, caml_thread_start, (void *) th, 0, &th_id);
if (th->wthread == NULL) {
-#endif
- th->wthread = (HANDLE) _beginthread(caml_thread_start, 0, (void *) th);
- if (th->wthread == (HANDLE)(-1)) {
/* Fork failed, remove thread info block from list of threads */
th->next->prev = curr_thread;
curr_thread->next = th->next;
CAMLprim value caml_thread_join(value th)
{
HANDLE h;
+
Begin_root(th) /* prevent deallocation of handle */
h = Threadhandle(th)->handle;
enter_blocking_section();
(* *)
(***********************************************************************)
-(* $Id: unix.mli,v 1.81 2005/03/24 17:20:53 doligez Exp $ *)
+(* $Id: unix.mli,v 1.81.4.1 2005/11/22 11:58:47 doligez Exp $ *)
(** Interface to the Unix system *)
| EOVERFLOW (** File size or position not representable *)
| EUNKNOWNERR of int (** Unknown error *)
-(** The type of error codes.
+(** The type of error codes.
Errors defined in the POSIX standard
and additional errors from UNIX98 and BSD.
All other errors are mapped to EUNKNOWNERR.
val environment : unit -> string array
(** Return the process environment, as an array of strings
with the format ``variable=value''. *)
-
+
val getenv : string -> string
(** Return the value associated to a variable in the process
environment. Raise [Not_found] if the variable is unbound.
type process_status =
- WEXITED of int
- (** The process terminated normally by [exit];
+ WEXITED of int
+ (** The process terminated normally by [exit];
the argument is the return code. *)
| WSIGNALED of int
(** The process was killed by a signal;
val execv : string -> string array -> 'a
(** [execv prog args] execute the program in file [prog], with
- the arguments [args], and the current process environment.
- These [execv*] functions never return: on success, the current
- program is replaced by the new one;
+ the arguments [args], and the current process environment.
+ These [execv*] functions never return: on success, the current
+ program is replaced by the new one;
on failure, a {!Unix.Unix_error} exception is raised. *)
val execve : string -> string array -> string array -> 'a
type file_perm = int
-(** The type of file access rights, e.g. [0o640] is read and write for user,
+(** The type of file access rights, e.g. [0o640] is read and write for user,
read for group, none for others *)
val openfile : string -> open_flag list -> file_perm -> file_descr
to the given size. *)
-(** {6 File statistics} *)
+(** {6 File status} *)
type file_kind =
st_size : int; (** Size in bytes *)
st_atime : float; (** Last access time *)
st_mtime : float; (** Last modification time *)
- st_ctime : float; (** Last status change time *)
+ st_ctime : float; (** Last status change time *)
}
(** The informations returned by the {!Unix.stat} calls. *)
st_size : int64; (** Size in bytes *)
st_atime : float; (** Last access time *)
st_mtime : float; (** Last modification time *)
- st_ctime : float; (** Last status change time *)
+ st_ctime : float; (** Last status change time *)
}
val stat : string -> stats
val lstat : string -> stats
and standard error of the command. *)
val close_process_in : in_channel -> process_status
-(** Close channels opened by {!Unix.open_process_in},
+(** Close channels opened by {!Unix.open_process_in},
wait for the associated command to terminate,
and return its termination status. *)
val close_process_out : out_channel -> process_status
-(** Close channels opened by {!Unix.open_process_out},
+(** Close channels opened by {!Unix.open_process_out},
wait for the associated command to terminate,
and return its termination status. *)
val close_process : in_channel * out_channel -> process_status
-(** Close channels opened by {!Unix.open_process},
+(** Close channels opened by {!Unix.open_process},
wait for the associated command to terminate,
and return its termination status. *)
val close_process_full :
in_channel * out_channel * in_channel -> process_status
-(** Close channels opened by {!Unix.open_process_full},
+(** Close channels opened by {!Unix.open_process_full},
wait for the associated command to terminate,
and return its termination status. *)
(** {6 Signals}
Note: installation of signal handlers is performed via
- the functions {!Sys.signal} and {!Sys.set_signal}.
+ the functions {!Sys.signal} and {!Sys.set_signal}.
*)
val kill : int -> int -> unit
(** [kill pid sig] sends signal number [sig] to the process
with id [pid]. *)
-type sigprocmask_command =
+type sigprocmask_command =
SIG_SETMASK
| SIG_BLOCK
| SIG_UNBLOCK
{ tms_utime : float; (** User time for the process *)
tms_stime : float; (** System time for the process *)
tms_cutime : float; (** User time for the children processes *)
- tms_cstime : float; (** System time for the children processes *)
+ tms_cstime : float; (** System time for the children processes *)
}
(** The execution times (CPU times) of a process. *)
tm_year : int; (** Year - 1900 *)
tm_wday : int; (** Day of week (Sunday is 0) *)
tm_yday : int; (** Day of year 0..365 *)
- tm_isdst : bool; (** Daylight time savings in effect *)
+ tm_isdst : bool; (** Daylight time savings in effect *)
}
(** The type representing wallclock time and calendar date. *)
00:00:00 GMT, Jan. 1, 1970. *)
type interval_timer =
- ITIMER_REAL
+ ITIMER_REAL
(** decrements in real time, and sends the signal [SIGALRM] when expired.*)
| ITIMER_VIRTUAL
(** decrements in process virtual time, and sends [SIGVTALRM] when expired. *)
type interval_timer_status =
{ it_interval : float; (** Period *)
- it_value : float; (** Current value of the timer *)
+ it_value : float; (** Current value of the timer *)
}
(** The type describing the status of an interval timer *)
pw_gid : int;
pw_gecos : string;
pw_dir : string;
- pw_shell : string
+ pw_shell : string
}
(** Structure of entries in the [passwd] database. *)
{ gr_name : string;
gr_passwd : string;
gr_gid : int;
- gr_mem : string array
+ gr_mem : string array
}
(** Structure of entries in the [groups] database. *)
val getpeername : file_descr -> sockaddr
(** Return the address of the host connected to the given socket. *)
-type msg_flag =
+type msg_flag =
MSG_OOB
| MSG_DONTROUTE
| MSG_PEEK
-(** The flags for {!Unix.recv}, {!Unix.recvfrom},
+(** The flags for {!Unix.recv}, {!Unix.recvfrom},
{!Unix.send} and {!Unix.sendto}. *)
val recv : file_descr -> string -> int -> int -> msg_flag list -> int
(** The socket options that can be consulted with {!Unix.getsockopt_optint}
and modified with {!Unix.setsockopt_optint}. These options have a
value of type [int option], with [None] meaning ``disabled''. *)
-
+
type socket_float_option =
SO_RCVTIMEO (** Timeout for input operations *)
| SO_SNDTIMEO (** Timeout for output operations *)
{ h_name : string;
h_aliases : string array;
h_addrtype : socket_domain;
- h_addr_list : inet_addr array
+ h_addr_list : inet_addr array
}
(** Structure of entries in the [hosts] database. *)
type protocol_entry =
- { p_name : string;
- p_aliases : string array;
- p_proto : int
+ { p_name : string;
+ p_aliases : string array;
+ p_proto : int
}
(** Structure of entries in the [protocols] database. *)
{ s_name : string;
s_aliases : string array;
s_port : int;
- s_proto : string
+ s_proto : string
}
(** Structure of entries in the [services] database. *)
AI_FAMILY of socket_domain (** Impose the given socket domain *)
| AI_SOCKTYPE of socket_type (** Impose the given socket type *)
| AI_PROTOCOL of int (** Impose the given protocol *)
- | AI_NUMERICHOST (** Do not call name resolver,
+ | AI_NUMERICHOST (** Do not call name resolver,
expect numeric IP address *)
| AI_CANONNAME (** Fill the [ai_canonname] field
of the result *)
for use with {!Unix.bind} *)
(** Options to {!Unix.getaddrinfo}. *)
-val getaddrinfo:
+val getaddrinfo:
string -> string -> getaddrinfo_option list -> addr_info list
(** [getaddrinfo host service opts] returns a list of {!Unix.addr_info}
records describing socket parameters and addresses suitable for
complete description. *)
type terminal_io =
- {
+ {
(* input modes *)
mutable c_ignbrk : bool; (** Ignore the break condition. *)
mutable c_brkint : bool; (** Signal interrupt on break condition. *)
before the read request is satisfied. *)
mutable c_vtime : int; (** Maximum read wait (in 0.1s units). *)
mutable c_vstart : char; (** Start character (usually ctrl-Q). *)
- mutable c_vstop : char; (** Stop character (usually ctrl-S). *)
+ mutable c_vstop : char; (** Stop character (usually ctrl-S). *)
}
val tcgetattr : file_descr -> terminal_io
(** Return the status of the terminal referred to by the given
file descriptor. *)
-type setattr_when =
+type setattr_when =
TCSANOW
| TCSADRAIN
| TCSAFLUSH
(** Waits until all output written on the given file descriptor
has been transmitted. *)
-type flush_queue =
+type flush_queue =
TCIFLUSH
| TCOFLUSH
| TCIOFLUSH
[TCOFLUSH] flushes data written but not transmitted, and
[TCIOFLUSH] flushes both. *)
-type flow_action =
+type flow_action =
TCOOFF
| TCOON
| TCIOFF
(* *)
(***********************************************************************)
-(* $Id: printast.ml,v 1.28 2005/03/23 03:08:37 garrigue Exp $ *)
+(* $Id: printast.ml,v 1.28.4.1 2005/11/16 16:01:12 doligez Exp $ *)
open Asttypes;;
open Format;;
and class_field i ppf x =
match x with
| Pcf_inher (ce, so) ->
- printf "Pcf_inher\n";
+ line i ppf "Pcf_inher\n";
class_expr (i+1) ppf ce;
option (i+1) string ppf so;
| Pcf_val (s, mf, e, loc) ->
(* *)
(***********************************************************************)
-(* $Id: filename.ml,v 1.37 2005/10/25 18:34:07 doligez Exp $ *)
+(* $Id: filename.ml,v 1.37.2.1 2005/11/29 12:17:27 doligez Exp $ *)
let generic_quote quotequote s =
let l = String.length s in
String.length name >= String.length suff &&
String.sub name (String.length name - String.length suff)
(String.length suff) = suff
- let temporary_directory =
+ let temp_dir_name =
try Sys.getenv "TMPDIR" with Not_found -> "/tmp"
let quote = generic_quote "'\\''"
end
(let s = String.sub name (String.length name - String.length suff)
(String.length suff) in
String.lowercase s = String.lowercase suff)
- let temporary_directory =
+ let temp_dir_name =
try Sys.getenv "TEMP" with Not_found -> "."
let quote s =
let l = String.length s in
let is_relative = Win32.is_relative
let is_implicit = Win32.is_implicit
let check_suffix = Win32.check_suffix
- let temporary_directory = Unix.temporary_directory
+ let temp_dir_name = Unix.temp_dir_name
let quote = Unix.quote
end
let (current_dir_name, parent_dir_name, dir_sep, is_dir_sep, rindex_dir_sep,
- is_relative, is_implicit, check_suffix, temporary_directory, quote) =
+ is_relative, is_implicit, check_suffix, temp_dir_name, quote) =
match Sys.os_type with
"Unix" ->
(Unix.current_dir_name, Unix.parent_dir_name, Unix.dir_sep,
Unix.is_dir_sep, Unix.rindex_dir_sep,
Unix.is_relative, Unix.is_implicit, Unix.check_suffix,
- Unix.temporary_directory, Unix.quote)
+ Unix.temp_dir_name, Unix.quote)
| "Win32" ->
(Win32.current_dir_name, Win32.parent_dir_name, Win32.dir_sep,
Win32.is_dir_sep, Win32.rindex_dir_sep,
Win32.is_relative, Win32.is_implicit, Win32.check_suffix,
- Win32.temporary_directory, Win32.quote)
+ Win32.temp_dir_name, Win32.quote)
| "Cygwin" ->
(Cygwin.current_dir_name, Cygwin.parent_dir_name, Cygwin.dir_sep,
Cygwin.is_dir_sep, Cygwin.rindex_dir_sep,
Cygwin.is_relative, Cygwin.is_implicit, Cygwin.check_suffix,
- Cygwin.temporary_directory, Cygwin.quote)
+ Cygwin.temp_dir_name, Cygwin.quote)
| _ -> assert false
let concat dirname filename =
let temp_file_name prefix suffix =
let rnd = (Random.State.bits prng) land 0xFFFFFF in
- concat temporary_directory (Printf.sprintf "%s%06x%s" prefix rnd suffix)
+ concat temp_dir_name (Printf.sprintf "%s%06x%s" prefix rnd suffix)
;;
let temp_file prefix suffix =
(* *)
(***********************************************************************)
-(* $Id: filename.mli,v 1.33 2005/10/25 18:34:07 doligez Exp $ *)
+(* $Id: filename.mli,v 1.33.2.1 2005/11/29 12:17:27 doligez Exp $ *)
(** Operations on file names. *)
(readable and writable only by the file owner). The file is
guaranteed to be different from any other file that existed when
[temp_file] was called.
- Under Unix, the temporary directory is [/tmp] by default; if set,
- the value of the environment variable [TMPDIR] is used instead.
- Under Windows, the name of the temporary directory is the
- value of the environment variable [TEMP], or [C:\temp] by default. *)
+*)
val open_temp_file :
?mode: open_flag list -> string -> string -> string * out_channel
It can contain one or several of [Open_append], [Open_binary],
and [Open_text]. The default is [[Open_text]] (open in text mode). *)
+val temp_dir_name : string
+(** The name of the temporary directory:
+ Under Unix, the value of the [TMPDIR] environment variable, or "/tmp"
+ if the variable is not set.
+ Under Windows, the value of the [TEMP] environment variable, or "."
+ if the variable is not set.
+*)
+
val quote : string -> string
(** Return a quoted version of a file name, suitable for use as
one argument in a shell command line, escaping all shell
(* *)
(***********************************************************************)
-(* $Id: printf.mli,v 1.46 2005/09/26 10:12:01 weis Exp $ *)
+(* $Id: printf.mli,v 1.46.2.1 2005/12/15 12:46:10 doligez Exp $ *)
(** Formatted output functions. *)
[out_channel -> unit]) and apply it to [outchan].
- [\{ fmt %\}]: convert a format string argument. The argument must
have the same type as the internal format string [fmt].
- - [\( fmt %\)]: format string substitution. Takes a format string
+ - [( fmt %)]: format string substitution. Takes a format string
argument and substitutes it to the internal format string [fmt]
to print following arguments. The argument must have the same
type as [fmt].
(* *)
(***********************************************************************)
-(* $Id: scanf.ml,v 1.63 2005/09/20 21:42:44 weis Exp $ *)
+(* $Id: scanf.ml,v 1.63.2.2 2006/01/03 17:32:43 weis Exp $ *)
(* The run-time library for scanners. *)
| 'B' | 'b' ->
let _x = scan_bool max ib in
scan_fmt (stack f (token_bool ib)) (i + 1)
- | 'l' | 'n' | 'L' as conv ->
+ | 'l' | 'n' | 'L' as typ ->
let i = i + 1 in
- if i > lim then scan_fmt (stack f (get_count conv ib)) i else begin
+ if i > lim then scan_fmt (stack f (get_count typ ib)) i else begin
match fmt.[i] with
| 'd' | 'i' | 'o' | 'u' | 'x' | 'X' as conv ->
let _x = scan_int_conv conv max ib in
- begin match conv with
+ begin match typ with
| 'l' -> scan_fmt (stack f (token_int32 conv ib)) (i + 1)
| 'n' -> scan_fmt (stack f (token_nativeint conv ib)) (i + 1)
| _ -> scan_fmt (stack f (token_int64 conv ib)) (i + 1) end
- | c -> scan_fmt (stack f (get_count conv ib)) i end
+ | c -> scan_fmt (stack f (get_count typ ib)) i end
| 'N' as conv ->
scan_fmt (stack f (get_count conv ib)) (i + 1)
| '!' ->
let _x = scan_String max ib in
let rf = token_string ib in
if not (compatible_format_type mf rf)
- then format_mismatch rf mf ib else
+ then format_mismatch rf mf ib else
if conv = '{' then scan_fmt (stack f rf) j else
let nf = scan_fmt (Obj.magic rf) 0 in
scan_fmt (stack f nf) j
let scanf fmt = bscanf Scanning.stdib fmt;;
-let bscanf_format ib fmt2 f =
+let bscanf_format ib fmt f =
+ let fmt = format_to_string fmt in
let fmt1 = ignore (scan_String max_int ib); token_string ib in
- let fmt2 = format_to_string fmt2 in
- if compatible_format_type fmt1 fmt2
- then let fresh_fmt = String.copy fmt1 in f (string_to_format fresh_fmt)
- else format_mismatch fmt1 fmt2 ib;;
+ if not (compatible_format_type fmt1 fmt) then
+ format_mismatch fmt1 fmt ib else
+ let fresh_fmt1 = String.copy fmt1 in
+ f (string_to_format fresh_fmt1);;
let sscanf_format s fmt =
let fmt = format_to_string fmt in
- if compatible_format_type s fmt
- then let fresh_fmt = String.copy s in string_to_format fresh_fmt
- else bad_input (format_mismatch_err s fmt);;
+ let fmt1 = s in
+ if not (compatible_format_type fmt1 fmt) then
+ bad_input (format_mismatch_err fmt1 fmt) else
+ let fresh_fmt1 = String.copy fmt1 in
+ string_to_format fresh_fmt1;;
(* *)
(***********************************************************************)
-(* $Id: scanf.mli,v 1.58 2005/09/20 21:42:44 weis Exp $ *)
+(* $Id: scanf.mli,v 1.58.2.1 2006/01/03 17:16:01 weis Exp $ *)
(** Formatted input functions. *)
val bscanf_format :
Scanning.scanbuf -> ('a, 'b, 'c, 'd) format4 ->
(('a, 'b, 'c, 'd) format4 -> 'e) -> 'e;;
-(** [bscanf_format ib fmt f] reads a [format] argument to the format
- specified by the second argument. The [format] argument read in
- buffer [ib] must have the same type as [fmt]. *)
+
+(** [bscanf_format ib fmt f] reads a format string token in buffer [ib],
+ according to the format string [fmt], and applies the function [f] to the
+ resulting format string value.
+ Raises [Scan_failure] if the format string value read has not the same type
+ as [fmt]. *)
val sscanf_format :
string -> ('a, 'b, 'c, 'd) format4 -> ('a, 'b, 'c, 'd) format4;;
-(** [sscanf_format ib fmt f] reads a [format] argument to the format
- specified by the second argument and returns it. The [format]
- argument read in string [s] must have the same type as [fmt]. *)
+(** Same as {!Scanf.bscanf_format}, but converts the given string to a format
+ string. *)
(* *)
(***********************************************************************)
-(* $Id: sys.ml,v 1.138.2.1 2005/10/26 15:25:30 xleroy Exp $ *)
+(* $Id: sys.ml,v 1.138.2.8 2006/01/04 13:05:49 doligez Exp $ *)
(* System interface *)
(* OCaml version string, must be in the format described in sys.mli. *)
-let ocaml_version = "3.09.0";;
+let ocaml_version = "3.09.1";;
# #
#########################################################################
-# $Id: Makefile,v 1.61 2005/08/01 15:51:09 xleroy Exp $
+# $Id: Makefile,v 1.61.2.1 2005/11/17 14:26:37 doligez Exp $
include ../config/Makefile
COMPFLAGS= -warn-error A $(INCLUDES)
LINKFLAGS=$(INCLUDES)
-all: ocamldep ocamlprof ocamlcp ocamlmktop ocamlmklib scrapelabels addlabels
+all: ocamldep ocamlprof ocamlcp ocamlmktop ocamlmklib scrapelabels addlabels \
+ dumpobj
opt.opt: ocamldep.opt
(* *)
(***********************************************************************)
-(* $Id: dumpobj.ml,v 1.35 2005/06/22 13:49:35 doligez Exp $ *)
+(* $Id: dumpobj.ml,v 1.35.2.2 2006/01/04 09:22:50 xleroy Exp $ *)
(* Disassembler for executable and .cmo object files *)
-open Obj
-open Printf
-open Config
open Asttypes
-open Lambda
+open Config
open Emitcode
-open Opcodes
open Instruct
+open Lambda
+open Location
+open Obj
+open Opcodes
open Opnames
+open Printf
(* Read signed and unsigned integers *)
(* Print an obj *)
+let same_custom x y =
+ Obj.field x 0 = Obj.field (Obj.repr y) 0
+
let rec print_obj x =
if Obj.is_block x then begin
let tag = Obj.tag x in
printf "%.12g" a.(i)
done;
printf "|]"
- end else if tag < Obj.no_scan_tag then begin
+ end else if tag = Obj.custom_tag && same_custom x 0l then
+ printf "%ldl" (Obj.magic x : int32)
+ else if tag = Obj.custom_tag && same_custom x 0n then
+ printf "%ndn" (Obj.magic x : nativeint)
+ else if tag = Obj.custom_tag && same_custom x 0L then
+ printf "%LdL" (Obj.magic x : int64)
+ else if tag < Obj.no_scan_tag then begin
printf "<%d>" (Obj.tag x);
match Obj.size x with
0 -> ()
];;
let print_event ev =
- printf "File \"%s\", line %d, character %d:\n" ev.ev_char.Lexing.pos_fname
- ev.ev_char.Lexing.pos_lnum
- (ev.ev_char.Lexing.pos_cnum - ev.ev_char.Lexing.pos_bol)
+ let ls = ev.ev_loc.loc_start in
+ let le = ev.ev_loc.loc_end in
+ printf "File \"%s\", line %d, characters %d-%d:\n" ls.Lexing.pos_fname
+ ls.Lexing.pos_lnum (ls.Lexing.pos_cnum - ls.Lexing.pos_bol)
+ (le.Lexing.pos_cnum - ls.Lexing.pos_bol)
let print_instr ic =
let pos = currpos ic in
# #
#########################################################################
-# $Id: make-package-macosx,v 1.10 2005/08/13 20:59:37 doligez Exp $
+# $Id: make-package-macosx,v 1.10.2.2 2006/01/04 13:05:49 doligez Exp $
cd package-macosx
rm -rf ocaml.pkg ocaml-rw.dmg
# stop here -> |
cat >resources/ReadMe.txt <<EOF
This package installs Objective Caml version ${VERSION}.
-You need Mac OS X 10.3 (panther), with X11 and the
-XCode tools installed.
+You need Mac OS X 10.4.x (Tiger), with X11 and the
+XCode tools (v2.2) installed.
Files will be installed in the following directories:
# #
#########################################################################
-# $Id: ocaml-objcopy-macosx,v 1.1 2005/01/21 18:15:55 doligez Exp $
+# $Id: ocaml-objcopy-macosx,v 1.1.10.1 2005/11/29 12:17:27 doligez Exp $
-TEMP=/tmp/ocaml-objcopy-$$.o
-UNDEF=/tmp/ocaml-objcopy-$$.sym
+TMP="${TMPDIR=/tmp}"
+TEMP="${TMP}"/ocaml-objcopy-$$.o
+UNDEF="${TMP}"/ocaml-objcopy-$$.sym
usage () {
echo "usage: objcopy {--redefine-sym <old>=<new>} file.o" >&2
(* *)
(***********************************************************************)
-(* $Id: toploop.ml,v 1.92 2005/08/08 09:41:51 xleroy Exp $ *)
+(* $Id: toploop.ml,v 1.92.2.1 2005/11/16 16:37:20 doligez Exp $ *)
(* The interactive toplevel loop *)
may_trace := true;
let retval = (Meta.reify_bytecode code code_size) () in
may_trace := false;
- if can_free then begin
+ if can_free then begin
Meta.static_release_bytecode code code_size;
Meta.static_free code;
end;
Result retval
with x ->
may_trace := false;
- if can_free then begin
+ if can_free then begin
Meta.static_release_bytecode code code_size;
Meta.static_free code;
end;
let outv = outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn in
print_out_exception ppf exn outv
-(* The table of toplevel directives.
+(* The table of toplevel directives.
Filled by functions from module topdirs. *)
let directive_table = (Hashtbl.create 13 : (string, directive_fun) Hashtbl.t)
match phr with
| Ptop_def sstr ->
let oldenv = !toplevel_env in
+ let _ = Unused_var.warn ppf sstr in
Typecore.reset_delayed_checks ();
let (str, sg, newenv) = Typemod.type_structure oldenv sstr in
Typecore.force_delayed_checks ();
end
with x ->
toplevel_env := oldenv; raise x
- end
+ end
| Ptop_dir(dir_name, dir_arg) ->
try
match (Hashtbl.find directive_table dir_name, dir_arg) with
let protect r newval body =
let oldval = !r in
try
- r := newval;
+ r := newval;
let res = body() in
r := oldval;
res
(* *)
(***********************************************************************)
-(* $Id: btype.ml,v 1.37 2005/03/23 03:08:37 garrigue Exp $ *)
+(* $Id: btype.ml,v 1.37.4.1 2005/12/05 13:18:42 garrigue Exp $ *)
(* Basic operations on core types *)
| Tobject(ty, {contents = Some (p, tl)})
-> Tobject (f ty, ref (Some(p, List.map f tl)))
| Tobject (ty, _) -> Tobject (f ty, ref None)
- | Tvariant row ->
- let row = row_repr row in
- Tvariant (copy_row f true row false (f row.row_more))
- | Tfield (p, k, ty1, ty2) -> Tfield (p, copy_kind k, f ty1, f ty2)
+ | Tvariant row -> assert false (* too ambiguous *)
+ | Tfield (p, k, ty1, ty2) -> (* the kind is kept shared *)
+ Tfield (p, field_kind_repr k, f ty1, f ty2)
| Tnil -> Tnil
| Tlink ty -> copy_type_desc f ty.desc
| Tsubst ty -> assert false
let save_desc ty desc =
saved_desc := (ty, desc)::!saved_desc
+let saved_kinds = ref [] (* duplicated kind variables *)
+let new_kinds = ref [] (* new kind variables *)
+let dup_kind r =
+ (match !r with None -> () | Some _ -> assert false);
+ if not (List.memq r !new_kinds) then begin
+ saved_kinds := r :: !saved_kinds;
+ let r' = ref None in
+ new_kinds := r' :: !new_kinds;
+ r := Some (Fvar r')
+ end
+
(* Restored type descriptions. *)
let cleanup_types () =
List.iter (fun (ty, desc) -> ty.desc <- desc) !saved_desc;
- saved_desc := []
+ List.iter (fun r -> r := None) !saved_kinds;
+ saved_desc := []; saved_kinds := []; new_kinds := []
(* Mark a type. *)
let rec mark_type ty =
(* *)
(***********************************************************************)
-(* $Id: btype.mli,v 1.17 2005/03/23 03:08:37 garrigue Exp $ *)
+(* $Id: btype.mli,v 1.17.4.1 2005/12/05 13:18:43 garrigue Exp $ *)
(* Basic operations on core types *)
val save_desc: type_expr -> type_desc -> unit
(* Save a type description *)
+val dup_kind: field_kind option ref -> unit
+ (* Save a None field_kind, and make it point to a fresh Fvar *)
val cleanup_types: unit -> unit
(* Restore type descriptions *)
(* *)
(***********************************************************************)
-(* $Id: ctype.ml,v 1.197 2005/09/20 04:08:49 garrigue Exp $ *)
+(* $Id: ctype.ml,v 1.197.2.6 2005/12/15 02:28:38 garrigue Exp $ *)
(* Operations on core types *)
match ty.desc with
Tvariant row ->
let more = row_more row in
- if more.level <> generic_level then generalize_parents more
+ let lv = more.level in
+ if (lv < lowest_level || lv > !current_level)
+ && lv <> generic_level then set_level more generic_level
| _ -> ()
end
in
(* Return a new copy *)
Tvariant (copy_row copy true row keep more')
end
+ | Tfield (p, k, ty1, ty2) ->
+ begin match field_kind_repr k with
+ Fabsent -> Tlink (copy ty2)
+ | Fpresent -> copy_type_desc copy desc
+ | Fvar r ->
+ dup_kind r;
+ copy_type_desc copy desc
+ end
| _ -> copy_type_desc copy desc
end;
t
| _ ->
assert false
-(* Fully expand the head of a type. Raise an exception if the type
- cannot be expanded. *)
+(* Fully expand the head of a type.
+ Raise Cannot_expand if the type cannot be expanded.
+ May raise Unify, if a recursion was hidden in the type. *)
let rec try_expand_head env ty =
let ty = repr ty in
match ty.desc with
(* Fully expand the head of a type. *)
let rec expand_head env ty =
- try try_expand_head env ty with Cannot_expand -> repr ty
+ let snap = Btype.snapshot () in
+ try try_expand_head env ty
+ with Cannot_expand | Unify _ -> (* expand_head shall never fail *)
+ Btype.backtrack snap;
+ repr ty
(* Make sure that the type parameters of the type constructor [ty]
respect the type constraints *)
if not (closed_parameterized_type tl t2'') then
link_type (repr t2) (repr t2')
| _ ->
- assert false
+ () (* t2 has already been expanded by update_level *)
end
(*
(* *)
(***********************************************************************)
-(* $Id: printtyp.ml,v 1.139 2005/08/16 00:48:56 garrigue Exp $ *)
+(* $Id: printtyp.ml,v 1.139.2.2 2005/12/07 23:37:27 garrigue Exp $ *)
(* Printing functions *)
let rec list_of_memo = function
Mnil -> []
- | Mcons (p, t1, t2, rem) -> (p,t1,t2) :: list_of_memo rem
+ | Mcons (p, t1, t2, rem) -> p :: list_of_memo rem
| Mlink rem -> list_of_memo !rem
let visited = ref []
| Tconstr (p, tl, abbrev) ->
fprintf ppf "@[<hov1>Tconstr(@,%a,@,%a,@,%a)@]" path p
raw_type_list tl
- (raw_list (fun ppf (p,t1,t2) ->
- fprintf ppf "@[%a,@ %a,@ %a@]" path p raw_type t1 raw_type t2))
- (list_of_memo !abbrev)
+ (raw_list path) (list_of_memo !abbrev)
| Tobject (t, nm) ->
fprintf ppf "@[<hov1>Tobject(@,%a,@,@[<1>ref%t@])@]" raw_type t
(fun ppf ->
(* Print an exception declaration *)
let tree_of_exception_declaration id decl =
+ reset_and_mark_loops_list decl;
let tyl = tree_of_typlist false decl in
Osig_exception (Ident.name id, tyl)
Osig_type(tree_of_type_decl id decl, tree_of_rec rs) ::
tree_of_signature rem
| Tsig_exception(id, decl) :: rem ->
- Osig_exception (Ident.name id, tree_of_typlist false decl) ::
- tree_of_signature rem
+ tree_of_exception_declaration id decl :: tree_of_signature rem
| Tsig_module(id, mty, rs) :: rem ->
Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs) ::
tree_of_signature rem
(* *)
(***********************************************************************)
-(* $Id: subst.ml,v 1.48 2005/03/23 03:08:37 garrigue Exp $ *)
+(* $Id: subst.ml,v 1.48.4.1 2005/12/05 13:18:43 garrigue Exp $ *)
(* Substitutions *)
| None ->
Tvariant row
end
- | Tfield(label, kind, t1, t2) ->
- begin match field_kind_repr kind with
- Fpresent ->
- Tfield(label, Fpresent, typexp s t1, typexp s t2)
- | Fabsent ->
- Tlink (typexp s t2)
- | Fvar _ (* {contents = None} *) as k ->
- let k = if s.for_saving then Fvar(ref None) else k in
- Tfield(label, k, typexp s t1, typexp s t2)
- end
+ | Tfield(label, kind, t1, t2) when field_kind_repr kind = Fabsent ->
+ Tlink (typexp s t2)
| _ -> copy_type_desc (typexp s) desc
end;
ty'
(* *)
(***********************************************************************)
-(* $Id: typecore.ml,v 1.176 2005/09/15 03:09:26 garrigue Exp $ *)
+(* $Id: typecore.ml,v 1.176.2.2 2005/12/11 09:56:33 xleroy Exp $ *)
(* Typechecking for the core language *)
(* *)
(***********************************************************************)
-(* $Id: unused_var.ml,v 1.4 2004/11/30 18:57:04 doligez Exp $ *)
+(* $Id: unused_var.ml,v 1.4.10.2 2005/12/28 17:27:46 doligez Exp $ *)
open Parsetree
| Pexp_for (id, e1, e2, _, e3) ->
expression ppf tbl e1;
expression ppf tbl e2;
- let defined = ([ (id, e.pexp_loc, ref false) ], []) in
+ let defined = ([ (id, e.pexp_loc, ref true) ], []) in
add_vars tbl defined;
expression ppf tbl e3;
check_rm_vars ppf tbl defined;
and class_expr ppf tbl ce =
match ce.pcl_desc with
| Pcl_constr _ -> ()
- | Pcl_structure cs -> class_structure ppf tbl cs
- | Pcl_fun (_, _, _, ce) -> class_expr ppf tbl ce
- | Pcl_apply (ce, _) -> class_expr ppf tbl ce
+ | Pcl_structure cs -> class_structure ppf tbl cs;
+ | Pcl_fun (_, _, _, ce) -> class_expr ppf tbl ce;
+ | Pcl_apply (ce, lel) ->
+ class_expr ppf tbl ce;
+ List.iter (fun (_, e) -> expression ppf tbl e) lel;
| Pcl_let (recflag, pel, ce) ->
let_pel ppf tbl recflag pel (Some (fun ppf tbl -> class_expr ppf tbl ce));
| Pcl_constraint (ce, _) -> class_expr ppf tbl ce;
(* *)
(***********************************************************************)
-(* $Id: unused_var.mli,v 1.1 2005/10/26 12:39:02 doligez Exp $ *)
+(* $Id: unused_var.mli,v 1.1.4.1 2005/11/16 16:37:20 doligez Exp $ *)
val warn : Format.formatter -> Parsetree.structure -> Parsetree.structure;;
+(* Warn on unused variables; return the second argument. *)
projects / ocaml.git / commitdiff