odoc_analyse.ml

(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             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 GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** Analysis of source files. This module is strongly inspired from
    driver/main.ml :-) *)

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 () = Compmisc.init_path ()

(** Return the initial environment in which compilation proceeds. *)
let initial_env () =
  let current = Env.get_unit_name () in
  let initial = !Odoc_global.initially_opened_module in
  let initially_opened_module =
    if initial = current then
      None
    else
      Some initial
  in
  let open_implicit_modules =
    let ln = !Odoc_global.library_namespace in
    let ln = if current = ln || ln = initial || ln = "" then [] else [ln] in
    ln @ List.rev !Clflags.open_modules in
  Typemod.initial_env
    ~loc:(Location.in_file "ocamldoc command line")
    ~open_implicit_modules
    ~initially_opened_module

(** 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

(** Analysis of an implementation file. Returns (Some typedtree) if
   no error occurred, else None and an error message is printed.*)

let tool_name = "ocamldoc"

(** Deactivate the generation of docstrings in the lexer *)
let no_docstring f x =
  Lexer.handle_docstrings := false;
  let result = f x in
  Lexer.handle_docstrings := true;
  result

let process_implementation_file sourcefile =
  init_path ();
  let prefixname = Filename.chop_extension sourcefile in
  let modulename = Misc.UString.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 ~tool_name inputfile
        (no_docstring Parse.implementation) Pparse.Structure
    in
    let typedtree =
      Typemod.type_implementation
        sourcefile prefixname modulename env parsetree
    in
    (Some (parsetree, typedtree), inputfile)
  with
  | Syntaxerr.Error _ as exn ->
      begin match Location.error_of_exn exn with
      | Some (`Ok err) ->
          fprintf Format.err_formatter "@[%a@]@."
            Location.print_report err
      | _ ->
          assert false
      end;
      None, inputfile
  | Failure s ->
      prerr_endline s;
      incr Odoc_global.errors ;
      None, inputfile

(** Analysis of an interface file. Returns (Some signature) if
   no error occurred, else None and an error message is printed.*)
let process_interface_file sourcefile =
  init_path ();
  let prefixname = Filename.chop_extension sourcefile in
  let modulename = Misc.UString.capitalize(Filename.basename prefixname) in
  Env.set_unit_name modulename;
  let inputfile = preprocess sourcefile in
  let ast =
    Pparse.file ~tool_name inputfile
      (no_docstring Parse.interface) Pparse.Signature
  in
  let sg = Typemod.type_interface (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. *)

let process_error exn =
  try Location.report_exception Format.err_formatter exn
  with exn ->
    fprintf Format.err_formatter
      "Compilation error(%s). Use the OCaml compiler to get more details.@."
      (Printexc.to_string exn)

(** Process the given file, according to its extension. Return the Module.t created, if any.*)
let process_file 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 file in
         match parsetree_typedtree_opt with
           None ->
             None
         | Some (parsetree, Typedtree.{structure; coercion; _}) ->
             let typedtree = (structure, coercion) in
             let file_module = Ast_analyser.analyse_typed_tree file
                 input_file 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 file in
         let file_module = Sig_analyser.analyse_signature file
             input_file 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
          Misc.UString.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_info =
          Some Odoc_types.{dummy_info with i_desc= Some txt } in
        let m =
          {
            Odoc_module.m_name = mod_name ;
            Odoc_module.m_type = Types.Mty_signature [] ;
            Odoc_module.m_info;
            Odoc_module.m_is_interface = true ;
            Odoc_module.m_file = file ;
            Odoc_module.m_kind = Odoc_module.Module_struct [] ;
            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 between 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_type_extension _
      | 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 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 ()
    );
  Odoc_cross.associate modules_list;

  if !Odoc_global.verbose then
    (
     print_string Odoc_messages.ok;
     print_newline ();
    );

  if !Odoc_global.sort_modules then
    List.sort (fun m1 m2 -> compare 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)