helm/www/lambdadelta/bin/xhtbl/xmlUnparser.ml

   1 module A = Array
   2 module F = Filename
   3 module L = List
   4 module P = Printf
   5 module S = String
   6
   7 module O = Options
   8 module T = Table
   9 module M = Matrix
  10
  11 let i = 0
  12
  13 let myself = F.basename (Sys.argv.(0))
  14
  15 let msg = P.sprintf "This file was generated by %s, do not edit" myself
  16
  17 let compose uri ext =
  18    if uri.[pred (S.length uri)] = '/' then uri else
  19    try
  20       let i = S.index uri '#' in
  21       let uri, fragment = S.sub uri 0 i, S.sub uri i (S.length uri - i) in
  22       uri ^ ext ^ fragment
  23    with Not_found -> uri ^ ext
  24
  25 let border cell =
  26    let str = S.make 4 'n' in
  27    if cell.M.cb.T.n then str.[0] <- 's';
  28    if cell.M.cb.T.e then str.[1] <- 's';
  29    if cell.M.cb.T.s then str.[2] <- 's';
  30    if cell.M.cb.T.w then str.[3] <- 's';
  31    str :: cell.M.cc
  32
  33 let text baseuri ext = function
  34    | T.Plain s              -> s
  35    | T.Link (true, uri, s)  -> P.sprintf "<a href=\"%s\">%s</a>" uri s
  36    | T.Link (false, uri, s) ->
  37       let uri = !O.baseuri ^ baseuri ^ compose uri ext in
  38       P.sprintf "<a href=\"%s\">%s</a>" uri s
  39
  40 let name cell =
  41    if cell.M.cn = "" then "" else P.sprintf " id=\"%s\"" cell.M.cn
  42
  43 let key cell =
  44    if cell.M.ck = [] then "<br/>" else S.concat "" (L.map (text cell.M.cu cell.M.cx) cell.M.ck)
  45
  46 let ind i = S.make (2 * i) ' '
  47
  48 let out_cell och cell =
  49    let cc = border cell in
  50    P.fprintf och "%s<td class=\"%s\"%s>%s</td>\n"
  51       (ind (i+4)) (S.concat " " cc) (name cell) (key cell)
  52
  53 let out_row och row =
  54    P.fprintf och "%s<tr>\n" (ind (i+3));
  55    A.iter (out_cell och) row;
  56    P.fprintf och "%s</tr>\n" (ind (i+3))
  57
  58 let out_space och (name, uri) =
  59    let name = if name = "" then name else ":" ^ name in
  60    P.fprintf och "                xmlns%s=\"%s\"\n" name uri
  61
  62 (****************************************************************************)
  63
  64 let open_out name spaces =
  65    let fname = F.concat !O.output_dir (P.sprintf "%s.xsl" name) in
  66    let spaces = ("xsl", "http://www.w3.org/1999/XSL/Transform") :: spaces in
  67    let och = open_out fname in
  68    P.fprintf och "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n\n";
  69    P.fprintf och "<!-- %s -->\n\n" msg;
  70    P.fprintf och "<xsl:stylesheet version=\"1.0\"\n";
  71    L.iter (out_space och) spaces;
  72    P.fprintf och ">\n\n";
  73    och
  74
  75 let output och name matrix =
  76    P.fprintf och "<xsl:template name=\"%s\">\n" name;
  77    P.fprintf och "%s<table cellpadding=\"4\" cellspacing=\"0\">\n" (ind (i+1));
  78    P.fprintf och "%s<tbody>\n" (ind (i+2));
  79    A.iter (out_row och) matrix.M.m;
  80    P.fprintf och "%s</tbody>\n" (ind (i+2));
  81    P.fprintf och "%s</table>\n" (ind (i+1));
  82    P.fprintf och "</xsl:template>\n\n"
  83
  84 let close_out och =
  85    P.fprintf och "</xsl:stylesheet>\n";
  86    close_out och
  87
  88 let map_incs och name =
  89    P.fprintf och "<xsl:include href=\"%s.xsl\"/>\n" name
  90
  91 let map_tbls och name =
  92    P.fprintf och "%s<xsl:when test=\"@name='%s'\">\n" (ind (i+2)) name;
  93    P.fprintf och "%s<xsl:call-template name=\"%s\"/>\n" (ind (i+3)) name;
  94    P.fprintf och "%s</xsl:when>\n" (ind (i+2))
  95
  96 let write_hook name incs tbls =
  97    let och = open_out name [] in
  98    L.iter (map_incs och) incs;
  99    P.fprintf och "\n<xsl:template name=\"%s\">\n" name;
 100    P.fprintf och "%s<xsl:choose>\n" (ind (i+1));
 101    L.iter (map_tbls och) tbls;
 102    P.fprintf och "%s</xsl:choose>\n" (ind (i+1));
 103    P.fprintf och "</xsl:template>\n\n";
 104    close_out och