1 ;;;; (texinfo html) -- translating stexinfo into shtml
3 ;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
4 ;;;; Copyright (C) 2003,2004,2009 Andy Wingo <wingo at pobox dot com>
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.
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.
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
23 ;;This module implements transformation from @code{stexi} to HTML. Note
24 ;;that the output of @code{stexi->shtml} is actually SXML with the HTML
25 ;;vocabulary. This means that the output can be further processed, and
26 ;;that it must eventually be serialized by
27 ;;@ref{sxml simple sxml->xml,sxml->xml}.
29 ;;References (i.e., the @code{@@ref} family of commands) are resolved by
30 ;;a @dfn{ref-resolver}.
31 ;;@xref{texinfo html add-ref-resolver!,add-ref-resolver!}, for more
36 ;; TODO: nice ref resolving API, default CSS stylesheet (esp. to remove
37 ;; margin-top on dd > p)
39 (define-module (texinfo html)
41 :use-module (sxml transform)
42 :use-module (srfi srfi-13)
43 :export (stexi->shtml add-ref-resolver! urlify))
45 ;; The caller is responsible for carring the returned list.
46 (define (arg-ref key %-args)
47 (and=> (assq key (cdr %-args)) (lambda (x) (stexi->shtml (cdr x)))))
48 (define (arg-req key %-args)
49 (or (arg-ref key %-args)
50 (error "Missing argument:" key %-args)))
51 (define (car* x) (and x (car x)))
58 ((#\space #\/ #\:) #\-)
64 (lambda (node-name manual-name) ;; the default
65 (urlify (string-append (or manual-name "") "#" node-name)))))
67 (define (add-ref-resolver! proc)
68 "Add @var{proc} to the head of the list of ref-resolvers. @var{proc}
69 will be expected to take the name of a node and the name of a manual and
70 return the URL of the referent, or @code{#f} to pass control to the next
71 ref-resolver in the list.
73 The default ref-resolver will return the concatenation of the manual
74 name, @code{#}, and the node name."
75 (set! ref-resolvers (cons proc ref-resolvers)))
77 (define (resolve-ref node manual)
78 (or (or-map (lambda (x) (x node manual)) ref-resolvers)
79 (error "Could not resolve reference" node manual)))
81 (define (ref tag args)
82 (let* ((node (car (arg-req 'node args)))
83 (section (or (car* (arg-ref 'section args)) node))
84 (manual (car* (arg-ref 'manual args)))
85 (target (resolve-ref node manual)))
86 `(span ,(and=> (assq tag '((xref "See ") (pxref "see "))) cdr)
87 (a (@ (href ,target)) ,section))))
89 (define (uref tag args)
90 (let ((url (car (arg-req 'url args))))
91 `(a (@ (href ,url)) ,(or (car* (arg-ref 'title args)) url))))
93 ;; @!*&%( Mozilla gets confused at an empty ("<a .. />") a tag. Put an
94 ;; empty string here to placate the reptile.
95 (define (node tag args)
96 `(a (@ (name ,(urlify (car (arg-req 'name args))))) ""))
98 (define (def tag args . body)
99 (define (code x) (and x (cons 'code x)))
100 (define (var x) (and x (cons 'var x)))
101 (define (b x) (and x (cons 'b x)))
102 (define (list/spaces . elts)
103 (let lp ((in elts) (out '()))
104 (cond ((null? in) (reverse! out))
105 ((null? (car in)) (lp (cdr in) out))
108 (if (null? out) out (cons " " out))))))))
109 (define (left-td-contents)
110 (list/spaces (code (arg-ref 'data-type args))
111 (b (list (code (arg-ref 'class args)))) ;; is this right?
112 (b (list (code (arg-ref 'name args))))
113 (if (memq tag '(deftypeop deftypefn deftypefun))
114 (code (arg-ref 'arguments args))
115 (var (list (code (arg-ref 'arguments args)))))))
117 (let* ((category (case tag
119 ((defspec) "Special Form")
120 ((defvar) "Variable")
121 (else (car (arg-req 'category args))))))
124 (@ (cellpadding "0") (cellspacing "0") (width "100%") (class "def"))
125 (tr (td ,@(left-td-contents))
126 (td (div (@ (class "right")) "[" ,category "]"))))
127 (div (@ (class "description")) ,@body))))
129 (define (enumerate tag . elts)
130 (define (tonumber start)
131 (let ((c (string-ref start 0)))
132 (cond ((number? c) (string->number start))
133 (else (1+ (- (char->integer c)
134 (char->integer (if (char-upper-case? c) #\A #\a))))))))
135 `(ol ,@(if (and (pair? elts) (pair? (car elts)) (eq? (caar elts) '%))
136 (cons `(@ (start ,@(tonumber (arg-req 'start (car elts)))))
137 ;; (type ,(type (arg-ref 'start (car elts)))))
141 (define (table tag args . body)
142 (let ((formatter (caar (arg-req 'formatter args))))
145 (cond ((and (pair? x) (eq? (car x) 'dt))
146 (list (car x) (cons formatter (cdr x))))
148 (apply append body)))))
150 (define (entry tag args . body)
151 (let lp ((out `((dt ,@(arg-req 'heading args))))
153 (if (and (pair? body) (pair? (car body)) (eq? (caar body) 'itemx))
154 (lp (append out `(dt ,@(map stexi->shtml (cdar body))))
156 (append out `((dd ,@(map stexi->shtml body)))))))
158 (define tag-replacements
159 '((titlepage div (@ (class "titlepage")))
160 (title h2 (@ (class "title")))
161 (subtitle h3 (@ (class "subtitle")))
162 (author h3 (@ (class "author")))
165 (smallexample pre (@ (class "smaller")))
166 (smalllisp pre (@ (class "smaller")))
167 (cartouche div (@ (class "cartouche")))
168 (verbatim pre (@ (class "verbatim")))
176 (appendixsubsubsec h5)
179 (unnumberedsubsec h4)
180 (unnumberedsubsubsec h5)
186 (quotation blockquote)
190 (*fragment* div) ;; should be ok
198 (key code (@ (class "key")))
200 (env code (@ (class "env")))
201 (file code (@ (class "file")))
202 (command code (@ (class "command")))
203 (option code (@ (class "option")))
204 (url code (@ (class "url")))
208 (email code (@ (class "email")))
211 (sc span (@ (class "small-caps")))))
214 '(page setfilename setchapternewpage iftex ifinfo ifplaintext ifxml sp vskip
215 menu ignore syncodeindex comment c dircategory direntry top shortcontents
219 `((% *preorder* . ,(lambda args args)) ;; Keep these around...
220 (texinfo . ,(lambda (tag args . body)
223 (@ (xmlns "http://www.w3.org/1999/xhtml"))
224 (head (title ,(car (arg-req 'title args))))
226 `((% *preorder* . ,(lambda args #f)) ;; ... filter out.
227 (*text* . ,(lambda (tag x) x))
228 (*default* . ,(lambda (tag . body)
229 (cons tag body)))))))
230 (copyright . ,(lambda args '(*ENTITY* "copy")))
231 (result . ,(lambda args '(*ENTITY* "rArr")))
232 (xref . ,ref) (ref . ,ref) (pxref . ,ref)
234 (node . ,node) (anchor . ,node)
236 (enumerate . ,enumerate)
237 (entry *preorder* . ,entry)
239 (deftp . ,def) (defcv . ,def) (defivar . ,def) (deftypeivar . ,def)
240 (defop . ,def) (deftypeop . ,def) (defmethod . ,def)
241 (deftypemethod . ,def) (defopt . ,def) (defvr . ,def) (defvar . ,def)
242 (deftypevr . ,def) (deftypevar . ,def) (deffn . ,def)
243 (deftypefn . ,def) (defmac . ,def) (defspec . ,def) (defun . ,def)
245 (ifnottex . ,(lambda (tag . body) body))
246 (*text* . ,(lambda (tag x) x))
247 (*default* . ,(lambda (tag . body)
248 (let ((subst (assq tag tag-replacements)))
250 (subst (append (cdr subst) body))
251 ((memq tag ignore-list) #f)
253 (warn "Don't know how to convert" tag "to HTML")
256 (define (stexi->shtml tree)
257 "Transform the stexi @var{tree} into shtml, resolving references via
258 ref-resolvers. See the module commentary for more details."
259 (pre-post-order tree rules))
261 ;;; arch-tag: ab05f3fe-9981-4a78-b64c-48efcd9983a6