X-Git-Url: https://git.hcoop.net/clinton/guile-figl.git/blobdiff_plain/c9e95a8c9a8e2d3e6ccd422d4286f3ff113e2b72..940b3bea6a7d1ac5f388bdb9a402aab94f211f0c:/figl/parse.scm

diff --git a/figl/parse.scm b/figl/parse.scm
index 57e6baf..132615a 100644
--- a/figl/parse.scm
+++ b/figl/parse.scm
@@ -23,15 +23,66 @@
 
 (define-module (figl parse)
   #:use-module (figl config)
+  #:use-module (figl contrib)
   #:use-module (sxml simple)
   #:use-module ((sxml xpath) #:hide (filter))
   #:use-module (sxml transform)
-  #:use-module ((srfi srfi-1) #:select (filter fold))
+  #:use-module (sxml fold)
+  #:use-module ((srfi srfi-1) #:select (filter fold append-map filter-map))
+  #:use-module (srfi srfi-9) ; define-record-type
+  #:use-module (srfi srfi-42) ; eager comprehensions
   #:use-module (texinfo docbook)
-  #:use-module (texinfo plain-text)
   #:use-module (ice-9 ftw)
+  #:use-module (ice-9 rdelim)
   #:use-module (ice-9 match)
-  #:export (fold-gl-definitions))
+  #:use-module (ice-9 regex)
+  #:export (gl-definition?
+            make-gl-definition
+            gl-definition-name
+            gl-definition-prototypes
+            gl-definition-documentation
+            gl-definition-copyright
+            parse-gl-definitions
+
+            gl-enumeration?
+            make-gl-enumeration
+            gl-enumeration-category
+            gl-enumeration-values
+            parse-gl-enumerations
+
+            gl-param-type?
+            make-gl-param-type
+            gl-param-type-type
+            gl-param-type-direction
+            gl-param-type-transfer-type
+            parse-gl-type-map))
+
+(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))
+
+;; values := (name . number) ...
+(define-record-type gl-enumeration
+  (make-gl-enumeration category values)
+  gl-enumeration?
+  (category gl-enumeration-category)
+  (values gl-enumeration-values))
+
+;; Seed of gl-param and more.
+;; TODO: Is this not really gl-type?
+(define-record-type gl-param-type
+  (%make-gl-param-type type direction transfer-type)
+  gl-param-type?
+  (type gl-param-type-type)
+  (direction gl-param-type-direction)
+  (transfer-type gl-param-type-transfer-type))
+
+;; Memoized for eq?, hash, memory usage.
+(define make-gl-param-type (memoize %make-gl-param-type))
 
 (define *namespaces*
   '((mml . "http://www.w3.org/1998/Math/MathML")))
@@ -120,7 +171,7 @@
 
 (define (parse-man-xml version filename)
   (define subdir (format #f "man~A" version))
-  (call-with-input-file (in-vicinity (upstream-man-pages)
+  (call-with-input-file (in-vicinity (upstream-doc)
                                      (in-vicinity subdir filename))
     (lambda (port)
       (zap-whitespace
@@ -130,7 +181,7 @@
 
 (define (xml-files version)
   (define subdir (format #f "man~A" version))
-  (scandir (in-vicinity (upstream-man-pages) subdir)
+  (scandir (in-vicinity (upstream-doc) subdir)
            (lambda (x) (string-suffix? ".xml" x))))
 
 (define (take-first proc)
@@ -144,8 +195,8 @@
 (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")))))))
@@ -156,8 +207,66 @@
 (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
@@ -176,13 +285,59 @@
         (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)
@@ -199,6 +354,9 @@
             `((itemx ,@rest)))))
      . ,(lambda (tag . body)
           `(table (% (formatter (asis))) ,@body)))
+    (trademark
+     . ,(match-lambda*
+         ((_ ('@ ('class "copyright"))) '(copyright))))
     (parameter
      . ,(lambda (tag body)
           `(var ,body)))
@@ -218,6 +376,8 @@
     (emphasis
      . ,(match-lambda*
          ((_) "")
+         ((_ ('@ ('role "bold")) (and body (? string?)))
+          `(strong ,(string-trim-both body)))
          ((_ ('@ ('role "bold")) . body) `(strong ,@body))
          ((_ body) `(var ,body))))
     (citerefentry
@@ -247,16 +407,16 @@
             rows))
       (row
        . ,(lambda (tag first . rest)
-            `(entry (% (heading ,first))
-                    ,@(list-intersperse rest ", "))))
+            `(entry (% (heading ,@first))
+                    (para ,@(apply
+                             append
+                             (list-intersperse rest '(", ")))))))
       (entry
        . ,(match-lambda*
-           ((_) "")
-           ((_ ('@ . _)) "")
-           ((_ ('@ . _) x) x)
-           ((_ ('@ . _) x ...) `(*fragment* ,@x))
-           ((_ x) x)
-           ((_ x ...) `(*fragment* ,@x)))))
+           ((_) '())
+           ((_ ('@ . _)) '())
+           ((_ ('@ . _) x ...) x)
+           ((_ x ...) x))))
      . ,(lambda (tag attrs . contents)
           `(table (% (formatter (asis)))
                   ,@(apply append (filter identity contents)))))
@@ -264,7 +424,7 @@
     ;; Poor man's mathml.
     (mml:math
      . ,(lambda (tag . contents)
-          `(math . ,(collapse-fragments contents))))
+          `(r . ,(collapse-fragments contents))))
     (mml:mn
      . ,(lambda (tag n . rest)
           (if (pair? rest)
@@ -345,37 +505,285 @@
 
 ;; Produces an stexinfo fragment.
 (define (generate-documentation purpose parameters description errors)
-  (string-trim-both
-   (stexi->plain-text
-    `(*fragment*
-      (heading ,purpose)
-      ,@(if parameters (sdocbook->stexi parameters) '())
-      ,@(if description (sdocbook->stexi description) '())
-      ,@(if errors (sdocbook->stexi errors) '())))))
+  `(*fragment*
+    (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)))))
-
-(define (fold-gl-definitions proc version . seeds)
-  (apply
-   values
-   (fold (lambda (file seeds)
-           (let ((xml (parse-man-xml version file)))
-             (call-with-values
-                 (lambda ()
-                   (apply proc
-                          (xml-name xml)
-                          (parse-prototype (xml-prototype xml))
-                          (generate-documentation (xml-purpose xml)
-                                                  (xml-parameters xml)
-                                                  (xml-description xml)
-                                                  (xml-errors xml))
-                          seeds))
-               list)))
-         seeds
-         (xml-files version))))
+  (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)))
+
+(define (trim-comment line)
+  (cond
+   ((string-index line #\#)
+    => (lambda (idx) (substring line 0 idx)))
+   (else line)))
+
+(define (expand-camel-case s)
+  (define (add-humps humps out more?)
+    (match humps
+      (() out)
+      ((head)
+       (if (null? out)
+           humps
+           (cons* head #\- out)))
+      ((head tail ...)
+       (let ((out (if (null? out)
+                      tail
+                      (append tail (cons #\- out)))))
+         (if more?
+             (cons* head #\- out)
+             (cons head out))))))
+  (let lp ((in (string->list s)) (humps '()) (out '()))
+    (match in
+      (()
+       (list->string (reverse (add-humps humps out #f))))
+      ((c in ...)
+       (if (and (char-lower-case? c)
+                ;; Try to keep subtokens like 12x3 in one piece.
+                (or (null? humps)
+                    (not (and-map char-numeric? humps))))
+           (lp in '() (cons c (add-humps humps out #t)))
+           (lp in (cons (char-downcase c) humps) out))))))
+
+(define (mangle-name name)
+  (string->symbol
+   (string-join (map expand-camel-case (string-split name #\_))
+                "-")))
+
+(define (parse-number num)
+  (cond
+   ((equal? "0xFFFFFFFFu" num)
+    #xFFFFFFFF)
+   ((equal? "0xFFFFFFFFFFFFFFFFull" num)
+    #xFFFFFFFFFFFFFFFF)
+   ((string-prefix? "0x" num)
+    (string->number (substring num 2) 16))
+   ((string-prefix? "GL_" num)
+    (cons #f (mangle-name (substring num 3))))
+   ;; Hackety hack...
+   ((string-prefix? "GLX_" num)
+    (cons #f (mangle-name (substring num 4))))
+   (else
+    (string->number num))))
+
+(define (read-line-and-trim-comment port)
+  (let ((line (read-line port)))
+    (if (eof-object? line)
+        line
+        (string-trim-both (trim-comment line)))))
+
+(define (resolve-enumerations enums)
+  ;; We shouldn't fail to resolve anything, but there are a couple bugs
+  ;; in enum.spec currently:
+  ;; http://www.khronos.org/bugzilla/show_bug.cgi?id=787.  Until they
+  ;; are fixed, allow resolution to fail.
+  (define (resolve-value category name value)
+    (match value
+      (#f #f)
+      ((? number?)
+       value)
+      ((#f . (and name (? symbol?)))
+       (resolve-value category name category))
+      ((? symbol?)
+       (resolve-value value name (assq-ref (assq-ref enums value) name)))))
+  (let lp ((in enums) (out '()))
+    (match in
+      (()
+       (reverse out))
+      (((category (name . value) ...) . in)
+       (lp in
+           (cons (make-gl-enumeration
+                  category
+                  (filter-map
+                   (lambda (name value)
+                     (and=> (resolve-value category name value)
+                            (lambda (value)
+                              (cons name value))))
+                   name value))
+                 out))))))
+
+(define (merge-alists in)
+  ;; O(n^2), whee
+  (define (collect-values key values in)
+    (let lp ((in in) (values values))
+      (if (null? in)
+          values
+          (lp (cdr in)
+              (if (eq? (caar in) key)
+                  (append values (cdar in))
+                  values)))))
+  (let lp ((in in) (out '()))
+    (cond
+     ((null? in) (reverse out))
+     ((assq (caar in) out) (lp (cdr in) out))
+     (else (lp (cdr in)
+               (acons (caar in)
+                      (collect-values (caar in) (cdar in) (cdr in))
+                      out))))))
+
+(define (parse-enumerations-from-port port)
+  (define (finish-block headers enums accum)
+    (if (null? enums)
+        accum
+        (fold (lambda (header accum)
+                (acons header (reverse enums) accum))
+              accum
+              headers)))
+  (let lp ((current-headers '()) (current-enums '()) (accum '()))
+    (let ((line (read-line-and-trim-comment port)))
+      (cond
+       ((eof-object? line)
+        (resolve-enumerations
+         (merge-alists
+          (reverse (finish-block current-headers current-enums accum)))))
+       ((string-index line #\:)
+        => (lambda (pos)
+             (let* ((ws (or (string-index-right line char-whitespace? 0 pos) 0))
+                    (headers (filter
+                              (compose not string-null?)
+                              (map string-trim-both
+                                   (string-split (substring line 0 ws) #\,))))
+                    (def (substring line (1+ ws) pos)))
+               (match (cons def headers)
+                 ((or ("define" _ ...)
+                      ((? (lambda (x) (string-suffix? "_future_use" x)))))
+                  (lp '()
+                      '()
+                      (finish-block current-headers current-enums accum)))
+                 (("enum" headers ...)
+                  (if (null? current-enums)
+                      (lp (append current-headers (map mangle-name headers))
+                          current-enums
+                          accum)
+                      (lp (map mangle-name headers)
+                          '()
+                          (finish-block current-headers current-enums accum))))
+                 (x (error "qux." x))))))
+       ((string-null? line)
+        (lp current-headers current-enums accum))
+       (else
+        (match (filter (compose not string-null?)
+                       (string-split (trim-comment line) char-whitespace?))
+          ((enum "=" value)
+           (lp current-headers
+               (acons (mangle-name enum)
+                      (or (parse-number value)
+                          (error "failed to parse" value))
+                      current-enums)
+               accum))
+          (("use" header enum)
+           (lp current-headers
+               (acons (mangle-name enum)
+                      (mangle-name header)
+                      current-enums)
+               accum))
+          (x (error x))))))))
+
+(define (parse-gl-enumerations spec)
+  (call-with-input-file (in-vicinity (upstream-doc)
+                                     (in-vicinity "spec" spec))
+    parse-enumerations-from-port))
+
+
+;;;
+;;; Type Map
+;;;
+
+(define valid-directions '(in out in/out))
+
+(define valid-transfer-types '(array reference value))
+
+(define* (string->directions str #:optional
+                             (expansion valid-directions))
+  (let ((direction (string->symbol str)))
+    (cond
+     ((eq? direction '*)
+      expansion)
+     ((memq direction expansion)
+      (list direction))
+     (else
+      (error "unknown direction" str)))))
+
+(define* (string->transfer-types str #:optional
+                                 (expansion valid-transfer-types))
+  (let ((trans (string->symbol str)))
+    (cond
+     ((eq? trans '*)
+      expansion)
+     ((memq trans expansion)
+      (list trans))
+     (else
+      (error "unknown transfer-type" str)))))
+
+(define (expand-type-map-entry type
+                               direction
+                               transfer-type
+                               mapped-type
+                               mapped-direction
+                               mapped-transfer-type)
+  (let ((type (mangle-name type))
+        (mapped-type (string->gl-type mapped-type)))
+    (list-ec (:list direction (string->directions direction))
+             (:list transfer-type (string->transfer-types transfer-type))
+             (:list mapped-direction
+                    (string->directions mapped-direction
+                                        (list direction)))
+             (:list mapped-transfer-type
+                    (string->transfer-types mapped-transfer-type
+                                            (list transfer-type)))
+             (cons (make-gl-param-type type
+                                       direction
+                                       transfer-type)
+                   (make-gl-param-type mapped-type
+                                       mapped-direction
+                                       mapped-transfer-type)))))
+               
+(define (parse-type-map-from-port port)
+  (define delimiter (make-regexp "[ \t]*,[ \t]*"))
+
+  (let lp ((accum '()))
+    (let ((line (read-line-and-trim-comment port)))
+      (cond
+       ((eof-object? line)
+        (reverse accum))
+       ((string-null? line)
+        (lp accum))
+       (else
+        ;; TODO: Filter needed here to avoid formatting bug:
+        ;; http://www.khronos.org/bugzilla/show_bug.cgi?id=790
+        (match (filter (compose not string-null?)
+                       (string-split line delimiter))
+          ((type direction transfer-type
+            mapped-type mapped-direction mapped-transfer-type)
+           (lp (append (expand-type-map-entry type
+                                              direction
+                                              transfer-type
+                                              mapped-type
+                                              mapped-direction
+                                              mapped-transfer-type)
+                       accum)))
+          (x (error x))))))))
+
+(define (parse-gl-type-map tm)
+  (call-with-input-file (in-vicinity (upstream-doc)
+                                     (in-vicinity "spec" tm))
+    parse-type-map-from-port))