html.scm 10 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281
  1. ;;;; (texinfo html) -- translating stexinfo into shtml
  2. ;;;;
  3. ;;;; Copyright (C) 2009, 2010, 2011, 2020 Free Software Foundation, Inc.
  4. ;;;; Copyright (C) 2003,2004,2009 Andy Wingo <wingo at pobox dot com>
  5. ;;;;
  6. ;;;; This library is free software; you can redistribute it and/or
  7. ;;;; modify it under the terms of the GNU Lesser General Public
  8. ;;;; License as published by the Free Software Foundation; either
  9. ;;;; version 3 of the License, or (at your option) any later version.
  10. ;;;;
  11. ;;;; This library is distributed in the hope that it will be useful,
  12. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  14. ;;;; Lesser General Public License for more details.
  15. ;;;;
  16. ;;;; You should have received a copy of the GNU Lesser General Public
  17. ;;;; License along with this library; if not, write to the Free Software
  18. ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  19. ;;;;
  20. ;;; Commentary:
  21. ;;
  22. ;;This module implements transformation from @code{stexi} to HTML. Note
  23. ;;that the output of @code{stexi->shtml} is actually SXML with the HTML
  24. ;;vocabulary. This means that the output can be further processed, and
  25. ;;that it must eventually be serialized by
  26. ;;@ref{sxml simple sxml->xml,sxml->xml}.
  27. ;;
  28. ;;References (i.e., the @code{@@ref} family of commands) are resolved by
  29. ;;a @dfn{ref-resolver}.
  30. ;;@xref{texinfo html add-ref-resolver!,add-ref-resolver!}, for more
  31. ;;information.
  32. ;;
  33. ;;; Code:
  34. ;; TODO: nice ref resolving API, default CSS stylesheet (esp. to remove
  35. ;; margin-top on dd > p)
  36. (define-module (texinfo html)
  37. #:use-module (texinfo)
  38. #:use-module (sxml transform)
  39. #:use-module (ice-9 match)
  40. #:use-module (srfi srfi-13)
  41. #:export (stexi->shtml add-ref-resolver! urlify))
  42. ;; The caller is responsible for carring the returned list.
  43. (define (arg-ref key %-args)
  44. (and=> (assq key (cdr %-args)) (lambda (x) (stexi->shtml (cdr x)))))
  45. (define (arg-req key %-args)
  46. (or (arg-ref key %-args)
  47. (error "Missing argument:" key %-args)))
  48. (define (car* x) (and x (car x)))
  49. (define (urlify str)
  50. (string-downcase
  51. (string-map
  52. (lambda (c)
  53. (case c
  54. ((#\space #\/ #\:) #\-)
  55. (else c)))
  56. str)))
  57. (define ref-resolvers
  58. (list
  59. (lambda (node-name manual-name) ;; the default
  60. (urlify (string-append (or manual-name "") "#" node-name)))))
  61. (define (add-ref-resolver! proc)
  62. "Add @var{proc} to the head of the list of ref-resolvers. @var{proc}
  63. will be expected to take the name of a node and the name of a manual and
  64. return the URL of the referent, or @code{#f} to pass control to the next
  65. ref-resolver in the list.
  66. The default ref-resolver will return the concatenation of the manual
  67. name, @code{#}, and the node name."
  68. (set! ref-resolvers (cons proc ref-resolvers)))
  69. (define (resolve-ref node manual)
  70. (or (or-map (lambda (x) (x node manual)) ref-resolvers)
  71. (error "Could not resolve reference" node manual)))
  72. (define (ref tag args)
  73. (let* ((node (car (arg-req 'node args)))
  74. (section (or (car* (arg-ref 'section args)) node))
  75. (manual (car* (arg-ref 'manual args)))
  76. (target (resolve-ref node manual)))
  77. `(span ,(and=> (assq tag '((xref "See ") (pxref "see "))) cdr)
  78. (a (@ (href ,target)) ,section))))
  79. (define (uref tag args)
  80. (let ((url (car (arg-req 'url args))))
  81. `(a (@ (href ,url)) ,(or (car* (arg-ref 'title args)) url))))
  82. ;; @!*&%( Mozilla gets confused at an empty ("<a .. />") a tag. Put an
  83. ;; empty string here to placate the reptile.
  84. (define (node tag args)
  85. `(a (@ (name ,(urlify (car (arg-req 'name args))))) ""))
  86. (define (def tag args . body)
  87. (define (code x) (and x (cons 'code x)))
  88. (define (var x) (and x (cons 'var x)))
  89. (define (b x) (and x (cons 'b x)))
  90. (define (list/spaces . elts)
  91. (let lp ((in elts) (out '()))
  92. (cond ((null? in) (reverse! out))
  93. ((null? (car in)) (lp (cdr in) out))
  94. (else (lp (cdr in)
  95. (cons (car in)
  96. (if (null? out) out (cons " " out))))))))
  97. (define (left-td-contents)
  98. (list/spaces (code (arg-ref 'data-type args))
  99. (b (list (code (arg-ref 'class args)))) ;; is this right?
  100. (b (list (code (arg-ref 'name args))))
  101. (if (memq tag '(deftypeop deftypefn deftypefun))
  102. (code (arg-ref 'arguments args))
  103. (var (list (code (arg-ref 'arguments args)))))))
  104. (let* ((category (case tag
  105. ((defun) "Function")
  106. ((defspec) "Special Form")
  107. ((defvar) "Variable")
  108. (else (car (arg-req 'category args))))))
  109. `(div
  110. (table
  111. (@ (cellpadding "0") (cellspacing "0") (width "100%") (class "def"))
  112. (tr (td ,@(left-td-contents))
  113. (td (div (@ (class "right")) "[" ,category "]"))))
  114. (div (@ (class "description")) ,@body))))
  115. (define (enumerate tag . elts)
  116. (define (tonumber start)
  117. (let ((c (string-ref start 0)))
  118. (cond ((number? c) (string->number start))
  119. (else (1+ (- (char->integer c)
  120. (char->integer (if (char-upper-case? c) #\A #\a))))))))
  121. `(ol ,@(if (and (pair? elts) (pair? (car elts)) (eq? (caar elts) '%))
  122. (cons `(@ (start ,@(tonumber (arg-req 'start (car elts)))))
  123. ;; (type ,(type (arg-ref 'start (car elts)))))
  124. (cdr elts))
  125. elts)))
  126. (define (itemize tag . elts)
  127. `(ul ,@(match elts
  128. ;; Strip `bullet' attribute.
  129. ((('% . attrs) . elts) elts)
  130. (elts elts))))
  131. (define (acronym tag . elts)
  132. (match elts
  133. ;; FIXME: Need attribute matcher that doesn't depend on attribute
  134. ;; order.
  135. ((('% ('acronym text) . _)) `(acronym ,text))))
  136. (define (table tag args . body)
  137. (let ((formatter (caar (arg-req 'formatter args))))
  138. (cons 'dl
  139. (map (lambda (x)
  140. (cond ((and (pair? x) (eq? (car x) 'dt))
  141. (list (car x) (cons formatter (cdr x))))
  142. (else x)))
  143. (apply append body)))))
  144. (define (entry tag args . body)
  145. (let lp ((out `((dt ,@(arg-req 'heading args))))
  146. (body body))
  147. (if (and (pair? body) (pair? (car body)) (eq? (caar body) 'itemx))
  148. (lp (append out `(dt ,@(map stexi->shtml (cdar body))))
  149. (cdr body))
  150. (append out `((dd ,@(map stexi->shtml body)))))))
  151. (define tag-replacements
  152. '((titlepage div (@ (class "titlepage")))
  153. (title h2 (@ (class "title")))
  154. (subtitle h3 (@ (class "subtitle")))
  155. (author h3 (@ (class "author")))
  156. (example pre)
  157. (lisp pre)
  158. (smallexample pre (@ (class "smaller")))
  159. (smalllisp pre (@ (class "smaller")))
  160. (cartouche div (@ (class "cartouche")))
  161. (verbatim pre (@ (class "verbatim")))
  162. (chapter h2)
  163. (section h3)
  164. (subsection h4)
  165. (subsubsection h5)
  166. (appendix h2)
  167. (appendixsec h3)
  168. (appendixsubsec h4)
  169. (appendixsubsubsec h5)
  170. (unnumbered h2)
  171. (unnumberedsec h3)
  172. (unnumberedsubsec h4)
  173. (unnumberedsubsubsec h5)
  174. (majorheading h2)
  175. (chapheading h2)
  176. (heading h3)
  177. (subheading h4)
  178. (subsubheading h5)
  179. (quotation blockquote)
  180. (item li) ;; itemx ?
  181. (para p)
  182. (*fragment* div) ;; should be ok
  183. (asis span)
  184. (w span (@ (class "verbatim")))
  185. (bold b)
  186. (i i)
  187. (sample samp)
  188. (samp samp)
  189. (code code)
  190. (math em)
  191. (kbd kbd)
  192. (key code (@ (class "key")))
  193. (var var)
  194. (env code (@ (class "env")))
  195. (file code (@ (class "file")))
  196. (command code (@ (class "command")))
  197. (option code (@ (class "option")))
  198. (url code (@ (class "url")))
  199. (dfn dfn)
  200. (cite cite)
  201. (acro acronym)
  202. (email code (@ (class "email")))
  203. (emph em)
  204. (strong strong)
  205. (sc span (@ (class "small-caps")))))
  206. (define ignore-list
  207. '(page setfilename setchapternewpage iftex ifinfo ifplaintext ifxml sp vskip
  208. menu ignore syncodeindex comment c dircategory direntry top shortcontents
  209. cindex printindex))
  210. (define rules
  211. `((% *preorder* . ,(lambda args args)) ;; Keep these around...
  212. (texinfo . ,(lambda (tag args . body)
  213. (pre-post-order
  214. `(html
  215. (@ (xmlns "http://www.w3.org/1999/xhtml"))
  216. (head (title ,(car (arg-req 'title args))))
  217. (body ,@body))
  218. `((% *preorder* . ,(lambda args #f)) ;; ... filter out.
  219. (*text* . ,(lambda (tag x) x))
  220. (*default* . ,(lambda (tag . body)
  221. (cons tag body)))))))
  222. (copyright . ,(lambda args '(*ENTITY* "copy")))
  223. (result . ,(lambda args '(*ENTITY* "rArr")))
  224. (tie . ,(lambda args '(*ENTITY* "nbsp")))
  225. (dots . ,(lambda args '(*ENTITY* "hellip")))
  226. (xref . ,ref) (ref . ,ref) (pxref . ,ref)
  227. (uref . ,uref)
  228. (node . ,node) (anchor . ,node)
  229. (table . ,table)
  230. (enumerate . ,enumerate)
  231. (itemize . ,itemize)
  232. (acronym . ,acronym)
  233. (entry *preorder* . ,entry)
  234. (deftp . ,def) (defcv . ,def) (defivar . ,def) (deftypeivar . ,def)
  235. (defop . ,def) (deftypeop . ,def) (defmethod . ,def)
  236. (deftypemethod . ,def) (defopt . ,def) (defvr . ,def) (defvar . ,def)
  237. (deftypevr . ,def) (deftypevar . ,def) (deffn . ,def)
  238. (deftypefn . ,def) (defmac . ,def) (defspec . ,def) (defun . ,def)
  239. (deftypefun . ,def)
  240. (ifnottex . ,(lambda (tag . body) body))
  241. (*text* . ,(lambda (tag x) x))
  242. (*default* . ,(lambda (tag . body)
  243. (let ((subst (assq tag tag-replacements)))
  244. (cond
  245. (subst (append (cdr subst) body))
  246. ((memq tag ignore-list) #f)
  247. (else
  248. (warn "Don't know how to convert" tag "to HTML")
  249. body)))))))
  250. (define (stexi->shtml tree)
  251. "Transform the stexi @var{tree} into shtml, resolving references via
  252. ref-resolvers. See the module commentary for more details."
  253. (pre-post-order tree rules))
  254. ;;; arch-tag: ab05f3fe-9981-4a78-b64c-48efcd9983a6