#:use-module (sxml simple)
#:use-module ((sxml xpath) #:hide (filter))
#:use-module (sxml transform)
- #:use-module ((srfi srfi-1) #:select (filter))
+ #:use-module (sxml fold)
+ #:use-module ((srfi srfi-1) #:select (filter fold append-map filter-map))
+ #:use-module (srfi srfi-9)
#:use-module (texinfo docbook)
#:use-module (ice-9 ftw)
- #:export ())
+ #:use-module (ice-9 match)
+ #:export (gl-definition?
+ make-gl-definition
+ gl-definition-name
+ gl-definition-prototypes
+ gl-definition-documentation
+ gl-definition-copyright
+ parse-gl-definitions))
-(define *man-sections*
- '("man2" "man3" "man4"))
+(define-record-type gl-definition
+ (make-gl-definition name prototypes documentation copyright)
+ gl-definition?
+ (name gl-definition-name)
+ (prototypes gl-definition-prototypes)
+ (documentation gl-definition-documentation)
+ (copyright gl-definition-copyright))
(define *namespaces*
'((mml . "http://www.w3.org/1998/Math/MathML")))
(trim-whitespace text)
text))))))
-(define (parse-man-xml section filename)
- (call-with-input-file (in-vicinity (upstream-man-pages)
- (in-vicinity section filename))
+(define (parse-man-xml version filename)
+ (define subdir (format #f "man~A" version))
+ (call-with-input-file (in-vicinity (upstream-doc)
+ (in-vicinity subdir filename))
(lambda (port)
(zap-whitespace
(xml->sxml port #:declare-namespaces? #t
#:default-entity-handler default-entity-handler
#:doctype-handler docbook-with-mathml-handler)))))
-(define (xml-files section)
- (scandir (in-vicinity (upstream-man-pages) section)
+(define (xml-files version)
+ (define subdir (format #f "man~A" version))
+ (scandir (in-vicinity (upstream-doc) subdir)
(lambda (x) (string-suffix? ".xml" x))))
(define (take-first proc)
(define xml-purpose
(take-first (sxpath '(refentry refnamediv refpurpose *text*))))
-(define xml-prototype
- (take-first (sxpath '(refentry refsynopsisdiv funcsynopsis))))
+(define xml-funcprototypes
+ (sxpath '(refentry refsynopsisdiv funcsynopsis funcprototype)))
(define xml-parameters
(take-first (sxpath '(refentry (refsect1 (@ id (equal? "parameters")))))))
(define xml-errors
(take-first (sxpath '(refentry (refsect1 (@ id (equal? "errors")))))))
-(define (parse-prototype xml)
- xml)
+(define xml-copyright
+ (take-first (sxpath '(refentry (refsect1 (@ id (equal? "Copyright")))))))
+
+(define (string->gl-type str)
+ (string->symbol
+ (string-join (string-split (string-trim-both str) #\space) "-")))
+
+(define (parse-prototypes sxml)
+ (define all-names
+ (match sxml
+ ((('funcprototype ('funcdef return-type ('function names))
+ . _)
+ ...)
+ names)))
+
+ (define (redundant-variant? s shun-suffix prefer-suffix)
+ (and (string-suffix? shun-suffix s)
+ (member (string-append (substring s 0 (- (string-length s)
+ (string-length shun-suffix)))
+ prefer-suffix)
+ all-names)))
+
+ (define (skip? s)
+ (or
+ ;; Skip double variants if we have a float variant.
+ ;; (http://www.opengl.org/wiki/Common_Mistakes#GL_DOUBLE).
+ (redundant-variant? s "d" "f")
+
+ ;; Skip byte variants if there is a short variant.
+ (redundant-variant? s "b" "s")
+
+ ;; Skip short variants if there is an int variant.
+ (redundant-variant? s "s" "i")
+
+ ;; Skip packed setters like glVertex3fv if e.g. glVertex3f exists.
+ (redundant-variant? s "v" "")
+ (redundant-variant? s "dv" "fv")
+ (redundant-variant? s "bv" "sv")
+ (redundant-variant? s "sv" "iv")))
+
+ (filter-map
+ (lambda (sxml)
+ (match sxml
+ (('funcprototype ('funcdef return-type ('function (? skip?)))
+ . _)
+ #f)
+ (('funcprototype ('funcdef return-type ('function name))
+ ('paramdef ('parameter "void")))
+ `(,(string->symbol name)
+ -> ,(string->gl-type return-type)))
+ (('funcprototype ('funcdef return-type ('function name))
+ ('paramdef ptype ('parameter pname))
+ ...)
+ `(,(string->symbol name)
+ ,@(map (lambda (pname ptype)
+ (list (string->symbol pname)
+ (string->gl-type ptype)))
+ pname ptype)
+ -> ,(string->gl-type return-type)))))
+ sxml))
+
+(define (collapse-fragments nodeset)
+ (match nodeset
+ ((('*fragment* elts ...) nodes ...)
+ (append (collapse-fragments elts)
+ (collapse-fragments nodes)))
+ ((((and tag (? symbol?)) elts ...) nodes ...)
+ (acons tag (collapse-fragments elts) (collapse-fragments nodes)))
+ ((elt nodes ...)
+ (cons elt (collapse-fragments nodes)))
+ (() '())))
+
+(define (list-intersperse src-l elem)
+ (if (null? src-l) src-l
+ (let loop ((l (cdr src-l)) (dest (cons (car src-l) '())))
+ (if (null? l) (reverse dest)
+ (loop (cdr l) (cons (car l) (cons elem dest)))))))
+
+(define (lift-tables sdocbook)
+ ;; Like sdocbook-flatten, but tweaked to lift tables from inside
+ ;; paras, but not paras from inside tables. Pretty hacky stuff.
+ (define *sdocbook-block-commands*
+ '(informaltable programlisting variablelist))
+
+ (define (inline-command? command)
+ (not (memq command *sdocbook-block-commands*)))
+
+ (define (fhere str accum block cont)
+ (values (cons str accum)
+ block
+ cont))
+ (define (fdown node accum block cont)
+ (match node
+ ((command (and attrs ('% . _)) body ...)
+ (values body '() '()
+ (lambda (accum block)
+ (values
+ `(,command ,attrs ,@(reverse accum))
+ block))))
+ ((command body ...)
+ (values body '() '()
+ (lambda (accum block)
+ (values
+ `(,command ,@(reverse accum))
+ block))))))
+ (define (fup node paccum pblock pcont kaccum kblock kcont)
+ (call-with-values (lambda () (kcont kaccum kblock))
+ (lambda (ret block)
+ (if (inline-command? (car ret))
+ (values (cons ret paccum) (append kblock pblock) pcont)
+ (values paccum (append kblock (cons ret pblock)) pcont)))))
+ (call-with-values
+ (lambda () (foldts*-values fdown fup fhere sdocbook '() '() #f))
+ (lambda (accum block cont)
+ (append (reverse accum)
+ (reverse block)
+ ))))
(define *rules*
`((refsect1
+ *preorder*
. ,(lambda (tag id . body)
- body))
- (title
- . ,(lambda (tag body)
- `(heading ,body)))
+ (append-map (lambda (nodeset)
+ (map
+ (lambda (x)
+ (pre-post-order x *rules*))
+ nodeset))
+ (map lift-tables
+ (match body
+ ((('title _) body ...) body)
+ (_ body))))))
(variablelist
((varlistentry
. ,(lambda (tag term . body)
- `(entry (% (heading ,@(cdr term))) ,@body)))
+ `(entry (% (heading ,@(cdar term))) ,@(apply append body))))
(listitem
+ . ,(lambda (tag . body)
+ (map (lambda (x)
+ (if (string? x)
+ `(para ,x)
+ x))
+ body)))
+ (term
. ,(lambda (tag . rest)
- (cond ((null? rest)
- (warn "null listitem")
- '(*fragment*))
- ((pair? (car rest))
- (if (not (null? (cdr rest)))
- (warn "ignoring listitem extra contents:" (cddr rest)))
- (car rest))
- (else
- (list 'para rest))))))
+ `((itemx ,@rest)))))
. ,(lambda (tag . body)
- `(table (% (formatter (var))) ,@body)))
- (term
- . ,(lambda (tag param . rest)
- (if (pair? param)
- param
- (list 'var param))))
+ `(table (% (formatter (asis))) ,@body)))
+ (trademark
+ . ,(match-lambda*
+ ((_ ('@ ('class "copyright"))) '(copyright))))
(parameter
. ,(lambda (tag body)
`(var ,body)))
(constant
. ,(lambda (tag . body)
`(code . ,body)))
+ (code
+ . ,(lambda (tag . body)
+ `(code . ,body)))
(function
. ,(lambda (tag body . ignored)
(or (null? ignored) (warn "ignored function tail" ignored))
`(code ,body)))
(emphasis
- . ,(lambda (tag . body)
- `(var . ,body)))
+ . ,(match-lambda*
+ ((_) "")
+ ((_ ('@ ('role "bold")) (and body (? string?)))
+ `(strong ,(string-trim-both body)))
+ ((_ ('@ ('role "bold")) . body) `(strong ,@body))
+ ((_ body) `(var ,body))))
+ (citerefentry
+ . ,(lambda (tag contents)
+ contents))
+ (refentrytitle
+ . ,(lambda (tag contents)
+ `(code ,contents)))
+ (inlineequation
+ . ,(lambda (tag contents)
+ contents))
+ (informalequation
+ . ,(lambda (tag contents)
+ contents))
+ (informaltable
+ . ,(lambda (tag attrs tgroup)
+ tgroup))
+ (tgroup
+ ((thead
+ . ,(lambda (tag . rows)
+ rows))
+ (colspec
+ . ,(lambda _
+ #f))
+ (tbody
+ . ,(lambda (tag . rows)
+ rows))
+ (row
+ . ,(lambda (tag first . rest)
+ `(entry (% (heading ,@first))
+ (para ,@(apply
+ append
+ (list-intersperse rest '(", ")))))))
+ (entry
+ . ,(match-lambda*
+ ((_) '())
+ ((_ ('@ . _)) '())
+ ((_ ('@ . _) x ...) x)
+ ((_ x ...) x))))
+ . ,(lambda (tag attrs . contents)
+ `(table (% (formatter (asis)))
+ ,@(apply append (filter identity contents)))))
+
+ ;; Poor man's mathml.
+ (mml:math
+ . ,(lambda (tag . contents)
+ `(r . ,(collapse-fragments contents))))
+ (mml:mn
+ . ,(lambda (tag n . rest)
+ (if (pair? rest)
+ `(*fragment* ,n . ,rest)
+ n)))
+ (mml:mi
+ . ,(case-lambda
+ ((tag contents)
+ `(code ,contents))
+ ((tag attrs contents)
+ (match attrs
+ (('@ (mathvariant "italic"))
+ `(var ,contents))
+ (_ `(code ,contents))))))
+ ;; It would be possible to represent a matrix as a @multitable, but
+ ;; Guile doesn't really have support for that. So instead print
+ ;; each row in parentheses.
+ (mml:mtable
+ ((mml:mtr
+ . ,(lambda (tag . body)
+ `("(" ,@(list-intersperse body " ") ")")))
+ (mml:mtd
+ . ,(match-lambda*
+ ((tag ('@ . _) body ...)
+ `(*fragment* ,@body))
+ ((tag body ...)
+ `(*fragment* ,@body)))))
+ . ,(lambda (tag . rows)
+ ;; Rely on outer mfence for outer parens, if any
+ (let ((rows (if (and (pair? rows) (eq? (caar rows) '@))
+ (cdr rows)
+ rows)))
+ `(*fragment* ,@(apply append (list-intersperse rows '(", ")))))))
+ (mml:mspace
+ . ,(lambda (tag . _)
+ " "))
+ (mml:msup
+ . ,(lambda (tag base exponent)
+ `(*fragment* ,base "^" ,exponent)))
+ (mml:msub
+ . ,(lambda (tag base exponent)
+ `(*fragment* ,base "_" ,exponent)))
+ (mml:mover
+ . ,(lambda (tag base over)
+ `(*fragment* ,base ,over)))
+ (mml:munderover
+ . ,(lambda (tag under base over)
+ `(*fragment* ,under ,base ,over)))
+ (mml:mfrac
+ . ,(lambda (tag num denom)
+ `(*fragment* ,num "/" ,denom)))
+ (mml:msqrt
+ . ,(lambda (tag base)
+ `(*fragment* "√" ,base)))
+ (mml:infinity
+ . ,(lambda (tag)
+ "∞"))
+ (mml:mo
+ . ,(lambda (tag operator)
+ operator))
+ (mml:mrow
+ . ,(lambda (tag . contents)
+ `(*fragment* . ,contents)))
+ (mml:mfenced
+ . ,(lambda (tag attrs left . right)
+ `(*fragment* ,@(assq-ref attrs 'open)
+ ,left
+ ","
+ ,@right
+ ,@(assq-ref attrs 'close))))
(*text*
. ,(lambda (tag text)
text))
;; Produces an stexinfo fragment.
(define (generate-documentation purpose parameters description errors)
`(*fragment*
- (heading ,purpose)
- ,@(sdocbook->stexi parameters)
- ,@(sdocbook->stexi description)
- ,@(sdocbook->stexi errors)))
+ (para ,(string-append (string (char-upcase (string-ref purpose 0)))
+ (substring purpose 1)
+ "."))
+ ,@(if parameters (sdocbook->stexi parameters) '())
+ ,@(if description (sdocbook->stexi description) '())
+ ,@(if errors (sdocbook->stexi errors) '())))
(define (xml->definition xml)
- `((name . ,(xml-name xml))
- (prototype . ,(parse-prototype (xml-prototype xml)))
- (documentation . ,(generate-documentation (xml-purpose xml)
- (xml-parameters xml)
- (xml-description xml)
- (xml-errors xml)))))
+ (let ((prototypes (parse-prototypes (xml-funcprototypes xml))))
+ (and (pair? prototypes)
+ (make-gl-definition (xml-name xml)
+ prototypes
+ (generate-documentation (xml-purpose xml)
+ (xml-parameters xml)
+ (xml-description xml)
+ (xml-errors xml))
+ (and=> (xml-copyright xml)
+ (lambda (c)
+ `(*fragment* ,@(sdocbook->stexi c))))))))
+
+(define (parse-gl-definitions version)
+ (filter-map (lambda (file)
+ (xml->definition (parse-man-xml version file)))
+ (xml-files version)))
HCoop / clinton / guile-figl.git / blobdiff