450 lines
16 KiB
OCaml
450 lines
16 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 () =
|
|
let dirs =
|
|
if !Clflags.thread_safe then
|
|
Filename.concat Config.standard_library "threads" :: !Clflags.include_dirs
|
|
else
|
|
!Clflags.include_dirs in
|
|
load_path := "" :: List.rev (Config.standard_library :: dirs);
|
|
Env.reset_cache()
|
|
|
|
(** Return the initial environment in which compilation proceeds. *)
|
|
let initial_env () =
|
|
try
|
|
if !Clflags.nopervasives
|
|
then Env.initial
|
|
else Env.open_pers_signature "Pervasives" Env.initial
|
|
with Not_found ->
|
|
fatal_error "cannot open pervasives.cmi"
|
|
|
|
(** Optionally preprocess a source file *)
|
|
let preprocess sourcefile =
|
|
match !Clflags.preprocessor with
|
|
None -> sourcefile
|
|
| Some pp ->
|
|
let tmpfile = Filename.temp_file "camlpp" "" in
|
|
let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in
|
|
if Ccomp.command comm <> 0 then begin
|
|
remove_file tmpfile;
|
|
Printf.eprintf "Preprocessing error\n";
|
|
exit 2
|
|
end;
|
|
tmpfile
|
|
|
|
(** Remove the input file if this file was the result of a preprocessing.*)
|
|
let remove_preprocessed inputfile =
|
|
match !Clflags.preprocessor with
|
|
None -> ()
|
|
| Some _ -> remove_file inputfile
|
|
|
|
let remove_preprocessed_if_ast inputfile =
|
|
match !Clflags.preprocessor with
|
|
None -> ()
|
|
| Some _ -> if inputfile <> !Location.input_name then remove_file inputfile
|
|
|
|
exception Outdated_version
|
|
|
|
(** Parse a file or get a dumped syntax tree in it *)
|
|
let parse_file inputfile parse_fun ast_magic =
|
|
let ic = open_in_bin inputfile in
|
|
let is_ast_file =
|
|
try
|
|
let buffer = String.create (String.length ast_magic) in
|
|
really_input ic buffer 0 (String.length ast_magic);
|
|
if buffer = ast_magic then true
|
|
else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then
|
|
raise Outdated_version
|
|
else false
|
|
with
|
|
Outdated_version ->
|
|
fatal_error "Ocaml and preprocessor have incompatible versions"
|
|
| _ -> false
|
|
in
|
|
let ast =
|
|
try
|
|
if is_ast_file then begin
|
|
Location.input_name := input_value ic;
|
|
input_value ic
|
|
end else begin
|
|
seek_in ic 0;
|
|
Location.input_name := inputfile;
|
|
let lexbuf = Lexing.from_channel ic in
|
|
Location.init lexbuf inputfile;
|
|
parse_fun lexbuf
|
|
end
|
|
with x -> close_in ic; raise x
|
|
in
|
|
close_in ic;
|
|
ast
|
|
|
|
let (++) x f = f x
|
|
|
|
(** Analysis of an implementation file. Returns (Some typedtree) if
|
|
no error occured, else None and an error message is printed.*)
|
|
let process_implementation_file ppf sourcefile =
|
|
|
|
init_path();
|
|
let prefixname = Filename.chop_extension sourcefile in
|
|
let modulename = String.capitalize(Filename.basename prefixname) in
|
|
let inputfile = preprocess sourcefile in
|
|
let env = initial_env () in
|
|
try
|
|
let parsetree = parse_file inputfile Parse.implementation ast_impl_magic_number in
|
|
let typedtree = Typemod.type_implementation sourcefile prefixname modulename env parsetree in
|
|
(Some (parsetree, typedtree), inputfile)
|
|
with
|
|
e ->
|
|
match e with
|
|
Syntaxerr.Error err ->
|
|
fprintf Format.err_formatter "@[%a@]@."
|
|
Syntaxerr.report_error err;
|
|
None, inputfile
|
|
| Failure s ->
|
|
prerr_endline s;
|
|
incr Odoc_global.errors ;
|
|
None, inputfile
|
|
| e ->
|
|
raise e
|
|
|
|
(** Analysis of an interface file. Returns (Some signature) if
|
|
no error occured, else None and an error message is printed.*)
|
|
let process_interface_file ppf sourcefile =
|
|
init_path();
|
|
let prefixname = Filename.chop_extension sourcefile in
|
|
let modulename = String.capitalize(Filename.basename prefixname) in
|
|
let inputfile = preprocess sourcefile in
|
|
let ast = parse_file inputfile Parse.interface ast_intf_magic_number in
|
|
let sg = Typemod.transl_signature (initial_env()) ast in
|
|
Warnings.check_fatal ();
|
|
(ast, sg, inputfile)
|
|
|
|
(** The module used to analyse the parsetree and signature of an implementation file.*)
|
|
module Ast_analyser = Odoc_ast.Analyser (Odoc_comments.Basic_info_retriever)
|
|
(** The module used to analyse the parse tree and typed tree of an interface file.*)
|
|
module Sig_analyser = Odoc_sig.Analyser (Odoc_comments.Basic_info_retriever)
|
|
|
|
(** Handle an error. This is a partial copy of the compiler
|
|
driver/error.ml file. We do this because there are
|
|
some differences between the possibly raised exceptions
|
|
in the bytecode (error.ml) and opt (opterros.ml) compilers
|
|
and we don't want to take care of this. Besisdes, this
|
|
differences only concern code generation (i believe).*)
|
|
let process_error exn =
|
|
let report ppf = function
|
|
| Lexer.Error(err, loc) ->
|
|
Location.print ppf loc;
|
|
Lexer.report_error ppf err
|
|
| Syntaxerr.Error err ->
|
|
Syntaxerr.report_error ppf err
|
|
| Env.Error err ->
|
|
Env.report_error ppf err
|
|
| Ctype.Tags(l, l') -> fprintf ppf
|
|
"In this program,@ variant constructors@ `%s and `%s@ \
|
|
have the same hash value." l l'
|
|
| Typecore.Error(loc, err) ->
|
|
Location.print ppf loc; Typecore.report_error ppf err
|
|
| Typetexp.Error(loc, err) ->
|
|
Location.print ppf loc; Typetexp.report_error ppf err
|
|
| Typedecl.Error(loc, err) ->
|
|
Location.print ppf loc; Typedecl.report_error ppf err
|
|
| Includemod.Error err ->
|
|
Includemod.report_error ppf err
|
|
| Typemod.Error(loc, err) ->
|
|
Location.print ppf loc; Typemod.report_error ppf err
|
|
| Translcore.Error(loc, err) ->
|
|
Location.print ppf loc; Translcore.report_error ppf err
|
|
| Sys_error msg ->
|
|
fprintf ppf "I/O error: %s" msg
|
|
| Typeclass.Error(loc, err) ->
|
|
Location.print ppf loc; Typeclass.report_error ppf err
|
|
| Translclass.Error(loc, err) ->
|
|
Location.print ppf loc; Translclass.report_error ppf err
|
|
| Warnings.Errors (n) ->
|
|
fprintf ppf "@.Error: %d error-enabled warnings occurred." n
|
|
| x ->
|
|
fprintf ppf "@]";
|
|
fprintf ppf "Compilation error. Use the OCaml compiler to get more details."
|
|
in
|
|
Format.fprintf Format.err_formatter "@[%a@]@." report exn
|
|
|
|
(** Process the given file, according to its extension. Return the Module.t created, if any.*)
|
|
let process_file ppf sourcefile =
|
|
if !Odoc_args.verbose then
|
|
(
|
|
print_string (Odoc_messages.analysing sourcefile) ;
|
|
print_newline ();
|
|
);
|
|
if Filename.check_suffix sourcefile "ml" then
|
|
(
|
|
try
|
|
let (parsetree_typedtree_opt, input_file) = process_implementation_file ppf sourcefile in
|
|
match parsetree_typedtree_opt with
|
|
None ->
|
|
None
|
|
| Some (parsetree, typedtree) ->
|
|
let file_module = Ast_analyser.analyse_typed_tree sourcefile !Location.input_name parsetree typedtree in
|
|
|
|
file_module.Odoc_module.m_top_deps <- Odoc_dep.impl_dependencies parsetree ;
|
|
|
|
if !Odoc_args.verbose then
|
|
(
|
|
print_string Odoc_messages.ok;
|
|
print_newline ()
|
|
);
|
|
remove_preprocessed input_file;
|
|
Some file_module
|
|
with
|
|
| Sys_error s
|
|
| Failure s ->
|
|
prerr_endline s ;
|
|
incr Odoc_global.errors ;
|
|
None
|
|
| e ->
|
|
process_error e ;
|
|
incr Odoc_global.errors ;
|
|
None
|
|
)
|
|
else
|
|
if Filename.check_suffix sourcefile "mli" then
|
|
(
|
|
try
|
|
let (ast, signat, input_file) = process_interface_file ppf sourcefile in
|
|
let file_module = Sig_analyser.analyse_signature sourcefile !Location.input_name ast signat in
|
|
|
|
file_module.Odoc_module.m_top_deps <- Odoc_dep.intf_dependencies ast ;
|
|
|
|
if !Odoc_args.verbose then
|
|
(
|
|
print_string Odoc_messages.ok;
|
|
print_newline ()
|
|
);
|
|
remove_preprocessed input_file;
|
|
Some file_module
|
|
with
|
|
| Sys_error s
|
|
| Failure s ->
|
|
prerr_endline s;
|
|
incr Odoc_global.errors ;
|
|
None
|
|
| e ->
|
|
process_error e ;
|
|
incr Odoc_global.errors ;
|
|
None
|
|
)
|
|
else
|
|
(
|
|
raise (Failure (Odoc_messages.unknown_extension sourcefile))
|
|
)
|
|
|
|
(** Remove the class elements after the stop special comment. *)
|
|
let rec remove_class_elements_after_stop eles =
|
|
match eles with
|
|
[] -> []
|
|
| ele :: q ->
|
|
match ele with
|
|
Odoc_class.Class_comment [ Odoc_types.Raw "/*" ] -> []
|
|
| Odoc_class.Class_attribute _
|
|
| Odoc_class.Class_method _
|
|
| Odoc_class.Class_comment _ -> ele :: (remove_class_elements_after_stop q)
|
|
|
|
(** Remove the class elements after the stop special comment in a class kind. *)
|
|
let rec remove_class_elements_after_stop_in_class_kind k =
|
|
match k with
|
|
Odoc_class.Class_structure (inher, l) ->
|
|
Odoc_class.Class_structure (inher, remove_class_elements_after_stop l)
|
|
| Odoc_class.Class_apply _ -> k
|
|
| Odoc_class.Class_constr _ -> k
|
|
| Odoc_class.Class_constraint (k1, ctk) ->
|
|
Odoc_class.Class_constraint (remove_class_elements_after_stop_in_class_kind k1,
|
|
remove_class_elements_after_stop_in_class_type_kind ctk)
|
|
|
|
(** Remove the class elements after the stop special comment in a class type kind. *)
|
|
and remove_class_elements_after_stop_in_class_type_kind tk =
|
|
match tk with
|
|
Odoc_class.Class_signature (inher, l) ->
|
|
Odoc_class.Class_signature (inher, remove_class_elements_after_stop l)
|
|
| Odoc_class.Class_type _ -> tk
|
|
|
|
|
|
(** Remove the module elements after the stop special comment. *)
|
|
let rec remove_module_elements_after_stop eles =
|
|
let f = remove_module_elements_after_stop in
|
|
match eles with
|
|
[] -> []
|
|
| ele :: q ->
|
|
match ele with
|
|
Odoc_module.Element_module_comment [ Odoc_types.Raw "/*" ] -> []
|
|
| Odoc_module.Element_module_comment _ ->
|
|
ele :: (f q)
|
|
| Odoc_module.Element_module m ->
|
|
m.Odoc_module.m_kind <- remove_module_elements_after_stop_in_module_kind m.Odoc_module.m_kind ;
|
|
(Odoc_module.Element_module m) :: (f q)
|
|
| Odoc_module.Element_module_type mt ->
|
|
mt.Odoc_module.mt_kind <- Odoc_misc.apply_opt
|
|
remove_module_elements_after_stop_in_module_type_kind mt.Odoc_module.mt_kind ;
|
|
(Odoc_module.Element_module_type mt) :: (f q)
|
|
| Odoc_module.Element_included_module _ ->
|
|
ele :: (f q)
|
|
| Odoc_module.Element_class c ->
|
|
c.Odoc_class.cl_kind <- remove_class_elements_after_stop_in_class_kind c.Odoc_class.cl_kind ;
|
|
(Odoc_module.Element_class c) :: (f q)
|
|
| Odoc_module.Element_class_type ct ->
|
|
ct.Odoc_class.clt_kind <- remove_class_elements_after_stop_in_class_type_kind ct.Odoc_class.clt_kind ;
|
|
(Odoc_module.Element_class_type ct) :: (f q)
|
|
| Odoc_module.Element_value _
|
|
| Odoc_module.Element_exception _
|
|
| Odoc_module.Element_type _ ->
|
|
ele :: (f q)
|
|
|
|
|
|
(** Remove the module elements after the stop special comment, in the given module kind. *)
|
|
and remove_module_elements_after_stop_in_module_kind k =
|
|
match k with
|
|
| Odoc_module.Module_struct l -> Odoc_module.Module_struct (remove_module_elements_after_stop l)
|
|
| Odoc_module.Module_alias _ -> k
|
|
| Odoc_module.Module_functor (params, k2) ->
|
|
Odoc_module.Module_functor (params, remove_module_elements_after_stop_in_module_kind k2)
|
|
| Odoc_module.Module_apply (k1, k2) ->
|
|
Odoc_module.Module_apply (remove_module_elements_after_stop_in_module_kind k1,
|
|
remove_module_elements_after_stop_in_module_kind k2)
|
|
| Odoc_module.Module_with (mtkind, s) ->
|
|
Odoc_module.Module_with (remove_module_elements_after_stop_in_module_type_kind mtkind, s)
|
|
| Odoc_module.Module_constraint (k2, mtkind) ->
|
|
Odoc_module.Module_constraint (remove_module_elements_after_stop_in_module_kind k2,
|
|
remove_module_elements_after_stop_in_module_type_kind mtkind)
|
|
|
|
(** Remove the module elements after the stop special comment, in the given module type kind. *)
|
|
and remove_module_elements_after_stop_in_module_type_kind tk =
|
|
match tk with
|
|
| Odoc_module.Module_type_struct l -> Odoc_module.Module_type_struct (remove_module_elements_after_stop l)
|
|
| Odoc_module.Module_type_functor (params, tk2) ->
|
|
Odoc_module.Module_type_functor (params, remove_module_elements_after_stop_in_module_type_kind tk2)
|
|
| Odoc_module.Module_type_alias _ -> tk
|
|
| Odoc_module.Module_type_with (tk2, s) ->
|
|
Odoc_module.Module_type_with (remove_module_elements_after_stop_in_module_type_kind tk2, s)
|
|
|
|
|
|
(** Remove elements after the stop special comment. *)
|
|
let remove_elements_after_stop module_list =
|
|
List.map
|
|
(fun m ->
|
|
m.Odoc_module.m_kind <- remove_module_elements_after_stop_in_module_kind m.Odoc_module.m_kind;
|
|
m
|
|
)
|
|
module_list
|
|
|
|
(** This function builds the modules from the given list of source files. *)
|
|
let analyse_files ?(init=[]) files =
|
|
let modules_pre =
|
|
init @
|
|
(List.fold_left
|
|
(fun acc -> fun file ->
|
|
try
|
|
match process_file Format.err_formatter file with
|
|
None ->
|
|
acc
|
|
| Some m ->
|
|
acc @ [ m ]
|
|
with
|
|
Failure s ->
|
|
prerr_endline s ;
|
|
incr Odoc_global.errors ;
|
|
acc
|
|
)
|
|
[]
|
|
files
|
|
)
|
|
in
|
|
(* Remove elements after the stop special comments, if needed. *)
|
|
let modules =
|
|
if !Odoc_args.no_stop then
|
|
modules_pre
|
|
else
|
|
remove_elements_after_stop modules_pre
|
|
in
|
|
|
|
|
|
if !Odoc_args.verbose then
|
|
(
|
|
print_string Odoc_messages.merging;
|
|
print_newline ()
|
|
);
|
|
let merged_modules = Odoc_merge.merge !Odoc_args.merge_options modules in
|
|
if !Odoc_args.verbose then
|
|
(
|
|
print_string Odoc_messages.ok;
|
|
print_newline ();
|
|
);
|
|
let modules_list =
|
|
(List.fold_left
|
|
(fun acc -> fun m -> acc @ (Odoc_module.module_all_submodules ~trans: false m))
|
|
merged_modules
|
|
merged_modules
|
|
)
|
|
in
|
|
if !Odoc_args.verbose then
|
|
(
|
|
print_string Odoc_messages.cross_referencing;
|
|
print_newline ()
|
|
);
|
|
let _ = Odoc_cross.associate modules_list in
|
|
|
|
if !Odoc_args.verbose then
|
|
(
|
|
print_string Odoc_messages.ok;
|
|
print_newline ();
|
|
);
|
|
|
|
if !Odoc_args.sort_modules then
|
|
Sort.list (fun m1 -> fun m2 -> m1.Odoc_module.m_name < m2.Odoc_module.m_name) merged_modules
|
|
else
|
|
merged_modules
|
|
|
|
let dump_modules file (modules : Odoc_module.t_module list) =
|
|
try
|
|
let chanout = open_out_bin file in
|
|
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)
|
|
|
|
|