helm/software/matita/matitadep.ml

   1 (* Copyright (C) 2005, HELM Team.
   2  *
   3  * This file is part of HELM, an Hypertextual, Electronic
   4  * Library of Mathematics, developed at the Computer Science
   5  * Department, University of Bologna, Italy.
   6  *
   7  * HELM is free software; you can redistribute it and/or
   8  * modify it under the terms of the GNU General Public License
   9  * as published by the Free Software Foundation; either version 2
  10  * of the License, or (at your option) any later version.
  11  *
  12  * HELM is distributed in the hope that it will be useful,
  13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  * GNU General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU General Public License
  18  * along with HELM; if not, write to the Free Software
  19  * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  20  * MA  02111-1307, USA.
  21  *
  22  * For details, see the HELM World-Wide-Web page,
  23  * http://helm.cs.unibo.it/
  24  *)
  25
  26 (* $Id$ *)
  27
  28 open Printf
  29
  30 module GA = GrafiteAst
  31 module U = UriManager
  32
  33 let main () =
  34   (* all are maps from "file" to "something" *)
  35   let include_deps = Hashtbl.create 13 in
  36   let baseuri_of = Hashtbl.create 13 in
  37   let baseuri_of_inv = Hashtbl.create 13 in
  38   let dot_name = "depends" in
  39   let dot_file = ref "" in
  40   let set_dot_file () = dot_file := dot_name^".dot" in
  41   (* helpers *)
  42   let include_paths = ref [] in
  43   let baseuri_of_script s =
  44      try Hashtbl.find baseuri_of s
  45      with Not_found ->
  46        let _,b,_,_ =
  47          Librarian.baseuri_of_script ~include_paths:!include_paths s
  48        in
  49        Hashtbl.add baseuri_of s b;
  50        Hashtbl.add baseuri_of_inv b s;
  51        b
  52   in
  53   let script_of_baseuri ma b =
  54     try Some (Hashtbl.find baseuri_of_inv b)
  55     with Not_found ->
  56       HLog.error ("Skipping dependency of '"^ma^"' over '"^b^"'");
  57       HLog.error ("Plase include the file defining such baseuri, or fix");
  58       HLog.error ("possibly incorrect verbatim URIs in the .ma file.");
  59       None
  60   in
  61   let buri alias = U.buri_of_uri (U.uri_of_string alias) in
  62   let resolve alias current_buri =
  63     let buri = buri alias in
  64     if buri <> current_buri then Some buri else None
  65   in
  66   (* initialization *)
  67   MatitaInit.add_cmdline_spec
  68     ["-dot", Arg.Unit set_dot_file,
  69     "Save dependency graph in dot format and generate a png";];
  70   MatitaInit.parse_cmdline_and_configuration_file ();
  71   MatitaInit.initialize_environment ();
  72   let args =
  73       let roots = Librarian.find_roots_in_dir (Sys.getcwd ()) in
  74       match roots with
  75       | [] ->
  76          prerr_endline ("No roots found in " ^ Sys.getcwd ());
  77          exit 1
  78       | [x] ->
  79          Sys.chdir (Filename.dirname x);
  80          let opts = Librarian.load_root_file "root" in
  81          include_paths :=
  82            (try Str.split (Str.regexp " ") (List.assoc "include_paths" opts)
  83            with Not_found -> []) @
  84            (Helm_registry.get_list Helm_registry.string "matita.includes");
  85          HExtlib.find ~test:(fun x -> Filename.check_suffix x ".ma") "."
  86       | _ ->
  87          let roots = List.map (HExtlib.chop_prefix (Sys.getcwd()^"/")) roots in
  88          prerr_endline ("Too many roots found:\n\t"^String.concat "\n\t" roots);
  89          prerr_endline ("\nEnter one of these directories and retry");
  90          exit 1
  91   in
  92   let fix_name f =
  93     let f =
  94       if Pcre.pmatch ~pat:"^\\./" f then String.sub f 2 (String.length f - 2)
  95       else f
  96     in
  97       HExtlib.normalize_path f
  98   in
  99   let ma_files = args in
 100   (* here we go *)
 101   (* fills:
 102               Hashtbl.add include_deps     ma_file ma_file
 103               Hashtbl.add include_deps_dot ma_file baseuri
 104   *)
 105   List.iter (fun ma_file -> ignore (baseuri_of_script ma_file)) ma_files;
 106   List.iter
 107    (fun ma_file ->
 108       let ma_baseuri = baseuri_of_script ma_file in
 109       let dependencies = DependenciesParser.deps_of_file ma_file in
 110       List.iter
 111        (function
 112          | DependenciesParser.UriDep uri ->
 113             let uri = UriManager.string_of_uri uri in
 114             if not (Http_getter_storage.is_legacy uri) then
 115               let dep = resolve uri ma_baseuri in
 116               (match dep with
 117               | None -> ()
 118               | Some u ->
 119                   match script_of_baseuri ma_file u with
 120                   | Some d -> Hashtbl.add include_deps ma_file d
 121                   | None -> ())
 122          | DependenciesParser.IncludeDep path ->
 123                 ignore (baseuri_of_script path);
 124                 Hashtbl.add include_deps ma_file path)
 125        dependencies)
 126    ma_files;
 127   (* generate regular depend output *)
 128   let deps =
 129     List.fold_left
 130      (fun acc ma_file ->
 131       let deps = Hashtbl.find_all include_deps ma_file in
 132       let deps = List.fast_sort Pervasives.compare deps in
 133       let deps = HExtlib.list_uniq deps in
 134       let deps = List.map fix_name deps in
 135       (fix_name ma_file, deps) :: acc)
 136      [] ma_files
 137   in
 138   let extern =
 139     List.fold_left
 140       (fun acc (_,d) ->
 141         List.fold_left
 142           (fun a x ->
 143              if List.exists (fun (t,_) -> x=t) deps then a
 144              else x::a)
 145           acc d)
 146       [] deps
 147   in
 148   Librarian.write_deps_file (Sys.getcwd())
 149    (deps@HExtlib.list_uniq (List.sort Pervasives.compare (List.map (fun x ->
 150            x,[]) extern)));
 151   (* dot generation *)
 152   if !dot_file <> "" then
 153     begin
 154       let oc = open_out !dot_file in
 155       let fmt = Format.formatter_of_out_channel oc in
 156       GraphvizPp.Dot.header fmt;
 157       List.iter
 158        (fun (ma_file,deps) ->
 159         GraphvizPp.Dot.node ma_file fmt;
 160         List.iter (fun dep -> GraphvizPp.Dot.edge ma_file dep fmt) deps)
 161        deps;
 162       List.iter
 163         (fun x -> GraphvizPp.Dot.node ~attrs:["style","dashed"] x fmt)
 164         extern;
 165       GraphvizPp.Dot.trailer fmt;
 166       close_out oc;
 167       ignore(Sys.command ("tred "^ !dot_file^"| dot -Tpng -o"^dot_name^".png"));
 168       HLog.message ("Type 'eog "^dot_name^".png' to view the graph");
 169     end;
 170 ;;
 171