Commit | Line | Data |
---|---|---|
47f3ce52 AW |
1 | ;;;; (texinfo html) -- translating stexinfo into shtml |
2 | ;;;; | |
38c50a99 | 3 | ;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. |
47f3ce52 AW |
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 | \f | |
21 | ;;; Commentary: | |
22 | ;; | |
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}. | |
28 | ;; | |
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 | |
32 | ;;information. | |
33 | ;; | |
34 | ;;; Code: | |
35 | ||
36 | ;; TODO: nice ref resolving API, default CSS stylesheet (esp. to remove | |
37 | ;; margin-top on dd > p) | |
38 | ||
39 | (define-module (texinfo html) | |
40 | :use-module (texinfo) | |
41 | :use-module (sxml transform) | |
42 | :use-module (srfi srfi-13) | |
43 | :export (stexi->shtml add-ref-resolver! urlify)) | |
44 | ||
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))) | |
52 | ||
53 | (define (urlify str) | |
54 | (string-downcase | |
55 | (string-map | |
56 | (lambda (c) | |
57 | (case c | |
58 | ((#\space #\/ #\:) #\-) | |
59 | (else c))) | |
60 | str))) | |
61 | ||
62 | (define ref-resolvers | |
63 | (list | |
64 | (lambda (node-name manual-name) ;; the default | |
65 | (urlify (string-append (or manual-name "") "#" node-name))))) | |
66 | ||
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. | |
72 | ||
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))) | |
76 | ||
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))) | |
80 | ||
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)))) | |
88 | ||
89 | (define (uref tag args) | |
90 | (let ((url (car (arg-req 'url args)))) | |
91 | `(a (@ (href ,url)) ,(or (car* (arg-ref 'title args)) url)))) | |
92 | ||
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))))) "")) | |
97 | ||
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)) | |
106 | (else (lp (cdr in) | |
107 | (cons (car in) | |
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))))))) | |
116 | ||
117 | (let* ((category (case tag | |
118 | ((defun) "Function") | |
119 | ((defspec) "Special Form") | |
120 | ((defvar) "Variable") | |
121 | (else (car (arg-req 'category args)))))) | |
122 | `(div | |
123 | (table | |
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)))) | |
128 | ||
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))))) | |
138 | (cdr elts)) | |
139 | elts))) | |
140 | ||
141 | (define (table tag args . body) | |
142 | (let ((formatter (caar (arg-req 'formatter args)))) | |
143 | (cons 'dl | |
144 | (map (lambda (x) | |
145 | (cond ((and (pair? x) (eq? (car x) 'dt)) | |
146 | (list (car x) (cons formatter (cdr x)))) | |
147 | (else x))) | |
148 | (apply append body))))) | |
149 | ||
150 | (define (entry tag args . body) | |
38c50a99 AW |
151 | (let lp ((out `((dt ,@(arg-req 'heading args)))) |
152 | (body body)) | |
c32f0d6b | 153 | (if (and (pair? body) (pair? (car body)) (eq? (caar body) 'itemx)) |
38c50a99 | 154 | (lp (append out `(dt ,@(map stexi->shtml (cdar body)))) |
c32f0d6b | 155 | (cdr body)) |
38c50a99 | 156 | (append out `((dd ,@(map stexi->shtml body))))))) |
47f3ce52 AW |
157 | |
158 | (define tag-replacements | |
159 | '((titlepage div (@ (class "titlepage"))) | |
160 | (title h2 (@ (class "title"))) | |
161 | (subtitle h3 (@ (class "subtitle"))) | |
162 | (author h3 (@ (class "author"))) | |
163 | (example pre) | |
164 | (lisp pre) | |
165 | (smallexample pre (@ (class "smaller"))) | |
166 | (smalllisp pre (@ (class "smaller"))) | |
167 | (cartouche div (@ (class "cartouche"))) | |
168 | (verbatim pre (@ (class "verbatim"))) | |
169 | (chapter h2) | |
170 | (section h3) | |
171 | (subsection h4) | |
172 | (subsubsection h5) | |
173 | (appendix h2) | |
174 | (appendixsec h3) | |
175 | (appendixsubsec h4) | |
176 | (appendixsubsubsec h5) | |
177 | (unnumbered h2) | |
178 | (unnumberedsec h3) | |
179 | (unnumberedsubsec h4) | |
180 | (unnumberedsubsubsec h5) | |
181 | (majorheading h2) | |
182 | (chapheading h2) | |
183 | (heading h3) | |
184 | (subheading h4) | |
185 | (subsubheading h5) | |
186 | (quotation blockquote) | |
187 | (itemize ul) | |
188 | (item li) ;; itemx ? | |
189 | (para p) | |
190 | (*fragment* div) ;; should be ok | |
191 | ||
192 | (asis span) | |
193 | (bold b) | |
194 | (sample samp) | |
195 | (samp samp) | |
196 | (code code) | |
197 | (kbd kbd) | |
198 | (key code (@ (class "key"))) | |
199 | (var var) | |
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"))) | |
205 | (dfn dfn) | |
206 | (cite cite) | |
207 | (acro acronym) | |
208 | (email code (@ (class "email"))) | |
209 | (emph em) | |
210 | (strong strong) | |
211 | (sc span (@ (class "small-caps"))))) | |
212 | ||
213 | (define ignore-list | |
214 | '(page setfilename setchapternewpage iftex ifinfo ifplaintext ifxml sp vskip | |
215 | menu ignore syncodeindex comment c dircategory direntry top shortcontents | |
216 | cindex printindex)) | |
47f3ce52 AW |
217 | |
218 | (define rules | |
219 | `((% *preorder* . ,(lambda args args)) ;; Keep these around... | |
220 | (texinfo . ,(lambda (tag args . body) | |
221 | (pre-post-order | |
222 | `(html | |
223 | (@ (xmlns "http://www.w3.org/1999/xhtml")) | |
224 | (head (title ,(car (arg-req 'title args)))) | |
225 | (body ,@body)) | |
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) | |
233 | (uref . ,uref) | |
234 | (node . ,node) (anchor . ,node) | |
235 | (table . ,table) | |
236 | (enumerate . ,enumerate) | |
c32f0d6b | 237 | (entry *preorder* . ,entry) |
47f3ce52 AW |
238 | |
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) | |
244 | (deftypefun . ,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))) | |
249 | (cond | |
250 | (subst (append (cdr subst) body)) | |
251 | ((memq tag ignore-list) #f) | |
252 | (else | |
253 | (warn "Don't know how to convert" tag "to HTML") | |
254 | body))))))) | |
255 | ||
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)) | |
260 | ||
261 | ;;; arch-tag: ab05f3fe-9981-4a78-b64c-48efcd9983a6 |