figl/parse.scm

   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)
  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?
  36             make-gl-definition
  37             gl-definition-name
  38             gl-definition-prototypes
  39             gl-definition-documentation
  40             gl-definition-copyright
  41             parse-gl-definitions))
  42
  43 (define-record-type gl-definition
  44   (make-gl-definition name prototypes documentation copyright)
  45   gl-definition?
  46   (name gl-definition-name)
  47   (prototypes gl-definition-prototypes)
  48   (documentation gl-definition-documentation)
  49   (copyright gl-definition-copyright))
  50
  51 (define *namespaces*
  52   '((mml . "http://www.w3.org/1998/Math/MathML")))
  53
  54 (define *entities*
  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     ))
  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
  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
 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))
 140     (lambda (port)
 141       (zap-whitespace
 142        (xml->sxml port #:declare-namespaces? #t
 143                   #:default-entity-handler default-entity-handler
 144                   #:doctype-handler docbook-with-mathml-handler)))))
 145
 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))))
 150
 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
 162 (define xml-funcprototypes
 163   (sxpath '(refentry refsynopsisdiv funcsynopsis funcprototype)))
 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
 174 (define xml-copyright
 175   (take-first (sxpath '(refentry (refsect1 (@ id (equal? "Copyright")))))))
 176
 177 (define (string->gl-type str)
 178   (string->symbol
 179    (string-join (string-split (string-trim-both str) #\space) "-")))
 180
 181 (define (parse-prototypes sxml)
 182   (define all-names
 183     (match sxml
 184       ((('funcprototype ('funcdef return-type ('function names))
 185                         . _)
 186         ...)
 187        names)))
 188
 189   (define (skip? s)
 190     (or
 191      ;; Skip double variants if we have a float variant.
 192      ;; (http://www.opengl.org/wiki/Common_Mistakes#GL_DOUBLE).
 193      (and (string-suffix? "d" s)
 194           (member (string-append (substring s 0 (1- (string-length s))) "f")
 195                   all-names))
 196      ;; Skip packed accessors like glVertex3fv.
 197      (string-suffix? "v" s)
 198      ;; Skip byte variants if there is a short variant.
 199      (and (string-suffix? "b" s)
 200           (member (string-append (substring s 0 (1- (string-length s))) "s")
 201                   all-names))
 202      ;; Skip short variants if there is an int variant.
 203      (and (or (string-suffix? "s" s)
 204               (string-suffix? "s" s)
 205               (string-suffix? "s" s)
 206               (string-suffix? "s" s))
 207           (member (string-append (substring s 0 (1- (string-length s))) "i")
 208                   all-names))))
 209
 210   (filter-map
 211    (lambda (sxml)
 212      (match sxml
 213        (('funcprototype ('funcdef return-type ('function (? skip?)))
 214                         . _)
 215         #f)
 216        (('funcprototype ('funcdef return-type ('function name))
 217                         ('paramdef ('parameter "void")))
 218         `(,(string->symbol name)
 219           -> ,(string->gl-type return-type)))
 220        (('funcprototype ('funcdef return-type ('function name))
 221                         ('paramdef ptype ('parameter pname))
 222                         ...)
 223         `(,(string->symbol name)
 224           ,@(map (lambda (pname ptype)
 225                    (list (string->symbol pname)
 226                          (string->gl-type ptype)))
 227                  pname ptype)
 228           -> ,(string->gl-type return-type)))))
 229    sxml))
 230
 231 (define (collapse-fragments nodeset)
 232   (match nodeset
 233     ((('*fragment* elts ...) nodes ...)
 234      (append (collapse-fragments elts)
 235              (collapse-fragments nodes)))
 236     ((((and tag (? symbol?)) elts ...) nodes ...)
 237      (acons tag (collapse-fragments elts) (collapse-fragments nodes)))
 238     ((elt nodes ...)
 239      (cons elt (collapse-fragments nodes)))
 240     (() '())))
 241
 242 (define (list-intersperse src-l elem)
 243   (if (null? src-l) src-l
 244       (let loop ((l (cdr src-l)) (dest (cons (car src-l) '())))
 245         (if (null? l) (reverse dest)
 246             (loop (cdr l) (cons (car l) (cons elem dest)))))))
 247
 248 (define (lift-tables sdocbook)
 249   ;; Like sdocbook-flatten, but tweaked to lift tables from inside
 250   ;; paras, but not paras from inside tables.  Pretty hacky stuff.
 251   (define *sdocbook-block-commands*
 252     '(informaltable programlisting variablelist))
 253
 254   (define (inline-command? command)
 255     (not (memq command *sdocbook-block-commands*)))
 256
 257   (define (fhere str accum block cont)
 258     (values (cons str accum)
 259             block
 260             cont))
 261   (define (fdown node accum block cont)
 262     (match node
 263       ((command (and attrs ('% . _)) body ...)
 264        (values body '() '()
 265                (lambda (accum block)
 266                  (values
 267                   `(,command ,attrs ,@(reverse accum))
 268                   block))))
 269       ((command body ...)
 270        (values body '() '()
 271                (lambda (accum block)
 272                  (values
 273                   `(,command ,@(reverse accum))
 274                   block))))))
 275   (define (fup node paccum pblock pcont kaccum kblock kcont)
 276     (call-with-values (lambda () (kcont kaccum kblock))
 277       (lambda (ret block)
 278         (if (inline-command? (car ret))
 279             (values (cons ret paccum) (append kblock pblock) pcont)
 280             (values paccum (append kblock (cons ret pblock)) pcont)))))
 281   (call-with-values
 282       (lambda () (foldts*-values fdown fup fhere sdocbook '() '() #f))
 283     (lambda (accum block cont)
 284       (append (reverse accum)
 285               (reverse block)
 286               ))))
 287
 288 (define *rules*
 289   `((refsect1
 290      *preorder*
 291      . ,(lambda (tag id . body)
 292           (append-map (lambda (nodeset)
 293                         (map
 294                          (lambda (x)
 295                            (pre-post-order x *rules*))
 296                          nodeset))
 297                       (map lift-tables
 298                            (match body
 299                              ((('title _) body ...) body)
 300                              (_ body))))))
 301     (variablelist
 302      ((varlistentry
 303        . ,(lambda (tag term . body)
 304             `(entry (% (heading ,@(cdar term))) ,@(apply append body))))
 305       (listitem
 306        . ,(lambda (tag . body)
 307             (map (lambda (x)
 308                    (if (string? x)
 309                        `(para ,x)
 310                        x))
 311                  body)))
 312       (term
 313        . ,(lambda (tag . rest)
 314             `((itemx ,@rest)))))
 315      . ,(lambda (tag . body)
 316           `(table (% (formatter (asis))) ,@body)))
 317     (trademark
 318      . ,(match-lambda*
 319          ((_ ('@ ('class "copyright"))) '(copyright))))
 320     (parameter
 321      . ,(lambda (tag body)
 322           `(var ,body)))
 323     (type
 324      . ,(lambda (tag body)
 325           `(code ,body)))
 326     (constant
 327      . ,(lambda (tag . body)
 328           `(code . ,body)))
 329     (code
 330      . ,(lambda (tag . body)
 331           `(code . ,body)))
 332     (function
 333      . ,(lambda (tag body . ignored)
 334           (or (null? ignored) (warn "ignored function tail" ignored))
 335           `(code ,body)))
 336     (emphasis
 337      . ,(match-lambda*
 338          ((_) "")
 339          ((_ ('@ ('role "bold")) (and body (? string?)))
 340           `(strong ,(string-trim-both body)))
 341          ((_ ('@ ('role "bold")) . body) `(strong ,@body))
 342          ((_ body) `(var ,body))))
 343     (citerefentry
 344      . ,(lambda (tag contents)
 345           contents))
 346     (refentrytitle
 347      . ,(lambda (tag contents)
 348           `(code ,contents)))
 349     (inlineequation
 350      . ,(lambda (tag contents)
 351           contents))
 352     (informalequation
 353      . ,(lambda (tag contents)
 354           contents))
 355     (informaltable
 356      . ,(lambda (tag attrs tgroup)
 357           tgroup))
 358     (tgroup
 359      ((thead
 360        . ,(lambda (tag . rows)
 361             rows))
 362       (colspec
 363        . ,(lambda _
 364             #f))
 365       (tbody
 366        . ,(lambda (tag . rows)
 367             rows))
 368       (row
 369        . ,(lambda (tag first . rest)
 370             `(entry (% (heading ,@first))
 371                     (para ,@(apply
 372                              append
 373                              (list-intersperse rest '(", ")))))))
 374       (entry
 375        . ,(match-lambda*
 376            ((_) '())
 377            ((_ ('@ . _)) '())
 378            ((_ ('@ . _) x ...) x)
 379            ((_ x ...) x))))
 380      . ,(lambda (tag attrs . contents)
 381           `(table (% (formatter (asis)))
 382                   ,@(apply append (filter identity contents)))))
 383
 384     ;; Poor man's mathml.
 385     (mml:math
 386      . ,(lambda (tag . contents)
 387           `(r . ,(collapse-fragments contents))))
 388     (mml:mn
 389      . ,(lambda (tag n . rest)
 390           (if (pair? rest)
 391               `(*fragment* ,n . ,rest)
 392               n)))
 393     (mml:mi
 394      . ,(case-lambda
 395           ((tag contents)
 396            `(code ,contents))
 397           ((tag attrs contents)
 398            (match attrs
 399              (('@ (mathvariant "italic"))
 400               `(var ,contents))
 401              (_ `(code ,contents))))))
 402     ;; It would be possible to represent a matrix as a @multitable, but
 403     ;; Guile doesn't really have support for that.  So instead print
 404     ;; each row in parentheses.
 405     (mml:mtable
 406      ((mml:mtr
 407        . ,(lambda (tag . body)
 408             `("(" ,@(list-intersperse body " ") ")")))
 409       (mml:mtd
 410        . ,(match-lambda*
 411            ((tag ('@ . _) body ...)
 412             `(*fragment* ,@body))
 413            ((tag body ...)
 414             `(*fragment* ,@body)))))
 415      . ,(lambda (tag . rows)
 416           ;; Rely on outer mfence for outer parens, if any
 417           (let ((rows (if (and (pair? rows) (eq? (caar rows) '@))
 418                           (cdr rows)
 419                           rows)))
 420             `(*fragment* ,@(apply append (list-intersperse rows '(", ")))))))
 421     (mml:mspace
 422      . ,(lambda (tag . _)
 423           " "))
 424     (mml:msup
 425      . ,(lambda (tag base exponent)
 426           `(*fragment* ,base "^" ,exponent)))
 427     (mml:msub
 428      . ,(lambda (tag base exponent)
 429           `(*fragment* ,base "_" ,exponent)))
 430     (mml:mover
 431      . ,(lambda (tag base over)
 432           `(*fragment* ,base ,over)))
 433     (mml:munderover
 434      . ,(lambda (tag under base over)
 435           `(*fragment* ,under ,base ,over)))
 436     (mml:mfrac
 437      . ,(lambda (tag num denom)
 438           `(*fragment* ,num "/" ,denom)))
 439     (mml:msqrt
 440      . ,(lambda (tag base)
 441           `(*fragment* "√" ,base)))
 442     (mml:infinity
 443      . ,(lambda (tag)
 444           "∞"))
 445     (mml:mo
 446      . ,(lambda (tag operator)
 447           operator))
 448     (mml:mrow
 449      . ,(lambda (tag . contents)
 450           `(*fragment* . ,contents)))
 451     (mml:mfenced
 452      . ,(lambda (tag attrs left . right)
 453           `(*fragment* ,@(assq-ref attrs 'open)
 454                        ,left
 455                        ","
 456                        ,@right
 457                        ,@(assq-ref attrs 'close))))
 458     (*text*
 459      . ,(lambda (tag text)
 460           text))
 461     ,@*sdocbook->stexi-rules*))
 462
 463 (define (sdocbook->stexi sdocbook)
 464   (pre-post-order sdocbook *rules*))
 465
 466 ;; Produces an stexinfo fragment.
 467 (define (generate-documentation purpose parameters description errors)
 468   `(*fragment*
 469     (para ,(string-append (string (char-upcase (string-ref purpose 0)))
 470                           (substring purpose 1)
 471                           "."))
 472     ,@(if parameters (sdocbook->stexi parameters) '())
 473     ,@(if description (sdocbook->stexi description) '())
 474     ,@(if errors (sdocbook->stexi errors) '())))
 475
 476 (define (xml->definition xml)
 477   (let ((prototypes (parse-prototypes (xml-funcprototypes xml))))
 478     (and (pair? prototypes)
 479          (make-gl-definition (xml-name xml)
 480                              prototypes
 481                              (generate-documentation (xml-purpose xml)
 482                                                      (xml-parameters xml)
 483                                                      (xml-description xml)
 484                                                      (xml-errors xml))
 485                              (and=> (xml-copyright xml)
 486                                     (lambda (c)
 487                                       `(*fragment* ,@(sdocbook->stexi c))))))))
 488
 489 (define (parse-gl-definitions version)
 490   (filter-map (lambda (file)
 491                 (xml->definition (parse-man-xml version file)))
 492               (xml-files version)))