diff options
Diffstat (limited to 'ocaml-binary-annot/ocamldoc/odoc_analyse.ml')
| -rw-r--r-- | ocaml-binary-annot/ocamldoc/odoc_analyse.ml | 539 |
1 files changed, 539 insertions, 0 deletions
diff --git a/ocaml-binary-annot/ocamldoc/odoc_analyse.ml b/ocaml-binary-annot/ocamldoc/odoc_analyse.ml new file mode 100644 index 0000000000..2091dd3967 --- /dev/null +++ b/ocaml-binary-annot/ocamldoc/odoc_analyse.ml @@ -0,0 +1,539 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** 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 = + 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 + Env.set_unit_name modulename; + 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 + Env.set_unit_name modulename; + 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. 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 + | 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, err) -> + Location.print_error ppf loc; Typecore.report_error ppf err + | Typetexp.Error(loc, err) -> + Location.print_error ppf loc; Typetexp.report_error 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, err) -> + Location.print_error ppf loc; Typemod.report_error 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, err) -> + Location.print_error ppf loc; Typeclass.report_error 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 () + ); + 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 + 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 () + ); + 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 = + 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 = + 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) |