;;; html.scm -- HTML engine.
;;;
;;; Copyright 2005, 2006, 2007, 2008, 2009, 2011, 2012, 2018, 2020 Ludovic Courtès
;;; Copyright 2003, 2004 Manuel Serrano
;;; Copyright 2022, 2023 Arun Isaac
;;;
;;;
;;; This file is part of Skribilo.
;;;
;;; Skribilo is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; Skribilo is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Skribilo. If not, see .
(define-module (skribilo engine html)
#:use-module (skribilo lib)
#:use-module (skribilo ast)
#:use-module (skribilo config)
#:use-module (skribilo engine)
#:use-module (skribilo writer)
#:use-module (skribilo location)
#:use-module (skribilo utils strings)
#:use-module (skribilo utils syntax)
#:use-module (skribilo package base)
#:autoload (skribilo utils images) (convert-image)
#:autoload (skribilo utils files) (file-prefix file-suffix)
#:autoload (skribilo parameters) (*destination-file*)
#:autoload (skribilo evaluator) (evaluate-document)
#:autoload (skribilo output) (output)
#:autoload (skribilo debug) (*debug*)
#:autoload (skribilo sui) (document-sui)
#:autoload (ice-9 rdelim) (read-line)
#:autoload (ice-9 regex) (regexp-substitute/global)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:use-module (srfi srfi-14)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-39)
#:use-module (rnrs exceptions)
#:use-module (rnrs io ports)
#:export (html-engine html-title-engine html-file
html-width html-class html-markup-class
html-title-authors))
(skribilo-module-syntax)
;; Keep a reference to the base engine.
(define base-engine (find-engine 'base))
(if (not (engine? base-engine))
(error "bootstrap problem: base engine broken" base-engine))
(define unspecified?
;; XXX: Hack to recognize the unspecified value as understood by
;; `engine-custom' et al.
(let ((really-unspecified? (@ (guile) unspecified?)))
(lambda (x)
(or (really-unspecified? x)
(eq? x 'unspecified)))))
;*---------------------------------------------------------------------*/
;* html-file-default ... */
;*---------------------------------------------------------------------*/
(define html-file-default
;; Default implementation of the `file-name-proc' custom.
(let ((table '())
(filename (gensym "filename")))
(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 #f "~a-~a.~a" base n suf)))
(lambda (node engine)
(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 engine 'chapter-file))
(and (is-markup? node 'section)
(engine-custom engine 'section-file))
(and (is-markup? node 'subsection)
(engine-custom engine 'subsection-file))
(and (is-markup? node 'subsubsection)
(engine-custom engine 'subsubsection-file)))
(let* ((b (or (and (string? (*destination-file*))
(file-prefix (*destination-file*)))
""))
(s (or (and (string? (*destination-file*))
(file-suffix (*destination-file*)))
"html"))
(nm (get-file-name b s)))
(markup-option-add! node filename nm)
nm))
((document? node)
(*destination-file*))
(else
(let ((p (ast-parent node)))
(if (container? p)
(let ((file (html-file p engine)))
(if (string? file)
(begin
(markup-option-add! node filename file)
file)
#f))
#f))))))))
;*---------------------------------------------------------------------*/
;* 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 "UTF-8")
;; 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 #f)
(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 #f)
(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 #f)
(right-margin-foreground #f)
;; author configuration
(author-font #f)
;; title configuration
(title-font #f)
(title-background #f)
(title-foreground #f)
(file-title-separator ,(! " — ")) ;; an "em dash"
;; html file naming
(file-name-proc ,html-file-default)
;; index configuration
(index-header-font-size #f) ;; +2.
;; chapter configuration
(chapter-number->string number->string)
(chapter-file #f)
;; section configuration
(section-title-start "")
(section-title-stop "
")
(section-title-background #f)
(section-title-foreground #f)
(section-title-number-separator " ")
(section-number->string number->string)
(section-file #f)
;; subsection configuration
(subsection-title-start "")
(subsection-title-stop "
")
(subsection-title-background #f)
(subsection-title-foreground #f)
(subsection-title-number-separator " ")
(subsection-number->string number->string)
(subsection-file #f)
;; subsubsection configuration
(subsubsection-title-start "")
(subsubsection-title-stop "
")
(subsubsection-title-background #f)
(subsubsection-title-foreground #f)
(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-file ... */
;*---------------------------------------------------------------------*/
(define (html-file node engine)
(let ((proc (or (engine-custom engine 'file-name-proc)
html-file-default)))
(proc node engine)))
;*---------------------------------------------------------------------*/
;* html-title-engine ... */
;*---------------------------------------------------------------------*/
(define html-title-engine
(copy-engine 'html-title base-engine
:filter (make-string-replace '((#\< "<")
(#\> ">")
(#\& "&")
(#\" """)))))
;*---------------------------------------------------------------------*/
;* html-browser-title ... */
;*---------------------------------------------------------------------*/
(define (html-browser-title node)
(and (markup? node)
(or (markup-option node :html-title)
(if (document? node)
(markup-option node :title)
(html-browser-title (ast-parent node))))))
;*---------------------------------------------------------------------*/
;* html-container-number ... */
;* ------------------------------------------------------------- */
;* Returns a string representing the container number */
;*---------------------------------------------------------------------*/
(define (html-container-number c engine)
(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 engine 'chapter-number->string)))
(define (html-section-number c)
(let ((p (ast-parent c))
(s (html-number (markup-option c :number)
(engine-custom engine 'section-number->string))))
(cond
((is-markup? p 'chapter)
(string-append (html-chapter-number p) "." s))
(else
s))))
(define (html-subsection-number c)
(let ((p (ast-parent c))
(s (html-number (markup-option c :number)
(engine-custom engine '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 engine '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-width ... */
;*---------------------------------------------------------------------*/
(define (html-width width)
(cond
((and (integer? width) (exact? width))
(format #f "~A" width))
((real? width)
(format #f "~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))
(format #t " class=\"~a\"" c)))))
;*---------------------------------------------------------------------*/
;* html-open ... */
;*---------------------------------------------------------------------*/
(define* (html-open tag #:optional (attributes '()))
"Output opening TAG with ATTRIBUTES, an association list mapping
attribute names to their values. Attribute names may be symbols or
strings. Values may be symbols, strings or numbers. Attributes with
unspecified or #f values are ignored."
(display "<")
(display tag)
(for-each (match-lambda
((name . value)
(when (and value
(not (unspecified? value)))
(format #t " ~a=\"~a\"" name value))))
attributes)
(display ">")
(newline))
;*---------------------------------------------------------------------*/
;* html-close ... */
;*---------------------------------------------------------------------*/
(define (html-close tag)
"Output closing TAG."
(display "")
(newline))
;*---------------------------------------------------------------------*/
;* style-declaration ... */
;*---------------------------------------------------------------------*/
(define (style-declaration properties)
"Return a style declaration with PROPERTIES, an association list
mapping property names to their values. Property names may be symbols
or strings. Values may be strings or numbers. Properties with #f
values are ignored. If PROPERTIES is empty or all of its elements were
ignored, return #f."
(match (filter-map (match-lambda
((name . value)
(and value
(format #f "~a: ~a;" name value))))
properties)
(() #f)
(serialized-properties
(string-join serialized-properties))))
;*---------------------------------------------------------------------*/
;* html-markup-class ... */
;*---------------------------------------------------------------------*/
(define (html-markup-class m)
(lambda (node engine)
(html-open m
`((class . ,(markup-class node))))))
;*---------------------------------------------------------------------*/
;* 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 :keywords)
:action (lambda (node engine)
(let* ((id (markup-ident node))
(title (new markup
(markup '&html-document-title)
(parent node)
(ident (string-append id "-title"))
(class (markup-class node))
(options `((author ,(markup-option node :author))))
(body (markup-option node :title)))))
;; Record the file name, for use by `html-file-default'.
(markup-option-add! node :file (*destination-file*))
(&html-generic-document node title engine)))
:after (lambda (node engine)
(if (engine-custom engine 'emit-sui)
(document-sui node engine))))
;*---------------------------------------------------------------------*/
;* &html-html ... */
;*---------------------------------------------------------------------*/
(markup-writer '&html-html
:before "
\n"
:after "")
;*---------------------------------------------------------------------*/
;* &html-head ... */
;*---------------------------------------------------------------------*/
(markup-writer '&html-head
:before (lambda (node engine)
(html-open 'head)
(html-open 'meta
`((http-equiv . "Content-Type")
(content . "text/html;")
(charset . ,(engine-custom (find-engine 'html)
'charset))))
(let ((head (engine-custom engine 'head)))
(when head
(display head)
(newline))))
:after "\n\n")
;*---------------------------------------------------------------------*/
;* &html-meta ... */
;*---------------------------------------------------------------------*/
(markup-writer '&html-meta
:before "string (or (markup-body node) '()))))
(output (keyword-list->comma-separated kw*) engine)))
:after "\">\n")
;*---------------------------------------------------------------------*/
;* &html-body ... */
;*---------------------------------------------------------------------*/
(markup-writer '&html-body
:before (lambda (node engine)
(let ((bg (engine-custom engine 'background)))
(html-open 'body
`((class . ,(markup-class node))
(bgcolor . ,(and (html-color-spec? bg)
bg))))))
:after " \n")
;*---------------------------------------------------------------------*/
;* &html-page ... */
;*---------------------------------------------------------------------*/
(markup-writer '&html-page
:action (lambda (node engine)
(define (html-margin m fn size bg fg cla)
(html-open 'td
`((align . "left")
(valign . "top")
(class . ,cla)
(width . ,(and size (html-width size)))
(bgcolor . ,(and (html-color-spec? bg)
bg))))
(html-open 'div
`((class . ,cla)))
(cond
((and (string? fg) (string? fn))
(format #t "