- xhtbl: support for relative links added

[helm.git] / helm / www / lambdadelta / bin / xhtbl / xmlUnparser.ml

diff --git a/helm/www/lambdadelta/bin/xhtbl/xmlUnparser.ml b/helm/www/lambdadelta/bin/xhtbl/xmlUnparser.ml
index 3583c2f7536e95d045a4dd0776bbf81d4169b8c2..603c7f1bebd1baa2706ce4273b34e5a214ccc5b3 100644 (file)
--- a/helm/www/lambdadelta/bin/xhtbl/xmlUnparser.ml
+++ b/helm/www/lambdadelta/bin/xhtbl/xmlUnparser.ml
@@ -22,8 +22,15 @@ let border cell =
    if cell.M.cb.T.w then str.[3] <- 's';
    str :: cell.M.cc
 
+let text baseuri ext = function
+   | T.Plain s              -> s
+   | T.Link (true, uri, s)  -> P.sprintf "<a href=\"%s\">%s</a>" uri s
+   | T.Link (false, uri, s) -> 
+      let uri = !O.baseuri ^ baseuri ^ uri ^ ext in
+      P.sprintf "<a href=\"%s\">%s</a>" uri s
+
 let key cell =
-   if cell.M.ck = [] then "<br/>" else S.concat " " cell.M.ck
+   if cell.M.ck = [] then "<br/>" else S.concat " " (L.map (text cell.M.cu cell.M.cx) cell.M.ck)
 
 let ind i = S.make (2 * i) ' '
 
@@ -37,16 +44,20 @@ let out_row och row =
    A.iter (out_cell och) row;
    P.fprintf och "%s</tr>\n" (ind (i+3))
 
+let out_space och (name, uri) =
+   let name = if name = "" then name else ":" ^ name in
+   P.fprintf och "                xmlns%s=\"%s\"\n" name uri
+
 (****************************************************************************)
 
-let open_out html name =
+let open_out name spaces =
    let fname = F.concat !O.output_dir (P.sprintf "%s.xsl" name) in
+   let spaces = ("xsl", "http://www.w3.org/1999/XSL/Transform") :: spaces in
    let och = open_out fname in
    P.fprintf och "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n\n";
    P.fprintf och "<!-- %s -->\n\n" msg;   
    P.fprintf och "<xsl:stylesheet version=\"1.0\"\n";
-   P.fprintf och "                xmlns:xsl=\"http://www.w3.org/1999/XSL/Transform\"\n";
-   if html then P.fprintf och "                xmlns=\"http://www.w3.org/1999/xhtml\"\n";
+   L.iter (out_space och) spaces;
    P.fprintf och ">\n\n";
    och
 
@@ -72,7 +83,7 @@ let map_tbls och name =
    P.fprintf och "%s</xsl:when>\n" (ind (i+2))
 
 let write_hook name incs tbls =
-   let och = open_out false name in
+   let och = open_out name [] in
    L.iter (map_incs och) incs;
    P.fprintf och "\n<xsl:template name=\"%s\">\n" name;
    P.fprintf och "%s<xsl:choose>\n" (ind (i+1));