#!/usr/bin/guile \
-e "(scripts generate-METAINFO)" -s
!#
;;; generate-METAINFO --- Display a METAINFO module

;;	Copyright (C) 2003,2004 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or
;; (at your option) any later version.
;;
;; This program 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
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;
;; As a special exception, the Free Software Foundation gives permission
;; for additional uses of the text contained in its release of GUILE.
;;
;; The exception is that, if you link the GUILE library with other files
;; to produce an executable, this does not by itself cause the
;; resulting executable to be covered by the GNU General Public License.
;; Your use of that executable is in no way restricted on account of
;; linking the GUILE library code into it.
;;
;; This exception does not however invalidate any other reasons why
;; the executable file might be covered by the GNU General Public License.
;;
;; This exception applies only to the code released by the
;; Free Software Foundation under the name GUILE.  If you copy
;; code from other Free Software Foundation releases into a copy of
;; GUILE, as the General Public License permits, the exception does
;; not apply to the code that you add in this way.  To avoid misleading
;; anyone as to the status of such modified files, you must delete
;; this exception notice from them.
;;
;; If you write modifications of your own for GUILE, it is your choice
;; whether to permit this exception to apply to your modifications.
;; If you do not wish that, delete this exception notice.

;;; Author: Thien-Thi Nguyen <ttn@gnu.org>

;;; Commentary:

;; Usage: generate-METAINFO [options] PREFIX -- [[-o] KEY VALUE]...
;;
;; Write the text of scheme module (PREFIX METAINFO) to stdout.  Options:
;;
;;  -f, --fullname   -- take PREFIX as full module name, do not add suffix
;;  -p, --procname P -- use P for the exported procedure name [METAINFO]
;;
;; The generated module exports a procedure that given KEY, returns VALUE
;; (normally a string), or #f if no such KEY exists.  KEY can be a symbol,
;; string or keyword; matching is case-insensitive.  Additionally, the
;; special key #t returns a list of available keys.  The special token "-o"
;; means to save the VALUE as an object (its string representation from the
;; command-line is `read' first) rather than as a string.  For example, the
;; invocation (note quotes to protect from the shell):
;;
;;   generate-METAINFO "(my stuff)" -- version 3.1415 creator jrhacker
;;
;; displays the following text (reformatted for legibility):
;;
;;   (define-module (my stuff METAINFO) #:export (METAINFO))
;;   (define (dsym obj) ...)
;;   (define (METAINFO key)
;;     (if (eq? #t key)
;;         '(version creator)
;;         (assq-ref `((version . "3.1415")
;;                     (creator . "jrhacker"))
;;                   (dsym key))))
;;
;; If we instead specify `-o version 3.1415' on the command line then the
;; first pair of the alist becomes `(version . 3.1415)'.  The quasiquote
;; is to handle cases where the value is not a string, character or number
;; (for example, a procedure object); these values preceded by a comma.
;;
;;
;; Usage from a Scheme program:
;;
;;  (generate-METAINFO module-name proc-name alist) => string
;;
;; MODULE-NAME is a list of symbols, the complete name of the module (no
;; suffix added).  PROC-NAME is a symbol.  ALIST keys are downcased and made
;; into symbols, and the values are saved by `write'.  The return value is
;; the same text that would have been sent to stdout in a shell invocation.

;;; Code:

(define-module (scripts generate-METAINFO)
  #:autoload (scripts PROGRAM) (HVQC-MAIN)
  #:export (generate-METAINFO))

(define (dsym obj)
  (string->symbol
   (string-downcase
    (begin (and (keyword? obj) (set! obj (keyword->symbol obj)))
           (and (symbol? obj)  (set! obj (symbol->string obj)))
           obj))))

(define (generate-METAINFO module-name proc-name alist)
  (let ((clean (map (lambda (pair)
                     (cons (dsym (car pair)) (cdr pair)))
                   alist)))
    (with-output-to-string
      (lambda ()
        (display ";;; created by generate-METAINFO --- editing is unwise!\n")
        (for-each
         (lambda (x) (write x) (newline))
         `((define-module ,module-name #:export (,proc-name))
           (define (dsym obj) ,@(cddr (procedure-source dsym)))
           (define (,proc-name key)
             (if (eq? #t key)
                 ',(map car clean)
                 (assq-ref (,'quasiquote
                            ,(map (lambda (pair)
                                    (cons (car pair)
                                          (let ((val (cdr pair)))
                                            (if (or (string? val)
                                                    (char? val)
                                                    (number? val))
                                                val
                                                (list 'unquote val)))))
                                  clean))
                           (dsym key))))))))))

(define (generate-METAINFO/qop qop)
  (define (badness!)
    (error "try: generate-METAINFO --help"))
  (or (< 2 (length (qop '())))
      (badness!))
  (display
   (generate-METAINFO
    (let ((syms (with-input-from-string (car (qop '())) read)))
      (or (list? syms)
          (badness!))
      (if (qop 'fullname)
          syms
          (append syms '(METAINFO))))
    (or (qop 'procname string->symbol) 'METAINFO)
    (let loop ((ls (cdr (qop '()))) (acc '()))
      (cond ((null? ls)
             (reverse acc))
            ((pair? (cdr ls))
             (if (string=? "-o" (car ls))
                 (loop (cdddr ls)
                       (acons (cadr ls)
                              (with-input-from-string (caddr ls) read)
                              acc))
                 (loop (cddr ls)
                       (acons (car ls)
                              (cadr ls)
                              acc))))
            (else
             (badness!)))))))

(define (main args)
  (HVQC-MAIN args generate-METAINFO/qop
             '(usage . commentary)
             '(package . "Guile")
             '(option-spec (fullname (single-char #\f))
                           (procname (single-char #\p) (value #t)))))

;;; generate-METAINFO ends here
