maint/update-low-level-bindings

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