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) | |
d3fe20d1 | 26 | #:use-module (figl contrib) |
f14c9685 | 27 | #:use-module (sxml simple) |
f9ad5a88 AW |
28 | #:use-module ((sxml xpath) #:hide (filter)) |
29 | #:use-module (sxml transform) | |
8925f36f | 30 | #:use-module (sxml fold) |
bb894c9d | 31 | #:use-module ((srfi srfi-1) #:select (filter fold append-map filter-map)) |
d3fe20d1 DH |
32 | #:use-module (srfi srfi-9) ; define-record-type |
33 | #:use-module (srfi srfi-42) ; eager comprehensions | |
f9ad5a88 | 34 | #:use-module (texinfo docbook) |
f14c9685 | 35 | #:use-module (ice-9 ftw) |
092cacd7 | 36 | #:use-module (ice-9 rdelim) |
227eae66 | 37 | #:use-module (ice-9 match) |
d3fe20d1 | 38 | #:use-module (ice-9 regex) |
8925f36f AW |
39 | #:export (gl-definition? |
40 | make-gl-definition | |
41 | gl-definition-name | |
bb894c9d | 42 | gl-definition-prototypes |
8925f36f AW |
43 | gl-definition-documentation |
44 | gl-definition-copyright | |
092cacd7 AW |
45 | parse-gl-definitions |
46 | ||
47 | gl-enumeration? | |
48 | make-gl-enumeration | |
49 | gl-enumeration-category | |
50 | gl-enumeration-values | |
d3fe20d1 DH |
51 | parse-gl-enumerations |
52 | ||
53 | gl-param-type? | |
54 | make-gl-param-type | |
55 | gl-param-type-type | |
56 | gl-param-type-direction | |
57 | gl-param-type-transfer-type | |
58 | parse-gl-type-map)) | |
8925f36f AW |
59 | |
60 | (define-record-type gl-definition | |
bb894c9d | 61 | (make-gl-definition name prototypes documentation copyright) |
8925f36f AW |
62 | gl-definition? |
63 | (name gl-definition-name) | |
bb894c9d | 64 | (prototypes gl-definition-prototypes) |
8925f36f AW |
65 | (documentation gl-definition-documentation) |
66 | (copyright gl-definition-copyright)) | |
f14c9685 | 67 | |
092cacd7 AW |
68 | ;; values := (name . number) ... |
69 | (define-record-type gl-enumeration | |
70 | (make-gl-enumeration category values) | |
71 | gl-enumeration? | |
72 | (category gl-enumeration-category) | |
73 | (values gl-enumeration-values)) | |
74 | ||
d3fe20d1 DH |
75 | ;; Seed of gl-param and more. |
76 | ;; TODO: Is this not really gl-type? | |
77 | (define-record-type gl-param-type | |
78 | (%make-gl-param-type type direction transfer-type) | |
79 | gl-param-type? | |
80 | (type gl-param-type-type) | |
81 | (direction gl-param-type-direction) | |
82 | (transfer-type gl-param-type-transfer-type)) | |
83 | ||
84 | ;; Memoized for eq?, hash, memory usage. | |
85 | (define make-gl-param-type (memoize %make-gl-param-type)) | |
86 | ||
f14c9685 AW |
87 | (define *namespaces* |
88 | '((mml . "http://www.w3.org/1998/Math/MathML"))) | |
89 | ||
90 | (define *entities* | |
f9ad5a88 AW |
91 | '(;; From http://www.w3.org/TR/MathML2/mmlextra.html |
92 | (af . "\u2061") ;; Function application. | |
93 | (it . "\u2062") ;; Invisible times. | |
94 | ;; http://www.w3.org/TR/MathML2/isonum.html | |
95 | (plus . "\u002B") ;; Plus sign. | |
96 | (times . "\u00D7") ;; Multiplication sign. | |
97 | ;; http://www.w3.org/TR/MathML2/isotech.html | |
98 | (Prime . "\u2033") ;; Double prime. | |
99 | (le . "\u2264") ;; Less than or equal to. | |
100 | (ne . "\u2260") ;; Not equal to. | |
101 | (minus . "\u2212") ;; Minus sign. | |
102 | ;; http://www.w3.org/TR/MathML2/isoamsc.html | |
103 | (lceil . "\u2308") ;; Left ceiling. | |
104 | (rceil . "\u2309") ;; Right ceiling. | |
105 | (lfloor . "\u230A") ;; Left floor. | |
106 | (rfloor . "\u230B") ;; Right floor. | |
107 | ;; http://www.w3.org/TR/MathML2/mmlalias.html | |
108 | (DoubleVerticalBar . "\u2225") ;; Parallel to. | |
109 | (LeftFloor . "\u230A") ;; Left floor. | |
110 | (RightFloor . "\u230B") ;; Right floor. | |
111 | (LeftCeiling . "\u2308") ;; Left ceiling. | |
112 | (RightCeiling . "\u2309") ;; Right ceiling. | |
113 | (CenterDot . "\u00B7") ;; Middle dot. | |
114 | (VerticalBar . "\u2223") ;; Divides. | |
115 | (PartialD . "\u2202") ;; Partial derivative. | |
116 | ;; http://www.w3.org/TR/MathML2/mmlextra.html | |
117 | (Hat . "\u005E") ;; Circumflex accent. | |
118 | ;; http://www.w3.org/TR/MathML2/isogrk3.html | |
119 | (Delta . "\u0394") ;; Greek capital letter delta. | |
120 | (Sigma . "\u03A3") ;; Greek capital letter sigma. | |
121 | ;; Misc. | |
122 | (nbsp . "\u00A0") | |
123 | )) | |
f14c9685 AW |
124 | |
125 | (define (default-entity-handler port name) | |
126 | (format (current-warning-port) | |
127 | "~a:~a:~a: undefined entitity: &~a;\n" | |
128 | (or (port-filename port) "<unknown file>") | |
129 | (port-line port) (port-column port) | |
130 | name) | |
131 | (symbol->string name)) | |
132 | ||
f9ad5a88 AW |
133 | (define dbmathml |
134 | "http://www.oasis-open.org/docbook/xml/mathml/1.1CR1/dbmathml.dtd") | |
135 | ||
136 | (define (docbook-with-mathml-handler docname systemid internal) | |
137 | (unless (equal? systemid dbmathml) | |
138 | (warn "unexpected doctype" docname systemid internal)) | |
139 | (values #:entities *entities* #:namespaces *namespaces*)) | |
140 | ||
141 | (define (trim-whitespace-left str) | |
142 | (let ((first (and (not (string-null? str)) | |
143 | (string-ref str 0)))) | |
144 | (if (and first (char-whitespace? first)) | |
145 | (string-append (string first) (string-trim str char-whitespace?)) | |
146 | str))) | |
147 | ||
148 | (define (trim-whitespace-right str) | |
149 | (let ((last (and (not (string-null? str)) | |
150 | (string-ref str (1- (string-length str)))))) | |
151 | (if (and last (char-whitespace? last)) | |
152 | (string-append (string-trim-right str char-whitespace?) (string last)) | |
153 | str))) | |
154 | ||
155 | (define (trim-whitespace str) | |
156 | (trim-whitespace-left | |
157 | (trim-whitespace-right str))) | |
158 | ||
159 | (define (zap-whitespace sxml) | |
160 | (define (not-whitespace x) | |
161 | (or (not (string? x)) | |
162 | (not (string-every char-whitespace? x)))) | |
163 | (pre-post-order sxml | |
164 | `((*default* . ,(lambda (tag . body) | |
165 | (cons tag | |
166 | (filter not-whitespace body)))) | |
167 | (*text* . ,(lambda (tag text) | |
168 | (if (string? text) | |
169 | (trim-whitespace text) | |
170 | text)))))) | |
171 | ||
53215235 AW |
172 | (define (parse-man-xml version filename) |
173 | (define subdir (format #f "man~A" version)) | |
a6a00658 | 174 | (call-with-input-file (in-vicinity (upstream-doc) |
53215235 | 175 | (in-vicinity subdir filename)) |
f14c9685 | 176 | (lambda (port) |
f9ad5a88 AW |
177 | (zap-whitespace |
178 | (xml->sxml port #:declare-namespaces? #t | |
179 | #:default-entity-handler default-entity-handler | |
180 | #:doctype-handler docbook-with-mathml-handler))))) | |
f14c9685 | 181 | |
53215235 AW |
182 | (define (xml-files version) |
183 | (define subdir (format #f "man~A" version)) | |
a6a00658 | 184 | (scandir (in-vicinity (upstream-doc) subdir) |
f14c9685 AW |
185 | (lambda (x) (string-suffix? ".xml" x)))) |
186 | ||
f9ad5a88 AW |
187 | (define (take-first proc) |
188 | (lambda (xml) | |
189 | (let ((res (proc xml))) | |
190 | (and (pair? res) (car res))))) | |
191 | ||
192 | (define xml-name | |
193 | (take-first (sxpath '(refentry refnamediv refname *text*)))) | |
194 | ||
195 | (define xml-purpose | |
196 | (take-first (sxpath '(refentry refnamediv refpurpose *text*)))) | |
197 | ||
bb894c9d AW |
198 | (define xml-funcprototypes |
199 | (sxpath '(refentry refsynopsisdiv funcsynopsis funcprototype))) | |
f9ad5a88 AW |
200 | |
201 | (define xml-parameters | |
202 | (take-first (sxpath '(refentry (refsect1 (@ id (equal? "parameters"))))))) | |
203 | ||
204 | (define xml-description | |
205 | (take-first (sxpath '(refentry (refsect1 (@ id (equal? "description"))))))) | |
206 | ||
207 | (define xml-errors | |
208 | (take-first (sxpath '(refentry (refsect1 (@ id (equal? "errors"))))))) | |
209 | ||
8925f36f AW |
210 | (define xml-copyright |
211 | (take-first (sxpath '(refentry (refsect1 (@ id (equal? "Copyright"))))))) | |
212 | ||
0e9b22c2 | 213 | (define (string->gl-type str) |
09522815 AW |
214 | (string->symbol |
215 | (string-join (string-split (string-trim-both str) #\space) "-"))) | |
bb894c9d AW |
216 | |
217 | (define (parse-prototypes sxml) | |
218 | (define all-names | |
219 | (match sxml | |
220 | ((('funcprototype ('funcdef return-type ('function names)) | |
221 | . _) | |
222 | ...) | |
223 | names))) | |
224 | ||
b002944d AW |
225 | (define (redundant-variant? s shun-suffix prefer-suffix) |
226 | (and (string-suffix? shun-suffix s) | |
227 | (member (string-append (substring s 0 (- (string-length s) | |
228 | (string-length shun-suffix))) | |
229 | prefer-suffix) | |
230 | all-names))) | |
231 | ||
bb894c9d AW |
232 | (define (skip? s) |
233 | (or | |
ca09631c AW |
234 | ;; Skip double variants if we have a float variant. |
235 | ;; (http://www.opengl.org/wiki/Common_Mistakes#GL_DOUBLE). | |
b002944d AW |
236 | (redundant-variant? s "d" "f") |
237 | ||
bb894c9d | 238 | ;; Skip byte variants if there is a short variant. |
b002944d AW |
239 | (redundant-variant? s "b" "s") |
240 | ||
bb894c9d | 241 | ;; Skip short variants if there is an int variant. |
b002944d AW |
242 | (redundant-variant? s "s" "i") |
243 | ||
244 | ;; Skip packed setters like glVertex3fv if e.g. glVertex3f exists. | |
245 | (redundant-variant? s "v" "") | |
246 | (redundant-variant? s "dv" "fv") | |
247 | (redundant-variant? s "bv" "sv") | |
248 | (redundant-variant? s "sv" "iv"))) | |
bb894c9d AW |
249 | |
250 | (filter-map | |
251 | (lambda (sxml) | |
252 | (match sxml | |
253 | (('funcprototype ('funcdef return-type ('function (? skip?))) | |
254 | . _) | |
255 | #f) | |
256 | (('funcprototype ('funcdef return-type ('function name)) | |
257 | ('paramdef ('parameter "void"))) | |
258 | `(,(string->symbol name) | |
259 | -> ,(string->gl-type return-type))) | |
260 | (('funcprototype ('funcdef return-type ('function name)) | |
261 | ('paramdef ptype ('parameter pname)) | |
262 | ...) | |
263 | `(,(string->symbol name) | |
264 | ,@(map (lambda (pname ptype) | |
265 | (list (string->symbol pname) | |
266 | (string->gl-type ptype))) | |
267 | pname ptype) | |
268 | -> ,(string->gl-type return-type))))) | |
269 | sxml)) | |
f9ad5a88 | 270 | |
227eae66 AW |
271 | (define (collapse-fragments nodeset) |
272 | (match nodeset | |
273 | ((('*fragment* elts ...) nodes ...) | |
274 | (append (collapse-fragments elts) | |
275 | (collapse-fragments nodes))) | |
276 | ((((and tag (? symbol?)) elts ...) nodes ...) | |
277 | (acons tag (collapse-fragments elts) (collapse-fragments nodes))) | |
278 | ((elt nodes ...) | |
279 | (cons elt (collapse-fragments nodes))) | |
280 | (() '()))) | |
281 | ||
282 | (define (list-intersperse src-l elem) | |
283 | (if (null? src-l) src-l | |
284 | (let loop ((l (cdr src-l)) (dest (cons (car src-l) '()))) | |
285 | (if (null? l) (reverse dest) | |
286 | (loop (cdr l) (cons (car l) (cons elem dest))))))) | |
287 | ||
8925f36f AW |
288 | (define (lift-tables sdocbook) |
289 | ;; Like sdocbook-flatten, but tweaked to lift tables from inside | |
290 | ;; paras, but not paras from inside tables. Pretty hacky stuff. | |
291 | (define *sdocbook-block-commands* | |
292 | '(informaltable programlisting variablelist)) | |
293 | ||
294 | (define (inline-command? command) | |
295 | (not (memq command *sdocbook-block-commands*))) | |
296 | ||
297 | (define (fhere str accum block cont) | |
298 | (values (cons str accum) | |
299 | block | |
300 | cont)) | |
301 | (define (fdown node accum block cont) | |
302 | (match node | |
303 | ((command (and attrs ('% . _)) body ...) | |
304 | (values body '() '() | |
305 | (lambda (accum block) | |
306 | (values | |
307 | `(,command ,attrs ,@(reverse accum)) | |
308 | block)))) | |
309 | ((command body ...) | |
310 | (values body '() '() | |
311 | (lambda (accum block) | |
312 | (values | |
313 | `(,command ,@(reverse accum)) | |
314 | block)))))) | |
315 | (define (fup node paccum pblock pcont kaccum kblock kcont) | |
316 | (call-with-values (lambda () (kcont kaccum kblock)) | |
317 | (lambda (ret block) | |
318 | (if (inline-command? (car ret)) | |
319 | (values (cons ret paccum) (append kblock pblock) pcont) | |
320 | (values paccum (append kblock (cons ret pblock)) pcont))))) | |
321 | (call-with-values | |
322 | (lambda () (foldts*-values fdown fup fhere sdocbook '() '() #f)) | |
323 | (lambda (accum block cont) | |
324 | (append (reverse accum) | |
325 | (reverse block) | |
326 | )))) | |
327 | ||
f9ad5a88 AW |
328 | (define *rules* |
329 | `((refsect1 | |
8925f36f | 330 | *preorder* |
f9ad5a88 | 331 | . ,(lambda (tag id . body) |
8925f36f AW |
332 | (append-map (lambda (nodeset) |
333 | (map | |
334 | (lambda (x) | |
335 | (pre-post-order x *rules*)) | |
336 | nodeset)) | |
3c9b6116 AW |
337 | (map lift-tables |
338 | (match body | |
339 | ((('title _) body ...) body) | |
340 | (_ body)))))) | |
f9ad5a88 AW |
341 | (variablelist |
342 | ((varlistentry | |
343 | . ,(lambda (tag term . body) | |
227eae66 | 344 | `(entry (% (heading ,@(cdar term))) ,@(apply append body)))) |
f9ad5a88 | 345 | (listitem |
227eae66 AW |
346 | . ,(lambda (tag . body) |
347 | (map (lambda (x) | |
348 | (if (string? x) | |
349 | `(para ,x) | |
350 | x)) | |
351 | body))) | |
352 | (term | |
f9ad5a88 | 353 | . ,(lambda (tag . rest) |
227eae66 | 354 | `((itemx ,@rest))))) |
f9ad5a88 | 355 | . ,(lambda (tag . body) |
227eae66 | 356 | `(table (% (formatter (asis))) ,@body))) |
8925f36f AW |
357 | (trademark |
358 | . ,(match-lambda* | |
359 | ((_ ('@ ('class "copyright"))) '(copyright)))) | |
f9ad5a88 AW |
360 | (parameter |
361 | . ,(lambda (tag body) | |
362 | `(var ,body))) | |
363 | (type | |
364 | . ,(lambda (tag body) | |
365 | `(code ,body))) | |
366 | (constant | |
367 | . ,(lambda (tag . body) | |
368 | `(code . ,body))) | |
227eae66 AW |
369 | (code |
370 | . ,(lambda (tag . body) | |
371 | `(code . ,body))) | |
f9ad5a88 AW |
372 | (function |
373 | . ,(lambda (tag body . ignored) | |
374 | (or (null? ignored) (warn "ignored function tail" ignored)) | |
375 | `(code ,body))) | |
376 | (emphasis | |
227eae66 AW |
377 | . ,(match-lambda* |
378 | ((_) "") | |
8925f36f AW |
379 | ((_ ('@ ('role "bold")) (and body (? string?))) |
380 | `(strong ,(string-trim-both body))) | |
227eae66 AW |
381 | ((_ ('@ ('role "bold")) . body) `(strong ,@body)) |
382 | ((_ body) `(var ,body)))) | |
383 | (citerefentry | |
384 | . ,(lambda (tag contents) | |
385 | contents)) | |
386 | (refentrytitle | |
387 | . ,(lambda (tag contents) | |
388 | `(code ,contents))) | |
389 | (inlineequation | |
390 | . ,(lambda (tag contents) | |
391 | contents)) | |
392 | (informalequation | |
393 | . ,(lambda (tag contents) | |
394 | contents)) | |
395 | (informaltable | |
396 | . ,(lambda (tag attrs tgroup) | |
397 | tgroup)) | |
398 | (tgroup | |
399 | ((thead | |
400 | . ,(lambda (tag . rows) | |
401 | rows)) | |
402 | (colspec | |
403 | . ,(lambda _ | |
404 | #f)) | |
405 | (tbody | |
406 | . ,(lambda (tag . rows) | |
407 | rows)) | |
408 | (row | |
409 | . ,(lambda (tag first . rest) | |
8925f36f AW |
410 | `(entry (% (heading ,@first)) |
411 | (para ,@(apply | |
412 | append | |
413 | (list-intersperse rest '(", "))))))) | |
227eae66 AW |
414 | (entry |
415 | . ,(match-lambda* | |
8925f36f AW |
416 | ((_) '()) |
417 | ((_ ('@ . _)) '()) | |
418 | ((_ ('@ . _) x ...) x) | |
419 | ((_ x ...) x)))) | |
227eae66 AW |
420 | . ,(lambda (tag attrs . contents) |
421 | `(table (% (formatter (asis))) | |
422 | ,@(apply append (filter identity contents))))) | |
423 | ||
424 | ;; Poor man's mathml. | |
425 | (mml:math | |
426 | . ,(lambda (tag . contents) | |
3c9b6116 | 427 | `(r . ,(collapse-fragments contents)))) |
227eae66 AW |
428 | (mml:mn |
429 | . ,(lambda (tag n . rest) | |
430 | (if (pair? rest) | |
431 | `(*fragment* ,n . ,rest) | |
432 | n))) | |
433 | (mml:mi | |
434 | . ,(case-lambda | |
435 | ((tag contents) | |
436 | `(code ,contents)) | |
437 | ((tag attrs contents) | |
438 | (match attrs | |
439 | (('@ (mathvariant "italic")) | |
440 | `(var ,contents)) | |
441 | (_ `(code ,contents)))))) | |
442 | ;; It would be possible to represent a matrix as a @multitable, but | |
443 | ;; Guile doesn't really have support for that. So instead print | |
444 | ;; each row in parentheses. | |
445 | (mml:mtable | |
446 | ((mml:mtr | |
447 | . ,(lambda (tag . body) | |
448 | `("(" ,@(list-intersperse body " ") ")"))) | |
449 | (mml:mtd | |
450 | . ,(match-lambda* | |
451 | ((tag ('@ . _) body ...) | |
452 | `(*fragment* ,@body)) | |
453 | ((tag body ...) | |
454 | `(*fragment* ,@body))))) | |
455 | . ,(lambda (tag . rows) | |
456 | ;; Rely on outer mfence for outer parens, if any | |
457 | (let ((rows (if (and (pair? rows) (eq? (caar rows) '@)) | |
458 | (cdr rows) | |
459 | rows))) | |
460 | `(*fragment* ,@(apply append (list-intersperse rows '(", "))))))) | |
461 | (mml:mspace | |
462 | . ,(lambda (tag . _) | |
463 | " ")) | |
464 | (mml:msup | |
465 | . ,(lambda (tag base exponent) | |
466 | `(*fragment* ,base "^" ,exponent))) | |
467 | (mml:msub | |
468 | . ,(lambda (tag base exponent) | |
469 | `(*fragment* ,base "_" ,exponent))) | |
470 | (mml:mover | |
471 | . ,(lambda (tag base over) | |
472 | `(*fragment* ,base ,over))) | |
473 | (mml:munderover | |
474 | . ,(lambda (tag under base over) | |
475 | `(*fragment* ,under ,base ,over))) | |
476 | (mml:mfrac | |
477 | . ,(lambda (tag num denom) | |
478 | `(*fragment* ,num "/" ,denom))) | |
479 | (mml:msqrt | |
480 | . ,(lambda (tag base) | |
481 | `(*fragment* "√" ,base))) | |
482 | (mml:infinity | |
483 | . ,(lambda (tag) | |
484 | "∞")) | |
485 | (mml:mo | |
486 | . ,(lambda (tag operator) | |
487 | operator)) | |
488 | (mml:mrow | |
489 | . ,(lambda (tag . contents) | |
490 | `(*fragment* . ,contents))) | |
491 | (mml:mfenced | |
492 | . ,(lambda (tag attrs left . right) | |
493 | `(*fragment* ,@(assq-ref attrs 'open) | |
494 | ,left | |
495 | "," | |
496 | ,@right | |
497 | ,@(assq-ref attrs 'close)))) | |
f9ad5a88 AW |
498 | (*text* |
499 | . ,(lambda (tag text) | |
500 | text)) | |
501 | ,@*sdocbook->stexi-rules*)) | |
502 | ||
503 | (define (sdocbook->stexi sdocbook) | |
504 | (pre-post-order sdocbook *rules*)) | |
505 | ||
506 | ;; Produces an stexinfo fragment. | |
507 | (define (generate-documentation purpose parameters description errors) | |
8925f36f | 508 | `(*fragment* |
3c9b6116 AW |
509 | (para ,(string-append (string (char-upcase (string-ref purpose 0))) |
510 | (substring purpose 1) | |
511 | ".")) | |
8925f36f AW |
512 | ,@(if parameters (sdocbook->stexi parameters) '()) |
513 | ,@(if description (sdocbook->stexi description) '()) | |
514 | ,@(if errors (sdocbook->stexi errors) '()))) | |
f9ad5a88 AW |
515 | |
516 | (define (xml->definition xml) | |
bb894c9d AW |
517 | (let ((prototypes (parse-prototypes (xml-funcprototypes xml)))) |
518 | (and (pair? prototypes) | |
519 | (make-gl-definition (xml-name xml) | |
520 | prototypes | |
521 | (generate-documentation (xml-purpose xml) | |
522 | (xml-parameters xml) | |
523 | (xml-description xml) | |
524 | (xml-errors xml)) | |
525 | (and=> (xml-copyright xml) | |
526 | (lambda (c) | |
527 | `(*fragment* ,@(sdocbook->stexi c)))))))) | |
8925f36f AW |
528 | |
529 | (define (parse-gl-definitions version) | |
bb894c9d AW |
530 | (filter-map (lambda (file) |
531 | (xml->definition (parse-man-xml version file))) | |
532 | (xml-files version))) | |
092cacd7 AW |
533 | |
534 | (define (trim-comment line) | |
535 | (cond | |
536 | ((string-index line #\#) | |
537 | => (lambda (idx) (substring line 0 idx))) | |
538 | (else line))) | |
539 | ||
540 | (define (expand-camel-case s) | |
541 | (define (add-humps humps out more?) | |
542 | (match humps | |
543 | (() out) | |
544 | ((head) | |
545 | (if (null? out) | |
546 | humps | |
547 | (cons* head #\- out))) | |
548 | ((head tail ...) | |
549 | (let ((out (if (null? out) | |
550 | tail | |
551 | (append tail (cons #\- out))))) | |
552 | (if more? | |
553 | (cons* head #\- out) | |
554 | (cons head out)))))) | |
555 | (let lp ((in (string->list s)) (humps '()) (out '())) | |
556 | (match in | |
557 | (() | |
558 | (list->string (reverse (add-humps humps out #f)))) | |
559 | ((c in ...) | |
560 | (if (and (char-lower-case? c) | |
561 | ;; Try to keep subtokens like 12x3 in one piece. | |
562 | (or (null? humps) | |
563 | (not (and-map char-numeric? humps)))) | |
564 | (lp in '() (cons c (add-humps humps out #t))) | |
565 | (lp in (cons (char-downcase c) humps) out)))))) | |
566 | ||
567 | (define (mangle-name name) | |
568 | (string->symbol | |
569 | (string-join (map expand-camel-case (string-split name #\_)) | |
570 | "-"))) | |
571 | ||
572 | (define (parse-number num) | |
573 | (cond | |
574 | ((equal? "0xFFFFFFFFu" num) | |
575 | #xFFFFFFFF) | |
576 | ((equal? "0xFFFFFFFFFFFFFFFFull" num) | |
577 | #xFFFFFFFFFFFFFFFF) | |
578 | ((string-prefix? "0x" num) | |
579 | (string->number (substring num 2) 16)) | |
580 | ((string-prefix? "GL_" num) | |
581 | (cons #f (mangle-name (substring num 3)))) | |
704372ea AW |
582 | ;; Hackety hack... |
583 | ((string-prefix? "GLX_" num) | |
584 | (cons #f (mangle-name (substring num 4)))) | |
092cacd7 AW |
585 | (else |
586 | (string->number num)))) | |
587 | ||
588 | (define (read-line-and-trim-comment port) | |
589 | (let ((line (read-line port))) | |
590 | (if (eof-object? line) | |
591 | line | |
592 | (string-trim-both (trim-comment line))))) | |
593 | ||
594 | (define (resolve-enumerations enums) | |
595 | ;; We shouldn't fail to resolve anything, but there are a couple bugs | |
596 | ;; in enum.spec currently: | |
597 | ;; http://www.khronos.org/bugzilla/show_bug.cgi?id=787. Until they | |
598 | ;; are fixed, allow resolution to fail. | |
599 | (define (resolve-value category name value) | |
600 | (match value | |
601 | (#f #f) | |
602 | ((? number?) | |
603 | value) | |
604 | ((#f . (and name (? symbol?))) | |
605 | (resolve-value category name category)) | |
606 | ((? symbol?) | |
607 | (resolve-value value name (assq-ref (assq-ref enums value) name))))) | |
608 | (let lp ((in enums) (out '())) | |
609 | (match in | |
610 | (() | |
611 | (reverse out)) | |
612 | (((category (name . value) ...) . in) | |
613 | (lp in | |
614 | (cons (make-gl-enumeration | |
615 | category | |
616 | (filter-map | |
617 | (lambda (name value) | |
618 | (and=> (resolve-value category name value) | |
619 | (lambda (value) | |
620 | (cons name value)))) | |
621 | name value)) | |
622 | out)))))) | |
623 | ||
624 | (define (merge-alists in) | |
625 | ;; O(n^2), whee | |
626 | (define (collect-values key values in) | |
627 | (let lp ((in in) (values values)) | |
628 | (if (null? in) | |
629 | values | |
630 | (lp (cdr in) | |
631 | (if (eq? (caar in) key) | |
632 | (append values (cdar in)) | |
633 | values))))) | |
634 | (let lp ((in in) (out '())) | |
635 | (cond | |
636 | ((null? in) (reverse out)) | |
637 | ((assq (caar in) out) (lp (cdr in) out)) | |
638 | (else (lp (cdr in) | |
639 | (acons (caar in) | |
640 | (collect-values (caar in) (cdar in) (cdr in)) | |
641 | out)))))) | |
642 | ||
643 | (define (parse-enumerations-from-port port) | |
644 | (define (finish-block headers enums accum) | |
645 | (if (null? enums) | |
646 | accum | |
647 | (fold (lambda (header accum) | |
648 | (acons header (reverse enums) accum)) | |
649 | accum | |
650 | headers))) | |
651 | (let lp ((current-headers '()) (current-enums '()) (accum '())) | |
652 | (let ((line (read-line-and-trim-comment port))) | |
653 | (cond | |
654 | ((eof-object? line) | |
655 | (resolve-enumerations | |
656 | (merge-alists | |
657 | (reverse (finish-block current-headers current-enums accum))))) | |
658 | ((string-index line #\:) | |
659 | => (lambda (pos) | |
660 | (let* ((ws (or (string-index-right line char-whitespace? 0 pos) 0)) | |
704372ea AW |
661 | (headers (filter |
662 | (compose not string-null?) | |
663 | (map string-trim-both | |
664 | (string-split (substring line 0 ws) #\,)))) | |
092cacd7 AW |
665 | (def (substring line (1+ ws) pos))) |
666 | (match (cons def headers) | |
704372ea AW |
667 | ((or ("define" _ ...) |
668 | ((? (lambda (x) (string-suffix? "_future_use" x))))) | |
092cacd7 AW |
669 | (lp '() |
670 | '() | |
671 | (finish-block current-headers current-enums accum))) | |
672 | (("enum" headers ...) | |
673 | (if (null? current-enums) | |
674 | (lp (append current-headers (map mangle-name headers)) | |
675 | current-enums | |
676 | accum) | |
677 | (lp (map mangle-name headers) | |
678 | '() | |
679 | (finish-block current-headers current-enums accum)))) | |
680 | (x (error "qux." x)))))) | |
681 | ((string-null? line) | |
682 | (lp current-headers current-enums accum)) | |
683 | (else | |
684 | (match (filter (compose not string-null?) | |
685 | (string-split (trim-comment line) char-whitespace?)) | |
686 | ((enum "=" value) | |
687 | (lp current-headers | |
688 | (acons (mangle-name enum) | |
689 | (or (parse-number value) | |
690 | (error "failed to parse" value)) | |
691 | current-enums) | |
692 | accum)) | |
693 | (("use" header enum) | |
694 | (lp current-headers | |
695 | (acons (mangle-name enum) | |
696 | (mangle-name header) | |
697 | current-enums) | |
698 | accum)) | |
699 | (x (error x)))))))) | |
700 | ||
701 | (define (parse-gl-enumerations spec) | |
702 | (call-with-input-file (in-vicinity (upstream-doc) | |
703 | (in-vicinity "spec" spec)) | |
704 | parse-enumerations-from-port)) | |
d3fe20d1 DH |
705 | |
706 | \f | |
707 | ;;; | |
708 | ;;; Type Map | |
709 | ;;; | |
710 | ||
711 | (define valid-directions '(in out in/out)) | |
712 | ||
713 | (define valid-transfer-types '(array reference value)) | |
714 | ||
715 | (define* (string->directions str #:optional | |
716 | (expansion valid-directions)) | |
717 | (let ((direction (string->symbol str))) | |
718 | (cond | |
940b3bea | 719 | ((eq? direction '*) |
d3fe20d1 | 720 | expansion) |
940b3bea | 721 | ((memq direction expansion) |
d3fe20d1 DH |
722 | (list direction)) |
723 | (else | |
724 | (error "unknown direction" str))))) | |
725 | ||
726 | (define* (string->transfer-types str #:optional | |
727 | (expansion valid-transfer-types)) | |
728 | (let ((trans (string->symbol str))) | |
729 | (cond | |
940b3bea | 730 | ((eq? trans '*) |
d3fe20d1 | 731 | expansion) |
940b3bea | 732 | ((memq trans expansion) |
d3fe20d1 DH |
733 | (list trans)) |
734 | (else | |
735 | (error "unknown transfer-type" str))))) | |
736 | ||
737 | (define (expand-type-map-entry type | |
738 | direction | |
739 | transfer-type | |
740 | mapped-type | |
741 | mapped-direction | |
742 | mapped-transfer-type) | |
743 | (let ((type (mangle-name type)) | |
744 | (mapped-type (string->gl-type mapped-type))) | |
745 | (list-ec (:list direction (string->directions direction)) | |
746 | (:list transfer-type (string->transfer-types transfer-type)) | |
747 | (:list mapped-direction | |
748 | (string->directions mapped-direction | |
749 | (list direction))) | |
750 | (:list mapped-transfer-type | |
751 | (string->transfer-types mapped-transfer-type | |
752 | (list transfer-type))) | |
753 | (cons (make-gl-param-type type | |
754 | direction | |
755 | transfer-type) | |
756 | (make-gl-param-type mapped-type | |
757 | mapped-direction | |
758 | mapped-transfer-type))))) | |
759 | ||
760 | (define (parse-type-map-from-port port) | |
761 | (define delimiter (make-regexp "[ \t]*,[ \t]*")) | |
762 | ||
763 | (let lp ((accum '())) | |
764 | (let ((line (read-line-and-trim-comment port))) | |
765 | (cond | |
766 | ((eof-object? line) | |
767 | (reverse accum)) | |
768 | ((string-null? line) | |
769 | (lp accum)) | |
770 | (else | |
771 | ;; TODO: Filter needed here to avoid formatting bug: | |
772 | ;; http://www.khronos.org/bugzilla/show_bug.cgi?id=790 | |
773 | (match (filter (compose not string-null?) | |
774 | (string-split line delimiter)) | |
775 | ((type direction transfer-type | |
776 | mapped-type mapped-direction mapped-transfer-type) | |
777 | (lp (append (expand-type-map-entry type | |
778 | direction | |
779 | transfer-type | |
780 | mapped-type | |
781 | mapped-direction | |
782 | mapped-transfer-type) | |
783 | accum))) | |
784 | (x (error x)))))))) | |
785 | ||
786 | (define (parse-gl-type-map tm) | |
787 | (call-with-input-file (in-vicinity (upstream-doc) | |
788 | (in-vicinity "spec" tm)) | |
789 | parse-type-map-from-port)) |