X-Git-Url: http://git.hcoop.net/clinton/guile-figl.git/blobdiff_plain/09522815a1e0bf2c3a60032c5c665e84134c5e44..1ffce6db96d5eab0a7c906ef87cb5ab0c742680a:/figl/parse.scm

diff --git a/figl/parse.scm b/figl/parse.scm
index 05104e4..a31836f 100644
--- a/figl/parse.scm
+++ b/figl/parse.scm
@@ -23,22 +23,39 @@
 
 (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 (sxml fold)
   #:use-module ((srfi srfi-1) #:select (filter fold append-map filter-map))
-  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9) ; define-record-type
+  #:use-module (srfi srfi-42) ; eager comprehensions
   #:use-module (texinfo docbook)
   #:use-module (ice-9 ftw)
+  #:use-module (ice-9 rdelim)
   #:use-module (ice-9 match)
+  #: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))
+            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)
@@ -48,6 +65,25 @@
   (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")))
 
@@ -135,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
@@ -145,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)
@@ -186,26 +222,30 @@
         ...)
        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).
-     (and (string-suffix? "d" s)
-          (member (string-append (substring s 0 (1- (string-length s))) "f")
-                  all-names))
-     ;; Skip packed accessors like glVertex3fv.
-     (string-suffix? "v" s)
+     (redundant-variant? s "d" "f")
+
      ;; Skip byte variants if there is a short variant.
-     (and (string-suffix? "b" s)
-          (member (string-append (substring s 0 (1- (string-length s))) "s")
-                  all-names))
+     (redundant-variant? s "b" "s")
+
      ;; Skip short variants if there is an int variant.
-     (and (or (string-suffix? "s" s)
-              (string-suffix? "s" s)
-              (string-suffix? "s" s)
-              (string-suffix? "s" s))
-          (member (string-append (substring s 0 (1- (string-length s))) "i")
-                  all-names))))
+     (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)
@@ -490,3 +530,260 @@
   (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
+     ((and (eq? direction '*) expansion)
+      expansion)
+     ((memq direction valid-directions)
+      (list direction))
+     (else
+      (error "unknown direction" str)))))
+
+(define* (string->transfer-types str #:optional
+                                 (expansion valid-transfer-types))
+  (let ((trans (string->symbol str)))
+    (cond
+     ((and (eq? trans '*) expansion)
+      expansion)
+     ((memq trans valid-transfer-types)
+      (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))