2 ;;; Copyright (C) 2013 Andy Wingo <wingo@pobox.com>
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.
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.
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/>.
20 ;; figl is the Foreign Interface to GL.
24 (define-module (figl parse)
25 #:use-module (figl config)
26 #:use-module (sxml simple)
27 #:use-module ((sxml xpath) #:hide (filter))
28 #:use-module (sxml transform)
29 #:use-module (sxml fold)
30 #:use-module ((srfi srfi-1) #:select (filter fold append-map filter-map))
31 #:use-module (srfi srfi-9)
32 #:use-module (texinfo docbook)
33 #:use-module (ice-9 ftw)
34 #:use-module (ice-9 match)
35 #:export (gl-definition?
38 gl-definition-prototypes
39 gl-definition-documentation
40 gl-definition-copyright
41 parse-gl-definitions))
43 (define-record-type gl-definition
44 (make-gl-definition name prototypes documentation copyright)
46 (name gl-definition-name)
47 (prototypes gl-definition-prototypes)
48 (documentation gl-definition-documentation)
49 (copyright gl-definition-copyright))
52 '((mml . "http://www.w3.org/1998/Math/MathML")))
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.
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)
95 (symbol->string name))
98 "http://www.oasis-open.org/docbook/xml/mathml/1.1CR1/dbmathml.dtd")
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*))
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?))
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))
119 (define (trim-whitespace str)
120 (trim-whitespace-left
121 (trim-whitespace-right str)))
123 (define (zap-whitespace sxml)
124 (define (not-whitespace x)
125 (or (not (string? x))
126 (not (string-every char-whitespace? x))))
128 `((*default* . ,(lambda (tag . body)
130 (filter not-whitespace body))))
131 (*text* . ,(lambda (tag text)
133 (trim-whitespace text)
136 (define (parse-man-xml version filename)
137 (define subdir (format #f "man~A" version))
138 (call-with-input-file (in-vicinity (upstream-man-pages)
139 (in-vicinity subdir filename))
142 (xml->sxml port #:declare-namespaces? #t
143 #:default-entity-handler default-entity-handler
144 #:doctype-handler docbook-with-mathml-handler)))))
146 (define (xml-files version)
147 (define subdir (format #f "man~A" version))
148 (scandir (in-vicinity (upstream-man-pages) subdir)
149 (lambda (x) (string-suffix? ".xml" x))))
151 (define (take-first proc)
153 (let ((res (proc xml)))
154 (and (pair? res) (car res)))))
157 (take-first (sxpath '(refentry refnamediv refname *text*))))
160 (take-first (sxpath '(refentry refnamediv refpurpose *text*))))
162 (define xml-funcprototypes
163 (sxpath '(refentry refsynopsisdiv funcsynopsis funcprototype)))
165 (define xml-parameters
166 (take-first (sxpath '(refentry (refsect1 (@ id (equal? "parameters")))))))
168 (define xml-description
169 (take-first (sxpath '(refentry (refsect1 (@ id (equal? "description")))))))
172 (take-first (sxpath '(refentry (refsect1 (@ id (equal? "errors")))))))
174 (define xml-copyright
175 (take-first (sxpath '(refentry (refsect1 (@ id (equal? "Copyright")))))))
177 (define (string->gl-type str)
179 (string-join (string-split (string-trim-both str) #\space) "-")))
181 (define (parse-prototypes sxml)
184 ((('funcprototype ('funcdef return-type ('function names))
189 (define (redundant-variant? s shun-suffix prefer-suffix)
190 (and (string-suffix? shun-suffix s)
191 (member (string-append (substring s 0 (- (string-length s)
192 (string-length shun-suffix)))
198 ;; Skip double variants if we have a float variant.
199 ;; (http://www.opengl.org/wiki/Common_Mistakes#GL_DOUBLE).
200 (redundant-variant? s "d" "f")
202 ;; Skip byte variants if there is a short variant.
203 (redundant-variant? s "b" "s")
205 ;; Skip short variants if there is an int variant.
206 (redundant-variant? s "s" "i")
208 ;; Skip packed setters like glVertex3fv if e.g. glVertex3f exists.
209 (redundant-variant? s "v" "")
210 (redundant-variant? s "dv" "fv")
211 (redundant-variant? s "bv" "sv")
212 (redundant-variant? s "sv" "iv")))
217 (('funcprototype ('funcdef return-type ('function (? skip?)))
220 (('funcprototype ('funcdef return-type ('function name))
221 ('paramdef ('parameter "void")))
222 `(,(string->symbol name)
223 -> ,(string->gl-type return-type)))
224 (('funcprototype ('funcdef return-type ('function name))
225 ('paramdef ptype ('parameter pname))
227 `(,(string->symbol name)
228 ,@(map (lambda (pname ptype)
229 (list (string->symbol pname)
230 (string->gl-type ptype)))
232 -> ,(string->gl-type return-type)))))
235 (define (collapse-fragments nodeset)
237 ((('*fragment* elts ...) nodes ...)
238 (append (collapse-fragments elts)
239 (collapse-fragments nodes)))
240 ((((and tag (? symbol?)) elts ...) nodes ...)
241 (acons tag (collapse-fragments elts) (collapse-fragments nodes)))
243 (cons elt (collapse-fragments nodes)))
246 (define (list-intersperse src-l elem)
247 (if (null? src-l) src-l
248 (let loop ((l (cdr src-l)) (dest (cons (car src-l) '())))
249 (if (null? l) (reverse dest)
250 (loop (cdr l) (cons (car l) (cons elem dest)))))))
252 (define (lift-tables sdocbook)
253 ;; Like sdocbook-flatten, but tweaked to lift tables from inside
254 ;; paras, but not paras from inside tables. Pretty hacky stuff.
255 (define *sdocbook-block-commands*
256 '(informaltable programlisting variablelist))
258 (define (inline-command? command)
259 (not (memq command *sdocbook-block-commands*)))
261 (define (fhere str accum block cont)
262 (values (cons str accum)
265 (define (fdown node accum block cont)
267 ((command (and attrs ('% . _)) body ...)
269 (lambda (accum block)
271 `(,command ,attrs ,@(reverse accum))
275 (lambda (accum block)
277 `(,command ,@(reverse accum))
279 (define (fup node paccum pblock pcont kaccum kblock kcont)
280 (call-with-values (lambda () (kcont kaccum kblock))
282 (if (inline-command? (car ret))
283 (values (cons ret paccum) (append kblock pblock) pcont)
284 (values paccum (append kblock (cons ret pblock)) pcont)))))
286 (lambda () (foldts*-values fdown fup fhere sdocbook '() '() #f))
287 (lambda (accum block cont)
288 (append (reverse accum)
295 . ,(lambda (tag id . body)
296 (append-map (lambda (nodeset)
299 (pre-post-order x *rules*))
303 ((('title _) body ...) body)
307 . ,(lambda (tag term . body)
308 `(entry (% (heading ,@(cdar term))) ,@(apply append body))))
310 . ,(lambda (tag . body)
317 . ,(lambda (tag . rest)
319 . ,(lambda (tag . body)
320 `(table (% (formatter (asis))) ,@body)))
323 ((_ ('@ ('class "copyright"))) '(copyright))))
325 . ,(lambda (tag body)
328 . ,(lambda (tag body)
331 . ,(lambda (tag . body)
334 . ,(lambda (tag . body)
337 . ,(lambda (tag body . ignored)
338 (or (null? ignored) (warn "ignored function tail" ignored))
343 ((_ ('@ ('role "bold")) (and body (? string?)))
344 `(strong ,(string-trim-both body)))
345 ((_ ('@ ('role "bold")) . body) `(strong ,@body))
346 ((_ body) `(var ,body))))
348 . ,(lambda (tag contents)
351 . ,(lambda (tag contents)
354 . ,(lambda (tag contents)
357 . ,(lambda (tag contents)
360 . ,(lambda (tag attrs tgroup)
364 . ,(lambda (tag . rows)
370 . ,(lambda (tag . rows)
373 . ,(lambda (tag first . rest)
374 `(entry (% (heading ,@first))
377 (list-intersperse rest '(", ")))))))
382 ((_ ('@ . _) x ...) x)
384 . ,(lambda (tag attrs . contents)
385 `(table (% (formatter (asis)))
386 ,@(apply append (filter identity contents)))))
388 ;; Poor man's mathml.
390 . ,(lambda (tag . contents)
391 `(r . ,(collapse-fragments contents))))
393 . ,(lambda (tag n . rest)
395 `(*fragment* ,n . ,rest)
401 ((tag attrs contents)
403 (('@ (mathvariant "italic"))
405 (_ `(code ,contents))))))
406 ;; It would be possible to represent a matrix as a @multitable, but
407 ;; Guile doesn't really have support for that. So instead print
408 ;; each row in parentheses.
411 . ,(lambda (tag . body)
412 `("(" ,@(list-intersperse body " ") ")")))
415 ((tag ('@ . _) body ...)
416 `(*fragment* ,@body))
418 `(*fragment* ,@body)))))
419 . ,(lambda (tag . rows)
420 ;; Rely on outer mfence for outer parens, if any
421 (let ((rows (if (and (pair? rows) (eq? (caar rows) '@))
424 `(*fragment* ,@(apply append (list-intersperse rows '(", ")))))))
429 . ,(lambda (tag base exponent)
430 `(*fragment* ,base "^" ,exponent)))
432 . ,(lambda (tag base exponent)
433 `(*fragment* ,base "_" ,exponent)))
435 . ,(lambda (tag base over)
436 `(*fragment* ,base ,over)))
438 . ,(lambda (tag under base over)
439 `(*fragment* ,under ,base ,over)))
441 . ,(lambda (tag num denom)
442 `(*fragment* ,num "/" ,denom)))
444 . ,(lambda (tag base)
445 `(*fragment* "√" ,base)))
450 . ,(lambda (tag operator)
453 . ,(lambda (tag . contents)
454 `(*fragment* . ,contents)))
456 . ,(lambda (tag attrs left . right)
457 `(*fragment* ,@(assq-ref attrs 'open)
461 ,@(assq-ref attrs 'close))))
463 . ,(lambda (tag text)
465 ,@*sdocbook->stexi-rules*))
467 (define (sdocbook->stexi sdocbook)
468 (pre-post-order sdocbook *rules*))
470 ;; Produces an stexinfo fragment.
471 (define (generate-documentation purpose parameters description errors)
473 (para ,(string-append (string (char-upcase (string-ref purpose 0)))
474 (substring purpose 1)
476 ,@(if parameters (sdocbook->stexi parameters) '())
477 ,@(if description (sdocbook->stexi description) '())
478 ,@(if errors (sdocbook->stexi errors) '())))
480 (define (xml->definition xml)
481 (let ((prototypes (parse-prototypes (xml-funcprototypes xml))))
482 (and (pair? prototypes)
483 (make-gl-definition (xml-name xml)
485 (generate-documentation (xml-purpose xml)
487 (xml-description xml)
489 (and=> (xml-copyright xml)
491 `(*fragment* ,@(sdocbook->stexi c))))))))
493 (define (parse-gl-definitions version)
494 (filter-map (lambda (file)
495 (xml->definition (parse-man-xml version file)))
496 (xml-files version)))