Commit | Line | Data |
---|---|---|
47f3ce52 AW |
1 | ;;;; (texinfo serialize) -- rendering stexinfo as texinfo |
2 | ;;;; | |
3 | ;;;; Copyright (C) 2009 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 | \f | |
21 | ;;; Commentary: | |
22 | ;; | |
23 | ;;Serialization of @code{stexi} to plain texinfo. | |
24 | ;; | |
25 | ;;; Code: | |
26 | ||
27 | (define-module (texinfo serialize) | |
28 | #:use-module (texinfo) | |
29 | #:use-module (texinfo string-utils) | |
30 | #:use-module (sxml transform) | |
31 | #:use-module (srfi srfi-1) | |
32 | #:use-module (srfi srfi-13) | |
33 | #:export (stexi->texi)) | |
34 | ||
35 | (define (list-intersperse src-l elem) | |
36 | (if (null? src-l) src-l | |
37 | (let loop ((l (cdr src-l)) (dest (cons (car src-l) '()))) | |
38 | (if (null? l) (reverse dest) | |
39 | (loop (cdr l) (cons (car l) (cons elem dest))))))) | |
40 | ||
41 | ;; converts improper lists to proper lists. | |
42 | (define (filter* pred l) | |
43 | (let lp ((in l) (out '())) | |
44 | (cond ((null? in) | |
45 | (reverse! out)) | |
46 | ((pair? in) | |
47 | (lp (cdr in) (if (pred (car in)) (cons (car in) out) out))) | |
48 | (else | |
49 | (lp '() (if (pred in) (cons in out) out)))))) | |
50 | ||
51 | ;; (list* 'a '(b c) 'd '(e f g)) => '(a b c d e f g) | |
52 | (define (list* . args) | |
53 | (let* ((args (reverse args)) | |
54 | (tail (car args))) | |
55 | (let lp ((in (cdr args)) (out tail)) | |
56 | (cond ((null? in) out) | |
57 | ((pair? (car in)) (lp (cdr in) (append (car in) out))) | |
58 | ((null? (car in)) (lp (cdr in) out)) | |
59 | (else (lp (cdr in) (cons (car in) out))))))) | |
60 | ||
61 | ;; Why? Well, because syntax-case defines `include', and carps about its | |
62 | ;; wrong usage below... | |
63 | (eval-when (eval load compile) | |
64 | (define (include exp lp command type formals args accum) | |
65 | (list* "\n" | |
66 | (list-intersperse | |
67 | args | |
68 | " ") | |
69 | " " command "@" accum))) | |
70 | ||
71 | (define (empty-command exp lp command type formals args accum) | |
72 | (list* " " command "@" accum)) | |
73 | ||
74 | (define (inline-text exp lp command type formals args accum) | |
75 | (if (not (string=? command "*braces*")) ;; fixme :( | |
76 | (list* "}" | |
77 | (append-map (lambda (x) (lp x '())) (reverse (cdr exp))) | |
78 | "{" command "@" accum) | |
79 | (list* "@}" | |
80 | (append-map (lambda (x) (lp x '())) (reverse (cdr exp))) | |
81 | "@{" accum))) | |
82 | ||
83 | (define (inline-args exp lp command type formals args accum) | |
84 | (list* "}" | |
85 | (if (not args) "" | |
86 | (list-intersperse | |
87 | (map | |
88 | (lambda (x) | |
89 | (cond ((not x) "") | |
90 | ((pair? x) | |
91 | (if (pair? (cdr x)) | |
92 | (warn "Strange inline-args!" args)) | |
93 | (car x)) | |
94 | (else (error "Invalid inline-args" args)))) | |
95 | (drop-while not | |
96 | (map (lambda (x) (assq-ref args x)) | |
97 | (reverse formals)))) | |
98 | ",")) | |
99 | "{" command "@" accum)) | |
100 | ||
101 | (define (serialize-text-args lp formals args) | |
102 | (apply | |
103 | append | |
104 | (list-intersperse | |
105 | (map (lambda (arg) (append-map (lambda (x) (lp x '())) arg)) | |
106 | (map | |
107 | reverse | |
108 | (drop-while | |
109 | not (map (lambda (x) (assq-ref args x)) | |
110 | (reverse formals))))) | |
111 | '(" ")))) | |
112 | ||
113 | (define (eol-text-args exp lp command type formals args accum) | |
114 | (list* "\n" | |
115 | (serialize-text-args lp formals args) | |
116 | " " command "@" accum)) | |
117 | ||
118 | (define (eol-text exp lp command type formals args accum) | |
119 | (list* "\n" | |
120 | (append-map (lambda (x) (lp x '())) | |
121 | (reverse (if args (cddr exp) (cdr exp)))) | |
122 | " " command "@" accum)) | |
123 | ||
124 | (define (eol-args exp lp command type formals args accum) | |
125 | (list* "\n" | |
126 | (list-intersperse | |
127 | (apply append | |
128 | (drop-while not | |
129 | (map (lambda (x) (assq-ref args x)) | |
130 | (reverse formals)))) | |
131 | ", ") | |
132 | " " command "@" accum)) | |
133 | ||
134 | (define (environ exp lp command type formals args accum) | |
135 | (case (car exp) | |
136 | ((texinfo) | |
137 | (list* "@bye\n" | |
138 | (append-map (lambda (x) (lp x '())) (reverse (cddr exp))) | |
139 | "\n@c %**end of header\n\n" | |
140 | (reverse (assq-ref args 'title)) "@settitle " | |
141 | (or (and=> (assq-ref args 'filename) | |
142 | (lambda (filename) | |
143 | (cons "\n" (reverse (cons "@setfilename " filename))))) | |
144 | "") | |
145 | "\\input texinfo @c -*-texinfo-*-\n@c %**start of header\n" | |
146 | accum)) | |
147 | (else | |
148 | (list* "\n\n" command "@end " | |
149 | (let ((body (append-map (lambda (x) (lp x '())) | |
150 | (reverse (if args (cddr exp) (cdr exp)))))) | |
151 | (if (or (null? body) | |
152 | (eqv? (string-ref (car body) | |
153 | (1- (string-length (car body)))) | |
154 | #\newline)) | |
155 | body | |
156 | (cons "\n" body))) | |
157 | "\n" | |
158 | (serialize-text-args lp formals args) | |
159 | " " command "@" accum)))) | |
160 | ||
161 | (define (table-environ exp lp command type formals args accum) | |
162 | (list* "\n\n" command "@end " | |
163 | (append-map (lambda (x) (lp x '())) | |
164 | (reverse (if args (cddr exp) (cdr exp)))) | |
165 | "\n" | |
166 | (let* ((arg (if args (cadar args) ""))) ;; zero or one args | |
167 | (if (pair? arg) | |
168 | (list (symbol->string (car arg)) "@") | |
169 | arg)) | |
170 | " " command "@" accum)) | |
171 | ||
172 | (define (wrap strings) | |
173 | (fill-string (string-concatenate strings) | |
174 | #:line-width 72)) | |
175 | ||
176 | (define (paragraph exp lp command type formals args accum) | |
177 | (list* "\n\n" | |
178 | (wrap | |
179 | (reverse | |
180 | (append-map (lambda (x) (lp x '())) (reverse (cdr exp))))) | |
181 | accum)) | |
182 | ||
183 | (define (item exp lp command type formals args accum) | |
184 | (list* (append-map (lambda (x) (lp x '())) (reverse (cdr exp))) | |
185 | "@item\n" | |
186 | accum)) | |
187 | ||
188 | (define (entry exp lp command type formals args accum) | |
189 | (list* (append-map (lambda (x) (lp x '())) (reverse (cddr exp))) | |
190 | "\n" | |
191 | (append-map (lambda (x) (lp x '())) (reverse (cdar args))) | |
192 | "@item " | |
193 | accum)) | |
194 | ||
195 | (define (fragment exp lp command type formals args accum) | |
196 | (list* "\n@c %end of fragment\n" | |
197 | (append-map (lambda (x) (lp x '())) (reverse (cdr exp))) | |
198 | "\n@c %start of fragment\n\n" | |
199 | accum)) | |
200 | ||
201 | (define serializers | |
202 | `((EMPTY-COMMAND . ,empty-command) | |
203 | (INLINE-TEXT . ,inline-text) | |
204 | (INLINE-ARGS . ,inline-args) | |
205 | (EOL-TEXT . ,eol-text) | |
206 | (EOL-TEXT-ARGS . ,eol-text-args) | |
207 | (INDEX . ,eol-text-args) | |
208 | (EOL-ARGS . ,eol-args) | |
209 | (ENVIRON . ,environ) | |
210 | (TABLE-ENVIRON . ,table-environ) | |
211 | (ENTRY . ,entry) | |
212 | (ITEM . ,item) | |
213 | (PARAGRAPH . ,paragraph) | |
214 | (FRAGMENT . ,fragment) | |
215 | (#f . ,include))) ; support writing include statements | |
216 | ||
217 | (define (serialize exp lp command type formals args accum) | |
218 | ((or (assq-ref serializers type) | |
219 | (error "Unknown command type" exp type)) | |
220 | exp lp command type formals args accum)) | |
221 | ||
222 | (define escaped-chars '(#\} #\{ #\@)) | |
223 | (define (escape str) | |
224 | "Escapes any illegal texinfo characters (currently @{, @}, and @@)." | |
225 | (let loop ((in (string->list str)) (out '())) | |
226 | (if (null? in) | |
227 | (apply string (reverse out)) | |
228 | (if (memq (car in) escaped-chars) | |
229 | (loop (cdr in) (cons* (car in) #\@ out)) | |
230 | (loop (cdr in) (cons (car in) out)))))) | |
231 | ||
232 | (define (stexi->texi tree) | |
233 | "Serialize the stexi @var{tree} into plain texinfo." | |
234 | (string-concatenate-reverse | |
235 | (let lp ((in tree) (out '())) | |
236 | (cond | |
237 | ((or (not in) (null? in)) out) | |
238 | ((string? in) (cons (escape in) out)) | |
239 | ((pair? in) | |
240 | (let ((command-spec (assq (car in) texi-command-specs))) | |
241 | (if (not command-spec) | |
242 | (begin | |
243 | (warn "Unknown stexi command, not rendering" in) | |
244 | out) | |
245 | (serialize in | |
246 | lp | |
247 | (symbol->string (car in)) | |
248 | (cadr command-spec) | |
249 | (filter* symbol? (cddr command-spec)) | |
250 | (cond | |
251 | ((and (pair? (cdr in)) (pair? (cadr in)) | |
252 | (eq? (caadr in) '%)) | |
253 | (cdadr in)) | |
254 | ((not (cadr command-spec)) | |
255 | ;; include | |
256 | (cdr in)) | |
257 | (else | |
258 | #f)) | |
259 | out)))) | |
260 | (else | |
261 | (error "Invalid stexi" in)))))) | |
262 | ||
263 | ;;; arch-tag: d3fa16ea-0bf7-4ec5-ab9f-3f08490f77f5 |