ocamldoc/odoc_analyse.ml

   1 (***********************************************************************)
   2 (*                             OCamldoc                                *)
   3 (*                                                                     *)
   4 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
   5 (*                                                                     *)
   6 (*  Copyright 2001 Institut National de Recherche en Informatique et   *)
   7 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   8 (*  under the terms of the Q Public License version 1.0.               *)
   9 (*                                                                     *)
  10 (***********************************************************************)
  11
  12 (* $Id$ *)
  13
  14 (** Analysis of source files. This module is strongly inspired from
  15     driver/main.ml :-) *)
  16
  17 let print_DEBUG s = print_string s ; print_newline ()
  18
  19 open Config
  20 open Clflags
  21 open Misc
  22 open Format
  23 open Typedtree
  24
  25
  26 (** Initialize the search path.
  27    The current directory is always searched first,
  28    then the directories specified with the -I option (in command-line order),
  29    then the standard library directory. *)
  30 let init_path () =
  31   load_path :=
  32     "" :: List.rev (Config.standard_library :: !Clflags.include_dirs);
  33   Env.reset_cache ()
  34
  35 (** Return the initial environment in which compilation proceeds. *)
  36 let initial_env () =
  37   try
  38     if !Clflags.nopervasives
  39     then Env.initial
  40     else Env.open_pers_signature "Pervasives" Env.initial
  41   with Not_found ->
  42     fatal_error "cannot open pervasives.cmi"
  43
  44 (** Optionally preprocess a source file *)
  45 let preprocess sourcefile =
  46   match !Clflags.preprocessor with
  47     None -> sourcefile
  48   | Some pp ->
  49       let tmpfile = Filename.temp_file "camlpp" "" in
  50       let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in
  51       if Ccomp.command comm <> 0 then begin
  52         remove_file tmpfile;
  53         Printf.eprintf "Preprocessing error\n";
  54         exit 2
  55       end;
  56       tmpfile
  57
  58 (** Remove the input file if this file was the result of a preprocessing.*)
  59 let remove_preprocessed inputfile =
  60   match !Clflags.preprocessor with
  61     None -> ()
  62   | Some _ -> remove_file inputfile
  63
  64 let remove_preprocessed_if_ast inputfile =
  65   match !Clflags.preprocessor with
  66     None -> ()
  67   | Some _ -> if inputfile <> !Location.input_name then remove_file inputfile
  68
  69 exception Outdated_version
  70
  71 (** Parse a file or get a dumped syntax tree in it *)
  72 let parse_file inputfile parse_fun ast_magic =
  73   let ic = open_in_bin inputfile in
  74   let is_ast_file =
  75     try
  76       let buffer = String.create (String.length ast_magic) in
  77       really_input ic buffer 0 (String.length ast_magic);
  78       if buffer = ast_magic then true
  79       else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then
  80         raise Outdated_version
  81       else false
  82     with
  83       Outdated_version ->
  84         fatal_error "Ocaml and preprocessor have incompatible versions"
  85     | _ -> false
  86   in
  87   let ast =
  88     try
  89       if is_ast_file then begin
  90         Location.input_name := input_value ic;
  91         input_value ic
  92       end else begin
  93         seek_in ic 0;
  94         Location.input_name := inputfile;
  95         let lexbuf = Lexing.from_channel ic in
  96         Location.init lexbuf inputfile;
  97         parse_fun lexbuf
  98       end
  99     with x -> close_in ic; raise x
 100   in
 101   close_in ic;
 102   ast
 103
 104 let (++) x f = f x
 105
 106 (** Analysis of an implementation file. Returns (Some typedtree) if
 107    no error occured, else None and an error message is printed.*)
 108 let process_implementation_file ppf sourcefile =
 109   init_path ();
 110   let prefixname = Filename.chop_extension sourcefile in
 111   let modulename = String.capitalize(Filename.basename prefixname) in
 112   Env.set_unit_name modulename;
 113   let inputfile = preprocess sourcefile in
 114   let env = initial_env () in
 115   try
 116     let parsetree = parse_file inputfile Parse.implementation ast_impl_magic_number in
 117     let typedtree = Typemod.type_implementation sourcefile prefixname modulename env parsetree in
 118     (Some (parsetree, typedtree), inputfile)
 119   with
 120     e ->
 121       match e with
 122         Syntaxerr.Error err ->
 123           fprintf Format.err_formatter "@[%a@]@."
 124             Syntaxerr.report_error err;
 125           None, inputfile
 126       | Failure s ->
 127           prerr_endline s;
 128           incr Odoc_global.errors ;
 129           None, inputfile
 130       | e ->
 131           raise e
 132
 133 (** Analysis of an interface file. Returns (Some signature) if
 134    no error occured, else None and an error message is printed.*)
 135 let process_interface_file ppf sourcefile =
 136   init_path ();
 137   let prefixname = Filename.chop_extension sourcefile in
 138   let modulename = String.capitalize(Filename.basename prefixname) in
 139   Env.set_unit_name modulename;
 140   let inputfile = preprocess sourcefile in
 141   let ast = parse_file inputfile Parse.interface ast_intf_magic_number in
 142   let sg = Typemod.transl_signature (initial_env()) ast in
 143   Warnings.check_fatal ();
 144   (ast, sg, inputfile)
 145
 146 (** The module used to analyse the parsetree and signature of an implementation file.*)
 147 module Ast_analyser = Odoc_ast.Analyser (Odoc_comments.Basic_info_retriever)
 148
 149 (** The module used to analyse the parse tree and typed tree of an interface file.*)
 150 module Sig_analyser = Odoc_sig.Analyser (Odoc_comments.Basic_info_retriever)
 151
 152 (** Handle an error. This is a partial copy of the compiler
 153    driver/error.ml file. We do this because there are
 154    some differences between the possibly raised exceptions
 155    in the bytecode (error.ml) and opt (opterros.ml) compilers
 156    and we don't want to take care of this. Besises, these
 157    differences only concern code generation (i believe).*)
 158 let process_error exn =
 159   let report ppf = function
 160   | Lexer.Error(err, loc) ->
 161       Location.print ppf loc;
 162       Lexer.report_error ppf err
 163   | Syntaxerr.Error err ->
 164       Syntaxerr.report_error ppf err
 165   | Env.Error err ->
 166       Env.report_error ppf err
 167   | Ctype.Tags(l, l') -> fprintf ppf
 168       "In this program,@ variant constructors@ `%s and `%s@ \
 169        have the same hash value." l l'
 170   | Typecore.Error(loc, err) ->
 171       Location.print ppf loc; Typecore.report_error ppf err
 172   | Typetexp.Error(loc, err) ->
 173       Location.print ppf loc; Typetexp.report_error ppf err
 174   | Typedecl.Error(loc, err) ->
 175       Location.print ppf loc; Typedecl.report_error ppf err
 176   | Includemod.Error err ->
 177       Includemod.report_error ppf err
 178   | Typemod.Error(loc, err) ->
 179       Location.print ppf loc; Typemod.report_error ppf err
 180   | Translcore.Error(loc, err) ->
 181       Location.print ppf loc; Translcore.report_error ppf err
 182   | Sys_error msg ->
 183       fprintf ppf "I/O error: %s" msg
 184   | Typeclass.Error(loc, err) ->
 185       Location.print ppf loc; Typeclass.report_error ppf err
 186   | Translclass.Error(loc, err) ->
 187       Location.print ppf loc; Translclass.report_error ppf err
 188   | Warnings.Errors (n) ->
 189       fprintf ppf "@.Error: error-enabled warnings (%d occurrences)" n
 190   | x ->
 191       fprintf ppf "@]";
 192       fprintf ppf "Compilation error. Use the OCaml compiler to get more details."
 193   in
 194   Format.fprintf Format.err_formatter "@[%a@]@." report exn
 195
 196 (** Process the given file, according to its extension. Return the Module.t created, if any.*)
 197 let process_file ppf sourcefile =
 198   if !Odoc_args.verbose then
 199     (
 200      let f = match sourcefile with
 201        Odoc_args.Impl_file f
 202      | Odoc_args.Intf_file f -> f
 203      | Odoc_args.Text_file f -> f
 204      in
 205      print_string (Odoc_messages.analysing f) ;
 206      print_newline ();
 207     );
 208   match sourcefile with
 209     Odoc_args.Impl_file file ->
 210       (
 211        try
 212          let (parsetree_typedtree_opt, input_file) = process_implementation_file ppf file in
 213          match parsetree_typedtree_opt with
 214            None ->
 215              None
 216          | Some (parsetree, typedtree) ->
 217              let file_module = Ast_analyser.analyse_typed_tree file
 218                  !Location.input_name parsetree typedtree
 219              in
 220              file_module.Odoc_module.m_top_deps <- Odoc_dep.impl_dependencies parsetree ;
 221
 222              if !Odoc_args.verbose then
 223                (
 224                 print_string Odoc_messages.ok;
 225                 print_newline ()
 226                );
 227              remove_preprocessed input_file;
 228              Some file_module
 229        with
 230        | Sys_error s
 231        | Failure s ->
 232            prerr_endline s ;
 233            incr Odoc_global.errors ;
 234            None
 235        | e ->
 236            process_error e ;
 237            incr Odoc_global.errors ;
 238            None
 239       )
 240   | Odoc_args.Intf_file file ->
 241       (
 242        try
 243          let (ast, signat, input_file) = process_interface_file ppf file in
 244          let file_module = Sig_analyser.analyse_signature file
 245              !Location.input_name ast signat
 246          in
 247
 248          file_module.Odoc_module.m_top_deps <- Odoc_dep.intf_dependencies ast ;
 249
 250          if !Odoc_args.verbose then
 251            (
 252             print_string Odoc_messages.ok;
 253             print_newline ()
 254            );
 255          remove_preprocessed input_file;
 256          Some file_module
 257        with
 258        | Sys_error s
 259        | Failure s ->
 260            prerr_endline s;
 261            incr Odoc_global.errors ;
 262            None
 263        | e ->
 264            process_error e ;
 265            incr Odoc_global.errors ;
 266            None
 267       )
 268   | Odoc_args.Text_file file ->
 269       try
 270         let mod_name =
 271           String.capitalize (Filename.basename (Filename.chop_extension file))
 272         in
 273         let txt =
 274           try Odoc_text.Texter.text_of_string (Odoc_misc.input_file_as_string file)
 275           with Odoc_text.Text_syntax (l, c, s) ->
 276             raise (Failure (Odoc_messages.text_parse_error l c s))
 277         in
 278         let m =
 279           {
 280             Odoc_module.m_name = mod_name ;
 281             Odoc_module.m_type = Types.Tmty_signature [] ;
 282             Odoc_module.m_info = None ;
 283             Odoc_module.m_is_interface = true ;
 284             Odoc_module.m_file = file ;
 285             Odoc_module.m_kind = Odoc_module.Module_struct
 286               [Odoc_module.Element_module_comment txt] ;
 287             Odoc_module.m_loc =
 288               { Odoc_types.loc_impl = None ;
 289                 Odoc_types.loc_inter = Some (file, 0) } ;
 290             Odoc_module.m_top_deps = [] ;
 291             Odoc_module.m_code = None ;
 292             Odoc_module.m_code_intf = None ;
 293             Odoc_module.m_text_only = true ;
 294           }
 295         in
 296         Some m
 297       with
 298        | Sys_error s
 299        | Failure s ->
 300            prerr_endline s;
 301            incr Odoc_global.errors ;
 302            None
 303        | e ->
 304            process_error e ;
 305            incr Odoc_global.errors ;
 306            None
 307
 308 (** Remove the class elements between the stop special comments. *)
 309 let rec remove_class_elements_between_stop keep eles =
 310   match eles with
 311     [] -> []
 312   | ele :: q ->
 313       match ele with
 314         Odoc_class.Class_comment [ Odoc_types.Raw "/*" ] ->
 315           remove_class_elements_between_stop (not keep) q
 316       | Odoc_class.Class_attribute _
 317       | Odoc_class.Class_method _
 318       | Odoc_class.Class_comment _ ->
 319           if keep then
 320             ele :: (remove_class_elements_between_stop keep q)
 321           else
 322             remove_class_elements_between_stop keep q
 323
 324 (** Remove the class elements between the stop special comments in a class kind. *)
 325 let rec remove_class_elements_between_stop_in_class_kind k =
 326   match k with
 327     Odoc_class.Class_structure (inher, l) ->
 328       Odoc_class.Class_structure (inher, remove_class_elements_between_stop true l)
 329   | Odoc_class.Class_apply _ -> k
 330   | Odoc_class.Class_constr _ -> k
 331   | Odoc_class.Class_constraint (k1, ctk) ->
 332       Odoc_class.Class_constraint (remove_class_elements_between_stop_in_class_kind k1,
 333                         remove_class_elements_between_stop_in_class_type_kind ctk)
 334
 335 (** Remove the class elements beetween the stop special comments in a class type kind. *)
 336 and remove_class_elements_between_stop_in_class_type_kind tk =
 337   match tk with
 338     Odoc_class.Class_signature (inher, l) ->
 339       Odoc_class.Class_signature (inher, remove_class_elements_between_stop true l)
 340   | Odoc_class.Class_type _ -> tk
 341
 342
 343 (** Remove the module elements between the stop special comments. *)
 344 let rec remove_module_elements_between_stop keep eles =
 345   let f = remove_module_elements_between_stop in
 346   match eles with
 347     [] -> []
 348   | ele :: q ->
 349       match ele with
 350         Odoc_module.Element_module_comment [ Odoc_types.Raw "/*" ] ->
 351           f (not keep) q
 352       | Odoc_module.Element_module_comment _ ->
 353           if keep then
 354             ele :: (f keep q)
 355           else
 356             f keep q
 357       | Odoc_module.Element_module m ->
 358           if keep then
 359             (
 360              m.Odoc_module.m_kind <- remove_module_elements_between_stop_in_module_kind m.Odoc_module.m_kind ;
 361              (Odoc_module.Element_module m) :: (f keep q)
 362             )
 363           else
 364             f keep q
 365       | Odoc_module.Element_module_type mt ->
 366           if keep then
 367             (
 368              mt.Odoc_module.mt_kind <- Odoc_misc.apply_opt
 369                  remove_module_elements_between_stop_in_module_type_kind mt.Odoc_module.mt_kind ;
 370              (Odoc_module.Element_module_type mt) :: (f keep q)
 371             )
 372           else
 373             f keep q
 374       | Odoc_module.Element_included_module _ ->
 375           if keep then
 376             ele :: (f keep q)
 377           else
 378             f keep q
 379       | Odoc_module.Element_class c ->
 380           if keep then
 381             (
 382              c.Odoc_class.cl_kind <- remove_class_elements_between_stop_in_class_kind c.Odoc_class.cl_kind ;
 383              (Odoc_module.Element_class c) :: (f keep q)
 384             )
 385           else
 386             f keep q
 387       | Odoc_module.Element_class_type ct ->
 388           if keep then
 389             (
 390              ct.Odoc_class.clt_kind <- remove_class_elements_between_stop_in_class_type_kind ct.Odoc_class.clt_kind ;
 391              (Odoc_module.Element_class_type ct) :: (f keep q)
 392             )
 393           else
 394             f keep q
 395       | Odoc_module.Element_value _
 396       | Odoc_module.Element_exception _
 397       | Odoc_module.Element_type _ ->
 398           if keep then
 399             ele :: (f keep q)
 400           else
 401             f keep q
 402
 403
 404 (** Remove the module elements between the stop special comments, in the given module kind. *)
 405 and remove_module_elements_between_stop_in_module_kind k =
 406   match k with
 407   | Odoc_module.Module_struct l -> Odoc_module.Module_struct (remove_module_elements_between_stop true l)
 408   | Odoc_module.Module_alias _ -> k
 409   | Odoc_module.Module_functor (params, k2)  ->
 410       Odoc_module.Module_functor (params, remove_module_elements_between_stop_in_module_kind k2)
 411   | Odoc_module.Module_apply (k1, k2) ->
 412       Odoc_module.Module_apply (remove_module_elements_between_stop_in_module_kind k1,
 413                     remove_module_elements_between_stop_in_module_kind k2)
 414   | Odoc_module.Module_with (mtkind, s) ->
 415       Odoc_module.Module_with (remove_module_elements_between_stop_in_module_type_kind mtkind, s)
 416   | Odoc_module.Module_constraint (k2, mtkind) ->
 417       Odoc_module.Module_constraint (remove_module_elements_between_stop_in_module_kind k2,
 418                          remove_module_elements_between_stop_in_module_type_kind mtkind)
 419
 420 (** Remove the module elements between the stop special comment, in the given module type kind. *)
 421 and remove_module_elements_between_stop_in_module_type_kind tk =
 422   match tk with
 423   | Odoc_module.Module_type_struct l -> Odoc_module.Module_type_struct (remove_module_elements_between_stop true l)
 424   | Odoc_module.Module_type_functor (params, tk2) ->
 425       Odoc_module.Module_type_functor (params, remove_module_elements_between_stop_in_module_type_kind tk2)
 426   | Odoc_module.Module_type_alias _ -> tk
 427   | Odoc_module.Module_type_with (tk2, s) ->
 428       Odoc_module.Module_type_with (remove_module_elements_between_stop_in_module_type_kind tk2, s)
 429
 430
 431 (** Remove elements between the stop special comment. *)
 432 let remove_elements_between_stop module_list =
 433   List.map
 434     (fun m ->
 435       m.Odoc_module.m_kind <- remove_module_elements_between_stop_in_module_kind m.Odoc_module.m_kind;
 436       m
 437     )
 438     module_list
 439
 440 (** This function builds the modules from the given list of source files. *)
 441 let analyse_files ?(init=[]) files =
 442   let modules_pre =
 443     init @
 444     (List.fold_left
 445        (fun acc -> fun file ->
 446          try
 447            match process_file Format.err_formatter file with
 448              None ->
 449                acc
 450            | Some m ->
 451                acc @ [ m ]
 452          with
 453            Failure s ->
 454              prerr_endline s ;
 455              incr Odoc_global.errors ;
 456              acc
 457        )
 458        []
 459        files
 460     )
 461   in
 462   (* Remove elements between the stop special comments, if needed. *)
 463   let modules =
 464     if !Odoc_args.no_stop then
 465       modules_pre
 466     else
 467       remove_elements_between_stop modules_pre
 468   in
 469
 470
 471   if !Odoc_args.verbose then
 472     (
 473      print_string Odoc_messages.merging;
 474      print_newline ()
 475     );
 476   let merged_modules = Odoc_merge.merge !Odoc_args.merge_options modules in
 477   if !Odoc_args.verbose then
 478     (
 479      print_string Odoc_messages.ok;
 480      print_newline ();
 481     );
 482   let modules_list =
 483     (List.fold_left
 484        (fun acc -> fun m -> acc @ (Odoc_module.module_all_submodules ~trans: false m))
 485        merged_modules
 486        merged_modules
 487     )
 488   in
 489   if !Odoc_args.verbose then
 490     (
 491      print_string Odoc_messages.cross_referencing;
 492      print_newline ()
 493     );
 494   let _ = Odoc_cross.associate modules_list in
 495
 496   if !Odoc_args.verbose then
 497     (
 498      print_string Odoc_messages.ok;
 499      print_newline ();
 500     );
 501
 502   if !Odoc_args.sort_modules then
 503     Sort.list (fun m1 -> fun m2 -> m1.Odoc_module.m_name < m2.Odoc_module.m_name) merged_modules
 504   else
 505     merged_modules
 506
 507 let dump_modules file (modules : Odoc_module.t_module list) =
 508   try
 509     let chanout = open_out_bin file in
 510     let dump = Odoc_types.make_dump modules in
 511     output_value chanout dump;
 512     close_out chanout
 513   with
 514     Sys_error s ->
 515       raise (Failure s)
 516
 517 let load_modules file =
 518   try
 519     let chanin = open_in_bin file in
 520     let dump = input_value chanin in
 521     close_in chanin ;
 522     let (l : Odoc_module.t_module list) = Odoc_types.open_dump dump in
 523     l
 524   with
 525     Sys_error s ->
 526       raise (Failure s)