Revert "update upstream sources"

[clinton/guile-figl.git] / maint / update-enumerations

#!/usr/bin/env guile
!#

;;; figl
;;; Copyright (C) 2013 Andy Wingo <wingo@pobox.com>
;;; Copyright (C) 2013 Daniel Hartwig <mandyke@gmail.com>
;;; 
;;; Figl is free software: you can redistribute it and/or modify it
;;; under the terms of the GNU Lesser General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;; 
;;; Figl is distributed in the hope that it will be useful, but WITHOUT
;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
;;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General
;;; Public License for more details.
;;; 
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; Generate Scheme enumerations for the GL API.
;;
;;; Code:

(use-modules (figl parse)
             (figl config)
             (ice-9 match)
             (sxml fold)
             ((srfi srfi-1) #:select (append-map))
             (srfi srfi-69) ; alist->hash-table
             (texinfo serialize)
             (texinfo plain-text)
             (ice-9 pretty-print))

(setlocale LC_ALL "")

(print-disable 'escape-newlines)

(define (list-intersperse src-l elem)
  (if (null? src-l) src-l
      (let loop ((l (cdr src-l)) (dest (cons (car src-l) '())))
        (if (null? l) (reverse dest)
            (loop (cdr l) (cons (car l) (cons elem dest)))))))

(define (module-name->scm-name mod-name)
  (string-join (list (abs-top-srcdir)
                     "figl"
                     (symbol->string mod-name)
                     "enums.scm")
               "/"))

(define (module-name->texi-name mod-name)
  (in-vicinity
   (in-vicinity (abs-top-srcdir) "doc")
   (string-append "low-level-" (symbol->string mod-name) "-enums.texi")))

(define (strip-bit name)
  (let ((str (symbol->string name)))
    (cond
     ((string-suffix? "-bit" str)
      (string->symbol (substring str 0 (- (string-length str) 4))))
     ((string-suffix? "-bits" str)
      (string->symbol (substring str 0 (- (string-length str) 5))))
     (else #f))))

(define type-map-table (make-parameter #f))

(define (use-type-map tm)
  (type-map-table (alist->hash-table tm eq? hashq)))

(define (type-map type)
  (hash-table-ref/default (type-map-table) type #f))

;; TODO: Some guesswork is applied here due to inconsistency between
;; the various .spec and type map files.  Ideally, the type map can
;; determine whether a type is a bitfield or enum.  However, some
;; definitions in enum.spec use a different name to those in gl.spec
;; and gl.tm.  For example, BufferAccessMask is known as
;; ARB_map_buffer_range in enum.spec.
;;
;; Perhaps provide an additional map to translate these odd enum.spec
;; names.

(define (bitfield? enum)
  (let* ((type (make-gl-param-type (gl-enumeration-category enum)
                                   'in
                                   'value))
         (mapped-type (type-map type)))
    (if mapped-type
        (eq? (gl-param-type-type mapped-type) 'GLbitfield)
        ;; otherwise, resort to guesswork
        (and-map (match-lambda ((name . value) (strip-bit name)))
                 (gl-enumeration-values enum)))))

(define (write-scm mod-name enums port)
  (display "\
;;; figl                           -*- mode: scheme; coding: utf-8 -*-
;;; Copyright (C) 2013 Andy Wingo <wingo@pobox.com>
;;; Copyright (C) 2013 Daniel Hartwig <mandyke@gmail.com>
;;;
;;; Figl is free software: you can redistribute it and/or modify it
;;; under the terms of the GNU Lesser General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;; 
;;; Figl is distributed in the hope that it will be useful, but WITHOUT
;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
;;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General
;;; Public License for more details.
;;; 
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this program.  If not, see
;;; <http://www.gnu.org/licenses/>.
;;;
;;; Derived from the API specifications at www.opengl.org/registry/api/.
;;;
;;; Automatically generated; you probably don't want to edit this.  To
;;; update, run \"make update-enums\" in the top-level build tree.
;;;

" port)
  (pretty-print
   `(define-module (figl ,mod-name enums)
      #:use-module (figl runtime)
      #:export ,(map gl-enumeration-category enums))
   port)
  (newline port)
  (for-each
   (lambda (enum)
     (pretty-print
      (if (bitfield? enum)
          `(define-bitfield ,(gl-enumeration-category enum)
             ,@(map (match-lambda
                     ((name . value) (list (or (strip-bit name) name)
                                           value)))
                    (gl-enumeration-values enum)))
          `(define-enumeration ,(gl-enumeration-category enum)
             ,@(map (match-lambda
                     ((name . value) (list name value)))
                    (gl-enumeration-values enum))))
      port)
     (newline port))
   enums))

(define (write-texi mod-name enums port)
  ;; FIXME: stexi->texi seems to have some issues with multiline
  ;; comments, otherwise this notice should appear in the fragment
  ;; itself.  Maybe I am not doing it right.
  (display
   (string-append
    "@c This is part of the Figl Reference Manual.\n"
    "@c Copyright (c) 2013 Andy Wingo and others\n"
    "@c See the file figl.texi for copying conditions.\n")
   port)
  (display
   (stexi->texi
    `(*fragment*
      (para "The functions from this section may be had by loading "
            "the module:")
      (example "(use-modules (figl " ,(object->string mod-name) " enums)")
      ,@(map
         (lambda (enum)
           (if (bitfield? enum)
               `(defmac (% (name ,(symbol->string (gl-enumeration-category enum)))
                           (arguments "bit..."))
                  (para
                   "Bitfield constructor.  The symbolic " (var "bit")
                   " arguments are replaced with their corresponding numeric "
                   "values and combined with " (code "logior") " at "
                   "compile-time.  The symbolic arguments known to this "
                   "bitfield constructor are:")
                  (para
                   ,@(list-intersperse
                      (map (lambda (name)
                             `(code ,(symbol->string (or (strip-bit name)
                                                         name))))
                           (map car (gl-enumeration-values enum)))
                     ", ")
                   "."))
               `(defmac (% (name ,(symbol->string (gl-enumeration-category enum)))
                           (arguments "enum"))
                  (para
                   "Enumerated value.  The symbolic " (var "enum") " argument "
                   "is replaced with its corresponding numeric value at "
                   "compile-time.  The symbolic arguments known to this "
                   "enumerated value form are:")
                  (para
                   ,@(list-intersperse
                      (map (lambda (name) `(code ,(symbol->string name)))
                           (map car (gl-enumeration-values enum)))
                     ", ")
                   "."))))
         enums)))
   port))

(define (write-enumerations mod-name enums)
  (call-with-output-file (module-name->scm-name mod-name)
    (lambda (port)
      (write-scm mod-name enums port)))
  (call-with-output-file (module-name->texi-name mod-name)
    (lambda (port)
      (write-texi mod-name enums port))))

(define* (main arg0)
  (use-type-map (parse-gl-type-map "gl.tm"))
  (write-enumerations 'gl (parse-gl-enumerations "enum.spec"))
  (use-type-map (parse-gl-type-map "glx.tm"))
  (write-enumerations 'glx (parse-gl-enumerations "glxenum.spec")))

(when (batch-mode?)
  (apply main (command-line)))