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 obj_file_of_baseuri writable baseuri =
  34   try
  35     LibraryMisc.obj_file_of_baseuri
  36      ~must_exist:true ~baseuri ~writable
  37   with
  38   | Http_getter_types.Unresolvable_URI _
  39   | Http_getter_types.Key_not_found _ ->
  40     LibraryMisc.obj_file_of_baseuri
  41      ~must_exist:false ~baseuri ~writable:true
  42 ;;
  43
  44 let main () =
  45   (* all are maps from "file" to "something" *)
  46   let include_deps = Hashtbl.create (Array.length Sys.argv) in
  47   let include_deps_dot = Hashtbl.create (Array.length Sys.argv) in
  48   let baseuri_of = Hashtbl.create (Array.length Sys.argv) in
  49   let baseuri_of_inv = Hashtbl.create (Array.length Sys.argv) in
  50   let uri_deps = Hashtbl.create (Array.length Sys.argv) in
  51   let ma_topo = Hashtbl.create (Array.length Sys.argv) in
  52   let ma_topo_keys = ref [] in
  53   let buri alias = U.buri_of_uri (U.uri_of_string alias) in
  54   let resolve alias current_buri =
  55     let buri = buri alias in
  56     if buri <> current_buri then Some buri else None in
  57   let dot_file = ref "" in
  58   let order_only = ref false in
  59   MatitaInit.add_cmdline_spec
  60     ["-dot", Arg.Set_string dot_file,
  61       "<file> Save dependency graph in dot format to the given file";
  62      "-order", Arg.Set order_only,
  63       "Only print (one of the possibles) build order(s) for the given *.ma"];
  64   MatitaInit.parse_cmdline_and_configuration_file ();
  65   MatitaInit.initialize_environment ();
  66   MatitamakeLib.initialize ();
  67   let include_paths =
  68    Helm_registry.get_list Helm_registry.string "matita.includes" in
  69   let args = Helm_registry.get_list Helm_registry.string "matita.args" in
  70   if args = [] then
  71     begin
  72       prerr_endline "At least one .ma file must be specified";
  73       exit 1
  74     end;
  75   let ma_files = args in
  76   let bof = Hashtbl.create 10 in
  77   let baseuri_of_script s =
  78      try Hashtbl.find bof s
  79      with Not_found ->
  80        let b,_ = DependenciesParser.baseuri_of_script ~include_paths s in
  81        Hashtbl.add bof s b; b
  82   in
  83   List.iter
  84    (fun ma_file ->
  85     let ic = open_in ma_file in
  86       let istream = Ulexing.from_utf8_channel ic in
  87       let dependencies = DependenciesParser.parse_dependencies istream in
  88     close_in ic;
  89     if !order_only then begin
  90       let relative_ma_file =
  91         (* change a path leading to a .ma file into a path relative to its
  92          * development root dir *)
  93         let absolute_ma_file =
  94           if Filename.is_relative ma_file then
  95             Filename.concat (Sys.getcwd ()) ma_file
  96           else
  97             ma_file in
  98         let ma_dir = Filename.dirname absolute_ma_file in
  99         match MatitamakeLib.development_for_dir ma_dir with
 100         | None ->
 101             eprintf "no development setup for dir '%s'\n%!" ma_dir;
 102             assert false
 103         | Some devel ->
 104             Pcre.replace
 105               ~pat:(Pcre.quote(MatitamakeLib.root_for_development devel) ^ "/?")
 106               ~templ:"" absolute_ma_file
 107       in
 108       ma_topo_keys := relative_ma_file :: !ma_topo_keys;
 109       List.iter
 110         (function
 111           | DependenciesParser.IncludeDep path ->
 112               Hashtbl.add ma_topo relative_ma_file path
 113           | _ -> ())
 114         dependencies
 115     end else
 116       List.iter
 117        (function
 118          | DependenciesParser.UriDep uri ->
 119             let uri = UriManager.string_of_uri uri in
 120             if not (Http_getter_storage.is_legacy uri) then
 121               Hashtbl.add uri_deps ma_file uri
 122          | DependenciesParser.BaseuriDep uri ->
 123             let uri = Http_getter_misc.strip_trailing_slash uri in
 124             Hashtbl.add baseuri_of ma_file uri;
 125             Hashtbl.add baseuri_of_inv uri ma_file
 126          | DependenciesParser.IncludeDep path ->
 127             try
 128               let baseuri = baseuri_of_script path in
 129               if not (Http_getter_storage.is_legacy baseuri) then
 130                 (let moo_file = obj_file_of_baseuri false baseuri in
 131                 Hashtbl.add include_deps ma_file moo_file;
 132                 Hashtbl.add include_deps_dot ma_file baseuri)
 133             with Sys_error _ ->
 134               HLog.warn
 135                 ("Unable to find " ^ path ^ " that is included in " ^ ma_file))
 136        dependencies)
 137    ma_files;
 138   Hashtbl.iter
 139     (fun file alias ->
 140       try
 141         let dep = resolve alias (Hashtbl.find baseuri_of file) in
 142         match dep with
 143         | None -> ()
 144         | Some u ->
 145            Hashtbl.add include_deps file (obj_file_of_baseuri false u)
 146       with Not_found ->
 147         prerr_endline ("File "^ file^" has no baseuri. Use set baseuri");
 148         exit 1)
 149     uri_deps;
 150       let gcp x y =
 151       (* explode and implode from the OCaml Expert FAQ. *)
 152         let explode s =
 153           let rec exp i l =
 154             if i < 0 then l else exp (i - 1) (s.[i] :: l) in
 155           exp (String.length s - 1) []
 156         in
 157         let implode l =
 158           let res = String.create (List.length l) in
 159           let rec imp i = function
 160           | [] -> res
 161           | c :: l -> res.[i] <- c; imp (i + 1) l in
 162           imp 0 l
 163         in
 164         let rec aux = function
 165           | x::tl1,y::tl2 when x = y -> x::(aux (tl1,tl2))
 166           | _ -> []
 167         in
 168         implode (aux (explode x,explode y))
 169       in
 170       let max_path = List.hd ma_files in
 171       let max_path = List.fold_left gcp max_path ma_files in
 172       let short x = Pcre.replace ~pat:("^"^max_path) x in
 173   if !dot_file <> "" then (* generate dependency graph if required *)
 174     begin
 175       let oc = open_out !dot_file in
 176       let fmt = Format.formatter_of_out_channel oc in
 177       GraphvizPp.Dot.header (* ~graph_attrs:["rankdir","LR"] *) fmt;
 178       List.iter
 179        (fun ma_file ->
 180         let deps = Hashtbl.find_all include_deps_dot ma_file in
 181         let deps =
 182           HExtlib.filter_map
 183             (fun u ->
 184               try Some (Hashtbl.find baseuri_of_inv u)
 185               with Not_found -> None)
 186             deps
 187         in
 188         let deps = List.fast_sort Pervasives.compare deps in
 189         let deps = HExtlib.list_uniq deps in
 190         GraphvizPp.Dot.node (short ma_file) fmt;
 191         List.iter (fun dep -> GraphvizPp.Dot.edge (short ma_file) (short dep) fmt) deps)
 192        ma_files;
 193       GraphvizPp.Dot.trailer fmt;
 194       close_out oc
 195     end;
 196   if !order_only then begin
 197     let module OrdererString =
 198       struct
 199         type t = string
 200         let compare = Pervasives.compare
 201       end
 202     in
 203     let module Topo = HTopoSort.Make (OrdererString) in
 204     let sorted_ma =
 205       Topo.topological_sort !ma_topo_keys (Hashtbl.find_all ma_topo) in
 206     List.iter print_endline sorted_ma
 207     (*Hashtbl.iter (fun k v -> printf "%s: %s\n" k v) ma_topo*)
 208   end else
 209     List.iter (* generate regular .depend output *)
 210      (fun ma_file ->
 211        try
 212         let deps = Hashtbl.find_all include_deps ma_file in
 213         let deps = List.fast_sort Pervasives.compare deps in
 214         let deps = HExtlib.list_uniq deps in
 215         let deps = ma_file :: deps in
 216         let baseuri = Hashtbl.find baseuri_of ma_file in
 217         let moo = obj_file_of_baseuri true baseuri in
 218         printf "%s: %s\n%s: %s\n%s: %s\n%s: %s\n"
 219           moo (String.concat " " deps)
 220           (Filename.basename(Pcre.replace ~pat:"ma$" ~templ:"mo" ma_file)) moo
 221           (Pcre.replace ~pat:"ma$" ~templ:"mo" ma_file) moo
 222           (Pcre.replace ~pat:"ma$" ~templ:"mo" (short ma_file)) moo
 223        with Not_found ->
 224          prerr_endline ("File "^ma_file^" has no baseuri. Use set baseuri");
 225          exit 1)
 226       ma_files
 227