498 lines
17 KiB
OCaml
498 lines
17 KiB
OCaml
(***********************************************************************)
|
|
(* *)
|
|
(* OCamldoc *)
|
|
(* *)
|
|
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
|
|
(* *)
|
|
(* Copyright 2001 Institut National de Recherche en Informatique et *)
|
|
(* en Automatique. All rights reserved. This file is distributed *)
|
|
(* under the terms of the Q Public License version 1.0. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
(** Analysis of source files. This module is strongly inspired from
|
|
driver/main.ml :-) *)
|
|
|
|
let print_DEBUG s = print_string s ; print_newline ()
|
|
|
|
open Config
|
|
open Clflags
|
|
open Misc
|
|
open Format
|
|
open Typedtree
|
|
|
|
|
|
(** Initialize the search path.
|
|
The current directory is always searched first,
|
|
then the directories specified with the -I option (in command-line order),
|
|
then the standard library directory. *)
|
|
let init_path () =
|
|
load_path :=
|
|
"" :: List.rev (Config.standard_library :: !Clflags.include_dirs);
|
|
Env.reset_cache ()
|
|
|
|
(** Return the initial environment in which compilation proceeds. *)
|
|
let initial_env () =
|
|
try
|
|
if !Clflags.nopervasives
|
|
then Env.initial
|
|
else Env.open_pers_signature "Pervasives" Env.initial
|
|
with Not_found ->
|
|
fatal_error "cannot open pervasives.cmi"
|
|
|
|
(** Optionally preprocess a source file *)
|
|
let preprocess sourcefile =
|
|
try
|
|
Pparse.preprocess sourcefile
|
|
with Pparse.Error err ->
|
|
Format.eprintf "Preprocessing error@.%a@."
|
|
Pparse.report_error err;
|
|
exit 2
|
|
|
|
let (++) x f = f x
|
|
|
|
(** Analysis of an implementation file. Returns (Some typedtree) if
|
|
no error occured, else None and an error message is printed.*)
|
|
let process_implementation_file ppf sourcefile =
|
|
init_path ();
|
|
let prefixname = Filename.chop_extension sourcefile in
|
|
let modulename = String.capitalize(Filename.basename prefixname) in
|
|
Env.set_unit_name modulename;
|
|
let inputfile = preprocess sourcefile in
|
|
let env = initial_env () in
|
|
try
|
|
let parsetree = Pparse.file Format.err_formatter inputfile Parse.implementation ast_impl_magic_number in
|
|
let typedtree =
|
|
Typemod.type_implementation
|
|
sourcefile prefixname modulename env parsetree
|
|
in
|
|
(Some (parsetree, typedtree), inputfile)
|
|
with
|
|
e ->
|
|
match e with
|
|
Syntaxerr.Error err ->
|
|
fprintf Format.err_formatter "@[%a@]@."
|
|
Syntaxerr.report_error err;
|
|
None, inputfile
|
|
| Failure s ->
|
|
prerr_endline s;
|
|
incr Odoc_global.errors ;
|
|
None, inputfile
|
|
| e ->
|
|
raise e
|
|
|
|
(** Analysis of an interface file. Returns (Some signature) if
|
|
no error occured, else None and an error message is printed.*)
|
|
let process_interface_file ppf sourcefile =
|
|
init_path ();
|
|
let prefixname = Filename.chop_extension sourcefile in
|
|
let modulename = String.capitalize(Filename.basename prefixname) in
|
|
Env.set_unit_name modulename;
|
|
let inputfile = preprocess sourcefile in
|
|
let ast = Pparse.file Format.err_formatter inputfile Parse.interface ast_intf_magic_number in
|
|
let sg = Typemod.transl_signature (initial_env()) ast in
|
|
Warnings.check_fatal ();
|
|
(ast, sg, inputfile)
|
|
|
|
(** The module used to analyse the parsetree and signature of an implementation file.*)
|
|
module Ast_analyser = Odoc_ast.Analyser (Odoc_comments.Basic_info_retriever)
|
|
|
|
(** The module used to analyse the parse tree and typed tree of an interface file.*)
|
|
module Sig_analyser = Odoc_sig.Analyser (Odoc_comments.Basic_info_retriever)
|
|
|
|
(** Handle an error. This is a partial copy of the compiler
|
|
driver/error.ml file. We do this because there are
|
|
some differences between the possibly raised exceptions
|
|
in the bytecode (error.ml) and opt (opterros.ml) compilers
|
|
and we don't want to take care of this. Besises, these
|
|
differences only concern code generation (i believe).*)
|
|
let process_error exn =
|
|
let report ppf = function
|
|
| Lexer.Error(err, loc) ->
|
|
Location.print_error ppf loc;
|
|
Lexer.report_error ppf err
|
|
| Syntaxerr.Error err ->
|
|
Syntaxerr.report_error ppf err
|
|
| Env.Error err ->
|
|
Location.print_error_cur_file ppf;
|
|
Env.report_error ppf err
|
|
| Cmi_format.Error err ->
|
|
Location.print_error_cur_file ppf;
|
|
Cmi_format.report_error ppf err
|
|
| Ctype.Tags(l, l') ->
|
|
Location.print_error_cur_file ppf;
|
|
fprintf ppf
|
|
"In this program,@ variant constructors@ `%s and `%s@ \
|
|
have the same hash value." l l'
|
|
| Typecore.Error(loc, env, err) ->
|
|
Location.print_error ppf loc; Typecore.report_error env ppf err
|
|
| Typetexp.Error(loc, env, err) ->
|
|
Location.print_error ppf loc; Typetexp.report_error env ppf err
|
|
| Typedecl.Error(loc, err) ->
|
|
Location.print_error ppf loc; Typedecl.report_error ppf err
|
|
| Includemod.Error err ->
|
|
Location.print_error_cur_file ppf;
|
|
Includemod.report_error ppf err
|
|
| Typemod.Error(loc, env, err) ->
|
|
Location.print_error ppf loc; Typemod.report_error env ppf err
|
|
| Translcore.Error(loc, err) ->
|
|
Location.print_error ppf loc; Translcore.report_error ppf err
|
|
| Sys_error msg ->
|
|
Location.print_error_cur_file ppf;
|
|
fprintf ppf "I/O error: %s" msg
|
|
| Typeclass.Error(loc, env, err) ->
|
|
Location.print_error ppf loc; Typeclass.report_error env ppf err
|
|
| Translclass.Error(loc, err) ->
|
|
Location.print_error ppf loc; Translclass.report_error ppf err
|
|
| Warnings.Errors (n) ->
|
|
Location.print_error_cur_file ppf;
|
|
fprintf ppf "Error-enabled warnings (%d occurrences)" n
|
|
| x ->
|
|
fprintf ppf "@]";
|
|
fprintf ppf
|
|
"Compilation error(%s). Use the OCaml compiler to get more details."
|
|
(Printexc.to_string x)
|
|
in
|
|
Format.fprintf Format.err_formatter "@[%a@]@." report exn
|
|
|
|
(** Process the given file, according to its extension. Return the Module.t created, if any.*)
|
|
let process_file ppf sourcefile =
|
|
if !Odoc_global.verbose then
|
|
(
|
|
let f = match sourcefile with
|
|
Odoc_global.Impl_file f
|
|
| Odoc_global.Intf_file f -> f
|
|
| Odoc_global.Text_file f -> f
|
|
in
|
|
print_string (Odoc_messages.analysing f) ;
|
|
print_newline ();
|
|
);
|
|
match sourcefile with
|
|
Odoc_global.Impl_file file ->
|
|
(
|
|
Location.input_name := file;
|
|
try
|
|
let (parsetree_typedtree_opt, input_file) = process_implementation_file ppf file in
|
|
match parsetree_typedtree_opt with
|
|
None ->
|
|
None
|
|
| Some (parsetree, typedtree) ->
|
|
let file_module = Ast_analyser.analyse_typed_tree file
|
|
!Location.input_name parsetree typedtree
|
|
in
|
|
file_module.Odoc_module.m_top_deps <- Odoc_dep.impl_dependencies parsetree ;
|
|
|
|
if !Odoc_global.verbose then
|
|
(
|
|
print_string Odoc_messages.ok;
|
|
print_newline ()
|
|
);
|
|
Pparse.remove_preprocessed input_file;
|
|
Some file_module
|
|
with
|
|
| Sys_error s
|
|
| Failure s ->
|
|
prerr_endline s ;
|
|
incr Odoc_global.errors ;
|
|
None
|
|
| e ->
|
|
process_error e ;
|
|
incr Odoc_global.errors ;
|
|
None
|
|
)
|
|
| Odoc_global.Intf_file file ->
|
|
(
|
|
Location.input_name := file;
|
|
try
|
|
let (ast, signat, input_file) = process_interface_file ppf file in
|
|
let file_module = Sig_analyser.analyse_signature file
|
|
!Location.input_name ast signat.sig_type
|
|
in
|
|
|
|
file_module.Odoc_module.m_top_deps <- Odoc_dep.intf_dependencies ast ;
|
|
|
|
if !Odoc_global.verbose then
|
|
(
|
|
print_string Odoc_messages.ok;
|
|
print_newline ()
|
|
);
|
|
Pparse.remove_preprocessed input_file;
|
|
Some file_module
|
|
with
|
|
| Sys_error s
|
|
| Failure s ->
|
|
prerr_endline s;
|
|
incr Odoc_global.errors ;
|
|
None
|
|
| e ->
|
|
process_error e ;
|
|
incr Odoc_global.errors ;
|
|
None
|
|
)
|
|
| Odoc_global.Text_file file ->
|
|
Location.input_name := file;
|
|
try
|
|
let mod_name =
|
|
let s =
|
|
try Filename.chop_extension file
|
|
with _ -> file
|
|
in
|
|
String.capitalize (Filename.basename s)
|
|
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.Mty_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 (Location.in_file file) } ;
|
|
Odoc_module.m_top_deps = [] ;
|
|
Odoc_module.m_code = None ;
|
|
Odoc_module.m_code_intf = None ;
|
|
Odoc_module.m_text_only = true ;
|
|
}
|
|
in
|
|
Some m
|
|
with
|
|
| Sys_error s
|
|
| Failure s ->
|
|
prerr_endline s;
|
|
incr Odoc_global.errors ;
|
|
None
|
|
| e ->
|
|
process_error e ;
|
|
incr Odoc_global.errors ;
|
|
None
|
|
|
|
(** Remove the class elements between the stop special comments. *)
|
|
let rec remove_class_elements_between_stop keep eles =
|
|
match eles with
|
|
[] -> []
|
|
| ele :: q ->
|
|
match ele with
|
|
Odoc_class.Class_comment [ Odoc_types.Raw "/*" ] ->
|
|
remove_class_elements_between_stop (not keep) q
|
|
| Odoc_class.Class_attribute _
|
|
| Odoc_class.Class_method _
|
|
| Odoc_class.Class_comment _ ->
|
|
if keep then
|
|
ele :: (remove_class_elements_between_stop keep q)
|
|
else
|
|
remove_class_elements_between_stop keep q
|
|
|
|
(** Remove the class elements between the stop special comments in a class kind. *)
|
|
let rec remove_class_elements_between_stop_in_class_kind k =
|
|
match k with
|
|
Odoc_class.Class_structure (inher, l) ->
|
|
Odoc_class.Class_structure (inher, remove_class_elements_between_stop true l)
|
|
| Odoc_class.Class_apply _ -> k
|
|
| Odoc_class.Class_constr _ -> k
|
|
| Odoc_class.Class_constraint (k1, ctk) ->
|
|
Odoc_class.Class_constraint (remove_class_elements_between_stop_in_class_kind k1,
|
|
remove_class_elements_between_stop_in_class_type_kind ctk)
|
|
|
|
(** Remove the class elements beetween the stop special comments in a class type kind. *)
|
|
and remove_class_elements_between_stop_in_class_type_kind tk =
|
|
match tk with
|
|
Odoc_class.Class_signature (inher, l) ->
|
|
Odoc_class.Class_signature (inher, remove_class_elements_between_stop true l)
|
|
| Odoc_class.Class_type _ -> tk
|
|
|
|
|
|
(** Remove the module elements between the stop special comments. *)
|
|
let rec remove_module_elements_between_stop keep eles =
|
|
let f = remove_module_elements_between_stop in
|
|
match eles with
|
|
[] -> []
|
|
| ele :: q ->
|
|
match ele with
|
|
Odoc_module.Element_module_comment [ Odoc_types.Raw "/*" ] ->
|
|
f (not keep) q
|
|
| Odoc_module.Element_module_comment _ ->
|
|
if keep then
|
|
ele :: (f keep q)
|
|
else
|
|
f keep q
|
|
| Odoc_module.Element_module m ->
|
|
if keep then
|
|
(
|
|
m.Odoc_module.m_kind <- remove_module_elements_between_stop_in_module_kind m.Odoc_module.m_kind ;
|
|
(Odoc_module.Element_module m) :: (f keep q)
|
|
)
|
|
else
|
|
f keep q
|
|
| Odoc_module.Element_module_type mt ->
|
|
if keep then
|
|
(
|
|
mt.Odoc_module.mt_kind <- Odoc_misc.apply_opt
|
|
remove_module_elements_between_stop_in_module_type_kind mt.Odoc_module.mt_kind ;
|
|
(Odoc_module.Element_module_type mt) :: (f keep q)
|
|
)
|
|
else
|
|
f keep q
|
|
| Odoc_module.Element_included_module _ ->
|
|
if keep then
|
|
ele :: (f keep q)
|
|
else
|
|
f keep q
|
|
| Odoc_module.Element_class c ->
|
|
if keep then
|
|
(
|
|
c.Odoc_class.cl_kind <- remove_class_elements_between_stop_in_class_kind c.Odoc_class.cl_kind ;
|
|
(Odoc_module.Element_class c) :: (f keep q)
|
|
)
|
|
else
|
|
f keep q
|
|
| Odoc_module.Element_class_type ct ->
|
|
if keep then
|
|
(
|
|
ct.Odoc_class.clt_kind <- remove_class_elements_between_stop_in_class_type_kind ct.Odoc_class.clt_kind ;
|
|
(Odoc_module.Element_class_type ct) :: (f keep q)
|
|
)
|
|
else
|
|
f keep q
|
|
| Odoc_module.Element_value _
|
|
| Odoc_module.Element_exception _
|
|
| Odoc_module.Element_type _ ->
|
|
if keep then
|
|
ele :: (f keep q)
|
|
else
|
|
f keep q
|
|
|
|
|
|
(** Remove the module elements between the stop special comments, in the given module kind. *)
|
|
and remove_module_elements_between_stop_in_module_kind k =
|
|
match k with
|
|
| Odoc_module.Module_struct l -> Odoc_module.Module_struct (remove_module_elements_between_stop true l)
|
|
| Odoc_module.Module_alias _ -> k
|
|
| Odoc_module.Module_functor (params, k2) ->
|
|
Odoc_module.Module_functor (params, remove_module_elements_between_stop_in_module_kind k2)
|
|
| Odoc_module.Module_apply (k1, k2) ->
|
|
Odoc_module.Module_apply (remove_module_elements_between_stop_in_module_kind k1,
|
|
remove_module_elements_between_stop_in_module_kind k2)
|
|
| Odoc_module.Module_with (mtkind, s) ->
|
|
Odoc_module.Module_with (remove_module_elements_between_stop_in_module_type_kind mtkind, s)
|
|
| Odoc_module.Module_constraint (k2, mtkind) ->
|
|
Odoc_module.Module_constraint (remove_module_elements_between_stop_in_module_kind k2,
|
|
remove_module_elements_between_stop_in_module_type_kind mtkind)
|
|
| Odoc_module.Module_typeof _ -> k
|
|
| Odoc_module.Module_unpack _ -> k
|
|
|
|
(** Remove the module elements between the stop special comment, in the given module type kind. *)
|
|
and remove_module_elements_between_stop_in_module_type_kind tk =
|
|
match tk with
|
|
| Odoc_module.Module_type_struct l -> Odoc_module.Module_type_struct (remove_module_elements_between_stop true l)
|
|
| Odoc_module.Module_type_functor (params, tk2) ->
|
|
Odoc_module.Module_type_functor (params, remove_module_elements_between_stop_in_module_type_kind tk2)
|
|
| Odoc_module.Module_type_alias _ -> tk
|
|
| Odoc_module.Module_type_with (tk2, s) ->
|
|
Odoc_module.Module_type_with (remove_module_elements_between_stop_in_module_type_kind tk2, s)
|
|
| Odoc_module.Module_type_typeof _ -> tk
|
|
|
|
(** Remove elements between the stop special comment. *)
|
|
let remove_elements_between_stop module_list =
|
|
List.map
|
|
(fun m ->
|
|
m.Odoc_module.m_kind <- remove_module_elements_between_stop_in_module_kind m.Odoc_module.m_kind;
|
|
m
|
|
)
|
|
module_list
|
|
|
|
(** This function builds the modules from the given list of source files. *)
|
|
let analyse_files ?(init=[]) files =
|
|
let modules_pre =
|
|
init @
|
|
(List.fold_left
|
|
(fun acc -> fun file ->
|
|
try
|
|
match process_file Format.err_formatter file with
|
|
None ->
|
|
acc
|
|
| Some m ->
|
|
acc @ [ m ]
|
|
with
|
|
Failure s ->
|
|
prerr_endline s ;
|
|
incr Odoc_global.errors ;
|
|
acc
|
|
)
|
|
[]
|
|
files
|
|
)
|
|
in
|
|
(* Remove elements between the stop special comments, if needed. *)
|
|
let modules =
|
|
if !Odoc_global.no_stop then
|
|
modules_pre
|
|
else
|
|
remove_elements_between_stop modules_pre
|
|
in
|
|
|
|
|
|
if !Odoc_global.verbose then
|
|
(
|
|
print_string Odoc_messages.merging;
|
|
print_newline ()
|
|
);
|
|
let merged_modules = Odoc_merge.merge !Odoc_global.merge_options modules in
|
|
if !Odoc_global.verbose then
|
|
(
|
|
print_string Odoc_messages.ok;
|
|
print_newline ();
|
|
);
|
|
let modules_list =
|
|
(List.fold_left
|
|
(fun acc -> fun m -> acc @ (Odoc_module.module_all_submodules ~trans: false m))
|
|
merged_modules
|
|
merged_modules
|
|
)
|
|
in
|
|
if !Odoc_global.verbose then
|
|
(
|
|
print_string Odoc_messages.cross_referencing;
|
|
print_newline ()
|
|
);
|
|
let _ = Odoc_cross.associate modules_list in
|
|
|
|
if !Odoc_global.verbose then
|
|
(
|
|
print_string Odoc_messages.ok;
|
|
print_newline ();
|
|
);
|
|
|
|
if !Odoc_global.sort_modules then
|
|
Sort.list (fun m1 -> fun m2 -> m1.Odoc_module.m_name < m2.Odoc_module.m_name) merged_modules
|
|
else
|
|
merged_modules
|
|
|
|
let dump_modules file (modules : Odoc_module.t_module list) =
|
|
try
|
|
let chanout = open_out_bin file in
|
|
let dump = Odoc_types.make_dump modules in
|
|
output_value chanout dump;
|
|
close_out chanout
|
|
with
|
|
Sys_error s ->
|
|
raise (Failure s)
|
|
|
|
let load_modules file =
|
|
try
|
|
let chanin = open_in_bin file in
|
|
let dump = input_value chanin in
|
|
close_in chanin ;
|
|
let (l : Odoc_module.t_module list) = Odoc_types.open_dump dump in
|
|
l
|
|
with
|
|
Sys_error s ->
|
|
raise (Failure s)
|