maint/update-low-level-bindings

   1 #!/usr/bin/env guile
   2 !#
   3
   4 ;;; figl
   5 ;;; Copyright (C) 2013 Andy Wingo <wingo@pobox.com>
   6 ;;;
   7 ;;; Figl is free software: you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU Lesser General Public License as
   9 ;;; published by the Free Software Foundation, either version 3 of the
  10 ;;; License, or (at your option) any later version.
  11 ;;;
  12 ;;; Figl is distributed in the hope that it will be useful, but WITHOUT
  13 ;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  14 ;;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General
  15 ;;; Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU Lesser General Public
  18 ;;; License along with this program.  If not, see
  19 ;;; <http://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22 ;;
  23 ;; Generate low-level Scheme bindings to the GL API.
  24 ;;
  25 ;;; Code:
  26
  27 (use-modules (figl parse)
  28              (figl config)
  29              (ice-9 match)
  30              (sxml fold)
  31              ((srfi srfi-1) #:select (append-map))
  32              (texinfo serialize)
  33              (texinfo plain-text)
  34              (ice-9 pretty-print))
  35
  36 (setlocale LC_ALL "")
  37
  38 (print-disable 'escape-newlines)
  39
  40 (define (list-intersperse src-l elem)
  41   (if (null? src-l) src-l
  42       (let loop ((l (cdr src-l)) (dest (cons (car src-l) '())))
  43         (if (null? l) (reverse dest)
  44             (loop (cdr l) (cons (car l) (cons elem dest)))))))
  45
  46 (define (module-name->scm-name mod-name)
  47   (string-join (list (abs-top-srcdir)
  48                      "figl"
  49                      (symbol->string mod-name)
  50                      "low-level.scm")
  51                "/"))
  52
  53 (define (module-name->texi-name mod-name)
  54   (in-vicinity
  55    (in-vicinity (abs-top-srcdir) "doc")
  56    (string-append "low-level-" (symbol->string mod-name) ".texi")))
  57
  58 (define (unique-copyrights defs)
  59   (let lp ((in defs) (out '()))
  60     (if (null? in)
  61         (reverse out)
  62         (let ((copyright (gl-definition-copyright (car in))))
  63           (lp (cdr in)
  64               (if (or (not copyright) (member copyright out))
  65                   out
  66                   (cons copyright out)))))))
  67
  68 (define (write-scm mod-name defs port)
  69   (display "\
  70 ;;; figl                           -*- mode: scheme; coding: utf-8 -*-
  71 ;;; Copyright (C) 2013 Andy Wingo <wingo@pobox.com>
  72 ;;;
  73 ;;; Figl is free software: you can redistribute it and/or modify it
  74 ;;; under the terms of the GNU Lesser General Public License as
  75 ;;; published by the Free Software Foundation, either version 3 of the
  76 ;;; License, or (at your option) any later version.
  77 ;;;
  78 ;;; Figl is distributed in the hope that it will be useful, but WITHOUT
  79 ;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  80 ;;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General
  81 ;;; Public License for more details.
  82 ;;;
  83 ;;; You should have received a copy of the GNU Lesser General Public
  84 ;;; License along with this program.  If not, see
  85 ;;; <http://www.gnu.org/licenses/>.
  86 ;;;
  87 ;;; Derived from upstream OpenGL documentation.
  88 " port)
  89   (for-each
  90    (lambda (copyright)
  91      (display ";;; " port)
  92      (newline port)
  93      (for-each (lambda (line)
  94                  (display ";;; " port)
  95                  (display line port)
  96                  (newline port))
  97                (string-split
  98                 (string-trim-both (stexi->plain-text copyright))
  99                 #\newline)))
 100    (unique-copyrights defs))
 101   (display "\
 102 ;;;
 103 ;;; Automatically generated; you probably don't want to edit this.  To
 104 ;;; update, run \"make update\" in the top-level build tree.
 105 ;;;
 106 " port)
 107   (newline port)
 108   (pretty-print
 109    `(define-module (figl ,mod-name low-level)
 110       #:use-module (figl ,mod-name runtime)
 111       #:use-module (figl ,mod-name types)
 112       #:export ,(append-map (lambda (def)
 113                               (map car (gl-definition-prototypes def)))
 114                             defs))
 115    port)
 116   (newline port)
 117   (for-each
 118    (lambda (def)
 119      (pretty-print
 120       `(,(symbol-append 'define- mod-name '-procedures)
 121         ,(gl-definition-prototypes def)
 122         ,(string-trim-both
 123           (stexi->plain-text
 124            (gl-definition-documentation def))))
 125       port)
 126      (newline port))
 127    defs))
 128
 129 (define (write-texi mod-name defs port)
 130   (display
 131    (stexi->texi
 132     `(*fragment*
 133       (para "The functions from this section may be had by loading "
 134             "the module:")
 135       (example "(use-modules (figl " ,(object->string mod-name) " low-level)")
 136       (copying
 137        (para
 138         "This section of the manual was derived from the upstream "
 139         "OpenGL documentation.  Each function's documentation has "
 140         "its own copyright statement; for full details, see the "
 141         "upstream documentation.  The copyright notices and licenses "
 142         "present in this section are as follows.")
 143        ,@(append-map cdr (unique-copyrights defs)))
 144       ,@(map
 145          (lambda (def)
 146            (match (gl-definition-prototypes def)
 147              (((name (pname ptype) ... '-> return-type)
 148                (name* (pname* ptype*) ... '-> return-type*)
 149                ...)
 150               `(deftypefun (% (name ,(symbol->string name))
 151                               (data-type ,(symbol->string return-type))
 152                               (arguments ,@(list-intersperse
 153                                             (map symbol->string pname)
 154                                             " ")))
 155                  ,@(map (lambda (name pname ptype return-type)
 156                           `(deftypefunx
 157                              (% (name ,(symbol->string name))
 158                                 (data-type ,(symbol->string return-type))
 159                                 (arguments ,@(list-intersperse
 160                                               (map symbol->string pname)
 161                                               " ")))))
 162                         name* pname* ptype* return-type*)
 163                  ,@(cdr (gl-definition-documentation def))))))
 164          defs)))
 165    port))
 166
 167 (define (write-bindings mod-name defs)
 168   (call-with-output-file (module-name->scm-name mod-name)
 169     (lambda (port)
 170       (write-scm mod-name defs port)))
 171   (call-with-output-file (module-name->texi-name mod-name)
 172     (lambda (port)
 173       (write-texi mod-name defs port))))
 174
 175 (define (partition-definitions version)
 176   (fold-values
 177    (lambda (def gl glu glx)
 178      (cond
 179       ((string-prefix? "glu" (gl-definition-name def))
 180        (values gl (cons def glu) glx))
 181       ((string-prefix? "glX" (gl-definition-name def))
 182        (values gl glu (cons def glx)))
 183       (else
 184        (values (cons def gl) glu glx))))
 185    (parse-gl-definitions version)
 186    '()
 187    '()
 188    '()))
 189
 190 (define* (main arg0 #:optional (version "2"))
 191   (call-with-values
 192       (lambda () (partition-definitions version))
 193     (lambda (gl glu glx)
 194       (write-bindings 'gl (reverse gl))
 195       (write-bindings 'glu (reverse glu))
 196       (write-bindings 'glx (reverse glx)))))
 197
 198 (when (batch-mode?)
 199   (apply main (command-line)))