#!/bin/sh
exec ${GUILE-/usr/bin/guile} -e '(scripts scan-api)' -s $0 "$@" # -*- scheme -*-
!#
;;; scan-api --- Scan and group interpreter and libguile interface elements

;; 	Copyright (C) 2002,2003 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., 59 Temple Place, Suite 330,
;; Boston, MA 02111-1307 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: scan-api GUILE SOFILE [GROUPINGS ...]
;;
;; Invoke GUILE, an executable guile interpreter, and use nm(1) on SOFILE, a
;; shared-object library, to determine available interface elements, and
;; display them to stdout as an alist:
;;
;;   ((meta ...) (interface ...))
;;
;; The meta fields are `GUILE_LOAD_PATH', `LTDL_LIBRARY_PATH', `guile'
;; `libguileinterface', `sofile' and `groups'.  The interface elements are in
;; turn sub-alists w/ keys `groups' and `scan-data'.  Interface elements
;; initially belong in one of two groups `Scheme' or `C' (but not both --
;; signal error if that happens).
;;
;; Optional GROUPINGS ... are files each containing a single "grouping
;; definition" alist with each entry of the form:
;;
;;   (NAME (description "DESCRIPTION") (members SYM...))
;;
;; All of the SYM... should be proper subsets of the interface.  In addition
;; to `description' and `members' forms, the entry may optionally include:
;;
;;   (grok USE-MODULES (lambda (x) CODE))
;;
;; where CODE implements a group-membership predicate to be applied to `x', a
;; symbol.  [When evaluated, CODE can assume (use-modules MODULE) has been
;; executed where MODULE is an element of USE-MODULES, a list.  [NOT YET
;; IMPLEMENTED!]]
;;
;; Currently, there are two convenience predicates that operate on `x':
;;   (in-group? x GROUP)
;;   (name-prefix? x PREFIX)
;;
;;
;; Ignorance is Strength ?
;;
;;   There once was a hacker whose righteous pen
;;   Carved thought into progress, named SCM.
;;   Though rough in some places, a recognized gem.
;;   Though initially closed, 1997 was when...
;;
;;   Freedom bestowed!, users w/ conscience crowed.
;;   Now perhaps wisdom of yore can be known and reknowed.
;;   Precious the time creeps, and indeed it quite flowed
;;   As euphoria deadened and years flew, disposed.
;;
;;   Was the gem polished and made to cut through the void?
;;   Was the past remembered and put to good employ?
;;   No, only old disk drives know of the joy.
;;   No, practioners dumped fine art and profaned, unalloyed.
;;
;;   Along comes the archeologist, sharpening tools.
;;   Along comes the criminologist, harping on fools.
;;   Along comes the poet wannabe, avoiding the duels.
;;   But the gem is buried beneath a tonnage of stools.
;;
;;   All is impermanent, the original hacker notes.
;;   So too this spew is what it connotes.
;;   Meaning formed, reformed, sound bytes and quotes.
;;   Love lost and re-cost, the dance of the motes.
;;
;;
;; TODO: Allow for concurrent Scheme/C membership.

;;; Code:

(define-module (scripts scan-api)
  :autoload (scripts PROGRAM) (HVQC-MAIN)
  :autoload (ice-9 popen) (open-pipe)
  :autoload (ice-9 rdelim) (read-line)
  :autoload (ice-9 regex) (match:substring)
  :export (scan-api))

(define put set-object-property!)
(define get object-property)

(define (add-props object . args)
  (let loop ((args args))
    (if (null? args)
        object                          ; retval
        (let ((key (car args))
              (value (cadr args)))
          (put object key value)
          (loop (cddr args))))))

(define (scan re command match)
  (let ((rx (make-regexp re))
        (port (open-pipe command OPEN_READ)))
    (let loop ((line (read-line port)))
      (or (eof-object? line)
          (begin
            (cond ((regexp-exec rx line) => match))
            (loop (read-line port)))))))

(define (scan-Scheme! ht guile)
  (scan "^.guile.+: ([^ \t]+)([ \t]+(.+))*$"
        (format #f "~A -c '~S ~S'"
                guile
                '(use-modules (ice-9 session))
                '(apropos "."))
        (lambda (m)
          (let ((x (string->symbol (match:substring m 1))))
            (put x 'Scheme (or (match:substring m 3)
                               ""))
            (hashq-set! ht x #t)))))

(define (scan-C! ht sofile)
  (scan "^[0-9a-fA-F]+ ([B-TV-Z]) (.+)$"
        (format #f "nm ~A" sofile)
        (lambda (m)
          (let ((x (string->symbol (match:substring m 2))))
            (put x 'C (string->symbol (match:substring m 1)))
            (and (hashq-get-handle ht x)
                 (error "both Scheme and C:" x))
            (hashq-set! ht x #t)))))

(define THIS-MODULE (current-module))

(define (in-group? x group)
  (memq group (get x 'groups)))

(define (name-prefix? x prefix)
  (string-match (string-append "^" prefix) (symbol->string x)))

(define (add-group-name! x name)
  (put x 'groups (cons name (get x 'groups))))

(define (make-grok-proc name form)
  (let* ((predicate? (eval-in-module form THIS-MODULE))
         (p (lambda (x)
              (and (predicate? x)
                   (add-group-name! x name)))))
    (put p 'name name)
    p))

(define (make-members-proc name members)
  (let ((p (lambda (x)
             (and (memq x members)
                  (add-group-name! x name)))))
    (put p 'name name)
    p))

(define (make-grouper files)            ; \/^^^o/ . o
  (let ((hook (make-hook 1)))           ; /\____\
    (for-each
     (lambda (file)
       (for-each
        (lambda (gdef)
          (let ((name (car gdef))
                (members (assq-ref gdef 'members))
                (grok (assq-ref gdef 'grok)))
            (or members grok
                (error "bad grouping, must have `members' or `grok'"))
            (add-hook! hook
                       (if grok
                           (add-props (make-grok-proc name (cadr grok))
                                      'description
                                      (assq-ref gdef 'description))
                           (make-members-proc name members))
                       #t)))            ; append
        (read (open-file file OPEN_READ))))
     files)
    hook))

(define (spew meta all)
  (format #t ";;; generated by scan-api -- do not edit!\n\n")
  (format #t "(\n")
  (format #t "(meta\n")
  (for-each (lambda (x) (format #t "  ~S\n" x)) meta)
  (format #t ") ;; end of meta\n")
  (format #t "(interface\n")
  (for-each (lambda (x)
              (format #t "(~A ~A (scan-data ~S))\n"
                      x
                      (cons 'groups (get x 'groups))
                      (get x 'scan-data)))
            all)
  (format #t ") ;; end of interface\n")
  (format #t ") ;; eof\n"))

(define (scan-api . args)
  (let ((guile (list-ref args 0))
        (sofile (list-ref args 1))
        (grouper (false-if-exception (make-grouper (cddr args))))
        (ht (make-hash-table 3331))
        (iface #f))                     ; set! later
    (scan-Scheme! ht guile)
    (scan-C!      ht sofile)
    (scan "(.+)"
          (format #f "~A -c '(display ~A)'"
                  guile
                  '(assq-ref %guile-build-info
                             'libguileinterface))
          (lambda (m)
            (set! iface (match:substring m 1))))
    (let ((all (sort (hash-fold (lambda (key value prior-result)
                                  (add-props
                                   key
                                   'string (symbol->string key)
                                   'scan-data (or (get key 'Scheme)
                                                  (get key 'C))
                                   'groups (if (get key 'Scheme)
                                               '(Scheme)
                                               '(C)))
                                  (and grouper (run-hook grouper key))
                                  (cons key prior-result))
                                '()
                                ht)
                     (lambda (a b)
                       (string<? (get a 'string)
                                 (get b 'string)))))
          (meta `((GUILE_LOAD_PATH . ,(or (getenv "GUILE_LOAD_PATH") ""))
                  (LTDL_LIBRARY_PATH . ,(or (getenv "LTDL_LIBRARY_PATH") ""))
                  (guile . ,guile)
                  (libguileinterface . ,iface)
                  (sofile . ,sofile)
                  (groups . ,(append (if grouper
                                         (map (lambda (p) (get p 'name))
                                              (hook->list grouper))
                                         '())
                                     '(Scheme C))))))
      (spew meta all)))
  #t)

(define (main args)
  (HVQC-MAIN args (lambda (args)
                    (apply scan-api (cdr args)))
             '(usage . commentary)
             '(package . "Guile")))

;;; scan-api ends here
