helm/software/matita/help/C/split.ml

   1 #!/usr/bin/ocamlrun /usr/bin/ocaml
   2 (* Copyright (C) 2006, HELM Team.
   3  *
   4  * This file is part of HELM, an Hypertextual, Electronic
   5  * Library of Mathematics, developed at the Computer Science
   6  * Department, University of Bologna, Italy.
   7  *
   8  * HELM is free software; you can redistribute it and/or
   9  * modify it under the terms of the GNU General Public License
  10  * as published by the Free Software Foundation; either version 2
  11  * of the License, or (at your option) any later version.
  12  *
  13  * HELM is distributed in the hope that it will be useful,
  14  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  15  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16  * GNU General Public License for more details.
  17  *
  18  * You should have received a copy of the GNU General Public License
  19  * along with HELM; if not, write to the Free Software
  20  * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  21  * MA  02111-1307, USA.
  22  *
  23  * For details, see the HELM World-Wide-Web page,
  24  * http://helm.cs.unibo.it/
  25  *)
  26
  27 let fname =
  28   try Sys.argv.(1)
  29   with Invalid_argument _ ->
  30     prerr_endline "Usage: split.ml <FILE.html>";
  31     exit 1 ;;
  32
  33 #use "topfind";;
  34 #require "unix";;
  35 #require "pxp-engine";;
  36 #require "pxp-lex-utf8";;
  37
  38 let xhtml_header =
  39 "<?xml version=\"1.0\" encoding=\"UTF-8\"?>
  40 <!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">
  41 <html xmlns=\"http://www.w3.org/1999/xhtml\">
  42   <body>
  43 "
  44
  45 let xhtml_trailer =
  46 "  </body>
  47 </html>
  48 "
  49
  50 type 'a node =
  51   ('a Pxp_document.node #Pxp_document.extension as 'a) Pxp_document.node
  52
  53 let resolver =
  54   Pxp_reader.lookup_public_id_as_file [
  55     "-//W3C//DTD XHTML 1.0 Transitional//EN", "xhtml1-transitional.dtd";
  56     "-//W3C//ENTITIES Latin 1 for XHTML//EN", "xhtml-lat1.ent";
  57     "-//W3C//ENTITIES Symbols for XHTML//EN", "xhtml-symbol.ent";
  58     "-//W3C//ENTITIES Special for XHTML//EN", "xhtml-special.ent"; ]
  59
  60 let parse_xml fname =
  61   Pxp_tree_parser.parse_wfdocument_entity
  62     { Pxp_types.default_config with Pxp_types.encoding = `Enc_utf8 }
  63     (Pxp_types.from_file ~alt:[ resolver ] fname)
  64     Pxp_tree_parser.default_spec
  65
  66   (** pattern matching like predicate on pxp nodes *)
  67 let match_elt tag attr_name ?attr_value () node =
  68   node#node_type = Pxp_document.T_element tag
  69   && (match attr_value with
  70      | Some attr_value ->
  71          (try node#attribute attr_name = Pxp_types.Value attr_value
  72           with Not_found -> false)
  73      | None -> List.mem attr_name node#attribute_names)
  74
  75 let slice doc =
  76   let article =
  77     try
  78       Pxp_document.find ~deeply:true
  79         (match_elt "div" "class" ~attr_value:"article" ()) doc#root
  80      with Not_found -> failwith "Can't find article <div>" in
  81   let titlepage =
  82     Pxp_document.find ~deeply:false
  83       (match_elt "div" "class" ~attr_value:"titlepage" ()) article in
  84   let toc =
  85     Pxp_document.find ~deeply:false
  86       (match_elt "div" "class" ~attr_value:"toc" ()) article in
  87   let secs =
  88     Pxp_document.find_all ~deeply:false
  89       (match_elt "div" "class" ~attr_value:"sect1" ()) article in
  90   titlepage :: toc :: secs
  91
  92 let localize_ids secs =
  93   let id2sec = Hashtbl.create 1023 in
  94   let sec_ids = ref [] in
  95   List.iter
  96     (fun sec ->
  97       match Pxp_document.find_all ~deeply:true (match_elt "a" "id" ()) sec with
  98       | sec_id :: ids ->
  99           let sec_id = sec_id#required_string_attribute "id" in
 100           sec_ids := sec_id :: !sec_ids;
 101           List.iter
 102             (fun id ->
 103               let id = id#required_string_attribute "id" in
 104               Hashtbl.add id2sec id sec_id)
 105             ids
 106       | _ -> failwith "can't find section id")
 107     secs;
 108   !sec_ids, id2sec
 109
 110 let fname_of_sec sec_name = sec_name ^ ".html"
 111
 112 let get_sec_name sec =
 113   let id =
 114     try
 115       Pxp_document.find ~deeply:true (match_elt "a" "id" ()) sec
 116     with Not_found -> failwith "can't find section id" in
 117   id#required_string_attribute "id"
 118
 119 let iter_xrefs f node =
 120   let a_s = Pxp_document.find_all ~deeply:true (match_elt "a" "href" ()) node in
 121   List.iter
 122     (fun (node: 'a node) ->
 123       let href = node#required_string_attribute "href" in
 124       assert (String.length href > 0);
 125       if href.[0] = '#' then
 126         let xref = String.sub href 1 (String.length href - 1) in
 127         f node xref)
 128     a_s
 129
 130 let patch_toc sec_ids id2sec toc =
 131   iter_xrefs
 132     (fun node xref ->
 133       if List.mem xref sec_ids then
 134         node#set_attribute "href" (Pxp_types.Value (fname_of_sec xref))
 135       else
 136         try
 137           let sec = Hashtbl.find id2sec xref in
 138           node#set_attribute "href"
 139             (Pxp_types.Value (fname_of_sec sec ^ "#" ^ xref))
 140         with Not_found -> ())
 141     toc
 142
 143 let patch_sec sec_ids id2sec sec =
 144   let sec_name = get_sec_name sec in
 145   iter_xrefs
 146     (fun node xref ->
 147       try
 148         let xref_sec = Hashtbl.find id2sec xref in
 149         if xref_sec <> sec_name then
 150           node#set_attribute "href"
 151             (Pxp_types.Value (fname_of_sec xref_sec ^ "#" ^ xref))
 152       with Not_found -> ())
 153     sec
 154
 155 let open_formatter fname =
 156   Unix.open_process_out (Printf.sprintf "xmllint --format -o %s -" fname)
 157
 158 let close_formatter oc = ignore (Unix.close_process_out oc)
 159
 160 let output_index (titlepage: 'a node) (toc: 'a node) fname =
 161   let oc = open_formatter fname in
 162   output_string oc xhtml_header;
 163   titlepage#write (`Out_channel oc) `Enc_utf8;
 164   toc#write (`Out_channel oc) `Enc_utf8;
 165   output_string oc xhtml_trailer;
 166   close_formatter oc
 167
 168 let output_sec (sec: 'a node) fname =
 169   let oc = open_formatter fname in
 170   output_string oc xhtml_header;
 171   sec#write (`Out_channel oc) `Enc_utf8;
 172   output_string oc xhtml_trailer;
 173   close_formatter oc
 174
 175 let main () =
 176   let doc = parse_xml fname in
 177   match slice doc with
 178   | titlepage :: toc :: secs ->
 179       let sec_ids, id2sec = localize_ids secs in
 180       patch_toc sec_ids id2sec toc;
 181       List.iter (patch_sec sec_ids id2sec) secs;
 182       output_index titlepage toc "index.html";
 183       List.iter (fun sec -> output_sec sec (get_sec_name sec ^ ".html")) secs
 184   | _ -> failwith "Unrecognized document structure"
 185
 186 let _ = main ()
 187