aboutsummaryrefslogtreecommitdiff
path: root/skribe/skr/html.skr
diff options
context:
space:
mode:
Diffstat (limited to 'skribe/skr/html.skr')
-rw-r--r--skribe/skr/html.skr2251
1 files changed, 0 insertions, 2251 deletions
diff --git a/skribe/skr/html.skr b/skribe/skr/html.skr
deleted file mode 100644
index ebac5f2..0000000
--- a/skribe/skr/html.skr
+++ /dev/null
@@ -1,2251 +0,0 @@
-;*=====================================================================*/
-;* 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 '((#\< "&lt;")
- (#\> "&gt;")
- (#\& "&amp;")
- (#\" "&quot;")
- (#\@ "&#x40;")))
- :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" "&#161;")
- ("cent" "&#162;")
- ("pound" "&#163;")
- ("currency" "&#164;")
- ("yen" "&#165;")
- ("section" "&#167;")
- ("mul" "&#168;")
- ("copyright" "&#169;")
- ("female" "&#170;")
- ("lguillemet" "&#171;")
- ("not" "&#172;")
- ("registered" "&#174;")
- ("degree" "&#176;")
- ("plusminus" "&#177;")
- ("micro" "&#181;")
- ("paragraph" "&#182;")
- ("middot" "&#183;")
- ("male" "&#184;")
- ("rguillemet" "&#187;")
- ("1/4" "&#188;")
- ("1/2" "&#189;")
- ("3/4" "&#190;")
- ("iquestion" "&#191;")
- ("Agrave" "&#192;")
- ("Aacute" "&#193;")
- ("Acircumflex" "&#194;")
- ("Atilde" "&#195;")
- ("Amul" "&#196;")
- ("Aring" "&#197;")
- ("AEligature" "&#198;")
- ("Oeligature" "&#338;")
- ("Ccedilla" "&#199;")
- ("Egrave" "&#200;")
- ("Eacute" "&#201;")
- ("Ecircumflex" "&#202;")
- ("Euml" "&#203;")
- ("Igrave" "&#204;")
- ("Iacute" "&#205;")
- ("Icircumflex" "&#206;")
- ("Iuml" "&#207;")
- ("ETH" "&#208;")
- ("Ntilde" "&#209;")
- ("Ograve" "&#210;")
- ("Oacute" "&#211;")
- ("Ocurcumflex" "&#212;")
- ("Otilde" "&#213;")
- ("Ouml" "&#214;")
- ("times" "&#215;")
- ("Oslash" "&#216;")
- ("Ugrave" "&#217;")
- ("Uacute" "&#218;")
- ("Ucircumflex" "&#219;")
- ("Uuml" "&#220;")
- ("Yacute" "&#221;")
- ("THORN" "&#222;")
- ("szlig" "&#223;")
- ("agrave" "&#224;")
- ("aacute" "&#225;")
- ("acircumflex" "&#226;")
- ("atilde" "&#227;")
- ("amul" "&#228;")
- ("aring" "&#229;")
- ("aeligature" "&#230;")
- ("oeligature" "&#339;")
- ("ccedilla" "&#231;")
- ("egrave" "&#232;")
- ("eacute" "&#233;")
- ("ecircumflex" "&#234;")
- ("euml" "&#235;")
- ("igrave" "&#236;")
- ("iacute" "&#237;")
- ("icircumflex" "&#238;")
- ("iuml" "&#239;")
- ("eth" "&#240;")
- ("ntilde" "&#241;")
- ("ograve" "&#242;")
- ("oacute" "&#243;")
- ("ocurcumflex" "&#244;")
- ("otilde" "&#245;")
- ("ouml" "&#246;")
- ("divide" "&#247;")
- ("oslash" "&#248;")
- ("ugrave" "&#249;")
- ("uacute" "&#250;")
- ("ucircumflex" "&#251;")
- ("uuml" "&#252;")
- ("yacute" "&#253;")
- ("thorn" "&#254;")
- ("ymul" "&#255;")
- ;; Greek
- ("Alpha" "&#913;")
- ("Beta" "&#914;")
- ("Gamma" "&#915;")
- ("Delta" "&#916;")
- ("Epsilon" "&#917;")
- ("Zeta" "&#918;")
- ("Eta" "&#919;")
- ("Theta" "&#920;")
- ("Iota" "&#921;")
- ("Kappa" "&#922;")
- ("Lambda" "&#923;")
- ("Mu" "&#924;")
- ("Nu" "&#925;")
- ("Xi" "&#926;")
- ("Omicron" "&#927;")
- ("Pi" "&#928;")
- ("Rho" "&#929;")
- ("Sigma" "&#931;")
- ("Tau" "&#932;")
- ("Upsilon" "&#933;")
- ("Phi" "&#934;")
- ("Chi" "&#935;")
- ("Psi" "&#936;")
- ("Omega" "&#937;")
- ("alpha" "&#945;")
- ("beta" "&#946;")
- ("gamma" "&#947;")
- ("delta" "&#948;")
- ("epsilon" "&#949;")
- ("zeta" "&#950;")
- ("eta" "&#951;")
- ("theta" "&#952;")
- ("iota" "&#953;")
- ("kappa" "&#954;")
- ("lambda" "&#955;")
- ("mu" "&#956;")
- ("nu" "&#957;")
- ("xi" "&#958;")
- ("omicron" "&#959;")
- ("pi" "&#960;")
- ("rho" "&#961;")
- ("sigmaf" "&#962;")
- ("sigma" "&#963;")
- ("tau" "&#964;")
- ("upsilon" "&#965;")
- ("phi" "&#966;")
- ("chi" "&#967;")
- ("psi" "&#968;")
- ("omega" "&#969;")
- ("thetasym" "&#977;")
- ("piv" "&#982;")
- ;; punctuation
- ("bullet" "&#8226;")
- ("ellipsis" "&#8230;")
- ("weierp" "&#8472;")
- ("image" "&#8465;")
- ("real" "&#8476;")
- ("tm" "&#8482;")
- ("alef" "&#8501;")
- ("<-" "&#8592;")
- ("<--" "&#8592;")
- ("uparrow" "&#8593;")
- ("->" "&#8594;")
- ("-->" "&#8594;")
- ("downarrow" "&#8595;")
- ("<->" "&#8596;")
- ("<-->" "&#8596;")
- ("<+" "&#8629;")
- ("<=" "&#8656;")
- ("<==" "&#8656;")
- ("Uparrow" "&#8657;")
- ("=>" "&#8658;")
- ("==>" "&#8658;")
- ("Downarrow" "&#8659;")
- ("<=>" "&#8660;")
- ("<==>" "&#8660;")
- ;; Mathematical operators
- ("forall" "&#8704;")
- ("partial" "&#8706;")
- ("exists" "&#8707;")
- ("emptyset" "&#8709;")
- ("infinity" "&#8734;")
- ("nabla" "&#8711;")
- ("in" "&#8712;")
- ("notin" "&#8713;")
- ("ni" "&#8715;")
- ("prod" "&#8719;")
- ("sum" "&#8721;")
- ("asterisk" "&#8727;")
- ("sqrt" "&#8730;")
- ("propto" "&#8733;")
- ("angle" "&#8736;")
- ("and" "&#8743;")
- ("or" "&#8744;")
- ("cap" "&#8745;")
- ("cup" "&#8746;")
- ("integral" "&#8747;")
- ("therefore" "&#8756;")
- ("models" "|=")
- ("vdash" "|-")
- ("dashv" "-|")
- ("sim" "&#8764;")
- ("cong" "&#8773;")
- ("approx" "&#8776;")
- ("neq" "&#8800;")
- ("equiv" "&#8801;")
- ("le" "&#8804;")
- ("ge" "&#8805;")
- ("subset" "&#8834;")
- ("supset" "&#8835;")
- ("nsupset" "&#8835;")
- ("subseteq" "&#8838;")
- ("supseteq" "&#8839;")
- ("oplus" "&#8853;")
- ("otimes" "&#8855;")
- ("perp" "&#8869;")
- ("mid" "|")
- ("lceil" "&#8968;")
- ("rceil" "&#8969;")
- ("lfloor" "&#8970;")
- ("rfloor" "&#8971;")
- ("langle" "&#9001;")
- ("rangle" "&#9002;")
- ;; Misc
- ("loz" "&#9674;")
- ("spades" "&#9824;")
- ("clubs" "&#9827;")
- ("hearts" "&#9829;")
- ("diams" "&#9830;")
- ("euro" "&#8464;")
- ;; LaTeX
- ("dag" "dag")
- ("ddag" "ddag")
- ("circ" "o")
- ("top" "T")
- ("bottom" "&#8869;")
- ("lhd" "<")
- ("rhd" ">")
- ("parallel" "||")))))
-
-;*---------------------------------------------------------------------*/
-;* html-title-engine ... */
-;*---------------------------------------------------------------------*/
-(define html-title-engine
- (copy-engine 'html-title base-engine
- :filter (make-string-replace '((#\< "&lt;")
- (#\> "&gt;")
- (#\& "&amp;")
- (#\" "&quot;")))))
-
-;*---------------------------------------------------------------------*/
-;* 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))