#!/usr/bin/guile \
-e "(scripts scan-api)" -s
!#
;;; scan-api --- Scan and group interpreter and libguile interface elements

;; 	Copyright (C) 2002,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: scan-api [-t NM-TYPES] 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).  Elements whose names contain " " (space)
;; are omitted.
;;
;; The default nm types are "B-TV-Z", which selects those symbols that have
;; code "B" through "T" or "V" through "Z".  You can use "--types SPEC" to
;; select another range.  SPEC is a normal regular expression character class,
;; without the surrounding square braces.  For example, "-t BU" would select
;; both symbols in the BSS section, and undefined symbols.
;;
;; Optional GROUPINGS ... specify 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)
;;
;;
;; Usage from a Scheme Program:
;;   (scan-api GUILE NM-TYPES SOFILE GROUPINGS) => (META INTERFACE)
;;
;; The first three args are strings.  GROUPINGS is a (possibly empty) list
;; of filenames.  The return value is a two-element list, composed of the
;; alists described above without the `meta' and `interface' initial symbols
;; (only the fields are included).
;;
;;
;; 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, practitioners 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)
  #:use-module ((ice-9 gumm) #:select (eval-in-current-module-proc))
  #:autoload (scripts PROGRAM) (HVQC-MAIN)
  #:autoload (ice-9 popen) (open-pipe)
  #:autoload (ice-9 rdelim) (read-line)
  #:autoload (ice-9 regex) (string-match 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]+(.+))*$"
        (simple-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 nm-types)
  (scan (string-append "^[0-9a-fA-F]+ ([" nm-types "]) (.+)$")
        (simple-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-EVAL (eval-in-current-module-proc))

(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? (THIS-MODULE-EVAL form))
         (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)))           ; /\__v_\
    (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)
  (simple-format #t ";;; generated by scan-api -- do not edit!\n\n")
  (simple-format #t "(\n")
  (simple-format #t "(meta\n")
  (for-each (lambda (x) (simple-format #t "  ~S\n" x)) meta)
  (simple-format #t ") ;; end of meta\n")
  (simple-format #t "(interface\n")
  (for-each (lambda (x)
              (simple-format #t "(~A ~A (scan-data ~S))\n"
                             x
                             (cons 'groups (get x 'groups))
                             (get x 'scan-data)))
            all)
  (simple-format #t ") ;; end of interface\n")
  (simple-format #t ") ;; eof\n"))

(define (scan-api guile nm-types sofile group-files)
  (let ((grouper (false-if-exception (make-grouper group-files)))
        (ht (make-hash-table #:size 3331))
        (iface #f))                     ; set! later
    (scan-Scheme! ht guile)
    (scan-C!      ht sofile nm-types)
    (scan "(.+)"
          (simple-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)
                  (nm-types . ,nm-types)
                  (groups . ,(append (if grouper
                                         (map (lambda (p) (get p 'name))
                                              (hook->list grouper))
                                         '())
                                     '(Scheme C))))))
      (list meta all))))

(define (scan-api/qop qop)
  (or (< 1 (length (qop '())))
      (error "not enough args, try scan-api --help"))
  (let* ((args (qop '()))
         (meta+all (scan-api (list-ref args 0)
                             (or (qop 'types) "B-TV-Z")
                             (list-ref args 1)
                             (cddr args))))
    (apply spew meta+all)
    #t))

(define (main args)
  (HVQC-MAIN args scan-api/qop
             '(usage . commentary)
             '(package . "Guile")
             `(option-spec (types (single-char #\t) (value #t)
                                  (predicate
                                   ,(lambda (s)
                                      (string-match "^[-A-Za-z]+$" s)))))))

;;; scan-api ends here
