diff options
Diffstat (limited to 'skribe/skr/html.skr')
| -rw-r--r-- | skribe/skr/html.skr | 2251 |
1 files changed, 2251 insertions, 0 deletions
diff --git a/skribe/skr/html.skr b/skribe/skr/html.skr new file mode 100644 index 0000000..ebac5f2 --- /dev/null +++ b/skribe/skr/html.skr @@ -0,0 +1,2251 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/html.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sat Jul 26 12:28:57 2003 */ +;* Last change : Thu Jun 2 10:57:42 2005 (serrano) */ +;* Copyright : 2003-05 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* HTML Skribe engine */ +;* ------------------------------------------------------------- */ +;* Implementation: */ +;* common: @path ../src/common/api.src@ */ +;* bigloo: @path ../src/bigloo/api.bgl@ */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/htmle.skb:ref@ */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* html-engine ... */ +;*---------------------------------------------------------------------*/ +(define html-engine + ;; setup the html engine + (default-engine-set! + (make-engine 'html + :version 1.0 + :format "html" + :delegate (find-engine 'base) + :filter (make-string-replace '((#\< "<") + (#\> ">") + (#\& "&") + (#\" """) + (#\@ "@"))) + :custom `(;; the icon associated with the URL + (favicon #f) + ;; charset used + (charset "ISO-8859-1") + ;; enable/disable Javascript + (javascript #f) + ;; user html head + (head #f) + ;; user CSS + (css ()) + ;; user inlined CSS + (inline-css ()) + ;; user JS + (js ()) + ;; emit-sui + (emit-sui #f) + ;; the body + (background "#ffffff") + (foreground #f) + ;; the margins + (margin-padding 3) + (left-margin #f) + (chapter-left-margin #f) + (section-left-margin #f) + (left-margin-font #f) + (left-margin-size 17.) + (left-margin-background "#dedeff") + (left-margin-foreground #f) + (right-margin #f) + (chapter-right-margin #f) + (section-right-margin #f) + (right-margin-font #f) + (right-margin-size 17.) + (right-margin-background "#dedeff") + (right-margin-foreground #f) + ;; author configuration + (author-font #f) + ;; title configuration + (title-font #f) + (title-background "#8381de") + (title-foreground #f) + (file-title-separator " -- ") + ;; index configuration + (index-header-font-size +2.) + ;; chapter configuration + (chapter-number->string number->string) + (chapter-file #f) + ;; section configuration + (section-title-start "<h3>") + (section-title-stop "</h3>") + (section-title-background "#dedeff") + (section-title-foreground "black") + (section-title-number-separator " ") + (section-number->string number->string) + (section-file #f) + ;; subsection configuration + (subsection-title-start "<h3>") + (subsection-title-stop "</h3>") + (subsection-title-background "#ffffff") + (subsection-title-foreground "#8381de") + (subsection-title-number-separator " ") + (subsection-number->string number->string) + (subsection-file #f) + ;; subsubsection configuration + (subsubsection-title-start "<h4>") + (subsubsection-title-stop "</h4>") + (subsubsection-title-background #f) + (subsubsection-title-foreground "#8381de") + (subsubsection-title-number-separator " ") + (subsubsection-number->string number->string) + (subsubsection-file #f) + ;; source fontification + (source-color #t) + (source-comment-color "#ffa600") + (source-error-color "red") + (source-define-color "#6959cf") + (source-module-color "#1919af") + (source-markup-color "#1919af") + (source-thread-color "#ad4386") + (source-string-color "red") + (source-bracket-color "red") + (source-type-color "#00cf00") + ;; image + (image-format ("png" "gif" "jpg" "jpeg"))) + :symbol-table '(("iexcl" "¡") + ("cent" "¢") + ("pound" "£") + ("currency" "¤") + ("yen" "¥") + ("section" "§") + ("mul" "¨") + ("copyright" "©") + ("female" "ª") + ("lguillemet" "«") + ("not" "¬") + ("registered" "®") + ("degree" "°") + ("plusminus" "±") + ("micro" "µ") + ("paragraph" "¶") + ("middot" "·") + ("male" "¸") + ("rguillemet" "»") + ("1/4" "¼") + ("1/2" "½") + ("3/4" "¾") + ("iquestion" "¿") + ("Agrave" "À") + ("Aacute" "Á") + ("Acircumflex" "Â") + ("Atilde" "Ã") + ("Amul" "Ä") + ("Aring" "Å") + ("AEligature" "Æ") + ("Oeligature" "Œ") + ("Ccedilla" "Ç") + ("Egrave" "È") + ("Eacute" "É") + ("Ecircumflex" "Ê") + ("Euml" "Ë") + ("Igrave" "Ì") + ("Iacute" "Í") + ("Icircumflex" "Î") + ("Iuml" "Ï") + ("ETH" "Ð") + ("Ntilde" "Ñ") + ("Ograve" "Ò") + ("Oacute" "Ó") + ("Ocurcumflex" "Ô") + ("Otilde" "Õ") + ("Ouml" "Ö") + ("times" "×") + ("Oslash" "Ø") + ("Ugrave" "Ù") + ("Uacute" "Ú") + ("Ucircumflex" "Û") + ("Uuml" "Ü") + ("Yacute" "Ý") + ("THORN" "Þ") + ("szlig" "ß") + ("agrave" "à") + ("aacute" "á") + ("acircumflex" "â") + ("atilde" "ã") + ("amul" "ä") + ("aring" "å") + ("aeligature" "æ") + ("oeligature" "œ") + ("ccedilla" "ç") + ("egrave" "è") + ("eacute" "é") + ("ecircumflex" "ê") + ("euml" "ë") + ("igrave" "ì") + ("iacute" "í") + ("icircumflex" "î") + ("iuml" "ï") + ("eth" "ð") + ("ntilde" "ñ") + ("ograve" "ò") + ("oacute" "ó") + ("ocurcumflex" "ô") + ("otilde" "õ") + ("ouml" "ö") + ("divide" "÷") + ("oslash" "ø") + ("ugrave" "ù") + ("uacute" "ú") + ("ucircumflex" "û") + ("uuml" "ü") + ("yacute" "ý") + ("thorn" "þ") + ("ymul" "ÿ") + ;; Greek + ("Alpha" "Α") + ("Beta" "Β") + ("Gamma" "Γ") + ("Delta" "Δ") + ("Epsilon" "Ε") + ("Zeta" "Ζ") + ("Eta" "Η") + ("Theta" "Θ") + ("Iota" "Ι") + ("Kappa" "Κ") + ("Lambda" "Λ") + ("Mu" "Μ") + ("Nu" "Ν") + ("Xi" "Ξ") + ("Omicron" "Ο") + ("Pi" "Π") + ("Rho" "Ρ") + ("Sigma" "Σ") + ("Tau" "Τ") + ("Upsilon" "Υ") + ("Phi" "Φ") + ("Chi" "Χ") + ("Psi" "Ψ") + ("Omega" "Ω") + ("alpha" "α") + ("beta" "β") + ("gamma" "γ") + ("delta" "δ") + ("epsilon" "ε") + ("zeta" "ζ") + ("eta" "η") + ("theta" "θ") + ("iota" "ι") + ("kappa" "κ") + ("lambda" "λ") + ("mu" "μ") + ("nu" "ν") + ("xi" "ξ") + ("omicron" "ο") + ("pi" "π") + ("rho" "ρ") + ("sigmaf" "ς") + ("sigma" "σ") + ("tau" "τ") + ("upsilon" "υ") + ("phi" "φ") + ("chi" "χ") + ("psi" "ψ") + ("omega" "ω") + ("thetasym" "ϑ") + ("piv" "ϖ") + ;; punctuation + ("bullet" "•") + ("ellipsis" "…") + ("weierp" "℘") + ("image" "ℑ") + ("real" "ℜ") + ("tm" "™") + ("alef" "ℵ") + ("<-" "←") + ("<--" "←") + ("uparrow" "↑") + ("->" "→") + ("-->" "→") + ("downarrow" "↓") + ("<->" "↔") + ("<-->" "↔") + ("<+" "↵") + ("<=" "⇐") + ("<==" "⇐") + ("Uparrow" "⇑") + ("=>" "⇒") + ("==>" "⇒") + ("Downarrow" "⇓") + ("<=>" "⇔") + ("<==>" "⇔") + ;; Mathematical operators + ("forall" "∀") + ("partial" "∂") + ("exists" "∃") + ("emptyset" "∅") + ("infinity" "∞") + ("nabla" "∇") + ("in" "∈") + ("notin" "∉") + ("ni" "∋") + ("prod" "∏") + ("sum" "∑") + ("asterisk" "∗") + ("sqrt" "√") + ("propto" "∝") + ("angle" "∠") + ("and" "∧") + ("or" "∨") + ("cap" "∩") + ("cup" "∪") + ("integral" "∫") + ("therefore" "∴") + ("models" "|=") + ("vdash" "|-") + ("dashv" "-|") + ("sim" "∼") + ("cong" "≅") + ("approx" "≈") + ("neq" "≠") + ("equiv" "≡") + ("le" "≤") + ("ge" "≥") + ("subset" "⊂") + ("supset" "⊃") + ("nsupset" "⊃") + ("subseteq" "⊆") + ("supseteq" "⊇") + ("oplus" "⊕") + ("otimes" "⊗") + ("perp" "⊥") + ("mid" "|") + ("lceil" "⌈") + ("rceil" "⌉") + ("lfloor" "⌊") + ("rfloor" "⌋") + ("langle" "〈") + ("rangle" "〉") + ;; Misc + ("loz" "◊") + ("spades" "♠") + ("clubs" "♣") + ("hearts" "♥") + ("diams" "♦") + ("euro" "ℐ") + ;; LaTeX + ("dag" "dag") + ("ddag" "ddag") + ("circ" "o") + ("top" "T") + ("bottom" "⊥") + ("lhd" "<") + ("rhd" ">") + ("parallel" "||"))))) + +;*---------------------------------------------------------------------*/ +;* html-title-engine ... */ +;*---------------------------------------------------------------------*/ +(define html-title-engine + (copy-engine 'html-title base-engine + :filter (make-string-replace '((#\< "<") + (#\> ">") + (#\& "&") + (#\" """))))) + +;*---------------------------------------------------------------------*/ +;* html-browser-title ... */ +;*---------------------------------------------------------------------*/ +(define (html-browser-title n) + (and (markup? n) + (or (markup-option n :html-title) + (if (document? n) + (markup-option n :title) + (html-browser-title (ast-parent n)))))) + +;*---------------------------------------------------------------------*/ +;* html-file ... */ +;*---------------------------------------------------------------------*/ +(define html-file + (let ((table '()) + (filename (gensym))) + (define (get-file-name base suf) + (let* ((c (assoc base table)) + (n (if (pair? c) + (let ((n (+ 1 (cdr c)))) + (set-cdr! c n) + n) + (begin + (set! table (cons (cons base 1) table)) + 1)))) + (format "~a-~a.~a" base n suf))) + (lambda (node e) + (let ((f (markup-option node filename)) + (file (markup-option node :file))) + (cond + ((string? f) + f) + ((string? file) + file) + ((or file + (and (is-markup? node 'chapter) + (engine-custom e 'chapter-file)) + (and (is-markup? node 'section) + (engine-custom e 'section-file)) + (and (is-markup? node 'subsection) + (engine-custom e 'subsection-file)) + (and (is-markup? node 'subsubsection) + (engine-custom e 'subsubsection-file))) + (let* ((b (or (and (string? *skribe-dest*) + (prefix *skribe-dest*)) + "")) + (s (or (and (string? *skribe-dest*) + (suffix *skribe-dest*)) + "html")) + (nm (get-file-name b s))) + (markup-option-add! node filename nm) + nm)) + ((document? node) + *skribe-dest*) + (else + (let ((p (ast-parent node))) + (if (container? p) + (let ((file (html-file p e))) + (if (string? file) + (begin + (markup-option-add! node filename file) + file) + #f)) + #f)))))))) + +;*---------------------------------------------------------------------*/ +;* html-container-number ... */ +;* ------------------------------------------------------------- */ +;* Returns a string representing the container number */ +;*---------------------------------------------------------------------*/ +(define (html-container-number c e) + (define (html-number n proc) + (cond + ((string? n) + n) + ((number? n) + (if (procedure? proc) + (proc n) + (number->string n))) + (else + ""))) + (define (html-chapter-number c) + (html-number (markup-option c :number) + (engine-custom e 'chapter-number->string))) + (define (html-section-number c) + (let ((p (ast-parent c)) + (s (html-number (markup-option c :number) + (engine-custom e 'section-number->string)))) + (cond + ((is-markup? p 'chapter) + (string-append (html-chapter-number p) "." s)) + (else + (string-append s))))) + (define (html-subsection-number c) + (let ((p (ast-parent c)) + (s (html-number (markup-option c :number) + (engine-custom e 'subsection-number->string)))) + (cond + ((is-markup? p 'section) + (string-append (html-section-number p) "." s)) + (else + (string-append "." s))))) + (define (html-subsubsection-number c) + (let ((p (ast-parent c)) + (s (html-number (markup-option c :number) + (engine-custom e 'subsubsection-number->string)))) + (cond + ((is-markup? p 'subsection) + (string-append (html-subsection-number p) "." s)) + (else + (string-append ".." s))))) + (define (inner-html-container-number c) + (html-number (markup-option c :number) #f)) + (let ((n (markup-option c :number))) + (if (not n) + "" + (case (markup-markup c) + ((chapter) + (html-chapter-number c)) + ((section) + (html-section-number c)) + ((subsection) + (html-subsection-number c)) + ((subsubsection) + (html-subsubsection-number c)) + (else + (if (container? c) + (inner-html-container-number c) + (skribe-error 'html-container-number + "Not a container" + (markup-markup c)))))))) + +;*---------------------------------------------------------------------*/ +;* html-counter ... */ +;*---------------------------------------------------------------------*/ +(define (html-counter cnts) + (cond + ((not cnts) + "") + ((null? cnts) + "") + ((not (pair? cnts)) + cnts) + ((null? (cdr cnts)) + (format "~a." (car cnts))) + (else + (let loop ((cnts cnts)) + (if (null? (cdr cnts)) + (format "~a" (car cnts)) + (format "~a.~a" (car cnts) (loop (cdr cnts)))))))) + +;*---------------------------------------------------------------------*/ +;* html-width ... */ +;*---------------------------------------------------------------------*/ +(define (html-width width) + (cond + ((and (integer? width) (exact? width)) + (format "~A" width)) + ((real? width) + (format "~A%" (inexact->exact (round width)))) + ((string? width) + width) + (else + (skribe-error 'html-width "bad width" width)))) + +;*---------------------------------------------------------------------*/ +;* html-class ... */ +;*---------------------------------------------------------------------*/ +(define (html-class m) + (if (markup? m) + (let ((c (markup-class m))) + (if (or (string? c) (symbol? c) (number? c)) + (printf " class=\"~a\"" c))))) + +;*---------------------------------------------------------------------*/ +;* html-markup-class ... */ +;*---------------------------------------------------------------------*/ +(define (html-markup-class m) + (lambda (n e) + (printf "<~a" m) + (html-class n) + (display ">"))) + +;*---------------------------------------------------------------------*/ +;* html-color-spec? ... */ +;*---------------------------------------------------------------------*/ +(define (html-color-spec? v) + (and v + (not (unspecified? v)) + (or (not (string? v)) (> (string-length v) 0)))) + +;*---------------------------------------------------------------------*/ +;* document ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'document + :options '(:title :author :ending :html-title :env) + :action (lambda (n e) + (let* ((id (markup-ident n)) + (title (new markup + (markup '&html-document-title) + (parent n) + (ident (string-append id "-title")) + (class (markup-class n)) + (options `((author ,(markup-option n :author)))) + (body (markup-option n :title))))) + (&html-generic-document n title e))) + :after (lambda (n e) + (if (engine-custom e 'emit-sui) + (document-sui n e)))) + +;*---------------------------------------------------------------------*/ +;* &html-html ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-html + :before "<!-- 95% W3C COMPLIANT, 95% CSS FREE, RAW HTML --> +<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"> +<html>\n" + :after "</html>") + +;*---------------------------------------------------------------------*/ +;* &html-head ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-head + :before (lambda (n e) + (printf "<head>\n") + (printf "<meta http-equiv=\"Content-Type\" content=\"text/html;") + (printf "charset=~A\">\n" (engine-custom (find-engine 'html) + 'charset))) + :after "</head>\n\n") + +;*---------------------------------------------------------------------*/ +;* &html-body ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-body + :before (lambda (n e) + (let ((bg (engine-custom e 'background))) + (display "<body") + (html-class n) + (when (html-color-spec? bg) (printf " bgcolor=\"~a\"" bg)) + (display ">\n"))) + :after "</body>\n") + +;*---------------------------------------------------------------------*/ +;* &html-page ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-page + :action (lambda (n e) + (define (html-margin m fn size bg fg cla) + (printf "<td align=\"left\" valign=\"top\" class=\"~a\"" cla) + (if size + (printf " width=\"~a\"" (html-width size))) + (if (html-color-spec? bg) + (printf " bgcolor=\"~a\">" bg) + (display ">")) + (printf "<div class=\"~a\">\n" cla) + (cond + ((and (string? fg) (string? fn)) + (printf "<font color=\"~a\" \"~a\">" fg fn)) + ((string? fg) + (printf "<font color=\"~a\">" fg)) + ((string? fn) + (printf "<font \"~a\">" fn))) + (if (procedure? m) + (skribe-eval (m n e) e) + (output m e)) + (if (or (string? fg) (string? fn)) + (display "</font>")) + (display "</div></td>\n")) + (let ((body (markup-body n)) + (lm (engine-custom e 'left-margin)) + (lmfn (engine-custom e 'left-margin-font)) + (lms (engine-custom e 'left-margin-size)) + (lmbg (engine-custom e 'left-margin-background)) + (lmfg (engine-custom e 'left-margin-foreground)) + (rm (engine-custom e 'right-margin)) + (rmfn (engine-custom e 'right-margin-font)) + (rms (engine-custom e 'right-margin-size)) + (rmbg (engine-custom e 'right-margin-background)) + (rmfg (engine-custom e 'right-margin-foreground))) + (cond + ((and lm rm) + (let* ((ep (engine-custom e 'margin-padding)) + (ac (if (number? ep) ep 0))) + (printf "<table cellpadding=\"~a\" cellspacing=\"0\" width=\"100%\" class=\"skribe-margins\"><tr>\n" ac)) + (html-margin lm lmfn lms lmbg lmfg "skribe-left-margin") + (html-margin body #f #f #f #f "skribe-body") + (html-margin rm rmfn rms rmbg rmfg "skribe-right-margin") + (display "</tr></table>")) + (lm + (let* ((ep (engine-custom e 'margin-padding)) + (ac (if (number? ep) ep 0))) + (printf "<table cellpadding=\"~a\" cellspacing=\"0\" width=\"100%\" class=\"skribe-margins\"><tr>\n" ac)) + (html-margin lm lmfn lms lmbg lmfg "skribe-left-margin") + (html-margin body #f #f #f #f "skribe-body") + (display "</tr></table>")) + (rm + (let* ((ep (engine-custom e 'margin-padding)) + (ac (if (number? ep) ep 0))) + (printf "<table cellpadding=\"~a\" cellspacing=\"0\" width=\"100%\" class=\"skribe-margins\"><tr>\n")) + (html-margin body #f #f #f #f "skribe-body") + (html-margin rm rmfn rms rmbg rmfg "skribe-right-margin") + (display "</tr></table>")) + (else + (display "<div class=\"skribe-body\">\n") + (output body e) + (display "</div>\n")))))) + +;*---------------------------------------------------------------------*/ +;* &html-generic-header ... */ +;*---------------------------------------------------------------------*/ +(define (&html-generic-header n e) + (let* ((ic (engine-custom e 'favicon)) + (id (markup-ident n))) + (unless (string? id) + (skribe-error '&html-generic-header + (format "Illegal identifier `~a'" id) + n)) + ;; title + (output (new markup + (markup '&html-header-title) + (parent n) + (ident (string-append id "-title")) + (class (markup-class n)) + (body (markup-body n))) + e) + ;; favicon + (output (new markup + (markup '&html-header-favicon) + (parent n) + (ident (string-append id "-favicon")) + (body (cond + ((string? ic) + ic) + ((procedure? ic) + (ic d e))))) + e) + ;; style + (output (new markup + (markup '&html-header-style) + (parent n) + (ident (string-append id "-style")) + (class (markup-class n))) + e) + ;; css + (output (new markup + (markup '&html-header-css) + (parent n) + (ident (string-append id "-css")) + (body (let ((c (engine-custom e 'css))) + (if (string? c) + (list c) + c)))) + e) + ;; javascript + (output (new markup + (markup '&html-header-javascript) + (parent n) + (ident (string-append id "-javascript"))) + e))) + +(markup-writer '&html-header-title + :before "<title>" + :action (lambda (n e) + (output (markup-body n) html-title-engine)) + :after "</title>\n") + +(markup-writer '&html-header-favicon + :action (lambda (n e) + (let ((i (markup-body n))) + (when i + (printf " <link rel=\"shortcut icon\" href=~s>\n" i))))) + +(markup-writer '&html-header-css + :action (lambda (n e) + (let ((css (markup-body n))) + (when (pair? css) + (for-each (lambda (css) + (printf " <link href=~s rel=\"stylesheet\" type=\"text/css\">\n" css)) + css))))) + +(markup-writer '&html-header-style + :before " <style type=\"text/css\">\n <!--\n" + :action (lambda (n e) + (let ((hd (engine-custom e 'head)) + (icss (let ((ic (engine-custom e 'inline-css))) + (if (string? ic) + (list ic) + ic)))) + (display " pre { font-family: monospace }\n") + (display " tt { font-family: monospace }\n") + (display " code { font-family: monospace }\n") + (display " p.flushright { text-align: right }\n") + (display " p.flushleft { text-align: left }\n") + (display " span.sc { font-variant: small-caps }\n") + (display " span.sf { font-family: sans-serif }\n") + (display " span.skribetitle { font-family: sans-serif; font-weight: bolder; font-size: x-large; }\n") + (when hd (display (format " ~a\n" hd))) + (when (pair? icss) + (for-each (lambda (css) + (let ((p (open-input-file css))) + (if (not (input-port? p)) + (skribe-error + 'html-css + "Can't open CSS file for input" + css) + (begin + (let loop ((l (read-line p))) + (unless (eof-object? l) + (display l) + (newline) + (loop (read-line p)))) + (close-input-port p))))) + icss)))) + :after " -->\n </style>\n") + +(markup-writer '&html-header-javascript + :action (lambda (n e) + (when (engine-custom e 'javascript) + (display " <script language=\"JavaScript\" type=\"text/javascript\">\n") + (display " <!--\n") + (display " function skribenospam( n, d, f ) {\n") + (display " nn=n.replace( / /g , \".\" );\n" ) + (display " dd=d.replace( / /g , \".\" );\n" ) + (display " document.write( \"<a href=\\\"mailto:\" + nn + \"@\" + dd + \"\\\">\" );\n") + (display " if( f ) {\n") + (display " document.write( \"<tt>\" + nn + \"@\" + dd + \"</\" + \"tt><\" + \"/a>\" );\n") + (display " }\n") + (display " }\n") + (display " -->\n") + (display " </script>\n")) + (let* ((ejs (engine-custom e 'js)) + (js (cond + ((string? ejs) + (list ejs)) + ((list? ejs) + ejs) + (else + '())))) + (for-each (lambda (s) + (printf "<script type=\"text/javascript\" src=\"~a\"></script>" s)) + js)))) + + +;*---------------------------------------------------------------------*/ +;* &html-header ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-document-header :action &html-generic-header) +(markup-writer '&html-chapter-header :action &html-generic-header) +(markup-writer '&html-section-header :action &html-generic-header) +(markup-writer '&html-subsection-header :action &html-generic-header) +(markup-writer '&html-subsubsection-header :action &html-generic-header) + +;*---------------------------------------------------------------------*/ +;* &html-ending ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-ending + :before "<div class=\"skribe-ending\">" + :action (lambda (n e) + (let ((body (markup-body n))) + (if body + (output body #t) + (skribe-eval [ +,(hrule) +,(p :class "ending" (font :size -1 [ +This ,(sc "Html") page has been produced by +,(ref :url (skribe-url) :text "Skribe"). +,(linebreak) +Last update ,(it (date)).]))] e)))) + :after "</div>\n") + +;*---------------------------------------------------------------------*/ +;* &html-generic-title ... */ +;*---------------------------------------------------------------------*/ +(define (&html-generic-title n e) + (let* ((title (markup-body n)) + (authors (markup-option n 'author)) + (tbg (engine-custom e 'title-background)) + (tfg (engine-custom e 'title-foreground)) + (tfont (engine-custom e 'title-font))) + (when title + (display "<table width=\"100%\" class=\"skribetitle\" cellspacing=\"0\" cellpadding=\"0\"><tbody>\n<tr>") + (if (html-color-spec? tbg) + (printf "<td align=\"center\" bgcolor=\"~a\">" tbg) + (display "<td align=\"center\">")) + (if (string? tfg) + (printf "<font color=\"~a\">" tfg)) + (when title + (if (string? tfont) + (begin + (printf "<font ~a><strong>" tfont) + (output title e) + (display "</strong></font>")) + (begin + (printf "<div class=\"skribetitle\"><strong><big><big><big>") + (output title e) + (display "</big></big></big></strong></div>")))) + (if (not authors) + (display "\n") + (html-title-authors authors e)) + (if (string? tfg) + (display "</font>")) + (display "</td></tr></tbody></table>\n")))) + +;*---------------------------------------------------------------------*/ +;* &html-document-title ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-document-title :action &html-generic-title) +(markup-writer '&html-chapter-title :action &html-generic-title) +(markup-writer '&html-section-title :action &html-generic-title) +(markup-writer '&html-subsection-title :action &html-generic-title) +(markup-writer '&html-subsubsection-title :action &html-generic-title) + +;*---------------------------------------------------------------------*/ +;* &html-footnotes */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-footnotes + :before (lambda (n e) + (let ((footnotes (markup-body n))) + (when (pair? footnotes) + (display "<div class=\"footnote\">") + (display "<br><br>\n") + (display "<hr width='20%' size='2' align='left'>\n")))) + :action (lambda (n e) + (let ((footnotes (markup-body n))) + (when (pair? footnotes) + (let loop ((fns footnotes)) + (if (pair? fns) + (let ((fn (car fns))) + (printf "<a name=\"footnote-~a\">" + (string-canonicalize + (container-ident fn))) + (printf "<sup><small>~a</small></sup></a>: " + (markup-option fn :number)) + (output (markup-body fn) e) + (display "\n<br>\n") + (loop (cdr fns))))) + (display "<div>"))))) + +;*---------------------------------------------------------------------*/ +;* html-title-authors ... */ +;*---------------------------------------------------------------------*/ +(define (html-title-authors authors e) + (define (html-authorsN authors cols first) + (define (make-row authors . opt) + (tr (map (lambda (v) + (apply td :align 'center :valign 'top v opt)) + authors))) + (define (make-rows authors) + (let loop ((authors authors) + (rows '()) + (row '()) + (cnum 0)) + (cond + ((null? authors) + (reverse! (cons (make-row (reverse! row)) rows))) + ((= cnum cols) + (loop authors + (cons (make-row (reverse! row)) rows) + '() + 0)) + (else + (loop (cdr authors) + rows + (cons (car authors) row) + (+ cnum 1)))))) + (output (table :cellpadding 10 + (if first + (cons (make-row (list (car authors)) :colspan cols) + (make-rows (cdr authors))) + (make-rows authors))) + e)) + (cond + ((pair? authors) + (display "<center>\n") + (let ((len (length authors))) + (case len + ((1) + (output (car authors) e)) + ((2 3) + (html-authorsN authors len #f)) + ((4) + (html-authorsN authors 2 #f)) + (else + (html-authorsN authors 3 #t)))) + (display "</center>\n")) + (else + (html-title-authors (list authors) e)))) + +;*---------------------------------------------------------------------*/ +;* document-sui ... */ +;*---------------------------------------------------------------------*/ +(define (document-sui n e) + (define (sui) + (display "(sui \"") + (skribe-eval (markup-option n :title) html-title-engine) + (display "\"\n") + (printf " :file ~s\n" (sui-referenced-file n e)) + (sui-marks n e) + (sui-blocks 'chapter n e) + (sui-blocks 'section n e) + (sui-blocks 'subsection n e) + (sui-blocks 'subsubsection n e) + (display " )\n")) + (if (string? *skribe-dest*) + (let ((f (format "~a.sui" (prefix *skribe-dest*)))) + (with-output-to-file f sui)) + (sui))) + +;*---------------------------------------------------------------------*/ +;* sui-referenced-file ... */ +;*---------------------------------------------------------------------*/ +(define (sui-referenced-file n e) + (let ((file (html-file n e))) + (if (member (suffix file) '("skb" "sui" "skr" "html")) + (string-append (strip-ref-base (prefix file)) ".html") + file))) + +;*---------------------------------------------------------------------*/ +;* sui-marks ... */ +;*---------------------------------------------------------------------*/ +(define (sui-marks n e) + (printf " (marks") + (for-each (lambda (m) + (printf "\n (~s" (markup-ident m)) + (printf " :file ~s" (sui-referenced-file m e)) + (printf " :mark ~s" (markup-ident m)) + (when (markup-class m) + (printf " :class ~s" (markup-class m))) + (display ")")) + (search-down (lambda (n) (is-markup? n 'mark)) n)) + (display ")\n")) + +;*---------------------------------------------------------------------*/ +;* sui-blocks ... */ +;*---------------------------------------------------------------------*/ +(define (sui-blocks kind n e) + (printf " (~as" kind) + (for-each (lambda (chap) + (display "\n (\"") + (skribe-eval (markup-option chap :title) html-title-engine) + (printf "\" :file ~s" (sui-referenced-file chap e)) + (printf " :mark ~s" (markup-ident chap)) + (when (markup-class chap) + (printf " :class ~s" (markup-class chap))) + (display ")")) + (container-search-down (lambda (n) (is-markup? n kind)) n)) + (display ")\n")) + +;*---------------------------------------------------------------------*/ +;* author ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'author + :options '(:name :title :affiliation :email :url :address :phone :photo :align) + :before (lambda (n e) + (display "<table") + (html-class n) + (display "><tbody>\n")) + :action (lambda (n e) + (let ((name (markup-option n :name)) + (title (markup-option n :title)) + (affiliation (markup-option n :affiliation)) + (email (markup-option n :email)) + (url (markup-option n :url)) + (address (markup-option n :address)) + (phone (markup-option n :phone)) + (nfn (engine-custom e 'author-font)) + (align (markup-option n :align))) + (define (row n) + (printf "<tr><td align=\"~a\">" align) + (output n e) + (display "</td></tr>")) + ;; name + (printf "<tr><td align=\"~a\">" align) + (if nfn + (printf "<font ~a>\n" nfn) + (display "<font size=\"+2\"><i>\n")) + (output name e) + (if nfn + (printf "</font>\n") + (display "</i></font>\n")) + (display "</td></tr>") + ;; title + (if title (row title)) + ;; affiliation + (if affiliation (row affiliation)) + ;; address + (if (pair? address) + (for-each row address)) + ;; telephone + (if phone (row phone)) + ;; email + (if email (row email)) + ;; url + (if url (row url)))) + :after "</tbody></table>") + +;*---------------------------------------------------------------------*/ +;* author ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'author + :options '(:name :title :affiliation :email :url :address :phone :photo :align) + :predicate (lambda (n e) (markup-option n :photo)) + :before (lambda (n e) + (display "<table") + (html-class n) + (display "><tbody>\n<tr>")) + :action (lambda (n e) + (let ((photo (markup-option n :photo))) + (display "<td>") + (output photo e) + (display "</td><td>") + (markup-option-add! n :photo #f) + (output n e) + (markup-option-add! n :photo photo) + (display "</td>"))) + :after "</tr>\n</tbody></table>") + +;*---------------------------------------------------------------------*/ +;* toc ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'toc + :options 'all + :action (lambda (n e) + (define (col n) + (let loop ((i 0)) + (if (< i n) + (begin + (display "<td></td>") + (loop (+ i 1)))))) + (define (toc-entry fe level) + (let* ((c (car fe)) + (ch (cdr fe)) + (t (markup-option c :title)) + (id (markup-ident c)) + (f (html-file c e))) + (unless (string? id) + (skribe-error 'toc + (format "Illegal identifier `~a'" id) + c)) + (display " <tr>") + ;; blank columns + (col level) + ;; number + (printf "<td valign=\"top\" align=\"left\">~a</td>" + (html-container-number c e)) + ;; title + (printf "<td colspan=\"~a\" width=\"100%\">" + (- 4 level)) + (printf "<a href=\"~a#~a\">" + (if (string=? f *skribe-dest*) + "" + (strip-ref-base (or f *skribe-dest* ""))) + (string-canonicalize id)) + (output (markup-option c :title) e) + (display "</a></td>") + (display "</tr>\n") + ;; the children + (for-each (lambda (n) (toc-entry n (+ 1 level))) ch))) + (define (symbol->keyword s) + (cond-expand + (stklos + (make-keyword s)) + (bigloo + (string->keyword (string-append ":" (symbol->string s)))))) + (let* ((c (markup-option n :chapter)) + (s (markup-option n :section)) + (ss (markup-option n :subsection)) + (sss (markup-option n :subsubsection)) + (b (markup-body n)) + (bb (if (handle? b) + (handle-ast b) + b))) + (if (not (container? bb)) + (error 'toc + "Illegal body (container expected)" + (if (markup? bb) + (markup-markup bb) + "???")) + (let ((lst (find-down (lambda (x) + (and (markup? x) + (markup-option x :toc) + (or (and sss (is-markup? x 'subsubsection)) + (and ss (is-markup? x 'subsection)) + (and s (is-markup? x 'section)) + (and c (is-markup? x 'chapter)) + (markup-option n (symbol->keyword + (markup-markup x)))))) + (container-body bb)))) + ;; avoid to produce an empty table + (unless (null? lst) + (display "<table cellspacing=\"1\" cellpadding=\"1\" width=\"100%\"") + (html-class n) + (display ">\n<tbody>\n") + + (for-each (lambda (n) (toc-entry n 0)) lst) + + (display "</tbody>\n</table>\n"))))))) + +;*---------------------------------------------------------------------*/ +;* &html-generic-document ... */ +;*---------------------------------------------------------------------*/ +(define (&html-generic-document n title e) + (let* ((id (markup-ident n)) + (header (new markup + (markup '&html-chapter-header) + (ident (string-append id "-header")) + (class (markup-class n)) + (parent n) + (body (html-browser-title n)))) + (head (new markup + (markup '&html-head) + (ident (string-append id "-head")) + (class (markup-class n)) + (parent n) + (body header))) + (ftnote (new markup + (markup '&html-footnotes) + (ident (string-append id "-footnote")) + (class (markup-class n)) + (parent n) + (body (reverse! + (container-env-get n 'footnote-env))))) + (page (new markup + (markup '&html-page) + (ident (string-append id "-page")) + (class (markup-class n)) + (parent n) + (body (list (markup-body n) ftnote)))) + (ending (new markup + (markup '&html-ending) + (ident (string-append id "-ending")) + (class (markup-class n)) + (parent n) + (body (or (markup-option n :ending) + (let ((p (ast-document n))) + (and p (markup-option p :ending))))))) + (body (new markup + (markup '&html-body) + (ident (string-append id "-body")) + (class (markup-class n)) + (parent n) + (body (list title page ending)))) + (html (new markup + (markup '&html-html) + (ident (string-append id "-html")) + (class (markup-class n)) + (parent n) + (body (list head body))))) + ;; No file must be opened for documents. These files are + ;; directly opened by Skribe + (if (document? n) + (output html e) + (with-output-to-file (html-file n e) + (lambda () + (output html e)))))) + +;*---------------------------------------------------------------------*/ +;* &html-generic-subdocument ... */ +;*---------------------------------------------------------------------*/ +(define (&html-generic-subdocument n e) + (let* ((p (ast-document n)) + (id (markup-ident n)) + (ti (let* ((nb (html-container-number n e)) + (tc (markup-option n :title)) + (ti (if (document? p) + (list (markup-option p :title) + (engine-custom e 'file-title-separator) + tc) + tc)) + (sep (engine-custom + e + (symbol-append (markup-markup n) + '-title-number-separator))) + (nti (and tc + (if (and nb (not (equal? nb ""))) + (list nb + (if (unspecified? sep) ". " sep) + ti) + ti)))) + (new markup + (markup (symbol-append '&html- (markup-markup n) '-title)) + (ident (string-append id "-title")) + (parent n) + (options '((author ()))) + (body nti))))) + (case (markup-markup n) + ((chapter) + (skribe-message " [~s chapter: ~a]\n" (engine-ident e) id)) + ((section) + (skribe-message " [~s section: ~a]\n" (engine-ident e) id))) + (&html-generic-document n ti e))) + +;*---------------------------------------------------------------------*/ +;* chapter ... @label chapter@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'chapter + :options '(:title :number :file :toc :html-title :env) + :before (lambda (n e) + (let ((title (markup-option n :title)) + (ident (markup-ident n))) + (display "<!-- ") + (output title html-title-engine) + (display " -->\n") + (display "<a name=\"") + (display (string-canonicalize ident)) + (display "\"></a>\n") + (display "<center><h1") + (html-class n) + (display ">") + (output (html-container-number n e) e) + (display " ") + (output (markup-option n :title) e) + (display "</h1></center>"))) + :after "<br>") + +;; This writer is invoked only for chapters rendered inside separate files! +(markup-writer 'chapter + :options '(:title :number :file :toc :html-title :env) + :predicate (lambda (n e) + (or (markup-option n :file) + (engine-custom e 'chapter-file))) + :action &html-generic-subdocument) + +;*---------------------------------------------------------------------*/ +;* html-section-title ... */ +;*---------------------------------------------------------------------*/ +(define (html-section-title n e) + (let* ((title (markup-option n :title)) + (number (markup-option n :number)) + (c (markup-class n)) + (ident (markup-ident n)) + (kind (markup-markup n)) + (tbg (engine-custom e (symbol-append kind '-title-background))) + (tfg (engine-custom e (symbol-append kind '-title-foreground))) + (tstart (engine-custom e (symbol-append kind '-title-start))) + (tstop (engine-custom e (symbol-append kind '-title-stop))) + (nsep (engine-custom e (symbol-append kind '-title-number-separator)))) + ;; the section header + (display "<!-- ") + (output title html-title-engine) + (display " -->\n") + (display "<a name=\"") + (display (string-canonicalize ident)) + (display "\"></a>\n") + (if c + (printf "<div class=\"~a-atitle\">" c) + (printf "<div class=\"skribe~atitle\">" (markup-markup n))) + (when (html-color-spec? tbg) + (display "<table width=\"100%\">") + (printf "<tr><td bgcolor=\"~a\">" tbg)) + (display tstart) + (if tfg (printf "<font color=\"~a\">" tfg)) + (if number + (begin + (output (html-container-number n e) e) + (output nsep e))) + (output title e) + (if tfg (display "</font>\n")) + (display tstop) + (when (and (string? tbg) (> (string-length tbg) 0)) + (display "</td></tr></table>\n")) + (display "</div>") + (display "<div") + (html-class n) + (display ">")) + (newline)) + +;*---------------------------------------------------------------------*/ +;* section ... @label section@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'section + :options '(:title :html-title :number :toc :file :env) + :before html-section-title + :after "</div><br>\n") + +;; on-file section writer +(markup-writer 'section + :options '(:title :html-title :number :toc :file :env) + :predicate (lambda (n e) + (or (markup-option n :file) + (engine-custom e 'section-file))) + :action &html-generic-subdocument) + +;*---------------------------------------------------------------------*/ +;* subsection ... @label subsection@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'subsection + :options '(:title :html-title :number :toc :env :file) + :before html-section-title + :after "</div>\n") + +;; on-file subsection writer +(markup-writer 'section + :options '(:title :html-title :number :toc :file :env) + :predicate (lambda (n e) + (or (markup-option n :file) + (engine-custom e 'subsection-file))) + :action &html-generic-subdocument) + +;*---------------------------------------------------------------------*/ +;* subsubsection ... @label subsubsection@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'subsubsection + :options '(:title :html-title :number :toc :env :file) + :before html-section-title + :after "</div>\n") + +;; on-file subsection writer +(markup-writer 'section + :options '(:title :html-title :number :toc :file :env) + :predicate (lambda (n e) + (or (markup-option n :file) + (engine-custom e 'subsubsection-file))) + :action &html-generic-subdocument) + +;*---------------------------------------------------------------------*/ +;* paragraph ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'paragraph + :before (lambda (n e) + (when (and (>= (skribe-debug) 2) (location? (ast-loc n))) + (printf "<span style=\"display: block; position: relative; left: -2cm; font-size: x-small; font-style: italic; color: ff8e1e;\">~a</span>" + (ast-location n))) + ((html-markup-class "p") n e)) + :after "</p>") + +;*---------------------------------------------------------------------*/ +;* footnote ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'footnote + :options '(:number) + :action (lambda (n e) + (printf "<a href=\"#footnote-~a\"><sup><small>~a</small></sup></a>" + (string-canonicalize (container-ident n)) + (markup-option n :number)))) + +;*---------------------------------------------------------------------*/ +;* linebreak ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'linebreak + :before (lambda (n e) + (display "<br") + (html-class n) + (display "/>"))) + +;*---------------------------------------------------------------------*/ +;* hrule ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'hrule + :options '(:width :height) + :before (lambda (n e) + (let ((width (markup-option n :width)) + (height (markup-option n :height))) + (display "<hr") + (html-class n) + (if (< width 100) + (printf " width=\"~a\"" (html-width width))) + (if (> height 1) + (printf " size=\"~a\"" height)) + (display ">")))) + +;*---------------------------------------------------------------------*/ +;* color ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'color + :options '(:bg :fg :width :margin) + :before (lambda (n e) + (let ((m (markup-option n :margin)) + (w (markup-option n :width)) + (bg (markup-option n :bg)) + (fg (markup-option n :fg))) + (when (html-color-spec? bg) + (display "<table cellspacing=\"0\"") + (html-class n) + (printf " cellpadding=\"~a\"" (if m m 0)) + (if w (printf " width=\"~a\"" (html-width w))) + (display "><tbody>\n<tr>") + (display "<td bgcolor=\"") + (output bg e) + (display "\">")) + (when (html-color-spec? fg) + (display "<font color=\"") + (output fg e) + (display "\">")))) + :after (lambda (n e) + (when (html-color-spec? (markup-option n :fg)) + (display "</font>")) + (when (html-color-spec? (markup-option n :bg)) + (display "</td></tr>\n</tbody></table>")))) + +;*---------------------------------------------------------------------*/ +;* frame ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'frame + :options '(:width :margin :border) + :before (lambda (n e) + (let ((m (markup-option n :margin)) + (b (markup-option n :border)) + (w (markup-option n :width))) + (display "<table cellspacing=\"0\"") + (html-class n) + (printf " cellpadding=\"~a\"" (if m m 0)) + (printf " border=\"~a\"" (if b b 0)) + (if w (printf " width=\"~a\"" (html-width w))) + (display "><tbody>\n<tr><td>"))) + :after "</td></tr>\n</tbody></table>") + +;*---------------------------------------------------------------------*/ +;* font ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'font + :options '(:size :face) + :before (lambda (n e) + (let ((size (markup-option n :size)) + (face (markup-option n :face))) + (when (and (number? size) (inexact? size)) + (let ((s (if (> size 0) "<big>" "<small>")) + (d (if (> size 0) 1 -1))) + (do ((i (inexact->exact size) (- i d))) + ((= i 0)) + (display s)))) + (when (or (and (number? size) (exact? size)) face) + (display "<font") + (html-class n) + (when (and (number? size) (exact? size) (not (= size 0))) + (printf " size=\"~a\"" size)) + (when face (printf " face=\"~a\"" face)) + (display ">")))) + :after (lambda (n e) + (let ((size (markup-option n :size)) + (face (markup-option n :face))) + (when (or (and (number? size) (exact? size) (not (= size 0))) + face) + (display "</font>")) + (when (and (number? size) (inexact? size)) + (let ((s (if (> size 0) "</big>" "</small>")) + (d (if (> size 0) 1 -1))) + (do ((i (inexact->exact size) (- i d))) + ((= i 0)) + (display s))))))) + +;*---------------------------------------------------------------------*/ +;* flush ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'flush + :options '(:side) + :before (lambda (n e) + (case (markup-option n :side) + ((center) + (display "<center") + (html-class n) + (display ">\n")) + ((left) + (display "<p style=\"text-align:left;\"") + (html-class n) + (display ">\n")) + ((right) + (display "<table ") + (html-class n) + (display "width=\"100%\" cellpadding=\"0\" cellspacing=\"0\" border=\"0\"><tr><td align=\"right\">")) + (else + (skribe-error 'flush + "Illegal side" + (markup-option n :side))))) + :after (lambda (n e) + (case (markup-option n :side) + ((center) + (display "</center>\n")) + ((right) + (display "</td></tr></table>\n")) + ((left) + (display "</p>\n"))))) + +;*---------------------------------------------------------------------*/ +;* center ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'center + :before (html-markup-class "center") + :after "</center>\n") + +;*---------------------------------------------------------------------*/ +;* pre ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'pre :before (html-markup-class "pre") :after "</pre>\n") + +;*---------------------------------------------------------------------*/ +;* prog ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'prog + :options '(:line :mark) + :before (html-markup-class "pre") + :after "</pre>\n") + +;*---------------------------------------------------------------------*/ +;* itemize ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'itemize + :options '(:symbol) + :before (html-markup-class "ul") + :action (lambda (n e) + (for-each (lambda (item) + (display "<li") + (html-class item) + (display ">") + (output item e) + (display "</li>\n")) + (markup-body n))) + :after "</ul>") + +;*---------------------------------------------------------------------*/ +;* enumerate ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'enumerate + :options '(:symbol) + :before (html-markup-class "ol") + :action (lambda (n e) + (for-each (lambda (item) + (display "<li") + (html-class item) + (display ">") + (output item e) + (display "</li>\n")) + (markup-body n))) + :after "</ol>") + +;*---------------------------------------------------------------------*/ +;* description ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'description + :options '(:symbol) + :before (html-markup-class "dl") + :action (lambda (n e) + (for-each (lambda (item) + (let ((k (markup-option item :key))) + (for-each (lambda (i) + (display " <dt") + (html-class i) + (display ">") + (output i e) + (display "</dt>")) + (if (pair? k) k (list k))) + (display "<dd") + (html-class item) + (display ">") + (output (markup-body item) e) + (display "</dd>\n"))) + (markup-body n))) + :after "</dl>") + +;*---------------------------------------------------------------------*/ +;* item ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'item + :options '(:key) + :action (lambda (n e) + (let ((k (markup-option n :key))) + (if k + (begin + (display "<b") + (html-class n) + (display ">") + (output k e) + (display "</b> ")))) + (output (markup-body n) e))) + +;*---------------------------------------------------------------------*/ +;* blockquote ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'blockquote + :options '() + :before (lambda (n e) + (display "<blockquote ") + (html-class n) + (display ">\n")) + :after "\n</blockquote>\n") + +;*---------------------------------------------------------------------*/ +;* figure ... @label figure@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'figure + :options '(:legend :number :multicolumns :legend-width) + :before (html-markup-class "br") + :action (lambda (n e) + (let ((ident (markup-ident n)) + (number (markup-option n :number)) + (legend (markup-option n :legend))) + (display "<a name=\"") + (display (string-canonicalize ident)) + (display "\"></a>\n") + (output (markup-body n) e) + (display "<br>\n") + (output (new markup + (markup '&html-figure-legend) + (parent n) + (ident (string-append ident "-legend")) + (class (markup-class n)) + (options `((:number ,number))) + (body legend)) + e))) + :after "<br>") + +;*---------------------------------------------------------------------*/ +;* &html-figure-legend ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-figure-legend + :options '(:number) + :before (lambda (n e) + (display "<center>") + (let ((number (markup-option n :number)) + (legend (markup-option n :legend))) + (if number + (printf "<strong>Fig. ~a:</strong> " number) + (printf "<strong>Fig. :</strong> ")))) + :after "</center>") + +;*---------------------------------------------------------------------*/ +;* table ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'table + :options '(:border :width :frame :rules :cellstyle :cellpadding :cellspacing) + :before (lambda (n e) + (let ((width (markup-option n :width)) + (border (markup-option n :border)) + (frame (markup-option n :frame)) + (rules (markup-option n :rules)) + (cstyle (markup-option n :cellstyle)) + (cp (markup-option n :cellpadding)) + (cs (markup-option n :cellspacing))) + (display "<table") + (html-class n) + (if width (printf " width=\"~a\"" (html-width width))) + (if border (printf " border=\"~a\"" border)) + (if (and (number? cp) (>= cp 0)) + (printf " cellpadding=\"~a\"" cp)) + (if (and (number? cs) (>= cs 0)) + (printf " cellspacing=\"~a\"" cs)) + (cond + ((symbol? cstyle) + (printf " style=\"border-collapse: ~a;\"" cstyle)) + ((string? cstyle) + (printf " style=\"border-collapse: separate; border-spacing=~a\"" cstyle)) + ((number? cstyle) + (printf " style=\"border-collapse: separate; border-spacing=~apt\"" cstyle))) + (if frame + (printf " frame=\"~a\"" + (if (eq? frame 'none) "void" frame))) + (if (and rules (not (eq? rules 'header))) + (printf " rules=\"~a\"" rules)) + (display "><tbody>\n"))) + :after "</tbody></table>\n") + +;*---------------------------------------------------------------------*/ +;* tr ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'tr + :options '(:bg) + :before (lambda (n e) + (let ((bg (markup-option n :bg))) + (display "<tr") + (html-class n) + (when (html-color-spec? bg) (printf " bgcolor=\"~a\"" bg)) + (display ">"))) + :after "</tr>\n") + +;*---------------------------------------------------------------------*/ +;* tc ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'tc + :options '(markup :width :align :valign :colspan :rowspan :bg) + :before (lambda (n e) + (let ((markup (or (markup-option n 'markup) 'td)) + (width (markup-option n :width)) + (align (markup-option n :align)) + (valign (let ((v (markup-option n :valign))) + (cond + ((or (eq? v 'center) + (equal? v "center")) + "middle") + (else + v)))) + (colspan (markup-option n :colspan)) + (rowspan (markup-option n :rowspan)) + (bg (markup-option n :bg))) + (printf "<~a" markup) + (html-class n) + (if width (printf " width=\"~a\"" (html-width width))) + (if align (printf " align=\"~a\"" align)) + (if valign (printf " valign=\"~a\"" valign)) + (if colspan (printf " colspan=\"~a\"" colspan)) + (if rowspan (printf " rowspan=\"~a\"" rowspan)) + (when (html-color-spec? bg) + (printf " bgcolor=\"~a\"" bg)) + (display ">"))) + :after (lambda (n e) + (let ((markup (or (markup-option n 'markup) 'td))) + (printf "</~a>" markup)))) + +;*---------------------------------------------------------------------*/ +;* image ... @label image@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'image + :options '(:file :url :width :height) + :action (lambda (n e) + (let* ((file (markup-option n :file)) + (url (markup-option n :url)) + (width (markup-option n :width)) + (height (markup-option n :height)) + (body (markup-body n)) + (efmt (engine-custom e 'image-format)) + (img (or url (convert-image file + (if (list? efmt) + efmt + '("gif" "jpg" "png")))))) + (if (not (string? img)) + (skribe-error 'html "Illegal image" file) + (begin + (printf "<img src=\"~a\" border=\"0\"" img) + (html-class n) + (if body + (begin + (display " alt=\"") + (output body e) + (display "\"")) + (printf " alt=\"~a\"" file)) + (if width (printf " width=\"~a\"" (html-width width))) + (if height (printf " height=\"~a\"" height)) + (display ">")))))) + +;*---------------------------------------------------------------------*/ +;* Ornaments ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'roman :before "") +(markup-writer 'bold :before (html-markup-class "strong") :after "</strong>") +(markup-writer 'underline :before (html-markup-class "u") :after "</u>") +(markup-writer 'strike :before (html-markup-class "strike") :after "</strike>") +(markup-writer 'emph :before (html-markup-class "em") :after "</em>") +(markup-writer 'kbd :before (html-markup-class "kbd") :after "</kbd>") +(markup-writer 'it :before (html-markup-class "em") :after "</em>") +(markup-writer 'tt :before (html-markup-class "tt") :after "</tt>") +(markup-writer 'code :before (html-markup-class "code") :after "</code>") +(markup-writer 'var :before (html-markup-class "var") :after "</var>") +(markup-writer 'samp :before (html-markup-class "samp") :after "</samp>") +(markup-writer 'sc :before "<span class=\"sc\">" :after "</span>") +(markup-writer 'sf :before "<span class=\"sf\">" :after "</span>") +(markup-writer 'sub :before (html-markup-class "sub") :after "</sub>") +(markup-writer 'sup :before (html-markup-class "sup") :after "</sup>") + +;*---------------------------------------------------------------------*/ +;* q ... @label q@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'q + :before "\"" + :after "\"") + +;*---------------------------------------------------------------------*/ +;* mailto ... @label mailto@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'mailto + :options '(:text) + :action (lambda (n e) + (let ((text (markup-option n :text))) + (display "<a href=\"mailto:") + (output (markup-body n) e) + (display #\") + (html-class n) + (display #\>) + (if text + (output text e) + (skribe-eval (tt (markup-body n)) e)) + (display "</a>")))) + +;*---------------------------------------------------------------------*/ +;* mailto ... @label mailto@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'mailto + :options '(:text) + :predicate (lambda (n e) + (and (engine-custom e 'javascript) + (or (string? (markup-body n)) + (and (pair? (markup-body n)) + (null? (cdr (markup-body n))) + (string? (car (markup-body n))))))) + :action (lambda (n e) + (let* ((body (markup-body n)) + (email (if (string? body) body (car body))) + (split (pregexp-split "@" email)) + (na (car split)) + (do (if (pair? (cdr split)) (cadr split) "")) + (nn (pregexp-replace* "[.]" na " ")) + (dd (pregexp-replace* "[.]" do " ")) + (text (markup-option n :text))) + (display "<script language=\"JavaScript\" type=\"text/javascript\"") + (if (not text) + (printf ">skribenospam( ~s, ~s, true )" nn dd) + (begin + (printf ">skribenospam( ~s, ~s, false )" nn dd) + (display "</script>") + (output text e) + (display "<script language=\"JavaScript\" type=\"text/javascript\">document.write(\"</\" + \"a>\")"))) + (display "</script>\n")))) + +;*---------------------------------------------------------------------*/ +;* mark ... @label mark@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'mark + :before (lambda (n e) + (printf "<a name=\"~a\"" (string-canonicalize (markup-ident n))) + (html-class n) + (display ">")) + :after "</a>") + +;*---------------------------------------------------------------------*/ +;* ref ... @label ref@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'ref + :options '(:text :chapter :section :subsection :subsubsection :figure :mark :handle) + :before (lambda (n e) + (let* ((c (handle-ast (markup-body n))) + (id (markup-ident c)) + (f (html-file c e)) + (class (if (markup-class n) + (markup-class n) + "inbound"))) + (printf "<a href=\"~a#~a\" class=\"~a\"" + (if (string=? f *skribe-dest*) + "" + (strip-ref-base (or f *skribe-dest* ""))) + (string-canonicalize id) + class) + (display ">"))) + :action (lambda (n e) + (let ((t (markup-option n :text)) + (m (markup-option n 'mark)) + (f (markup-option n :figure)) + (c (markup-option n :chapter)) + (s (markup-option n :section)) + (ss (markup-option n :subsection)) + (sss (markup-option n :subsubsection))) + (cond + (t + (output t e)) + (f + (output (new markup + (markup '&html-figure-ref) + (body (markup-body n))) + e)) + ((or c s ss sss) + (output (new markup + (markup '&html-section-ref) + (body (markup-body n))) + e)) + + ((not m) + (output (new markup + (markup '&html-unmark-ref) + (body (markup-body n))) + e)) + (else + (display m))))) + :after "</a>") + +;*---------------------------------------------------------------------*/ +;* &html-figure-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-figure-ref + :action (lambda (n e) + (let ((c (handle-ast (markup-body n)))) + (if (or (not (markup? c)) + (not (is-markup? c 'figure))) + (display "???") + (output (markup-option c :number) e))))) + +;*---------------------------------------------------------------------*/ +;* &html-section-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-section-ref + :action (lambda (n e) + (let ((c (handle-ast (markup-body n)))) + (if (not (markup? c)) + (display "???") + (output (markup-option c :title) e))))) + +;*---------------------------------------------------------------------*/ +;* &html-unmark-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-unmark-ref + :action (lambda (n e) + (let ((c (handle-ast (markup-body n)))) + (if (not (markup? c)) + (display "???") + (let ((t (markup-option c :title))) + (if t + (output t e) + (let ((l (markup-option c :legend))) + (if l + (output t e) + (display + (string-canonicalize + (markup-ident c))))))))))) + +;*---------------------------------------------------------------------*/ +;* bib-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'bib-ref + :options '(:text :bib) + :before "[" + :action (lambda (n e) (output n e (markup-writer-get 'ref e))) + :after "]") + +;*---------------------------------------------------------------------*/ +;* bib-ref+ ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'bib-ref+ + :options '(:text :bib) + :before "[" + :action (lambda (n e) + (let loop ((rs (markup-body n))) + (cond + ((null? rs) + #f) + (else + (if (is-markup? (car rs) 'bib-ref) + (output (car rs) e (markup-writer-get 'ref e)) + (output (car rs) e)) + (if (pair? (cdr rs)) + (begin + (display ",") + (loop (cdr rs)))))))) + :after "]") + +;*---------------------------------------------------------------------*/ +;* url-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'url-ref + :options '(:url :text) + :before (lambda (n e) + (let* ((url (markup-option n :url)) + (class (cond + ((markup-class n) + (markup-class n)) + ((not (string? url)) + #f) + (else + (let ((l (string-length url))) + (let loop ((i 0)) + (cond + ((= i l) + #f) + ((char=? (string-ref url i) #\:) + (substring url 0 i)) + (else + (loop (+ i 1)))))))))) + (display "<a href=\"") + (output url html-title-engine) + (display "\"") + (when class (printf " class=\"~a\"" class)) + (display ">"))) + :action (lambda (n e) + (let ((v (markup-option n :text))) + (output (or v (markup-option n :url)) e))) + :after "</a>") + +;*---------------------------------------------------------------------*/ +;* line-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'line-ref + :options '(:offset) + :before (html-markup-class "i") + :action (lambda (n e) + (let ((o (markup-option n :offset)) + (v (string->number (markup-option n :text)))) + (if (and (number? o) (number? v)) + (markup-option-add! n :text (+ o v))) + (output n e (markup-writer-get 'ref e)) + (if (and (number? o) (number? v)) + (markup-option-add! n :text v)))) + :after "</i>") + +;*---------------------------------------------------------------------*/ +;* page-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'page-ref + :options '(:mark :handle) + :action (lambda (n e) + (error 'page-ref:html "Not implemented yet" n))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry-label ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-label + :options '(:title) + :before (lambda (n e) + (printf "<a name=\"~a\"" (string-canonicalize (markup-ident n))) + (html-class n) + (display ">")) + :action (lambda (n e) + (output n e (markup-writer-get '&bib-entry-label base-engine))) + :after "</a>") + +;*---------------------------------------------------------------------*/ +;* &bib-entry-title ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-title + :action (lambda (n e) + (let* ((t (bold (markup-body n))) + (en (handle-ast (ast-parent n))) + (url (or (markup-option en 'url) + (markup-option en 'documenturl))) + (ht (if url (ref :url (markup-body url) :text t) t))) + (skribe-eval ht e)))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry-url ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-url + :action (lambda (n e) + (let* ((en (handle-ast (ast-parent n))) + (url (markup-option en 'url)) + (t (bold (markup-body url)))) + (skribe-eval (ref :url (markup-body url) :text t) e)))) + +;*---------------------------------------------------------------------*/ +;* &the-index-header ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&the-index-header + :action (lambda (n e) + (display "<center") + (html-class n) + (display ">") + (for-each (lambda (h) + (let ((f (engine-custom e 'index-header-font-size))) + (if f + (skribe-eval (font :size f (bold (it h))) e) + (output h e)) + (display " "))) + (markup-body n)) + (display "</center>") + (skribe-eval (linebreak 2) e))) + +;*---------------------------------------------------------------------*/ +;* &source-comment ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-comment + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-comment-color)) + (n1 (it (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-line-comment ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-line-comment + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-comment-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-keyword ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-keyword + :action (lambda (n e) + (skribe-eval (bold (markup-body n)) e))) + +;*---------------------------------------------------------------------*/ +;* &source-error ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-error + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-error-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-define ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-define + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-define-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-module ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-module + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-module-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-markup ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-markup + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-markup-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-thread ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-thread + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-thread-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-string ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-string + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-string-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-bracket ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-bracket + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-bracket-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc (bold n1)) + (bold n1)))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-type ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-type + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-type-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + (it n1)))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-key ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-key + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-type-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc (bold n1)) + (it n1)))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-type ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-type + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-type-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg "red" (bold n1)) + (bold n1)))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* Restore the base engine */ +;*---------------------------------------------------------------------*/ +(default-engine-set! (find-engine 'base)) |