matita/matita/contribs/lambdadelta/bin/index/index.ml

   1 module KF = Filename
   2 module KP = Printf
   3 module KU = Unix
   4
   5 type status = {
   6 (* base directory *)
   7   bd: string;
   8 (* input prefix *)
   9   ip: string;
  10 (* output prefix *)
  11   op: string;
  12 (* current path *)
  13   cp: string list
  14 }
  15
  16 let initial_status = {
  17   bd = ""; ip = ""; op = "";
  18   cp = [];
  19 }
  20
  21 let imp_st = ref initial_status
  22
  23 let i_ext = ".ld.ldw.xml"
  24 let o_ext = ".ld.html"
  25
  26 let concats l =
  27   List.fold_left KF.concat "" l
  28
  29 let concat st dname = {st with
  30   ip = KF.concat st.ip dname; op = KF.concat st.op dname;
  31 }
  32
  33 let normalize dname =
  34   if dname = KF.current_dir_name then "" else dname
  35
  36 let mk_rlink s_to s_body =
  37   KP.sprintf "<rlink to=\"%s\">%s</rlink>" s_to s_body
  38
  39 let out_entry st dname och dirs name =
  40   let iname = concats [st.bd; st.ip; dname; name] in
  41   let stats = KU.lstat iname in
  42   match stats.KU.st_kind with
  43   | KU.S_REG when KF.check_suffix name i_ext ->
  44     let base = KF.chop_suffix name i_ext in
  45     let oname = concats [st.bd; st.op; dname; base^o_ext] in
  46     KP.fprintf och "    <file class=\"global emph\" type=\"&#x1F5CF;\" to=\"%s\" name=\"%s.ld\"/>\n" oname base;
  47     dirs
  48   | KU.S_DIR ->
  49     let oname = concats [st.bd; st.op; dname; name] in
  50     KP.fprintf och "    <file class=\"alpha emph\" type=\"&#x1F5C1;\" to=\"%s\" name=\"%s/\"/>\n" oname name;
  51     name :: dirs
  52   | _        ->
  53     dirs
  54
  55 let mk_path st och =
  56   let path = String.concat "/" (List.rev st.cp) in
  57   KP.fprintf och "    Contents of %s/\n" path
  58
  59 let list_dir st dname och =
  60   let iname = concats [st.bd; st.ip; dname] in
  61   let dir = Sys.readdir iname in
  62   Array.sort String.compare dir;
  63   KP.fprintf och "   <index>\n";
  64   let dirs = Array.fold_left (out_entry st dname och) [] dir in
  65   KP.fprintf och "   </index>\n";
  66   dirs
  67
  68 let out_index st dname och =
  69   KP.fprintf och "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n\n";
  70   KP.fprintf och "<page xmlns=\"http://lambdadelta.info/\"\n";
  71   KP.fprintf och "      description=\"\\lambda\\delta home page\"\n";
  72   KP.fprintf och "      title=\"\\lambda\\delta home page\"\n";
  73   KP.fprintf och "      head=\"λδ digital library (LDDL)\"\n";
  74   KP.fprintf och ">\n";
  75   KP.fprintf och "  <sitemap name=\"sitemap\"/>\n";
  76   KP.fprintf och "  <section5 name=\"index\">Index</section5>\n";
  77   KP.fprintf och "  <subsection name=\"path\">\n";
  78   mk_path st och;
  79   KP.fprintf och "  </subsection>\n";
  80   KP.fprintf och "  <body>\n";
  81   let dirs = list_dir st dname och in
  82   KP.fprintf och "  </body>\n";
  83   KP.fprintf och "  <footer><img label=\"helena\"/></footer>\n";
  84   KP.fprintf och "</page>\n";
  85   dirs
  86
  87 let rec out_dir st dname =
  88   let s_to, s_body =
  89     if dname = ""
  90     then concats [st.bd; st.op], "ld:"
  91     else concats [st.bd; st.op; dname], dname
  92   in
  93   let st = {st with cp = mk_rlink s_to s_body :: st.cp} in
  94   let oname = concats [st.bd; st.ip; dname; "index.ldw.xml"] in
  95   let och = open_out oname in
  96   let dirs = out_index st dname och in
  97   close_out och;
  98   let map st = out_dir (concat st dname) in
  99   List.iter (map st) dirs
 100
 101 let help_b = "<dir>  Set this base directory"
 102 let help_i = "<dir>  Set this input prefix"
 103 let help_o = "<dir>  Set this output prefix"
 104 let help = "Usage: index [ -bio <dir> | <dir> ]*"
 105
 106 let set_b bd =
 107   imp_st := {!imp_st with bd = normalize bd}
 108
 109 let set_i ip =
 110   imp_st := {!imp_st with ip = normalize ip}
 111
 112 let set_o op =
 113   imp_st := {!imp_st with op = normalize op}
 114
 115 let process dname =
 116   out_dir !imp_st (normalize dname)
 117
 118 let main =
 119   Arg.parse [
 120     "-b", Arg.String set_b, help_b;
 121     "-i", Arg.String set_i, help_i;
 122     "-o", Arg.String set_o, help_o;
 123   ] process help