src/TeXmacs/progs/convert/html/tmhtml.scm

   1
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;
   4 ;; MODULE      : tmhtml.scm
   5 ;; DESCRIPTION : conversion of TeXmacs trees into Html trees
   6 ;; COPYRIGHT   : (C) 2002  Joris van der Hoeven, David Allouche
   7 ;;
   8 ;; This software falls under the GNU general public license and comes WITHOUT
   9 ;; ANY WARRANTY WHATSOEVER. See the file $TEXMACS_PATH/LICENSE for details.
  10 ;; If you don't have this file, write to the Free Software Foundation, Inc.,
  11 ;; 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  12 ;;
  13 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14
  15 (texmacs-module (convert html tmhtml)
  16   (:use (convert tools tmconcat)
  17         (convert mathml tmmath)
  18         (convert tools stm)
  19         (convert tools tmlength)
  20         (convert tools tmtable)
  21         (convert tools old-tmtable)
  22         (convert tools sxml)
  23         (convert tools sxhtml)
  24         (convert html htmlout)))
  25
  26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27 ;; Initialization
  28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29
  30 (define tmhtml-env (make-ahash-table))
  31 (define tmhtml-css? #t)
  32 (define tmhtml-mathml? #f)
  33 (define tmhtml-images? #f)
  34 (define tmhtml-serial 0)
  35 (define tmhtml-image-cache (make-ahash-table))
  36 (define tmhtml-image-root-url (string->url "image"))
  37 (define tmhtml-image-root-string "image")
  38
  39 (tm-define (tmhtml-initialize opts)
  40   (set! tmhtml-env (make-ahash-table))
  41   (set! tmhtml-css?
  42         (== (assoc-ref opts "texmacs->html:css") "on"))
  43   (set! tmhtml-mathml?
  44         (== (assoc-ref opts "texmacs->html:mathml") "on"))
  45   (set! tmhtml-images?
  46         (== (assoc-ref opts "texmacs->html:images") "on"))
  47   (set! tmhtml-image-cache (make-ahash-table))
  48   (let* ((suffix (url-suffix current-save-target))
  49          (n (+ (string-length suffix) 1)))
  50     (if (in? suffix '("html" "xhtml"))
  51         (begin
  52           (set! tmhtml-image-root-url (url-unglue current-save-target n))
  53           (set! tmhtml-image-root-string
  54                 (url->string (url-tail tmhtml-image-root-url))))
  55         (begin
  56           (set! tmhtml-image-root-url (string->url "image"))
  57           (set! tmhtml-image-root-string "image")))))
  58
  59 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  60 ;; Empty handler and strings
  61 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  62
  63 (define (tmhtml-noop l) '())
  64
  65 (define (cork->html s)
  66   (utf8->html (cork->utf8 s)))
  67
  68 (define (tmhtml-sub-token s pos)
  69   (with ss (substring s pos (- (string-length s) 1))
  70     (if (= (string-length ss) 1) ss
  71         (tmhtml-math-token (string-append "<" ss ">")))))
  72
  73 (define (tmhtml-math-token s)
  74   (cond ((= (string-length s) 1)
  75          (cond ((== s "*") " ")
  76                ((in? s '("+" "-" "=")) (string-append " " s " "))
  77                ((char-alphabetic? (string-ref s 0)) `(h:var ,s))
  78                (else s)))
  79         ((string-starts? s "<cal-")
  80          `(h:font (@ (face "Zapf Chancery")) ,(tmhtml-sub-token s 5)))
  81         ((string-starts? s "<b-cal-")
  82          `(h:u (h:font (@ (face "Zapf Chancery")) ,(tmhtml-sub-token s 7))))
  83         ((string-starts? s "<frak-")
  84          `(h:u ,(tmhtml-sub-token s 6)))
  85         ((string-starts? s "<bbb-") `(h:u (h:b ,(tmhtml-sub-token s 5))))
  86         ((string-starts? s "<b-") `(h:b (h:var ,(tmhtml-sub-token s 3))))
  87         ((string-starts? s "<")
  88          (with encoded (cork->utf8 s)
  89            (utf8->html (if (== s encoded)
  90                            (old-tm->xml-cdata s)
  91                            encoded))))
  92         (else s)))
  93
  94 (define (tmhtml-string s)
  95   (if (ahash-ref tmhtml-env :math)
  96       (tmhtml-post-simplify-nodes
  97        (map tmhtml-math-token (tmconcat-tokenize-math s)))
  98       (list (cork->html s))))
  99
 100 (define (tmhtml-text s)
 101   (if (or (ahash-ref tmhtml-env :math) (ahash-ref tmhtml-env :preformatted))
 102       (tmhtml-string s)
 103       (tmhtml-string (make-ligatures s))))
 104
 105 (define cork-endash (char->string (integer->char 21)))
 106 (define cork-ldquo (char->string (integer->char 16)))
 107 (define cork-rdquo (char->string (integer->char 17)))
 108
 109 (define (make-ligatures s)
 110   ;; Make texmacs ligatures in Cork encoding
 111   (string-replace
 112    (string-replace
 113     (string-replace s "--" cork-endash) "``" cork-ldquo) "''" cork-rdquo))
 114
 115 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 116 ;; Entire documents
 117 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 118
 119 (define (tmhtml-find-title doc)
 120   (cond ((func? doc 'tmdoc-title 1) (cadr doc))
 121         ((func? doc 'tmdoc-title* 2) (cadr doc))
 122         ((func? doc 'tmdoc-title** 3) (caddr doc))
 123         ((npair? doc) #f)
 124         (else (with title (tmhtml-find-title (car doc))
 125                 (if title title
 126                     (tmhtml-find-title (cdr doc)))))))
 127
 128 (define (tmhtml-css-header)
 129   (let ((html
 130          (string-append
 131           "body { text-align: justify } "
 132           "h5 { display: inline; padding-right: 1em } "
 133           "h6 { display: inline; padding-right: 1em } "
 134           "table { border-collapse: collapse } "
 135           "td { padding: 0.2em; vertical-align: baseline } "
 136           ".subsup { display: inline; vertical-align: -0.2em } "
 137           ".subsup td { padding: 0px; text-align: left} "
 138           ".fraction { display: inline; vertical-align: -0.8em } "
 139           ".fraction td { padding: 0px; text-align: center } "
 140           ".wide { position: relative; margin-left: -0.4em } "
 141           ".accent { position: relative; margin-left: -0.4em; top: -0.1em } "
 142           ".title-block { width: 100%; text-align: center } "
 143           ".title-block p { margin: 0px } "
 144           ".compact-block p { margin-top: 0px; margin-bottom: 0px } "
 145           ".left-tab { text-align: left } "
 146           ".center-tab { text-align: center } "
 147           ".right-tab { float: right; position: relative; top: -1em } "))
 148         (mathml "math { font-family: cmr, times, verdana } "))
 149     (if tmhtml-mathml? (string-append html mathml) html)))
 150
 151 (define (tmhtml-file l)
 152   ;; This handler is special:
 153   ;; Since !file is a special node used only at the top of trees
 154   ;; it produces a single node, and not a nodeset like other handlers.
 155   (let* ((doc (car l))
 156          (styles (cdadr l))
 157          (lang (caddr l))
 158          (tmpath (cadddr l))
 159          (title (tmhtml-force-string (tmhtml-find-title doc)))
 160          (css `(h:style (@ (type "text/css")) ,(tmhtml-css-header)))
 161          (body (tmhtml doc)))
 162     (set! title (cond ((not title) "No title")
 163                       ((or (in? "tmdoc" styles) (in? "tmweb" styles))
 164                        `(concat ,title " (FSF GNU project)"))
 165                       (else title)))
 166     (if (or (in? "tmdoc" styles) (in? "tmweb" styles) (in? "mmxdoc" styles))
 167         (with ss (if (in? "mmxdoc" styles)
 168                      "http://www.texmacs.org/css/mmxdoc.css"
 169                      "http://www.texmacs.org/css/tmdoc.css")
 170           (set! css `(h:link (@ (rel "stylesheet")
 171                                 (href ,ss)
 172                                 (type "text/css"))))
 173           (set! body (tmhtml-tmdoc-post body))))
 174     `(h:html
 175       (h:head
 176        (h:title ,@(tmhtml title))
 177        (h:meta (@ (name "generator")
 178                   (content ,(string-append "TeXmacs " (texmacs-version)))))
 179        ,css)
 180       (h:body ,@body))))
 181
 182 (define (tmhtml-finalize-document top)
 183   ;; @top must be a node produced by tmhtml-file
 184   "Prepare a XML document for serialization"
 185   (define xmlns-attrs
 186     '((xmlns "http://www.w3.org/1999/xhtml")
 187       (xmlns:m "http://www.w3.org/1998/Math/MathML")
 188       (xmlns:x "http://www.texmacs.org/2002/extensions")))
 189   (define doctype-list
 190     (let ((html "-//W3C//DTD XHTML 1.1 plus MathML 2.0//EN")
 191           (mathml "http://www.w3.org/TR/MathML2/dtd/xhtml-math11-f.dtd"))
 192       (if tmhtml-mathml? (list html mathml) (list html))))
 193   `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"")
 194           (*DOCTYPE* html PUBLIC ,@doctype-list)
 195           ,((cut sxml-set-attrs <> xmlns-attrs)
 196             (sxml-strip-ns-prefix "h" (sxml-strip-ns-prefix "m" top)))))
 197
 198 (define (tmhtml-finalize-selection l)
 199   ;; @l is a nodeset produced by any handler _but_ tmhtml-file
 200   "Prepare a HTML node-set for serialization."
 201   `(*TOP* ,@(map (cut sxml-strip-ns-prefix "h" <>) l)))
 202
 203 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 204 ;; Block structures
 205 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 206
 207 (define (tmhtml-document-elem x)
 208   ;; NOTE: this should not really be necessary, but it improves
 209   ;; the layout of verbatim environments with a missing block structure
 210   (if (and (list-2? x)
 211            (or (== (car x) 'verbatim) (== (car x) 'code))
 212            (not (func? (cadr x) 'document)))
 213       (tmhtml (list (car x) (list 'document (cadr x))))
 214       (tmhtml x)))
 215
 216 (define (tmhtml-compute-max-vspace l after?)
 217   (and (nnull? l)
 218     (with s1 (tmhtml-compute-vspace (car l) after?)
 219       (with s2 (tmhtml-compute-max-vspace (cdr l) after?)
 220         (cond ((not s1) s2)
 221               ((not s2) s1)
 222               (else
 223                 (with l1 (string->tmlength s1)
 224                   (with l2 (string->tmlength s2)
 225                     (if (== (tmlength-unit l1) (tmlength-unit l2))
 226                         (if (>= (tmlength-value l1) (tmlength-value l2)) s1 s2)
 227                         l1 ;; FIXME: do something more subtle here
 228                         )))))))))
 229
 230 (define (tmhtml-compute-vspace x after?)
 231   (cond ((and (not after?) (func? x 'vspace* 1)) (tmhtml-force-string (cadr x)))
 232         ((and after? (func? x 'vspace 1)) (tmhtml-force-string (cadr x)))
 233         ;;((and (not after?) (func? x 'document)) (tmhtml-compute-vspace (cadr x) #f))
 234         ;;((and after? (func? x 'document)) (tmhtml-compute-vspace (cAr x) #t))
 235         ((func? x 'concat) (tmhtml-compute-max-vspace (cdr x) after?))
 236         ((func? x 'with) (tmhtml-compute-vspace (cAr x) after?))
 237         ;;((func? x 'surround) (tmhtml-compute-max-vspace (cDdr x) after?))
 238         ;;((func? x 'surround) (tmhtml-compute-max-vspace (cdr x) after?))
 239         (else #f)))
 240
 241 (define (tmhtml-document-p x)
 242   (let* ((body (tmhtml-document-elem x))
 243          (l1 (tmhtml-compute-vspace x #f))
 244          (l2 (tmhtml-compute-vspace x #t))
 245          (h1 (and l1 (tmlength->htmllength l1 #t)))
 246          (h2 (and l2 (tmlength->htmllength l2 #t)))
 247          (s1 (and h1 (string-append "margin-top: " h1)))
 248          (s2 (and h2 (string-append "margin-bottom: " h2)))
 249          (s (cond ((and s1 s2) (string-append s1 "; " s2))
 250                   (s1 s2)
 251                   (s2 s1)
 252                   (else #f))))
 253     ;;(display* "paragraph= " x "\n")
 254     ;;(display* "style    = " s "\n")
 255     (if s `(h:p (@ (style ,s)) ,@body) `(h:p ,@body))))
 256
 257 (define (xtmhtml-document-p x)
 258   (with body (tmhtml-document-elem x)
 259     `(h:p ,@body)))
 260
 261 (define (tmhtml-document l)
 262   (cond ((null? l) '())
 263         ((ahash-ref tmhtml-env :preformatted)
 264          (tmhtml-post-simplify-nodes
 265           (list-concatenate
 266            ((cut list-intersperse <> '("\n"))
 267             (map tmhtml l)))))
 268         (else
 269           (tmhtml-post-paragraphs (map tmhtml-document-p l)))))
 270
 271 (define (tmhtml-paragraph l)
 272   (let rec ((l l))
 273     (if (null? l) '()
 274         (let ((h (tmhtml (car l)))
 275               (r (rec (cdr l))))
 276           (cond ((null? h) r)           ; correct when r is null too
 277                 ((null? r) h)
 278                 (else `(,@h (h:br) ,@r)))))))
 279
 280 (define (tmhtml-post-paragraphs l)
 281   ;; Post process a collection of h:p elements
 282   ;;
 283   ;; If a h:p contains a h:hN, remove the h:p node and prepend the rest of the
 284   ;; contents to the next h:p. If the next element, after post processing is
 285   ;; not a h:p, create an intermediate h:p to hold the data.
 286   ;;
 287   ;; If a h:p contains a list element, remove the enclosing h:p. The TeXmacs
 288   ;; editor ensures that an <item-list> or <desc-list> is the only element
 289   ;; contained in its enclosing <doc-item>.
 290   ;;
 291   ;; If a h:p contains a h:pre element, remove the enclosing h:p. The VERBATIM
 292   ;; handler ensures that block VERBATIM and CODE environment are alone in the
 293   ;; paragraph.
 294   ;;
 295   ;; NOTE: assumes the heading is at the start of a paragraph. That is
 296   ;; consistent with the fact that (as of 2003-02-04) the only converted
 297   ;; invisible markup is <label> and correct usage requires it to be after the
 298   ;; section title.
 299   (let rec ((in l) (out '()) (trail #f))
 300     (let* ((para (and (pair? in) (car in)))
 301            (cont (and para (sxml-content para)))
 302            (first (and cont (pair? cont) (car cont)))
 303            (next (lambda (o t) (rec (cdr in) o t)))
 304            (flush (lambda () (if trail `((h:p ,@trail) ,@out) out)))
 305            (accept (lambda () (if trail (sxml-prepend para trail) para)))
 306            (give (lambda () (and (pair? (cdr cont)) (cdr cont)))))
 307       ;; invariant: (xor prev prev-trail)
 308       (cond ((null? in) (reverse (flush)))
 309             ((or (null? cont) (string? first))
 310              (next (cons (accept) out) #f))
 311             ((sxhtml-heading? first)
 312              ;; tmhtml-post-heading should be called by concat handler
 313              (next (cons first (flush)) (give)))
 314             ((sxhtml-list? first)
 315              ;; texmacs editor ensures there is no trail after a list
 316              (next (append cont (flush)) #f))
 317             ((== 'h:pre (sxml-name first))
 318              ;; handlers and editor ensure there is no trail after a h:pre
 319              (next (append cont (flush)) #f))
 320             ((and (sxhtml-table? first) (null? (cdr cont)))
 321              ;; if table is not alone, we cannot help but produce bad html
 322              ;; if table is alone, drop the enclosing <h:p>
 323              (next (append cont (flush)) #f))
 324             (else (next (cons (accept) out) #f))))))
 325
 326 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 327 ;; Surrounding block structures
 328 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 329
 330 (define document-done '())
 331 (define concat-done '())
 332
 333 (define (serialize-print x)
 334   (set! concat-done (cons x concat-done)))
 335
 336 (define (serialize-paragraph x)
 337   (serialize-concat x)
 338   (with l (tmconcat-simplify (reverse concat-done))
 339     (set! document-done (cons (cons 'concat l) document-done))
 340     (set! concat-done '())))
 341
 342 (define (serialize-concat x)
 343   (cond ((in? x '("" (document) (concat))) (noop))
 344         ((func? x 'document)
 345          (for-each serialize-paragraph (cDdr x))
 346          (serialize-concat (cAr x)))
 347         ((func? x 'concat)
 348          (for-each serialize-concat (cdr x)))
 349         ((func? x 'surround 3)
 350          (serialize-concat (cadr x))
 351          (serialize-concat (cadddr x))
 352          (serialize-concat (caddr x)))
 353         ((func? x 'with)
 354          (let* ((r (simplify-document (cAr x)))
 355                 (w (lambda (y) `(with ,@(cDdr x) ,y))))
 356            (if (not (func? r 'document))
 357                (serialize-print (w r))
 358                (let* ((head (cadr r))
 359                       (body `(document ,@(cDr (cddr r))))
 360                       (tail (cAr r)))
 361                  (serialize-paragraph (w head))
 362                  (set! document-done (cons (w body) document-done))
 363                  (serialize-concat (w tail))))))
 364         (else (serialize-print x))))
 365
 366 (define (simplify-document x)
 367   (with-global document-done '()
 368     (with-global concat-done '()
 369       (serialize-paragraph x)
 370       (if (list-1? document-done)
 371           (car document-done)
 372           (cons 'document (reverse document-done))))))
 373
 374 (define (block-document? x)
 375   (cond ((func? x 'document) #t)
 376         ((func? x 'concat) (list-any block-document? (cdr x)))
 377         ((func? x 'surround 3) (block-document? (cAr x)))
 378         ((func? x 'with) (block-document? (cAr x)))
 379         (else #f)))
 380
 381 (define (blockify x)
 382   (cond ((func? x 'document) x)
 383         ((or (func? x 'surround 3) (func? x 'with))
 384          (rcons (cDr x) (blockify (cAr x))))
 385         (else `(document ,x))))
 386
 387 (define (tmhtml-surround l)
 388   (let* ((r1 `(surround ,@l))
 389          (r2 (simplify-document r1))
 390          (f? (and (block-document? r1) (not (func? r2 'document))))
 391          (r3 (if f? (blockify r2) r2)))
 392     (tmhtml r3)))
 393
 394 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 395 ;; Horizontal concatenations
 396 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 397
 398 (define (tmhtml-glue-scripts l)
 399   (cond ((or (null? l) (null? (cdr l))) l)
 400         ((and (func? (car l) 'rsub 1) (func? (cadr l) 'rsup 1))
 401          (cons `(rsubsup ,(cadar l) ,(cadadr l))
 402                (tmhtml-glue-scripts (cddr l))))
 403         (else (cons (car l) (tmhtml-glue-scripts (cdr l))))))
 404
 405 (define (heading? l)
 406   (cond ((null? l) #f)
 407         ((sxhtml-label? (car l)) (heading? (cdr l)))
 408         ((sxhtml-heading? (car l)) #t)
 409         (else #f)))
 410
 411 (define (tmhtml-post-heading l)
 412   ;; Post-process the converted result of a concat containing a section title.
 413   ;;
 414   ;; Any label preceding the section is moved after it.
 415   ;;
 416   ;; The first label after the section is changed to an 'id' attribute in the
 417   ;; heading element, if it has not already an 'id' attribute.
 418   ;;
 419   ;; NOTE: assumes the heading is the first node (not counting labels)
 420   (receive (labels-before rest) (list-span l sxhtml-label?)
 421     (receive (heading rest) (car+cdr rest)
 422       (if (sxml-attr heading 'id)
 423           `(,heading ,@labels-before ,@rest)
 424           (receive (labels-after rest) (list-partition rest sxhtml-label?)
 425             (let ((labels (append labels-before labels-after)))
 426               (if (null? labels) l
 427                   (cons (sxml-prepend (sxhtml-glue-label heading (car labels))
 428                                       (cdr labels))
 429                         rest))))))))
 430
 431 (define (tmhtml-post-table l)
 432   ;; Post process the converted result of a concat containing a table.
 433   ;;
 434   ;; If a label is adjacent to the table, use it to set the table id. If there
 435   ;; are several labels adjacent to the table, leave all but one label
 436   ;; untouched. There is no guarantee on which label is glued.
 437   (define (glue-label-to-table x knil)
 438     (cond ((null? knil) (list x))
 439           ((and (sxhtml-label? x)
 440                 (sxhtml-table? (car knil))
 441                 (not (sxml-attr (car knil) 'id)))
 442            (cons (sxhtml-glue-label (car knil) x)
 443                  (cdr knil)))
 444           ((and (sxhtml-table? x)
 445                 (not (sxml-attr x 'id))
 446                 (sxhtml-label? (car knil)))
 447            (cons (sxhtml-glue-label x (car knil))
 448                  (cdr knil)))
 449           (else (cons x knil))))
 450   (list-fold-right glue-label-to-table '() l))
 451
 452 (define (tmhtml-concat l)
 453   (set! l (tmhtml-glue-scripts l))
 454   (set! l (tmconcat-structure-tabs l))
 455   ;; FIXME: tabs which are inside a 'with' are not treated correctly
 456   (tmhtml-post-simplify-nodes
 457    (let ((l (tmhtml-list l)))
 458      (cond ((null? l) '())
 459            ((string? (car l)) l)
 460            ((heading? l) (tmhtml-post-heading l))
 461            ((list-any sxhtml-table? l) (tmhtml-post-table l))
 462            ((and (null? (cdr l)) (pair? (car l))
 463                  (== (caar l) 'h:div) (== (cadar l) '(@ (class "left-tab"))))
 464             (cddar l))
 465            (else l)))))
 466
 467 (define (tmhtml-align-left l)
 468   (with r (tmhtml-concat l)
 469     (if (in? r '(() (""))) '()
 470         `((h:div (@ (class "left-tab")) ,@r)))))
 471
 472 (define (tmhtml-align-middle l)
 473   (with r (tmhtml-concat l)
 474     (if (in? r '(() (""))) '()
 475         `((h:div (@ (class "center-tab")) ,@r)))))
 476
 477 (define (tmhtml-align-right l)
 478   (with r (tmhtml-concat l)
 479     (if (in? r '(() (""))) '()
 480         `((h:div (@ (class "right-tab")) ,@r)))))
 481
 482 (define (tmhtml-post-simplify-nodes l)
 483   ;; Catenate adjacent string nodes and remove empty string nodes
 484   (let rec ((l l))
 485     (cond ((null? l) '())
 486           ((and (string? (car l)) (string-null? (car l)))
 487            (rec (cdr l)))
 488           ((null? (cdr l)) l)
 489           ((and (string? (car l)) (string? (cadr l)))
 490            (rec (cons (string-append (car l) (cadr l)) (cddr l))))
 491           (else (cons (car l) (rec (cdr l)))))))
 492
 493 (define (tmhtml-post-simplify-element e)
 494   ;; Simplify the nodes of the element content
 495   (list (append (sxml-element-head e)
 496                 (tmhtml-post-simplify-nodes (sxml-content e)))))
 497
 498 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 499 ;; Formatting text
 500 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 501
 502 (define (tmhtml-hspace l)
 503   (with len (tmlength->htmllength (if (list-1? l) (car l) (cadr l)) #t)
 504     (if (not len) '()
 505         `((spacer (@ (type "block")
 506                      (style ,(string-append "width: " len))))))))
 507
 508 (define (tmhtml-vspace l)
 509   '())
 510
 511 (define (tmhtml-move l)
 512   (tmhtml (car l)))
 513
 514 (define (tmhtml-resize l)
 515   (tmhtml (car l)))
 516
 517 (define (tmhtml-float l)
 518   (tmhtml (cAr l)))
 519
 520 (define (tmhtml-repeat l)
 521   (tmhtml (car l)))
 522
 523 (define (tmhtml-datoms l)
 524   (tmhtml (cAr l)))
 525
 526 (define (tmhtml-new-line l)
 527   '((h:br)))
 528
 529 (define (tmhtml-next-line l)
 530   '((h:br)))
 531
 532 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 533 ;; Mathematics
 534 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 535
 536 (define (tmhtml-id l)
 537   (tmhtml (car l)))
 538
 539 (define (tmhtml-big l)
 540   (cond ((in? (car l) '("sum" "prod" "int" "oint" "amalg"))
 541          (tmhtml (string-append "<" (car l) ">")))
 542         ((in? (car l) '("<cap>" "<cup>" "<vee>" "<wedge>"))
 543          (with s (substring (car l) 1 (- (string-length (car l)) 1))
 544            (tmhtml (string-append "<big" s ">"))))
 545         ((== (car l) ".") '())
 546         (else (tmhtml (car l)))))
 547
 548 (define (tmhtml-below l)
 549   `("below (" ,@(tmhtml (car l)) ", " ,@(tmhtml (cadr l)) ")"))
 550
 551 (define (tmhtml-above l)
 552   `("above (" ,@(tmhtml (car l)) ", " ,@(tmhtml (cadr l)) ")"))
 553
 554 (define (tmhtml-sub l)
 555   `((h:sub ,@(tmhtml (car l)))))
 556
 557 (define (tmhtml-sup l)
 558   `((h:sup ,@(tmhtml (car l)))))
 559
 560 (define (tmhtml-subsup l)
 561   (let* ((sub (tmhtml (car l)))
 562          (sup (tmhtml (cadr l)))
 563          (r1 `(h:tr (h:td ,@sup)))
 564          (r2 `(h:tr (h:td ,@sub))))
 565     `((h:sub (h:table (@ (class "subsup")) ,r1 ,r2)))))
 566
 567 ;;(define (tmhtml-frac l)
 568 ;;  (let* ((num (tmhtml (car l)))
 569 ;;       (den (tmhtml (cadr l))))
 570 ;;    `("frac (" ,@num ", " ,@den ")")))
 571
 572 (define (tmhtml-frac l)
 573   (let* ((num (tmhtml (car l)))
 574          (den (tmhtml (cadr l)))
 575          (n `(h:tr (h:td (@ (style "border-bottom: solid 1px")) ,@num)))
 576          (d `(h:tr (h:td ,@den))))
 577     `((h:table (@ (class "fraction")) ,n ,d))))
 578
 579 (define (tmhtml-sqrt l)
 580   (if (= (length l) 1)
 581       `("sqrt (" ,@(tmhtml (car l)) ")")
 582       `("sqrt" (h:sub ,@(tmhtml (cadr l)))
 583         " (" ,@(tmhtml (car l)) ")")))
 584
 585 (define (tmhtml-short? l)
 586   (and (list-1? l)
 587        (or (string? (car l))
 588            (and (func? (car l) 'h:i) (tmhtml-short? (cdar l)))
 589            (and (func? (car l) 'h:b) (tmhtml-short? (cdar l)))
 590            (and (func? (car l) 'h:u) (tmhtml-short? (cdar l)))
 591            (and (func? (car l) 'h:var) (tmhtml-short? (cdar l)))
 592            (and (func? (car l) 'h:font) (tmhtml-short? (cdar l))))))
 593
 594 (define (tmhtml-wide l)
 595   (let* ((body (tmhtml (car l)))
 596          (acc (tmhtml (cadr l)))
 597          (class (if (in? acc '(("^") ("~"))) "accent" "wide")))
 598     (if (tmhtml-short? body)
 599         `(,@body (h:sup (@ (class ,class)) ,@acc))
 600         `("(" ,@body ")" (h:sup ,@acc)))))
 601
 602 (define (tmhtml-neg l)
 603   `("not(" ,@(tmhtml (car l)) ")"))
 604
 605 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 606 ;; Color conversions
 607 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 608
 609 (define (tmcolor->htmlcolor x)
 610   (with s (tmhtml-force-string x)
 611     (cond ((== s "light grey") "#d0d0d0")
 612           ((== s "dark grey") "#707070")
 613           ((== s "dark red") "#800000")
 614           ((== s "dark green") "#008000")
 615           ((== s "dark blue") "#000080")
 616           ((== s "dark yellow") "#808000")
 617           ((== s "dark magenta") "#800080")
 618           ((== s "dark cyan") "#008080")
 619           ((== s "dark orange") "#804000")
 620           ((== s "dark brown") "#401000")
 621           ((== s "broken white") "#ffffdf")
 622           ((== s "pastel red") "#ffdfdf")
 623           ((== s "pastel green") "#dfffdf")
 624           ((== s "pastel blue") "#dfdfff")
 625           ((== s "pastel yellow") "#ffffdf")
 626           ((== s "pastel magenta") "#ffdfff")
 627           ((== s "pastel cyan") "#dfffff")
 628           ((== s "pastel orange") "#ffdfbf")
 629           ((== s "pastel brown") "#dfbfbf")
 630           (else s))))
 631
 632 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 633 ;; Length conversions
 634 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 635
 636 (define-table tmhtml-length-table
 637   ("mm" . 0.1)
 638   ("cm" . 1.0)
 639   ("in" . 2.54)
 640   ("pt" . 3.514598e-2)
 641   ("tmpt" . 2.7457797e-5)
 642   ("fn" . 0.4)
 643   ("em" . 0.4)
 644   ("ex" . 0.2)
 645   ("spc" . 0.2)
 646   ("pc" . 0.42175)
 647   ("par" . 16)
 648   ("pag" . 12)
 649   ("px" . 0.025)
 650   ("ln" . 0.025))
 651
 652 (define (make-exact x)
 653   (number->string (inexact->exact x)))
 654
 655 (define (number->htmlstring x)
 656   (number->string (if (exact? x)
 657                       (if (integer? x) x (exact->inexact x))
 658                       (if (and (integer? (inexact->exact x))
 659                                (= x (exact->inexact (inexact->exact x))))
 660                           (inexact->exact x) x))))
 661
 662 (define (tmlength->htmllength len css?)
 663   (and-let* ((len-str (tmhtml-force-string len))
 664              (tmlen (string->tmlength len-str))
 665              (dummy2? (not (tmlength-null? tmlen)))
 666              (val (tmlength-value tmlen))
 667              (unit (symbol->string (tmlength-unit tmlen)))
 668              (incm (ahash-ref tmhtml-length-table unit))
 669              (cmpx (/ 1 (ahash-ref tmhtml-length-table "px"))))
 670     (cond ((== unit "px") (number->htmlstring val))
 671           ((in? unit '("par" "pag"))
 672            (string-append (number->htmlstring (* 100 val)) "%"))
 673           ((and css? (== unit "tmpt"))
 674            (string-append (number->htmlstring (* cmpx val incm)) "px"))
 675           ((and css? (== unit "fn"))
 676            (string-append (number->htmlstring val) "em"))
 677           ((and css? (== unit "spc"))
 678            (string-append (number->htmlstring (/ val 2)) "em"))
 679           ((and css? (== unit "ln"))
 680            (string-append (number->htmlstring val) "px"))
 681           (css? len)
 682           (else (number->htmlstring (* cmpx val incm))))))
 683
 684 (define (tmlength->px len)
 685   (and-let* ((tmlen (string->tmlength len))
 686              (dummy? (not (tmlength-null? tmlen)))
 687              (val (tmlength-value tmlen))
 688              (unit (symbol->string (tmlength-unit tmlen)))
 689              (incm (ahash-ref tmhtml-length-table unit))
 690              (cmpx (/ 1 (ahash-ref tmhtml-length-table "px"))))
 691     (* cmpx val incm)))
 692
 693 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 694 ;; Local environment changes
 695 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 696
 697 (define (tmhtml-with-mode val arg)
 698   (ahash-with tmhtml-env :math (== val "math")
 699     (tmhtml (if (== val "prog") `(verbatim ,arg) arg))))
 700
 701 (define (tmhtml-with-color val arg)
 702   `((h:font (@ (color ,(tmcolor->htmlcolor val))) ,@(tmhtml arg))))
 703
 704 (define (tmhtml-with-font-size val arg)
 705   (let* ((x (* (string->number val) 100))
 706          (s (cond ((< x 1) "-4") ((< x 55) "-4") ((< x 65) "-3")
 707                   ((< x 75) "-2") ((< x 95) "-1") ((< x 115) "0")
 708                   ((< x 135) "+1") ((< x 155) "+2") ((< x 185) "+3")
 709                   ((< x 225) "+4") ((< x 500) "+5") (else "+5"))))
 710     (if s `((h:font (@ (size ,s)) ,@(tmhtml arg))) (tmhtml arg))))
 711
 712 (define (tmhtml-with-block style arg)
 713   (with r (tmhtml (blockify arg))
 714     (if (in? r '(() ("") ((h:p)) ((h:p "")))) '()
 715         `((h:div (@ (style ,style)) ,@r)))))
 716
 717 (define (tmhtml-with-par-left val arg)
 718   (with x (tmlength->px val)
 719     (if (not x) (tmhtml arg)
 720         (with d (- x (ahash-ref tmhtml-env :left-margin))
 721           (with s (string-append "margin-left: " (number->htmlstring d) "px")
 722             (ahash-with tmhtml-env :left-margin x
 723               (tmhtml-with-block s arg)))))))
 724
 725 (define (tmhtml-with-par-right val arg)
 726   (with x (tmlength->px val)
 727     (if (not x) (tmhtml arg)
 728         (with d (- x (ahash-ref tmhtml-env :right-margin))
 729           (with s (string-append "margin-right: " (number->htmlstring d) "px")
 730             (ahash-with tmhtml-env :right-margin x
 731               (tmhtml-with-block s arg)))))))
 732
 733 (define (tmhtml-with-par-first val arg)
 734   (with x (tmlength->htmllength val #t)
 735     (if (not x) (tmhtml arg)
 736         (with s (string-append "text-indent: " x)
 737           (tmhtml-with-block s arg)))))
 738
 739 (define (tmhtml-with-par-par-sep val arg)
 740   (with x (tmlength->px val)
 741     (if (== (inexact->exact x) 0)
 742         `((h:div (@ (class "compact-block")) ,@(tmhtml arg)))
 743         (tmhtml arg))))
 744
 745 (define (tmhtml-with-one var val arg)
 746   (cond ((drd-ref tmhtml-with-cmd% (list var val)) =>
 747          (lambda (w) (list (append w (tmhtml arg)))))
 748         ((drd-ref tmhtml-with-cmd% var) =>
 749          (lambda (h) (h val arg)))
 750         (else (tmhtml arg))))
 751
 752 (define (tmhtml-force-string x)
 753   (cond ((string? x) x)
 754         ((func? x 'quote 1) (tmhtml-force-string (cadr x)))
 755         ((func? x 'tmlen 1)
 756          (string-append (tmhtml-force-string (cadr x)) "tmpt"))
 757         ((func? x 'tmlen 3)
 758          (string-append (tmhtml-force-string (caddr x)) "tmpt"))
 759         ;;(else (force-string x))))
 760         (else (texmacs->verbatim (tm->tree x)))))
 761
 762 (define (tmhtml-with l)
 763   (cond ((null? l) '())
 764         ((null? (cdr l)) (tmhtml (car l)))
 765         ((null? (cddr l)) '())
 766         ((func? (cAr l) 'graphics) (tmhtml-png (cons 'with l)))
 767         (else
 768          (let* ((var (tmhtml-force-string (car l)))
 769                 (val (tmhtml-force-string (cadr l)))
 770                 (next (cddr l)))
 771            (tmhtml-with-one var val `(with ,@next))))))
 772
 773 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 774 ;; Other macro-related primitives
 775 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 776
 777 (define (tmhtml-compound l)
 778   ;; Explicit expansions are converted and handled as implicit expansions.
 779   (tmhtml-implicit-compound (cons (string->symbol (car l)) (cdr l))))
 780
 781 (define (tmhtml-mark l)
 782   ;; Explicit expansions are converted and handled as implicit expansions.
 783   (tmhtml (cadr l)))
 784
 785 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 786 ;; Source code
 787 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 788
 789 (define (blue sym)
 790   `(h:font (@ (color "blue")) ,sym))
 791
 792 (define (tmhtml-src-args l)
 793   (if (null? l) l
 794       `(,(blue "|")
 795         ,@(tmhtml (car l))
 796         ,@(tmhtml-src-args (cdr l)))))
 797
 798 (define (tmhtml-inline-tag l)
 799   `(,(blue "&lt;")
 800     ,@(tmhtml (car l))
 801     ,@(tmhtml-src-args (cdr l))
 802     ,(blue "&gt;")))
 803
 804 (define (tmhtml-open-tag l)
 805   `(,(blue "&lt;\\")
 806     ,@(tmhtml (car l))
 807     ,@(tmhtml-src-args (cdr l))
 808     ,(blue "|")))
 809
 810 (define (tmhtml-middle-tag l)
 811   `(,@(tmhtml-src-args (cdr l))
 812     ,(blue "|")))
 813
 814 (define (tmhtml-close-tag l)
 815   `(,@(tmhtml-src-args (cdr l))
 816     ,(blue "&gt;")))
 817
 818 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 819 ;; Other primitives
 820 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 821
 822 (define (tmhtml-label l)
 823   ;; WARNING: bad conversion if ID is not a string.
 824   `((h:a (@ (id ,(cork->html (force-string (car l))))))))
 825
 826 ;(define (tmhtml-reference l)
 827 ;  (list 'ref (cork->html (force-string (car l)))))
 828
 829 ;(define (tmhtml-pageref l)
 830 ;  (list 'pageref (cork->html (force-string (car l)))))
 831
 832 (define (tmhtml-suffix s)
 833   ;; Change .tm suffix to .xhtml suffix for local files for correct
 834   ;; conversion of entire web-sites. We might create an option
 835   ;; in order to disable this suffix change
 836   (let* ((sdir (string-rindex s #\/))
 837          (sep (string-rindex s #\#)))
 838     (cond ((or (string-starts? s "http:") (string-starts? s "ftp:")) s)
 839           ((and sep (or (not sdir) (< sdir sep)))
 840            (string-append (tmhtml-suffix (substring s 0 sep))
 841                           (string-drop s sep)))
 842           ((string-ends? s ".tm")
 843            (string-append (string-drop-right s 3)
 844                           (if tmhtml-mathml? ".xhtml" ".html")))
 845           (else s))))
 846
 847 (define (tmhtml-hyperlink l)
 848   ;; WARNING: bad conversion if URI is not a string.
 849   ;; TODO: change label at start of content into ID attribute, move other
 850   ;; labels out (A elements cannot be nested!).
 851   (let* ((body (tmhtml (first l)))
 852          (to (cork->html (force-string (second l)))))
 853     (if (string-starts? to "$")
 854         body ;; temporary fix for URLs like $TEXMACS_PATH/...
 855         `((h:a (@ (href ,(tmhtml-suffix to))) ,@body)))))
 856
 857 (define (tmhtml-specific l)
 858   (cond ((== (car l) "html") (list (string-decode (force-string (cadr l)))))
 859         ((== (car l) "image") (tmhtml-png (cadr l)))
 860         (else '())))
 861
 862 (define (tmhtml-action l)
 863   `((h:u ,@(tmhtml (car l)))))
 864
 865 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 866 ;;; Tables
 867 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 868
 869 (define (map* fun l)
 870   (list-filter (map fun l) identity))
 871
 872 (define (html-css-attrs l)
 873   ;; l is a list of either key-value lists (XML) or strings (CSS)
 874   ;; we return a list with the corresponding @-style attribute
 875   (if (null? l) '()
 876       (receive (css html) (list-partition l string?)
 877         (if (nnull? css)
 878             (with style (apply string-append (list-intersperse css "; "))
 879               (set! html (cons `(style ,style) html))))
 880         `((@ ,@html)))))
 881
 882 (define (length-attr what x . opt)
 883   (with len (tmlength->htmllength x #t)
 884     (and len (apply string-append (cons* what ": " len opt)))))
 885
 886 (define (border-attr what x)
 887   (length-attr what x " solid"))
 888
 889 (define (tmhtml-make-cell-attr x)
 890   (cond ((== (car x) "cell-width") (length-attr "width" (cadr x)))
 891         ((== (car x) "cell-height") (length-attr "height" (cadr x)))
 892         ((== x '("cell-halign" "l")) "text-align: left")
 893         ((== x '("cell-halign" "c")) "text-align: center")
 894         ((== x '("cell-halign" "r")) "text-align: right")
 895         ((== x '("cell-valign" "t")) "vertical-align: top")
 896         ((== x '("cell-valign" "c")) "vertical-align: middle")
 897         ((== x '("cell-valign" "b")) "vertical-align: bottom")
 898         ((== x '("cell-valign" "B")) "vertical-align: baseline")
 899         ((== (car x) "cell-background")
 900          `(bgcolor ,(tmcolor->htmlcolor (cadr x))))
 901         ((== (car x) "cell-lborder") (border-attr "border-left" (cadr x)))
 902         ((== (car x) "cell-rborder") (border-attr "border-right" (cadr x)))
 903         ((== (car x) "cell-tborder") (border-attr "border-top" (cadr x)))
 904         ((== (car x) "cell-bborder") (border-attr "border-bottom" (cadr x)))
 905         ((== (car x) "cell-lsep") (length-attr "padding-left" (cadr x)))
 906         ((== (car x) "cell-rsep") (length-attr "padding-right" (cadr x)))
 907         ((== (car x) "cell-tsep") (length-attr "padding-top" (cadr x)))
 908         ((== (car x) "cell-bsep") (length-attr "padding-bottom" (cadr x)))
 909         (else #f)))
 910
 911 (define (tmhtml-make-cell c cellf)
 912   (ahash-with tmhtml-env :left-margin 0
 913     `(h:td ,@(html-css-attrs (map* tmhtml-make-cell-attr cellf))
 914            ,@(tmhtml (cadr c)))))
 915
 916 (define (tmhtml-make-cells-bis l cellf)
 917   (if (null? l) l
 918       (cons (tmhtml-make-cell (car l) (car cellf))
 919             (tmhtml-make-cells-bis (cdr l) (cdr cellf)))))
 920
 921 (define (tmhtml-width-part attrl)
 922   (cond ((null? attrl) 0)
 923         ((== (caar attrl) "cell-hpart") (string->number (cadar attrl)))
 924         (else (tmhtml-width-part (cdr attrl)))))
 925
 926 (define (tmhtml-width-replace attrl sum)
 927   (with part (tmhtml-width-part attrl)
 928     (if (== part 0) attrl
 929         (with l (list-filter attrl (lambda (x) (!= (car x) "cell-width")))
 930           (with w (number->htmlstring (/ part sum))
 931             (cons (list "cell-width" (string-append w "par")) l))))))
 932
 933 (define (tmhtml-make-cells l cellf)
 934   (let* ((partl (map tmhtml-width-part cellf))
 935          (sum (apply + partl)))
 936     (if (!= sum 0) (set! cellf (map (cut tmhtml-width-replace <> sum) cellf)))
 937     (tmhtml-make-cells-bis l cellf)))
 938
 939 (define (tmhtml-make-row-attr x)
 940   (tmhtml-make-cell-attr x))
 941
 942 (define (tmhtml-make-row r rowf cellf)
 943   `(h:tr ,@(html-css-attrs (map* tmhtml-make-row-attr rowf))
 944          ,@(tmhtml-make-cells (cdr r) cellf)))
 945
 946 (define (tmhtml-make-rows l rowf cellf)
 947   (if (null? l) l
 948       (cons (tmhtml-make-row  (car l) (car rowf) (car cellf))
 949             (tmhtml-make-rows (cdr l) (cdr rowf) (cdr cellf)))))
 950
 951 (define (tmhtml-make-column-attr x)
 952   (tmhtml-make-cell-attr x))
 953
 954 (define (tmhtml-make-col colf)
 955   `(h:col ,@(html-css-attrs (map* tmhtml-make-column-attr colf))))
 956
 957 (define (tmhtml-make-column-group colf)
 958   (if (list-every null? colf) '()
 959       `((h:colgroup ,@(map tmhtml-make-col colf)))))
 960
 961 (define (tmhtml-make-table-attr x)
 962   (cond ((== (car x) "table-width") (length-attr "width" (cadr x)))
 963         ((== (car x) "table-height") (length-attr "height" (cadr x)))
 964         ((== (car x) "table-lborder") (border-attr "border-left" (cadr x)))
 965         ((== (car x) "table-rborder") (border-attr "border-right" (cadr x)))
 966         ((== (car x) "table-tborder") (border-attr "border-top" (cadr x)))
 967         ((== (car x) "table-bborder") (border-attr "border-bottom" (cadr x)))
 968         ((== (car x) "table-lsep") (length-attr "padding-left" (cadr x)))
 969         ((== (car x) "table-rsep") (length-attr "padding-right" (cadr x)))
 970         ((== (car x) "table-tsep") (length-attr "padding-top" (cadr x)))
 971         ((== (car x) "table-bsep") (length-attr "padding-bottom" (cadr x)))
 972         (else #f)))
 973
 974 (define (tmhtml-make-table t tablef colf rowf cellf)
 975   (let* ((attrs (map* tmhtml-make-table-attr tablef))
 976          (em (- (* (tmtable-rows t) 0.55)))
 977          (va (string-append "vertical-align: " (number->htmlstring em) "em")))
 978     (if (not (list-find attrs (cut == <> "width: 100%")))
 979         (set! attrs (cons* "display: inline" va attrs)))
 980     `(h:table ,@(html-css-attrs attrs)
 981               ,@(tmhtml-make-column-group colf)
 982               (h:tbody ,@(tmhtml-make-rows (cdr t) rowf cellf)))))
 983
 984 (define (tmhtml-table l)
 985   (list (tmhtml-make-table (cons 'table l) '() '() '() '())))
 986
 987 (define (tmhtml-tformat l)
 988   (with t (tmtable-normalize (cons 'tformat l))
 989     (receive (tablef colf rowf cellf) (tmtable-properties* t)
 990       (list (tmhtml-make-table (cAr t) tablef colf rowf cellf)))))
 991
 992 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 993 ;;; Pictures
 994 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 995
 996 (define (tmhtml-png-names)
 997   (set! tmhtml-serial (+ tmhtml-serial 1))
 998   (let* ((postfix (string-append "-" (number->string tmhtml-serial) ".png"))
 999          (name-url (url-glue tmhtml-image-root-url postfix))
1000          (name-string (string-append tmhtml-image-root-string postfix)))
1001     (values name-url name-string)))
1002
1003 (define (tmhtml-png x)
1004   (with cached (ahash-ref tmhtml-image-cache x)
1005     (if (not cached)
1006         (receive (name-url name-string) (tmhtml-png-names)
1007           (let* ((extents (print-snippet name-url x))
1008                  (pixels (inexact->exact (/ (second extents) 2100)))
1009                  (valign (number->htmlstring pixels))
1010                  (style (string-append "vertical-align: " valign "px")))
1011             ;;(display* x " -> " extents "\n")
1012             (set! cached `((h:img (@ (src ,name-string) (style ,style)))))
1013             (ahash-set! tmhtml-image-cache x cached)))
1014         cached)))
1015
1016 (define (tmhtml-graphics l)
1017   (tmhtml-png (cons 'graphics l)))
1018
1019 (define (tmhtml-postscript-name name)
1020   (with u (url-relative current-save-target (string->url name))
1021     (if (and (or (string-ends? name ".ps") (string-ends? name ".eps"))
1022              (url-exists? u))
1023         (receive (name-url name-string) (tmhtml-png-names)
1024           (system-2 "convert" u name-url)
1025           name-string)
1026         name)))
1027
1028 (define (tmhtml-postscript l)
1029   ;; FIXME: Should also test that width and height are not magnifications.
1030   ;; Currently, magnifications make tmlength->htmllength return #f.
1031   (if (nstring? (first l))
1032       (tmhtml-png (cons 'postscript l))
1033       (let* ((s (tmhtml-postscript-name (cork->html (first l))))
1034              (w (tmlength->htmllength (second l) #f))
1035              (h (tmlength->htmllength (third l) #f)))
1036         `((h:img (@ (src ,s)
1037                     ,@(if w `((width ,w)) '())
1038                     ,@(if h `((height ,h)) '())))))))
1039
1040 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1041 ;;; Standard markup
1042 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1043
1044 (define (tmhtml-list-document list-doc)
1045   ;; Convert a list-document to a list of <h:li> elements.
1046   ;; WARNING: makes the xpath environment inconsistent
1047   (define (item->li mark item)
1048     (cond ((null? item) '(h:li))
1049           ((null? (cdr item)) `(h:li ,@(tmhtml (car item))))
1050           (else `(h:li ,@(tmhtml `(document ,@item))))))
1051   (if (null? (cdr list-doc)) '((h:li))
1052       (stm-list-map item->li
1053                     (lambda (x) (== x '(item)))
1054                     (cdr list-doc))))
1055
1056 ;; TODO: when the first data of the list is a label, it must be used to set the
1057 ;; ID attribute of the resulting xhtml element. When that is done, remove the
1058 ;; warning comment from htmltm-handler.
1059
1060 (define (tmhtml-itemize args)
1061   `((h:ul ,@(tmhtml-list-document (car args)))))
1062
1063 (define (tmhtml-enumerate args)
1064   `((h:ol ,@(tmhtml-list-document (car args)))))
1065
1066 (define (tmhtml-desc-document desc-doc)
1067   ;; WARNING: makes the xpath environment inconsistent
1068   (define (item->dt-dd mark item)
1069     (let ((html-item (if (null? (cdr item))
1070                          (tmhtml (car item))
1071                          (tmhtml `(document ,@item)))))
1072       (append
1073        (if mark (tmhtml mark) '())
1074        (cond ((and (null? html-item) mark) '())
1075              ((null? html-item) '((h:dd)))
1076              (else `((h:dd ,@html-item)))))))
1077   (if (null? (cdr desc-doc)) '((h:dd))
1078       (apply append (stm-list-map item->dt-dd
1079                                   (lambda (x) (func? x 'item* 1))
1080                                   (cdr desc-doc)))))
1081
1082 (define (tmhtml-description args)
1083   `((h:dl ,@(tmhtml-desc-document (car args)))))
1084
1085 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1086 ;; Verbatim
1087 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1088
1089 (define (tmhtml-verbatim args)
1090   ;; Block-level verbatim environments should only contain inline elements.
1091   ;;
1092   ;; @args should be a single element list, we will call this element @body.
1093   ;;
1094   ;; If @body is a block structure, it will be either:
1095   ;; -- a simple DOCUMENT (normal case), and @(tmhtml body) will produce a list
1096   ;;    of h:p elements;
1097   ;; -- a block structure producing a single element (degenerate case).
1098   ;;
1099   ;; Verbatim structures which do not contain a DOCUMENT but are direct
1100   ;; children of a DOCUMENT (i.e. they occupy a whole paragraph) are degenerate
1101   ;; cases of block-level verbatim and must be exported as PRE.
1102   ;;
1103   ;; Inline verbatim has little special significance for display in TeXmacs. In
1104   ;; LaTeX it is used to escape special characters (and protect multiple inline
1105   ;; spaces, yuck!), but in TeXmacs there is no such problem.
1106   (with body (first args)
1107     (if (stm-block-structure? body)
1108         (verbatim-pre
1109          (ahash-with tmhtml-env :preformatted #t
1110                      (tmhtml body)))
1111         (verbatim-tt (tmhtml body)))))
1112
1113 (define (verbatim-tt content)
1114   `((h:tt (@ (class "verbatim")) ,@content)))
1115
1116 (define (verbatim-pre content)
1117   `((h:pre (@ (class "verbatim") (xml:space "preserve")) ,@content)))
1118
1119 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1120 ;; Additional tags
1121 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1122
1123 (define (tmhtml-doc-title-block l)
1124   `((h:table (@ (class "title-block"))
1125              (h:tr (h:td ,@(tmhtml (car l)))))))
1126
1127 (define (tmhtml-equation* l)
1128   (with first (simplify-document (car l))
1129     (with x `(with "mode" "math" (with "math-display" "true" ,first))
1130       `((h:center ,@(tmhtml x))))))
1131
1132 (define (tmhtml-equation-lab l)
1133   (with first (simplify-document (car l))
1134     (with x `(with "mode" "math" (with "math-display" "true" ,first))
1135       `((h:table (@ (width "100%"))
1136                  (h:tr (h:td (@ (align "center") (width "100%"))
1137                              ,@(tmhtml x))
1138                        (h:td (@ (align "right"))
1139                              "(" ,@(tmhtml (cadr l)) ")")))))))
1140
1141 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1142 ;; Tmdoc tags
1143 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1144
1145 (define (tmhtml-make-block content)
1146   (let* ((l '(h:td
1147               (@ (align "left"))
1148               (h:img (@ (src "http://www.texmacs.org/Images/tm_gnu1b.png")))))
1149          (c `(h:td
1150               (@ (align "center") (width "100%"))
1151               ,@(tmhtml content)))
1152          (r '(h:td
1153               (@ (align "right"))
1154               (h:img (@ (src "http://www.texmacs.org/Images/tm_gnu2b.png")))))
1155          (row `(h:tr ,l ,c ,r)))
1156     `(h:table (@ (width "100%") (cellspacing "0") (cellpadding "3")) ,row)))
1157
1158 (define (tmhtml-tmdoc-title l)
1159   (list `(h:div (@ (class "tmdoc-title-1"))
1160                 ,(tmhtml-make-block (car l)))))
1161
1162 (define (tmhtml-tmdoc-title* l)
1163   (list `(h:div (@ (class "tmdoc-title-2"))
1164                 ,(tmhtml-make-block (car l)))
1165         `(h:div (@ (class "tmdoc-navbar")) ,@(tmhtml (cadr l)))))
1166
1167 (define (tmhtml-tmdoc-title** l)
1168   (list `(h:div (@ (class "tmdoc-navbar")) ,@(tmhtml (car l)))
1169         `(h:div (@ (class "tmdoc-title-3")) ,(tmhtml-make-block (cadr l)))
1170         `(h:div (@ (class "tmdoc-navbar")) ,@(tmhtml (caddr l)))))
1171
1172 (define (tmhtml-tmdoc-flag l)
1173   ;(tmhtml (car l)))
1174   (list `(h:div (@ (class "tmdoc-flag")) ,@(tmhtml (car l)))))
1175
1176 (define (tmhtml-tmdoc-copyright* l)
1177   (if (null? l) l
1178       `(", " ,@(tmhtml (car l)) ,@(tmhtml-tmdoc-copyright* (cdr l)))))
1179
1180 (define (tmhtml-tmdoc-copyright l)
1181   (with content
1182       `("&copy;" " " ,@(tmhtml (car l))
1183         " " ,@(tmhtml (cadr l))
1184         ,@(tmhtml-tmdoc-copyright* (cddr l)))
1185     (list `(h:div (@ (class "tmdoc-copyright")) ,@content))))
1186
1187 (define (tmhtml-tmdoc-license l)
1188   (list `(h:div (@ (class "tmdoc-license")) ,@(tmhtml (car l)))))
1189
1190 (define (tmhtml-key l)
1191   `((h:u (h:tt ,@(tmhtml (car l))))))
1192
1193 (define (tmhtml-tmdoc-bar? y)
1194   (or (func? y 'h:h1)
1195       (func? y 'h:h2)
1196       (and (func? y 'h:div)
1197            (nnull? (cdr y))
1198            (func? (cadr y) '@ 1)
1199            (== (first (cadadr y)) 'class)
1200            (string-starts? (second (cadadr y)) "tmdoc"))))
1201
1202 (define (tmhtml-tmdoc-post-sub x)
1203   ;; FIXME: these rewritings are quite hacky;
1204   ;; better simplification would be nice...
1205   (cond ((and (func? x 'h:p) (list-find (cdr x) tmhtml-tmdoc-bar?)) (cdr x))
1206         ((func? x 'h:p)
1207          (with r (append-map tmhtml-tmdoc-post-sub (cdr x))
1208            (if (== (cdr x) r) (list x) r)))
1209         (else (list x))))
1210
1211 (define (tmhtml-tmdoc-post body)
1212   (with r (append-map tmhtml-tmdoc-post-sub body)
1213     `((h:div (@ (class "tmdoc-body")) ,@r))))
1214
1215 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1216 ;; Main conversion routines
1217 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1218
1219 (define (tmhtml-list l)
1220   (append-map tmhtml l))
1221
1222 (define (tmhtml-dispatch htable l)
1223   (let ((x (drd-ref ,htable (car l))))
1224     (cond ((not x) #f)
1225           ((procedure? x) (x (cdr l)))
1226           (else (tmhtml-post-simplify-element
1227                  (append x (tmhtml-list (cdr l))))))))
1228
1229 (define (tmhtml-implicit-compound l)
1230   (or (tmhtml-dispatch 'tmhtml-stdmarkup% l)
1231       '()))
1232
1233 (tm-define (tmhtml-root x)
1234   (ahash-with tmhtml-env :math #f
1235     (ahash-with tmhtml-env :preformatted #f
1236       (ahash-with tmhtml-env :left-margin 0
1237         (ahash-with tmhtml-env :right-margin 0
1238           (tmhtml x))))))
1239
1240 (define (tmhtml x)
1241   ;; Main conversion function.
1242   ;; Takes a TeXmacs tree in Scheme notation and produce a SXML node-set.
1243   ;; All handler functions have a similar prototype.
1244   (cond ((and tmhtml-mathml? (ahash-ref tmhtml-env :math))
1245          `((m:math (@ (xmlns "http://www.w3.org/1998/Math/MathML"))
1246                    ,(texmacs->mathml x tmhtml-env))))
1247         ((and tmhtml-images? (ahash-ref tmhtml-env :math))
1248          (tmhtml-png `(with "mode" "math" ,x)))
1249         ((string? x)
1250          (if (string-null? x) '() (tmhtml-text x))) ; non-verbatim string nodes
1251         (else (or (tmhtml-dispatch 'tmhtml-primitives% x)
1252                   (tmhtml-implicit-compound x)))))
1253
1254 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1255 ;; Dispatching
1256 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1257
1258 (drd-dispatcher tmhtml-primitives%
1259   (document tmhtml-document)
1260   (para tmhtml-paragraph)
1261   (surround tmhtml-surround)
1262   (concat tmhtml-concat)
1263   (format tmhtml-noop)
1264   (hspace tmhtml-hspace)
1265   (vspace* tmhtml-vspace)
1266   (vspace tmhtml-vspace)
1267   (space tmhtml-hspace)
1268   (htab tmhtml-hspace)
1269   (split tmhtml-noop)
1270   (move tmhtml-move)
1271   (resize tmhtml-resize)
1272   (float tmhtml-float)
1273   (repeat tmhtml-repeat)
1274   (datoms tmhtml-datoms)
1275   (dlines tmhtml-datoms)
1276   (dpages tmhtml-datoms)
1277   (dbox tmhtml-datoms)
1278
1279   (with-limits tmhtml-noop)
1280   (line-break tmhtml-noop)
1281   (new-line tmhtml-new-line)
1282   (line-sep tmhtml-noop)
1283   (next-line tmhtml-next-line)
1284   (no_break tmhtml-noop)
1285   (no-indent tmhtml-noop)
1286   (yes-indent tmhtml-noop)
1287   (no-indent* tmhtml-noop)
1288   (yes-indent* tmhtml-noop)
1289   (page-break* tmhtml-noop)
1290   (page-break tmhtml-noop)
1291   (no-page-break* tmhtml-noop)
1292   (no-page-break tmhtml-noop)
1293   (new-page* tmhtml-noop)
1294   (new-page tmhtml-noop)
1295   (new-dpage* tmhtml-noop)
1296   (new-dpage tmhtml-noop)
1297
1298   (group tmhtml-id)
1299   (left tmhtml-id)
1300   (mid tmhtml-id)
1301   (right tmhtml-id)
1302   (big tmhtml-big)
1303   (lprime tmhtml-id)
1304   (rprime tmhtml-id)
1305   (below tmhtml-below)
1306   (above tmhtml-above)
1307   (lsub tmhtml-sub)
1308   (lsup tmhtml-sup)
1309   (rsub tmhtml-sub)
1310   (rsup tmhtml-sup)
1311   (rsubsup tmhtml-subsup)
1312   (frac tmhtml-frac)
1313   (sqrt tmhtml-sqrt)
1314   (wide tmhtml-wide)
1315   (neg tmhtml-neg)
1316   ((:or tree old-matrix old-table old-mosaic old-mosaic-item)
1317    tmhtml-noop)
1318   (table tmhtml-table)
1319   (tformat tmhtml-tformat)
1320   ((:or twith cwith tmarker row cell sub-table) tmhtml-noop)
1321
1322   (assign tmhtml-noop)
1323   (with tmhtml-with)
1324   (provides tmhtml-noop)
1325   ((:or value quote-value) tmhtml-compound)
1326   ((:or macro drd-props arg quote-arg) tmhtml-noop)
1327   (compound tmhtml-compound)
1328   ((:or xmacro get-label get-arity map-args eval-args) tmhtml-noop)
1329   (mark tmhtml-mark)
1330   (eval tmhtml-noop)
1331   ((:or if if* case while for-each extern include use-package) tmhtml-noop)
1332
1333   ((:or or xor and not plus minus times over div mod merge length range
1334         number date translate is-tuple look-up equal unequal less lesseq
1335         greater greatereq if case while extern authorize)
1336    tmhtml-noop)
1337
1338   ((:or style-with style-with* style-only style-only*
1339         active active* inactive inactive* rewrite-inactive) tmhtml-noop)
1340   (inline-tag tmhtml-inline-tag)
1341   (open-tag tmhtml-open-tag)
1342   (middle-tag tmhtml-middle-tag)
1343   (close-tag tmhtml-close-tag)
1344   (symbol tmhtml-noop)
1345   (latex tmhtml-noop)
1346   (hybrid tmhtml-noop)
1347
1348   ((:or tuple collection associate) tmhtml-noop)
1349   (label tmhtml-label)
1350   (reference tmhtml-noop)
1351   (pageref tmhtml-noop)
1352   (write tmhtml-noop)
1353   (specific tmhtml-specific)
1354   (hlink tmhtml-hyperlink)
1355   (action tmhtml-action)
1356   ((:or tag meaning) tmhtml-noop)
1357   ((:or switch fold exclusive progressive superposed) tmhtml-noop)
1358   (graphics tmhtml-graphics)
1359   ((:or point line arc bezier) tmhtml-noop)
1360   (postscript tmhtml-postscript)
1361
1362   (!file tmhtml-file))
1363
1364 (drd-table tmhtml-stdmarkup%
1365   ;; special auxiliary tags
1366   (!left ,tmhtml-align-left)
1367   (!middle ,tmhtml-align-middle)
1368   (!right ,tmhtml-align-right)
1369   ;; Sectioning
1370   (chapter-title (h:h1))
1371   (section-title (h:h2))
1372   (subsection-title (h:h3))
1373   (subsubsection-title (h:h4))
1374   (paragraph-title (h:h5))
1375   (subparagraph-title (h:h6))
1376   ;; Lists
1377   ((:or itemize itemize-minus itemize-dot itemize-arrow)
1378    ,tmhtml-itemize)
1379   ((:or enumerate enumerate-numeric enumerate-roman enumerate-Roman
1380         enumerate-alpha enumerate-Alpha)
1381    ,tmhtml-enumerate)
1382   ((:or description description-compact description-dash
1383         description-align description-long)
1384    ,tmhtml-description)
1385   (item* (h:dt))
1386   ;; Phrase elements
1387   (strong (h:strong))
1388   (em (h:em))
1389   (dfn (h:dfn))
1390   (code* (h:code))
1391   (samp (h:samp)) ; WARNING: semantic documentation does not match HTML4
1392   (kbd (h:kbd))
1393   (var (h:var))
1394   (abbr (h:abbr))
1395   (acronym (h:acronym))
1396   (verbatim ,tmhtml-verbatim)
1397   (code ,tmhtml-verbatim)
1398   ;; Presentation
1399   (tt (h:tt))
1400   (hrule (h:hr))
1401   ;; Names
1402   (TeXmacs ,(lambda x '("TeXmacs")))
1403   (TeX ,(lambda x '("TeX")))
1404   (LaTeX ,(lambda x '("LaTeX")))
1405   ;; additional tags
1406   (doc-title-block ,tmhtml-doc-title-block)
1407   (equation* ,tmhtml-equation*)
1408   (equation-lab ,tmhtml-equation-lab)
1409   (equations-base ,tmhtml-equation*)
1410   ;; tmdoc tags
1411   (tmdoc-title ,tmhtml-tmdoc-title)
1412   (tmdoc-title* ,tmhtml-tmdoc-title*)
1413   (tmdoc-title** ,tmhtml-tmdoc-title**)
1414   (tmdoc-flag ,tmhtml-tmdoc-flag)
1415   (tmdoc-copyright ,tmhtml-tmdoc-copyright)
1416   (tmdoc-license ,tmhtml-tmdoc-license)
1417   (key ,tmhtml-key)
1418   (hyper-link ,tmhtml-hyperlink))
1419
1420 ;;    (name (h:name)) ; not in HTML4
1421 ;;    (person (h:person)))) ; not in HTML4
1422
1423 (drd-table tmhtml-with-cmd%
1424   ("mode" ,tmhtml-with-mode)
1425   ("color" ,tmhtml-with-color)
1426   ("font-size" ,tmhtml-with-font-size)
1427   ("par-left" ,tmhtml-with-par-left)
1428   ("par-right" ,tmhtml-with-par-right)
1429   ("par-first" ,tmhtml-with-par-first)
1430   ("par-par-sep" ,tmhtml-with-par-par-sep)
1431   (("font-family" "tt") (h:tt))
1432   (("font-family" "ss") (h:class (@ (style "font-family: sans-serif"))))
1433   (("font-series" "bold") (h:b))
1434   (("font-shape" "italic") (h:i))
1435   (("font" "roman") (h:class (@ (style "font-family: Times New Roman"))))
1436   (("font" "times") (h:class (@ (style "font-family: Times New Roman"))))
1437   (("font" "helvetica") (h:class (@ (style "font-family: Helvetica"))))
1438   (("font" "courier") (h:class (@ (style "font-family: Coutier"))))
1439   (("math-font" "cal") (h:class (@ (style "font-family: Flemish Script"))))
1440   (("math-font" "frak") (h:class (@ (style "font-family: Bernhard Modern"))))
1441   (("font-series" "medium") (h:class (@ (style "font-weight: normal"))))
1442   (("font-shape" "right") (h:class (@ (style "font-style: normal"))))
1443   (("font-shape" "small-caps")
1444    (h:class (@ (style "font-variant: small-caps")))))
1445
1446 (drd-table tmhtml-with-cmd% ; deprecated
1447   (("par-mode" "left") (h:div (@ (align "left"))))
1448   (("par-mode" "justify") (h:div (@ (align "justify"))))
1449   (("par-mode" "center") (h:center)))
1450
1451 (drd-table tmhtml-with-cmd% ; netscape4
1452   (("par-columns" "1") (h:multicol (@ (cols "1"))))
1453   (("par-columns" "2") (h:multicol (@ (cols "2"))))
1454   (("par-columns" "3") (h:multicol (@ (cols "3"))))
1455   (("par-columns" "4") (h:multicol (@ (cols "4"))))
1456   (("par-columns" "5") (h:multicol (@ (cols "5")))))
1457
1458 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1459 ;; Interface
1460 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1461
1462 (tm-define (texmacs->html x opts)
1463   (if (tmfile? x)
1464       (let* ((body (tmfile-extract x 'body))
1465              (style* (tmfile-extract x 'style))
1466              (style (if (list? style*) style* (list style*)))
1467              (lan (tmfile-init x "language"))
1468              (doc (list '!file body style lan (get-texmacs-path))))
1469         (texmacs->html doc opts))
1470       (begin
1471         (tmhtml-initialize opts)
1472         ((if (func? x '!file)
1473              tmhtml-finalize-document
1474              tmhtml-finalize-selection)
1475          (tmhtml-root x)))))