Commit | Line | Data |
---|---|---|
f14c9685 AW |
1 | ;;; figl |
2 | ;;; Copyright (C) 2013 Andy Wingo <wingo@pobox.com> | |
3 | ;;; | |
4 | ;;; Figl is free software: you can redistribute it and/or modify it | |
5 | ;;; under the terms of the GNU Lesser General Public License as | |
6 | ;;; published by the Free Software Foundation, either version 3 of the | |
7 | ;;; License, or (at your option) any later version. | |
8 | ;;; | |
9 | ;;; Figl is distributed in the hope that it will be useful, but WITHOUT | |
10 | ;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY | |
11 | ;;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General | |
12 | ;;; Public License for more details. | |
13 | ;;; | |
14 | ;;; You should have received a copy of the GNU Lesser General Public | |
15 | ;;; License along with this program. If not, see | |
16 | ;;; <http://www.gnu.org/licenses/>. | |
17 | ||
18 | ;;; Commentary: | |
19 | ;; | |
20 | ;; figl is the Foreign Interface to GL. | |
21 | ;; | |
22 | ;;; Code: | |
23 | ||
24 | (define-module (figl parse) | |
25 | #:use-module (figl config) | |
26 | #:use-module (sxml simple) | |
f9ad5a88 AW |
27 | #:use-module ((sxml xpath) #:hide (filter)) |
28 | #:use-module (sxml transform) | |
8925f36f | 29 | #:use-module (sxml fold) |
bb894c9d | 30 | #:use-module ((srfi srfi-1) #:select (filter fold append-map filter-map)) |
8925f36f | 31 | #:use-module (srfi srfi-9) |
f9ad5a88 | 32 | #:use-module (texinfo docbook) |
f14c9685 | 33 | #:use-module (ice-9 ftw) |
227eae66 | 34 | #:use-module (ice-9 match) |
8925f36f AW |
35 | #:export (gl-definition? |
36 | make-gl-definition | |
37 | gl-definition-name | |
bb894c9d | 38 | gl-definition-prototypes |
8925f36f AW |
39 | gl-definition-documentation |
40 | gl-definition-copyright | |
41 | parse-gl-definitions)) | |
42 | ||
43 | (define-record-type gl-definition | |
bb894c9d | 44 | (make-gl-definition name prototypes documentation copyright) |
8925f36f AW |
45 | gl-definition? |
46 | (name gl-definition-name) | |
bb894c9d | 47 | (prototypes gl-definition-prototypes) |
8925f36f AW |
48 | (documentation gl-definition-documentation) |
49 | (copyright gl-definition-copyright)) | |
f14c9685 AW |
50 | |
51 | (define *namespaces* | |
52 | '((mml . "http://www.w3.org/1998/Math/MathML"))) | |
53 | ||
54 | (define *entities* | |
f9ad5a88 AW |
55 | '(;; From http://www.w3.org/TR/MathML2/mmlextra.html |
56 | (af . "\u2061") ;; Function application. | |
57 | (it . "\u2062") ;; Invisible times. | |
58 | ;; http://www.w3.org/TR/MathML2/isonum.html | |
59 | (plus . "\u002B") ;; Plus sign. | |
60 | (times . "\u00D7") ;; Multiplication sign. | |
61 | ;; http://www.w3.org/TR/MathML2/isotech.html | |
62 | (Prime . "\u2033") ;; Double prime. | |
63 | (le . "\u2264") ;; Less than or equal to. | |
64 | (ne . "\u2260") ;; Not equal to. | |
65 | (minus . "\u2212") ;; Minus sign. | |
66 | ;; http://www.w3.org/TR/MathML2/isoamsc.html | |
67 | (lceil . "\u2308") ;; Left ceiling. | |
68 | (rceil . "\u2309") ;; Right ceiling. | |
69 | (lfloor . "\u230A") ;; Left floor. | |
70 | (rfloor . "\u230B") ;; Right floor. | |
71 | ;; http://www.w3.org/TR/MathML2/mmlalias.html | |
72 | (DoubleVerticalBar . "\u2225") ;; Parallel to. | |
73 | (LeftFloor . "\u230A") ;; Left floor. | |
74 | (RightFloor . "\u230B") ;; Right floor. | |
75 | (LeftCeiling . "\u2308") ;; Left ceiling. | |
76 | (RightCeiling . "\u2309") ;; Right ceiling. | |
77 | (CenterDot . "\u00B7") ;; Middle dot. | |
78 | (VerticalBar . "\u2223") ;; Divides. | |
79 | (PartialD . "\u2202") ;; Partial derivative. | |
80 | ;; http://www.w3.org/TR/MathML2/mmlextra.html | |
81 | (Hat . "\u005E") ;; Circumflex accent. | |
82 | ;; http://www.w3.org/TR/MathML2/isogrk3.html | |
83 | (Delta . "\u0394") ;; Greek capital letter delta. | |
84 | (Sigma . "\u03A3") ;; Greek capital letter sigma. | |
85 | ;; Misc. | |
86 | (nbsp . "\u00A0") | |
87 | )) | |
f14c9685 AW |
88 | |
89 | (define (default-entity-handler port name) | |
90 | (format (current-warning-port) | |
91 | "~a:~a:~a: undefined entitity: &~a;\n" | |
92 | (or (port-filename port) "<unknown file>") | |
93 | (port-line port) (port-column port) | |
94 | name) | |
95 | (symbol->string name)) | |
96 | ||
f9ad5a88 AW |
97 | (define dbmathml |
98 | "http://www.oasis-open.org/docbook/xml/mathml/1.1CR1/dbmathml.dtd") | |
99 | ||
100 | (define (docbook-with-mathml-handler docname systemid internal) | |
101 | (unless (equal? systemid dbmathml) | |
102 | (warn "unexpected doctype" docname systemid internal)) | |
103 | (values #:entities *entities* #:namespaces *namespaces*)) | |
104 | ||
105 | (define (trim-whitespace-left str) | |
106 | (let ((first (and (not (string-null? str)) | |
107 | (string-ref str 0)))) | |
108 | (if (and first (char-whitespace? first)) | |
109 | (string-append (string first) (string-trim str char-whitespace?)) | |
110 | str))) | |
111 | ||
112 | (define (trim-whitespace-right str) | |
113 | (let ((last (and (not (string-null? str)) | |
114 | (string-ref str (1- (string-length str)))))) | |
115 | (if (and last (char-whitespace? last)) | |
116 | (string-append (string-trim-right str char-whitespace?) (string last)) | |
117 | str))) | |
118 | ||
119 | (define (trim-whitespace str) | |
120 | (trim-whitespace-left | |
121 | (trim-whitespace-right str))) | |
122 | ||
123 | (define (zap-whitespace sxml) | |
124 | (define (not-whitespace x) | |
125 | (or (not (string? x)) | |
126 | (not (string-every char-whitespace? x)))) | |
127 | (pre-post-order sxml | |
128 | `((*default* . ,(lambda (tag . body) | |
129 | (cons tag | |
130 | (filter not-whitespace body)))) | |
131 | (*text* . ,(lambda (tag text) | |
132 | (if (string? text) | |
133 | (trim-whitespace text) | |
134 | text)))))) | |
135 | ||
53215235 AW |
136 | (define (parse-man-xml version filename) |
137 | (define subdir (format #f "man~A" version)) | |
f14c9685 | 138 | (call-with-input-file (in-vicinity (upstream-man-pages) |
53215235 | 139 | (in-vicinity subdir filename)) |
f14c9685 | 140 | (lambda (port) |
f9ad5a88 AW |
141 | (zap-whitespace |
142 | (xml->sxml port #:declare-namespaces? #t | |
143 | #:default-entity-handler default-entity-handler | |
144 | #:doctype-handler docbook-with-mathml-handler))))) | |
f14c9685 | 145 | |
53215235 AW |
146 | (define (xml-files version) |
147 | (define subdir (format #f "man~A" version)) | |
148 | (scandir (in-vicinity (upstream-man-pages) subdir) | |
f14c9685 AW |
149 | (lambda (x) (string-suffix? ".xml" x)))) |
150 | ||
f9ad5a88 AW |
151 | (define (take-first proc) |
152 | (lambda (xml) | |
153 | (let ((res (proc xml))) | |
154 | (and (pair? res) (car res))))) | |
155 | ||
156 | (define xml-name | |
157 | (take-first (sxpath '(refentry refnamediv refname *text*)))) | |
158 | ||
159 | (define xml-purpose | |
160 | (take-first (sxpath '(refentry refnamediv refpurpose *text*)))) | |
161 | ||
bb894c9d AW |
162 | (define xml-funcprototypes |
163 | (sxpath '(refentry refsynopsisdiv funcsynopsis funcprototype))) | |
f9ad5a88 AW |
164 | |
165 | (define xml-parameters | |
166 | (take-first (sxpath '(refentry (refsect1 (@ id (equal? "parameters"))))))) | |
167 | ||
168 | (define xml-description | |
169 | (take-first (sxpath '(refentry (refsect1 (@ id (equal? "description"))))))) | |
170 | ||
171 | (define xml-errors | |
172 | (take-first (sxpath '(refentry (refsect1 (@ id (equal? "errors"))))))) | |
173 | ||
8925f36f AW |
174 | (define xml-copyright |
175 | (take-first (sxpath '(refentry (refsect1 (@ id (equal? "Copyright"))))))) | |
176 | ||
0e9b22c2 | 177 | (define (string->gl-type str) |
bb894c9d AW |
178 | (let ((str (string-trim-both str))) |
179 | (cond | |
180 | ((string=? (string-take-right str 1) "*") '*) | |
181 | ((string-prefix? "const " str) | |
182 | (string->gl-type (string-drop str (string-length "const ")))) | |
183 | (else | |
184 | (string->symbol str))))) | |
185 | ||
186 | (define (parse-prototypes sxml) | |
187 | (define all-names | |
188 | (match sxml | |
189 | ((('funcprototype ('funcdef return-type ('function names)) | |
190 | . _) | |
191 | ...) | |
192 | names))) | |
193 | ||
194 | (define (skip? s) | |
195 | (or | |
ca09631c AW |
196 | ;; Skip double variants if we have a float variant. |
197 | ;; (http://www.opengl.org/wiki/Common_Mistakes#GL_DOUBLE). | |
198 | (and (string-suffix? "d" s) | |
199 | (member (string-append (substring s 0 (1- (string-length s))) "f") | |
bb894c9d AW |
200 | all-names)) |
201 | ;; Skip packed accessors like glVertex3fv. | |
202 | (string-suffix? "v" s) | |
203 | ;; Skip byte variants if there is a short variant. | |
204 | (and (string-suffix? "b" s) | |
205 | (member (string-append (substring s 0 (1- (string-length s))) "s") | |
206 | all-names)) | |
207 | ;; Skip short variants if there is an int variant. | |
208 | (and (or (string-suffix? "s" s) | |
209 | (string-suffix? "s" s) | |
210 | (string-suffix? "s" s) | |
211 | (string-suffix? "s" s)) | |
212 | (member (string-append (substring s 0 (1- (string-length s))) "i") | |
213 | all-names)))) | |
214 | ||
215 | (filter-map | |
216 | (lambda (sxml) | |
217 | (match sxml | |
218 | (('funcprototype ('funcdef return-type ('function (? skip?))) | |
219 | . _) | |
220 | #f) | |
221 | (('funcprototype ('funcdef return-type ('function name)) | |
222 | ('paramdef ('parameter "void"))) | |
223 | `(,(string->symbol name) | |
224 | -> ,(string->gl-type return-type))) | |
225 | (('funcprototype ('funcdef return-type ('function name)) | |
226 | ('paramdef ptype ('parameter pname)) | |
227 | ...) | |
228 | `(,(string->symbol name) | |
229 | ,@(map (lambda (pname ptype) | |
230 | (list (string->symbol pname) | |
231 | (string->gl-type ptype))) | |
232 | pname ptype) | |
233 | -> ,(string->gl-type return-type))))) | |
234 | sxml)) | |
f9ad5a88 | 235 | |
227eae66 AW |
236 | (define (collapse-fragments nodeset) |
237 | (match nodeset | |
238 | ((('*fragment* elts ...) nodes ...) | |
239 | (append (collapse-fragments elts) | |
240 | (collapse-fragments nodes))) | |
241 | ((((and tag (? symbol?)) elts ...) nodes ...) | |
242 | (acons tag (collapse-fragments elts) (collapse-fragments nodes))) | |
243 | ((elt nodes ...) | |
244 | (cons elt (collapse-fragments nodes))) | |
245 | (() '()))) | |
246 | ||
247 | (define (list-intersperse src-l elem) | |
248 | (if (null? src-l) src-l | |
249 | (let loop ((l (cdr src-l)) (dest (cons (car src-l) '()))) | |
250 | (if (null? l) (reverse dest) | |
251 | (loop (cdr l) (cons (car l) (cons elem dest))))))) | |
252 | ||
8925f36f AW |
253 | (define (lift-tables sdocbook) |
254 | ;; Like sdocbook-flatten, but tweaked to lift tables from inside | |
255 | ;; paras, but not paras from inside tables. Pretty hacky stuff. | |
256 | (define *sdocbook-block-commands* | |
257 | '(informaltable programlisting variablelist)) | |
258 | ||
259 | (define (inline-command? command) | |
260 | (not (memq command *sdocbook-block-commands*))) | |
261 | ||
262 | (define (fhere str accum block cont) | |
263 | (values (cons str accum) | |
264 | block | |
265 | cont)) | |
266 | (define (fdown node accum block cont) | |
267 | (match node | |
268 | ((command (and attrs ('% . _)) body ...) | |
269 | (values body '() '() | |
270 | (lambda (accum block) | |
271 | (values | |
272 | `(,command ,attrs ,@(reverse accum)) | |
273 | block)))) | |
274 | ((command body ...) | |
275 | (values body '() '() | |
276 | (lambda (accum block) | |
277 | (values | |
278 | `(,command ,@(reverse accum)) | |
279 | block)))))) | |
280 | (define (fup node paccum pblock pcont kaccum kblock kcont) | |
281 | (call-with-values (lambda () (kcont kaccum kblock)) | |
282 | (lambda (ret block) | |
283 | (if (inline-command? (car ret)) | |
284 | (values (cons ret paccum) (append kblock pblock) pcont) | |
285 | (values paccum (append kblock (cons ret pblock)) pcont))))) | |
286 | (call-with-values | |
287 | (lambda () (foldts*-values fdown fup fhere sdocbook '() '() #f)) | |
288 | (lambda (accum block cont) | |
289 | (append (reverse accum) | |
290 | (reverse block) | |
291 | )))) | |
292 | ||
f9ad5a88 AW |
293 | (define *rules* |
294 | `((refsect1 | |
8925f36f | 295 | *preorder* |
f9ad5a88 | 296 | . ,(lambda (tag id . body) |
8925f36f AW |
297 | (append-map (lambda (nodeset) |
298 | (map | |
299 | (lambda (x) | |
300 | (pre-post-order x *rules*)) | |
301 | nodeset)) | |
3c9b6116 AW |
302 | (map lift-tables |
303 | (match body | |
304 | ((('title _) body ...) body) | |
305 | (_ body)))))) | |
f9ad5a88 AW |
306 | (variablelist |
307 | ((varlistentry | |
308 | . ,(lambda (tag term . body) | |
227eae66 | 309 | `(entry (% (heading ,@(cdar term))) ,@(apply append body)))) |
f9ad5a88 | 310 | (listitem |
227eae66 AW |
311 | . ,(lambda (tag . body) |
312 | (map (lambda (x) | |
313 | (if (string? x) | |
314 | `(para ,x) | |
315 | x)) | |
316 | body))) | |
317 | (term | |
f9ad5a88 | 318 | . ,(lambda (tag . rest) |
227eae66 | 319 | `((itemx ,@rest))))) |
f9ad5a88 | 320 | . ,(lambda (tag . body) |
227eae66 | 321 | `(table (% (formatter (asis))) ,@body))) |
8925f36f AW |
322 | (trademark |
323 | . ,(match-lambda* | |
324 | ((_ ('@ ('class "copyright"))) '(copyright)))) | |
f9ad5a88 AW |
325 | (parameter |
326 | . ,(lambda (tag body) | |
327 | `(var ,body))) | |
328 | (type | |
329 | . ,(lambda (tag body) | |
330 | `(code ,body))) | |
331 | (constant | |
332 | . ,(lambda (tag . body) | |
333 | `(code . ,body))) | |
227eae66 AW |
334 | (code |
335 | . ,(lambda (tag . body) | |
336 | `(code . ,body))) | |
f9ad5a88 AW |
337 | (function |
338 | . ,(lambda (tag body . ignored) | |
339 | (or (null? ignored) (warn "ignored function tail" ignored)) | |
340 | `(code ,body))) | |
341 | (emphasis | |
227eae66 AW |
342 | . ,(match-lambda* |
343 | ((_) "") | |
8925f36f AW |
344 | ((_ ('@ ('role "bold")) (and body (? string?))) |
345 | `(strong ,(string-trim-both body))) | |
227eae66 AW |
346 | ((_ ('@ ('role "bold")) . body) `(strong ,@body)) |
347 | ((_ body) `(var ,body)))) | |
348 | (citerefentry | |
349 | . ,(lambda (tag contents) | |
350 | contents)) | |
351 | (refentrytitle | |
352 | . ,(lambda (tag contents) | |
353 | `(code ,contents))) | |
354 | (inlineequation | |
355 | . ,(lambda (tag contents) | |
356 | contents)) | |
357 | (informalequation | |
358 | . ,(lambda (tag contents) | |
359 | contents)) | |
360 | (informaltable | |
361 | . ,(lambda (tag attrs tgroup) | |
362 | tgroup)) | |
363 | (tgroup | |
364 | ((thead | |
365 | . ,(lambda (tag . rows) | |
366 | rows)) | |
367 | (colspec | |
368 | . ,(lambda _ | |
369 | #f)) | |
370 | (tbody | |
371 | . ,(lambda (tag . rows) | |
372 | rows)) | |
373 | (row | |
374 | . ,(lambda (tag first . rest) | |
8925f36f AW |
375 | `(entry (% (heading ,@first)) |
376 | (para ,@(apply | |
377 | append | |
378 | (list-intersperse rest '(", "))))))) | |
227eae66 AW |
379 | (entry |
380 | . ,(match-lambda* | |
8925f36f AW |
381 | ((_) '()) |
382 | ((_ ('@ . _)) '()) | |
383 | ((_ ('@ . _) x ...) x) | |
384 | ((_ x ...) x)))) | |
227eae66 AW |
385 | . ,(lambda (tag attrs . contents) |
386 | `(table (% (formatter (asis))) | |
387 | ,@(apply append (filter identity contents))))) | |
388 | ||
389 | ;; Poor man's mathml. | |
390 | (mml:math | |
391 | . ,(lambda (tag . contents) | |
3c9b6116 | 392 | `(r . ,(collapse-fragments contents)))) |
227eae66 AW |
393 | (mml:mn |
394 | . ,(lambda (tag n . rest) | |
395 | (if (pair? rest) | |
396 | `(*fragment* ,n . ,rest) | |
397 | n))) | |
398 | (mml:mi | |
399 | . ,(case-lambda | |
400 | ((tag contents) | |
401 | `(code ,contents)) | |
402 | ((tag attrs contents) | |
403 | (match attrs | |
404 | (('@ (mathvariant "italic")) | |
405 | `(var ,contents)) | |
406 | (_ `(code ,contents)))))) | |
407 | ;; It would be possible to represent a matrix as a @multitable, but | |
408 | ;; Guile doesn't really have support for that. So instead print | |
409 | ;; each row in parentheses. | |
410 | (mml:mtable | |
411 | ((mml:mtr | |
412 | . ,(lambda (tag . body) | |
413 | `("(" ,@(list-intersperse body " ") ")"))) | |
414 | (mml:mtd | |
415 | . ,(match-lambda* | |
416 | ((tag ('@ . _) body ...) | |
417 | `(*fragment* ,@body)) | |
418 | ((tag body ...) | |
419 | `(*fragment* ,@body))))) | |
420 | . ,(lambda (tag . rows) | |
421 | ;; Rely on outer mfence for outer parens, if any | |
422 | (let ((rows (if (and (pair? rows) (eq? (caar rows) '@)) | |
423 | (cdr rows) | |
424 | rows))) | |
425 | `(*fragment* ,@(apply append (list-intersperse rows '(", "))))))) | |
426 | (mml:mspace | |
427 | . ,(lambda (tag . _) | |
428 | " ")) | |
429 | (mml:msup | |
430 | . ,(lambda (tag base exponent) | |
431 | `(*fragment* ,base "^" ,exponent))) | |
432 | (mml:msub | |
433 | . ,(lambda (tag base exponent) | |
434 | `(*fragment* ,base "_" ,exponent))) | |
435 | (mml:mover | |
436 | . ,(lambda (tag base over) | |
437 | `(*fragment* ,base ,over))) | |
438 | (mml:munderover | |
439 | . ,(lambda (tag under base over) | |
440 | `(*fragment* ,under ,base ,over))) | |
441 | (mml:mfrac | |
442 | . ,(lambda (tag num denom) | |
443 | `(*fragment* ,num "/" ,denom))) | |
444 | (mml:msqrt | |
445 | . ,(lambda (tag base) | |
446 | `(*fragment* "√" ,base))) | |
447 | (mml:infinity | |
448 | . ,(lambda (tag) | |
449 | "∞")) | |
450 | (mml:mo | |
451 | . ,(lambda (tag operator) | |
452 | operator)) | |
453 | (mml:mrow | |
454 | . ,(lambda (tag . contents) | |
455 | `(*fragment* . ,contents))) | |
456 | (mml:mfenced | |
457 | . ,(lambda (tag attrs left . right) | |
458 | `(*fragment* ,@(assq-ref attrs 'open) | |
459 | ,left | |
460 | "," | |
461 | ,@right | |
462 | ,@(assq-ref attrs 'close)))) | |
f9ad5a88 AW |
463 | (*text* |
464 | . ,(lambda (tag text) | |
465 | text)) | |
466 | ,@*sdocbook->stexi-rules*)) | |
467 | ||
468 | (define (sdocbook->stexi sdocbook) | |
469 | (pre-post-order sdocbook *rules*)) | |
470 | ||
471 | ;; Produces an stexinfo fragment. | |
472 | (define (generate-documentation purpose parameters description errors) | |
8925f36f | 473 | `(*fragment* |
3c9b6116 AW |
474 | (para ,(string-append (string (char-upcase (string-ref purpose 0))) |
475 | (substring purpose 1) | |
476 | ".")) | |
8925f36f AW |
477 | ,@(if parameters (sdocbook->stexi parameters) '()) |
478 | ,@(if description (sdocbook->stexi description) '()) | |
479 | ,@(if errors (sdocbook->stexi errors) '()))) | |
f9ad5a88 AW |
480 | |
481 | (define (xml->definition xml) | |
bb894c9d AW |
482 | (let ((prototypes (parse-prototypes (xml-funcprototypes xml)))) |
483 | (and (pair? prototypes) | |
484 | (make-gl-definition (xml-name xml) | |
485 | prototypes | |
486 | (generate-documentation (xml-purpose xml) | |
487 | (xml-parameters xml) | |
488 | (xml-description xml) | |
489 | (xml-errors xml)) | |
490 | (and=> (xml-copyright xml) | |
491 | (lambda (c) | |
492 | `(*fragment* ,@(sdocbook->stexi c)))))))) | |
8925f36f AW |
493 | |
494 | (define (parse-gl-definitions version) | |
bb894c9d AW |
495 | (filter-map (lambda (file) |
496 | (xml->definition (parse-man-xml version file))) | |
497 | (xml-files version))) |