l4/pkg/ocaml/contrib/ocamlbuild/main.ml

   1 (***********************************************************************)
   2 (*                             ocamlbuild                              *)
   3 (*                                                                     *)
   4 (*  Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
   5 (*                                                                     *)
   6 (*  Copyright 2007 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
  13 (* Original author: Berke Durak *)
  14 open My_std
  15 open Log
  16 open Pathname.Operators
  17 open Command
  18 open Tools
  19 open Ocaml_specific
  20 open Format
  21 ;;
  22
  23 exception Exit_build_error of string
  24 exception Exit_silently
  25
  26 let clean () =
  27   Log.finish ();
  28   Shell.rm_rf !Options.build_dir;
  29   if !Options.make_links then begin
  30     let entry =
  31       Slurp.map (fun _ _ _ -> true)
  32         (Slurp.slurp Filename.current_dir_name)
  33     in
  34     Slurp.force (Resource.clean_up_links entry)
  35   end;
  36   raise Exit_silently
  37 ;;
  38
  39 let show_tags () =
  40   List.iter begin fun path ->
  41     Log.eprintf "@[<2>Tags for %S:@ {. %a .}@]" path Tags.print (tags_of_pathname path)
  42   end !Options.show_tags
  43 ;;
  44
  45 let show_documentation () =
  46   let rules = Rule.get_rules () in
  47   let flags = Flags.get_flags () in
  48   let pp fmt = Log.raw_dprintf (-1) fmt in
  49   List.iter begin fun rule ->
  50     pp "%a@\n@\n" (Rule.pretty_print Resource.print_pattern) rule
  51   end rules;
  52   List.iter begin fun (tags, flag) ->
  53     let sflag = Command.string_of_command_spec flag in
  54     pp "@[<2>flag@ {. %a .}@ %S@]@\n@\n" Tags.print tags sflag
  55   end flags;
  56   pp "@."
  57 ;;
  58
  59 let proceed () =
  60   Hooks.call_hook Hooks.Before_options;
  61   Options.init ();
  62   if !Options.must_clean then clean ();
  63   Hooks.call_hook Hooks.After_options;
  64   Plugin.execute_plugin_if_needed ();
  65
  66   if !Options.targets = []
  67     && !Options.show_tags = []
  68     && not !Options.show_documentation
  69     then raise Exit_silently;
  70
  71   let target_dirs = List.union [] (List.map Pathname.dirname !Options.targets) in
  72
  73   Configuration.parse_string
  74     "<**/*.ml> or <**/*.mli> or <**/*.mlpack> or <**/*.ml.depends>: ocaml
  75      <**/*.byte>: ocaml, byte, program
  76      <**/*.odoc>: ocaml, doc
  77      <**/*.native>: ocaml, native, program
  78      <**/*.cma>: ocaml, byte, library
  79      <**/*.cmxa>: ocaml, native, library
  80      <**/*.cmo>: ocaml, byte
  81      <**/*.cmi>: ocaml, byte, native
  82      <**/*.cmx>: ocaml, native
  83     ";
  84
  85   Configuration.tag_any !Options.tags;
  86   if !Options.recursive
  87   || Sys.file_exists (* authorized since we're not in build *) "_tags"
  88   || Sys.file_exists (* authorized since we're not in build *) "myocamlbuild.ml"
  89   then Configuration.tag_any ["traverse"];
  90
  91   let newpwd = Sys.getcwd () in
  92   Sys.chdir Pathname.pwd;
  93   let entry_include_dirs = ref [] in
  94   let entry =
  95     Slurp.filter
  96       begin fun path name _ ->
  97         let dir =
  98           if path = Filename.current_dir_name then
  99             None
 100           else
 101             Some path
 102         in
 103         let path_name = path/name in
 104         if name = "_tags" then
 105           ignore (Configuration.parse_file ?dir path_name);
 106
 107         (String.length name > 0 && name.[0] <> '_' && name <> !Options.build_dir && not (List.mem name !Options.exclude_dirs))
 108         && begin
 109           if path_name <> Filename.current_dir_name && Pathname.is_directory path_name then
 110             let tags = tags_of_pathname path_name in
 111             if Tags.mem "include" tags
 112             || List.mem path_name !Options.include_dirs then
 113               (entry_include_dirs := path_name :: !entry_include_dirs; true)
 114             else
 115               Tags.mem "traverse" tags
 116               || List.exists (Pathname.is_prefix path_name) !Options.include_dirs
 117               || List.exists (Pathname.is_prefix path_name) target_dirs
 118           else true
 119         end
 120       end
 121       (Slurp.slurp Filename.current_dir_name)
 122   in
 123   Hooks.call_hook Hooks.Before_hygiene;
 124   let hygiene_entry =
 125     Slurp.map begin fun path name () ->
 126       let tags = tags_of_pathname (path/name) in
 127       not (Tags.mem "not_hygienic" tags) && not (Tags.mem "precious" tags)
 128     end entry in
 129   if !Options.hygiene then
 130     Fda.inspect hygiene_entry
 131   else
 132     Slurp.force hygiene_entry;
 133   let entry = hygiene_entry in
 134   Hooks.call_hook Hooks.After_hygiene;
 135   Options.include_dirs := Pathname.current_dir_name :: List.rev !entry_include_dirs;
 136   dprintf 3 "include directories are:@ %a" print_string_list !Options.include_dirs;
 137   Options.entry := Some entry;
 138
 139   List.iter Configuration.parse_string !Options.tag_lines;
 140
 141   Hooks.call_hook Hooks.Before_rules;
 142   Ocaml_specific.init ();
 143   Hooks.call_hook Hooks.After_rules;
 144
 145   Sys.chdir newpwd;
 146   (*let () = dprintf 0 "source_dir_path_set:@ %a" StringSet.print source_dir_path_set*)
 147
 148   if !Options.show_documentation then begin
 149     show_documentation ();
 150     raise Exit_silently
 151   end;
 152   Digest_cache.init ();
 153
 154   Sys.catch_break true;
 155
 156   show_tags ();
 157
 158   let targets =
 159     List.map begin fun starget ->
 160       let starget = Resource.import starget in
 161       let target = path_and_context_of_string starget in
 162       let ext = Pathname.get_extension starget in
 163       (target, starget, ext)
 164     end !Options.targets in
 165
 166   try
 167     let targets =
 168       List.map begin fun (target, starget, ext) ->
 169         Shell.mkdir_p (Pathname.dirname starget);
 170         let target = Solver.solve_target starget target in
 171         (target, ext)
 172       end targets in
 173
 174     Command.dump_parallel_stats ();
 175
 176     Log.finish ();
 177
 178     Shell.chdir Pathname.pwd;
 179
 180     let call spec = sys_command (Command.string_of_command_spec spec) in
 181
 182     let cmds =
 183       List.fold_right begin fun (target, ext) acc ->
 184         let cmd = !Options.build_dir/target in
 185         let link x =
 186           if !Options.make_links then ignore (call (S [A"ln"; A"-sf"; P x; A Pathname.current_dir_name])) in
 187         match ext with
 188         | "byte" | "native" | "top" ->
 189             link cmd; cmd :: acc
 190         | "html" ->
 191             link (Pathname.dirname cmd); acc
 192         | _ ->
 193             if !Options.program_to_execute then
 194               eprintf "Warning: Won't execute %s whose extension is neither .byte nor .native" cmd;
 195             acc
 196       end targets [] in
 197
 198     if !Options.program_to_execute then
 199       begin
 200         match List.rev cmds with
 201         | [] -> raise (Exit_usage "Using -- requires one target");
 202         | cmd :: rest ->
 203           if rest <> [] then dprintf 0 "Warning: Using -- only run the last target";
 204           let cmd_spec = S [P cmd; atomize !Options.program_args] in
 205           dprintf 3 "Running the user command:@ %a" Pathname.print cmd;
 206           raise (Exit_with_code (call cmd_spec)) (* Exit with the exit code of the called command *)
 207       end
 208     else
 209       ()
 210   with
 211   | Ocaml_dependencies.Circular_dependencies(seen, p) ->
 212       raise
 213         (Exit_build_error
 214           (sbprintf "@[<2>Circular dependencies: %S already seen in@ %a@]@." p pp_l seen))
 215 ;;
 216
 217 open Exit_codes;;
 218
 219 let main () =
 220   let exit rc =
 221     Log.finish ~how:(if rc <> 0 then `Error else `Success) ();
 222     Pervasives.exit rc
 223   in
 224   try
 225     proceed ()
 226   with e ->
 227     if !Options.catch_errors then
 228       try raise e with
 229       | Exit_OK -> exit rc_ok
 230       | Fda.Exit_hygiene_failed ->
 231           Log.eprintf "Exiting due to hygiene violations.";
 232           exit rc_hygiene
 233       | Exit_usage u ->
 234           Log.eprintf "Usage:@ %s." u;
 235           exit rc_usage
 236       | Exit_system_error msg ->
 237           Log.eprintf "System error:@ %s." msg;
 238           exit rc_system_error
 239       | Exit_with_code rc ->
 240           exit rc
 241       | Exit_silently ->
 242           Log.finish ~how:`Quiet ();
 243           Pervasives.exit rc_ok
 244       | Exit_silently_with_code rc ->
 245           Log.finish ~how:`Quiet ();
 246           Pervasives.exit rc
 247       | Solver.Failed backtrace ->
 248           Log.raw_dprintf (-1) "@[<v0>@[<2>Solver failed:@ %a@]@\n@[<v2>Backtrace:%a@]@]@."
 249             Report.print_backtrace_analyze backtrace Report.print_backtrace backtrace;
 250           exit rc_solver_failed
 251       | Failure s ->
 252           Log.eprintf "Failure:@ %s." s;
 253           exit rc_failure
 254       | Solver.Circular(r, rs) ->
 255           Log.eprintf "Circular build detected@ (%a already seen in %a)"
 256           Resource.print r (List.print Resource.print) rs;
 257           exit rc_circularity
 258       | Invalid_argument s ->
 259           Log.eprintf
 260             "INTERNAL ERROR: Invalid argument %s\n\
 261             This is likely to be a bug, please report this to the ocamlbuild\n\
 262             developers." s;
 263           exit rc_invalid_argument
 264       | Ocaml_utils.Ocamldep_error msg ->
 265           Log.eprintf "Ocamldep error: %s" msg;
 266           exit rc_ocamldep_error
 267       | Lexers.Error msg ->
 268           Log.eprintf "Lexical analysis error: %s" msg;
 269           exit rc_lexing_error
 270       | Arg.Bad msg ->
 271           Log.eprintf "%s" msg;
 272           exit rc_usage
 273       | Exit_build_error msg ->
 274           Log.eprintf "%s" msg;
 275           exit rc_build_error
 276       | Arg.Help msg ->
 277           Log.eprintf "%s" msg;
 278           exit rc_ok
 279       | e ->
 280           try
 281             Log.eprintf "%a" My_unix.report_error e;
 282             exit 100
 283           with
 284           | e ->
 285             Log.eprintf "Exception@ %s." (Printexc.to_string e);
 286             exit 100
 287     else raise e
 288 ;;