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