maint/update-enumerations

   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                      "enums.scm")
  28                "/"))
  29
  30 #;
  31 (define (module-name->texi-name mod-name)
  32   (in-vicinity
  33    (in-vicinity (abs-top-srcdir) "doc")
  34    (string-append "low-level-" (symbol->string mod-name) ".texi")))
  35
  36 (define (write-scm mod-name enums port)
  37   (display "\
  38 ;;; figl                           -*- mode: scheme; coding: utf-8 -*-
  39 ;;; Copyright (C) 2013 Andy Wingo <wingo@pobox.com>
  40 ;;;
  41 ;;; Figl is free software: you can redistribute it and/or modify it
  42 ;;; under the terms of the GNU Lesser General Public License as
  43 ;;; published by the Free Software Foundation, either version 3 of the
  44 ;;; License, or (at your option) any later version.
  45 ;;;
  46 ;;; Figl is distributed in the hope that it will be useful, but WITHOUT
  47 ;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  48 ;;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General
  49 ;;; Public License for more details.
  50 ;;;
  51 ;;; You should have received a copy of the GNU Lesser General Public
  52 ;;; License along with this program.  If not, see
  53 ;;; <http://www.gnu.org/licenses/>.
  54 ;;;
  55 ;;; Derived from the API specifications at www.opengl.org/registry/api/.
  56 ;;;
  57 ;;; Automatically generated; you probably don't want to edit this.  To
  58 ;;; update, run \"make update-enums\" in the top-level build tree.
  59 ;;;
  60
  61 " port)
  62   (pretty-print
  63    `(define-module (figl ,mod-name enums)
  64       #:use-module (figl runtime)
  65       #:export ,(map gl-enumeration-category enums))
  66    port)
  67   (newline port)
  68   (for-each
  69    (lambda (enum)
  70      (define (strip-bit name)
  71        (let ((str (symbol->string name)))
  72          (cond
  73           ((string-suffix? "-bit" str)
  74            (string->symbol (substring str 0 (- (string-length str) 4))))
  75           ((string-suffix? "-bits" str)
  76            (string->symbol (substring str 0 (- (string-length str) 5))))
  77           (else #f))))
  78      (define (bitfield? enum)
  79        (and-map (match-lambda ((name . value) (strip-bit name)))
  80                 (gl-enumeration-values enum)))
  81      (pretty-print
  82       (if (bitfield? enum)
  83           `(define-bitfield ,(gl-enumeration-category enum)
  84              ,@(map (match-lambda
  85                      ((name . value) (list (strip-bit name) value)))
  86                     (gl-enumeration-values enum)))
  87           `(define-enumeration ,(gl-enumeration-category enum)
  88              ,@(map (match-lambda
  89                      ((name . value) (list name value)))
  90                     (gl-enumeration-values enum))))
  91       port)
  92      (newline port))
  93    enums))
  94
  95 #;
  96 (define (write-texi mod-name defs port)
  97   (display
  98    (stexi->texi
  99     `(*fragment*
 100       (para "The functions from this section may be had by loading "
 101             "the module:")
 102       (example "(use-modules (figl " ,(object->string mod-name) " low-level)")
 103       (copying
 104        (para
 105         "This section of the manual was derived from the upstream "
 106         "OpenGL documentation.  Each function's documentation has "
 107         "its own copyright statement; for full details, see the "
 108         "upstream documentation.  The copyright notices and licenses "
 109         "present in this section are as follows.")
 110        ,@(append-map cdr (unique-copyrights defs)))
 111       ,@(map
 112          (lambda (def)
 113            (match (gl-definition-prototypes def)
 114              (((name (pname ptype) ... '-> return-type)
 115                (name* (pname* ptype*) ... '-> return-type*)
 116                ...)
 117               `(deftypefun (% (name ,(symbol->string name))
 118                               (data-type ,(symbol->string return-type))
 119                               (arguments ,@(list-intersperse
 120                                             (map symbol->string pname)
 121                                             " ")))
 122                  ,@(map (lambda (name pname ptype return-type)
 123                           `(deftypefunx
 124                              (% (name ,(symbol->string name))
 125                                 (data-type ,(symbol->string return-type))
 126                                 (arguments ,@(list-intersperse
 127                                               (map symbol->string pname)
 128                                               " ")))))
 129                         name* pname* ptype* return-type*)
 130                  ,@(cdr (gl-definition-documentation def))))))
 131          defs)))
 132    port))
 133
 134 (define (write-enumerations mod-name enums)
 135   (call-with-output-file (module-name->scm-name mod-name)
 136     (lambda (port)
 137       (write-scm mod-name enums port)))
 138   #;
 139   (call-with-output-file (module-name->texi-name mod-name)
 140     (lambda (port)
 141       (write-texi mod-name enums port))))
 142
 143 (define* (main arg0)
 144   (write-enumerations 'gl (parse-gl-enumerations "enum.spec")))
 145
 146 (when (batch-mode?)
 147   (apply main (command-line)))