rename upstream-man-pages to upstream-doc

[clinton/guile-figl.git] / figl / parse.scm

diff --git a/figl/parse.scm b/figl/parse.scm
index d966240..558619a 100644 (file)
--- a/figl/parse.scm
+++ b/figl/parse.scm
@@ -26,12 +26,27 @@
   #:use-module (sxml simple)
   #:use-module ((sxml xpath) #:hide (filter))
   #:use-module (sxml transform)
   #: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)

   #:use-module (texinfo docbook)
   #:use-module (texinfo docbook)

-  #:use-module (texinfo serialize)

   #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)

-  #:export (fold-gl-definitions))
+  #:export (gl-definition?
+            make-gl-definition
+            gl-definition-name
+            gl-definition-prototypes
+            gl-definition-documentation
+            gl-definition-copyright
+            parse-gl-definitions))
+
+(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")))
 
 (define *namespaces*
   '((mml . "http://www.w3.org/1998/Math/MathML")))


@@ -120,7 +135,7 @@
 
 (define (parse-man-xml version filename)
   (define subdir (format #f "man~A" version))
 
 (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
                                      (in-vicinity subdir filename))
     (lambda (port)
       (zap-whitespace


@@ -130,7 +145,7 @@
 
 (define (xml-files version)
   (define subdir (format #f "man~A" version))
 
 (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)
            (lambda (x) (string-suffix? ".xml" x))))
 
 (define (take-first proc)


@@ -144,8 +159,8 @@
 (define xml-purpose
   (take-first (sxpath '(refentry refnamediv refpurpose *text*))))
 
 (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-parameters
   (take-first (sxpath '(refentry (refsect1 (@ id (equal? "parameters")))))))


@@ -156,8 +171,66 @@
 (define xml-errors
   (take-first (sxpath '(refentry (refsect1 (@ id (equal? "errors")))))))
 
 (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
 
 (define (collapse-fragments nodeset)
   (match nodeset


@@ -176,13 +249,59 @@
         (if (null? l) (reverse dest)
             (loop (cdr l) (cons (car l) (cons elem dest)))))))
 
         (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
 (define *rules*
   `((refsect1

+     *preorder*

      . ,(lambda (tag id . body)
      . ,(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)
     (variablelist
      ((varlistentry
        . ,(lambda (tag term . body)


@@ -199,6 +318,9 @@
             `((itemx ,@rest)))))
      . ,(lambda (tag . body)
           `(table (% (formatter (asis))) ,@body)))
             `((itemx ,@rest)))))
      . ,(lambda (tag . body)
           `(table (% (formatter (asis))) ,@body)))

+    (trademark
+     . ,(match-lambda*
+         ((_ ('@ ('class "copyright"))) '(copyright))))

     (parameter
      . ,(lambda (tag body)
           `(var ,body)))
     (parameter
      . ,(lambda (tag body)
           `(var ,body)))


@@ -218,6 +340,8 @@
     (emphasis
      . ,(match-lambda*
          ((_) "")
     (emphasis
      . ,(match-lambda*
          ((_) "")

+         ((_ ('@ ('role "bold")) (and body (? string?)))
+          `(strong ,(string-trim-both body)))

          ((_ ('@ ('role "bold")) . body) `(strong ,@body))
          ((_ body) `(var ,body))))
     (citerefentry
          ((_ ('@ ('role "bold")) . body) `(strong ,@body))
          ((_ body) `(var ,body))))
     (citerefentry


@@ -247,16 +371,16 @@
             rows))
       (row
        . ,(lambda (tag first . rest)
             rows))
       (row
        . ,(lambda (tag first . rest)

-            `(entry (% (heading ,first))
-                    ,@(list-intersperse rest ", "))))
+            `(entry (% (heading ,@first))
+                    (para ,@(apply
+                             append
+                             (list-intersperse rest '(", ")))))))

       (entry
        . ,(match-lambda*
       (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)))))
      . ,(lambda (tag attrs . contents)
           `(table (% (formatter (asis)))
                   ,@(apply append (filter identity contents)))))


@@ -264,7 +388,7 @@
     ;; Poor man's mathml.
     (mml:math
      . ,(lambda (tag . contents)
     ;; 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)
     (mml:mn
      . ,(lambda (tag n . rest)
           (if (pair? rest)


@@ -345,36 +469,28 @@
 
 ;; Produces an stexinfo fragment.
 (define (generate-documentation purpose parameters description errors)
 
 ;; Produces an stexinfo fragment.
 (define (generate-documentation purpose parameters description errors)

-  (stexi->texi
-   `(*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)
 
 (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)))