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-doc)
 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-doc) 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 (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)))
 193                                 prefer-suffix)
 194                  all-names)))
 195
 196   (define (skip? s)
 197     (or
 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")
 201
 202      ;; Skip byte variants if there is a short variant.
 203      (redundant-variant? s "b" "s")
 204
 205      ;; Skip short variants if there is an int variant.
 206      (redundant-variant? s "s" "i")
 207
 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")))
 213
 214   (filter-map
 215    (lambda (sxml)
 216      (match sxml
 217        (('funcprototype ('funcdef return-type ('function (? skip?)))
 218                         . _)
 219         #f)
 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))
 226                         ...)
 227         `(,(string->symbol name)
 228           ,@(map (lambda (pname ptype)
 229                    (list (string->symbol pname)
 230                          (string->gl-type ptype)))
 231                  pname ptype)
 232           -> ,(string->gl-type return-type)))))
 233    sxml))
 234
 235 (define (collapse-fragments nodeset)
 236   (match 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)))
 242     ((elt nodes ...)
 243      (cons elt (collapse-fragments nodes)))
 244     (() '())))
 245
 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)))))))
 251
 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))
 257
 258   (define (inline-command? command)
 259     (not (memq command *sdocbook-block-commands*)))
 260
 261   (define (fhere str accum block cont)
 262     (values (cons str accum)
 263             block
 264             cont))
 265   (define (fdown node accum block cont)
 266     (match node
 267       ((command (and attrs ('% . _)) body ...)
 268        (values body '() '()
 269                (lambda (accum block)
 270                  (values
 271                   `(,command ,attrs ,@(reverse accum))
 272                   block))))
 273       ((command body ...)
 274        (values body '() '()
 275                (lambda (accum block)
 276                  (values
 277                   `(,command ,@(reverse accum))
 278                   block))))))
 279   (define (fup node paccum pblock pcont kaccum kblock kcont)
 280     (call-with-values (lambda () (kcont kaccum kblock))
 281       (lambda (ret block)
 282         (if (inline-command? (car ret))
 283             (values (cons ret paccum) (append kblock pblock) pcont)
 284             (values paccum (append kblock (cons ret pblock)) pcont)))))
 285   (call-with-values
 286       (lambda () (foldts*-values fdown fup fhere sdocbook '() '() #f))
 287     (lambda (accum block cont)
 288       (append (reverse accum)
 289               (reverse block)
 290               ))))
 291
 292 (define *rules*
 293   `((refsect1
 294      *preorder*
 295      . ,(lambda (tag id . body)
 296           (append-map (lambda (nodeset)
 297                         (map
 298                          (lambda (x)
 299                            (pre-post-order x *rules*))
 300                          nodeset))
 301                       (map lift-tables
 302                            (match body
 303                              ((('title _) body ...) body)
 304                              (_ body))))))
 305     (variablelist
 306      ((varlistentry
 307        . ,(lambda (tag term . body)
 308             `(entry (% (heading ,@(cdar term))) ,@(apply append body))))
 309       (listitem
 310        . ,(lambda (tag . body)
 311             (map (lambda (x)
 312                    (if (string? x)
 313                        `(para ,x)
 314                        x))
 315                  body)))
 316       (term
 317        . ,(lambda (tag . rest)
 318             `((itemx ,@rest)))))
 319      . ,(lambda (tag . body)
 320           `(table (% (formatter (asis))) ,@body)))
 321     (trademark
 322      . ,(match-lambda*
 323          ((_ ('@ ('class "copyright"))) '(copyright))))
 324     (parameter
 325      . ,(lambda (tag body)
 326           `(var ,body)))
 327     (type
 328      . ,(lambda (tag body)
 329           `(code ,body)))
 330     (constant
 331      . ,(lambda (tag . body)
 332           `(code . ,body)))
 333     (code
 334      . ,(lambda (tag . body)
 335           `(code . ,body)))
 336     (function
 337      . ,(lambda (tag body . ignored)
 338           (or (null? ignored) (warn "ignored function tail" ignored))
 339           `(code ,body)))
 340     (emphasis
 341      . ,(match-lambda*
 342          ((_) "")
 343          ((_ ('@ ('role "bold")) (and body (? string?)))
 344           `(strong ,(string-trim-both body)))
 345          ((_ ('@ ('role "bold")) . body) `(strong ,@body))
 346          ((_ body) `(var ,body))))
 347     (citerefentry
 348      . ,(lambda (tag contents)
 349           contents))
 350     (refentrytitle
 351      . ,(lambda (tag contents)
 352           `(code ,contents)))
 353     (inlineequation
 354      . ,(lambda (tag contents)
 355           contents))
 356     (informalequation
 357      . ,(lambda (tag contents)
 358           contents))
 359     (informaltable
 360      . ,(lambda (tag attrs tgroup)
 361           tgroup))
 362     (tgroup
 363      ((thead
 364        . ,(lambda (tag . rows)
 365             rows))
 366       (colspec
 367        . ,(lambda _
 368             #f))
 369       (tbody
 370        . ,(lambda (tag . rows)
 371             rows))
 372       (row
 373        . ,(lambda (tag first . rest)
 374             `(entry (% (heading ,@first))
 375                     (para ,@(apply
 376                              append
 377                              (list-intersperse rest '(", ")))))))
 378       (entry
 379        . ,(match-lambda*
 380            ((_) '())
 381            ((_ ('@ . _)) '())
 382            ((_ ('@ . _) x ...) x)
 383            ((_ x ...) x))))
 384      . ,(lambda (tag attrs . contents)
 385           `(table (% (formatter (asis)))
 386                   ,@(apply append (filter identity contents)))))
 387
 388     ;; Poor man's mathml.
 389     (mml:math
 390      . ,(lambda (tag . contents)
 391           `(r . ,(collapse-fragments contents))))
 392     (mml:mn
 393      . ,(lambda (tag n . rest)
 394           (if (pair? rest)
 395               `(*fragment* ,n . ,rest)
 396               n)))
 397     (mml:mi
 398      . ,(case-lambda
 399           ((tag contents)
 400            `(code ,contents))
 401           ((tag attrs contents)
 402            (match attrs
 403              (('@ (mathvariant "italic"))
 404               `(var ,contents))
 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.
 409     (mml:mtable
 410      ((mml:mtr
 411        . ,(lambda (tag . body)
 412             `("(" ,@(list-intersperse body " ") ")")))
 413       (mml:mtd
 414        . ,(match-lambda*
 415            ((tag ('@ . _) body ...)
 416             `(*fragment* ,@body))
 417            ((tag 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) '@))
 422                           (cdr rows)
 423                           rows)))
 424             `(*fragment* ,@(apply append (list-intersperse rows '(", ")))))))
 425     (mml:mspace
 426      . ,(lambda (tag . _)
 427           " "))
 428     (mml:msup
 429      . ,(lambda (tag base exponent)
 430           `(*fragment* ,base "^" ,exponent)))
 431     (mml:msub
 432      . ,(lambda (tag base exponent)
 433           `(*fragment* ,base "_" ,exponent)))
 434     (mml:mover
 435      . ,(lambda (tag base over)
 436           `(*fragment* ,base ,over)))
 437     (mml:munderover
 438      . ,(lambda (tag under base over)
 439           `(*fragment* ,under ,base ,over)))
 440     (mml:mfrac
 441      . ,(lambda (tag num denom)
 442           `(*fragment* ,num "/" ,denom)))
 443     (mml:msqrt
 444      . ,(lambda (tag base)
 445           `(*fragment* "√" ,base)))
 446     (mml:infinity
 447      . ,(lambda (tag)
 448           "∞"))
 449     (mml:mo
 450      . ,(lambda (tag operator)
 451           operator))
 452     (mml:mrow
 453      . ,(lambda (tag . contents)
 454           `(*fragment* . ,contents)))
 455     (mml:mfenced
 456      . ,(lambda (tag attrs left . right)
 457           `(*fragment* ,@(assq-ref attrs 'open)
 458                        ,left
 459                        ","
 460                        ,@right
 461                        ,@(assq-ref attrs 'close))))
 462     (*text*
 463      . ,(lambda (tag text)
 464           text))
 465     ,@*sdocbook->stexi-rules*))
 466
 467 (define (sdocbook->stexi sdocbook)
 468   (pre-post-order sdocbook *rules*))
 469
 470 ;; Produces an stexinfo fragment.
 471 (define (generate-documentation purpose parameters description errors)
 472   `(*fragment*
 473     (para ,(string-append (string (char-upcase (string-ref purpose 0)))
 474                           (substring purpose 1)
 475                           "."))
 476     ,@(if parameters (sdocbook->stexi parameters) '())
 477     ,@(if description (sdocbook->stexi description) '())
 478     ,@(if errors (sdocbook->stexi errors) '())))
 479
 480 (define (xml->definition xml)
 481   (let ((prototypes (parse-prototypes (xml-funcprototypes xml))))
 482     (and (pair? prototypes)
 483          (make-gl-definition (xml-name xml)
 484                              prototypes
 485                              (generate-documentation (xml-purpose xml)
 486                                                      (xml-parameters xml)
 487                                                      (xml-description xml)
 488                                                      (xml-errors xml))
 489                              (and=> (xml-copyright xml)
 490                                     (lambda (c)
 491                                       `(*fragment* ,@(sdocbook->stexi c))))))))
 492
 493 (define (parse-gl-definitions version)
 494   (filter-map (lambda (file)
 495                 (xml->definition (parse-man-xml version file)))
 496               (xml-files version)))