guile18/scripts/api-diff

   1 #!/bin/sh
   2 # aside from this initial boilerplate, this is actually -*- scheme -*- code
   3 main='(module-ref (resolve-module '\''(scripts api-diff)) '\'main')'
   4 exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
   5 !#
   6 ;;; api-diff --- diff guile-api.alist files
   7
   8 ;;      Copyright (C) 2002, 2006 Free Software Foundation, Inc.
   9 ;;
  10 ;; This program is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or
  13 ;; (at your option) any later version.
  14 ;;
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19 ;;
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with this software; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301 USA
  24
  25 ;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
  26
  27 ;;; Commentary:
  28
  29 ;; Usage: api-diff [-d GROUPS] ALIST-FILE-A ALIST-FILE-B
  30 ;;
  31 ;; Read in the alists from files ALIST-FILE-A and ALIST-FILE-B
  32 ;; and display a (count) summary of the groups defined therein.
  33 ;; Optional arg "--details" (or "-d") specifies a comma-separated
  34 ;; list of groups, in which case api-diff displays instead the
  35 ;; elements added and deleted for each of the specified groups.
  36 ;;
  37 ;; For scheme programming, this module exports the proc:
  38 ;;  (api-diff A-file B-file)
  39 ;;
  40 ;; Note that the convention is that the "older" alist/file is
  41 ;; specified first.
  42 ;;
  43 ;; TODO: Develop scheme interface.
  44
  45 ;;; Code:
  46
  47 (define-module (scripts api-diff)
  48   :use-module (ice-9 common-list)
  49   :use-module (ice-9 format)
  50   :use-module (ice-9 getopt-long)
  51   :autoload (srfi srfi-13) (string-tokenize)
  52   :export (api-diff))
  53
  54 (define (read-alist-file file)
  55   (with-input-from-file file
  56     (lambda () (read))))
  57
  58 (define put set-object-property!)
  59 (define get object-property)
  60
  61 (define (read-api-alist-file file)
  62   (let* ((alist (read-alist-file file))
  63          (meta (assq-ref alist 'meta))
  64          (interface (assq-ref alist 'interface)))
  65     (put interface 'meta meta)
  66     (put interface 'groups (let ((ht (make-hash-table 31)))
  67                              (for-each (lambda (group)
  68                                          (hashq-set! ht group '()))
  69                                        (assq-ref meta 'groups))
  70                              ht))
  71     interface))
  72
  73 (define (hang-by-the-roots interface)
  74   (let ((ht (get interface 'groups)))
  75     (for-each (lambda (x)
  76                 (for-each (lambda (group)
  77                             (hashq-set! ht group
  78                                         (cons (car x)
  79                                               (hashq-ref ht group))))
  80                           (assq-ref x 'groups)))
  81               interface))
  82   interface)
  83
  84 (define (diff? a b)
  85   (let ((result (set-difference a b)))
  86     (if (null? result)
  87         #f                              ; CL weenies bite me
  88         result)))
  89
  90 (define (diff+note! a b note-removals note-additions note-same)
  91   (let ((same? #t))
  92     (cond ((diff? a b) => (lambda (x) (note-removals x) (set! same? #f))))
  93     (cond ((diff? b a) => (lambda (x) (note-additions x) (set! same? #f))))
  94     (and same? (note-same))))
  95
  96 (define (group-diff i-old i-new . options)
  97   (let* ((i-old (hang-by-the-roots i-old))
  98          (g-old (hash-fold acons '() (get i-old 'groups)))
  99          (g-old-names (map car g-old))
 100          (i-new (hang-by-the-roots i-new))
 101          (g-new (hash-fold acons '() (get i-new 'groups)))
 102          (g-new-names (map car g-new)))
 103     (cond ((null? options)
 104            (diff+note! g-old-names g-new-names
 105                        (lambda (removals)
 106                          (format #t "groups-removed: ~A\n" removals))
 107                        (lambda (additions)
 108                          (format #t "groups-added: ~A\n" additions))
 109                        (lambda () #t))
 110            (for-each (lambda (group)
 111                        (let* ((old (assq-ref g-old group))
 112                               (new (assq-ref g-new group))
 113                               (old-count (and old (length old)))
 114                               (new-count (and new (length new)))
 115                               (delta (and old new (- new-count old-count))))
 116                          (format #t " ~5@A  ~5@A  :  "
 117                                  (or old-count "-")
 118                                  (or new-count "-"))
 119                          (cond ((and old new)
 120                                 (let ((add-count 0) (sub-count 0))
 121                                   (diff+note!
 122                                    old new
 123                                    (lambda (subs)
 124                                      (set! sub-count (length subs)))
 125                                    (lambda (adds)
 126                                      (set! add-count (length adds)))
 127                                    (lambda () #t))
 128                                   (format #t "~5@D ~5@D : ~5@D"
 129                                           add-count (- sub-count) delta)))
 130                                (else
 131                                 (format #t "~5@A ~5@A : ~5@A" "-" "-" "-")))
 132                          (format #t "     ~A\n" group)))
 133                      (sort (union g-old-names g-new-names)
 134                            (lambda (a b)
 135                              (string<? (symbol->string a)
 136                                        (symbol->string b))))))
 137           ((assq-ref options 'details)
 138            => (lambda (groups)
 139                 (for-each (lambda (group)
 140                             (let* ((old (or (assq-ref g-old group) '()))
 141                                    (new (or (assq-ref g-new group) '()))
 142                                    (>>! (lambda (label ls)
 143                                           (format #t "~A ~A:\n" group label)
 144                                           (for-each (lambda (x)
 145                                                       (format #t " ~A\n" x))
 146                                                     ls))))
 147                               (diff+note! old new
 148                                           (lambda (removals)
 149                                             (>>! 'removals removals))
 150                                           (lambda (additions)
 151                                             (>>! 'additions additions))
 152                                           (lambda ()
 153                                             (format #t "~A: no changes\n"
 154                                                     group)))))
 155                           groups)))
 156           (else
 157            (error "api-diff: group-diff: bad options")))))
 158
 159 (define (api-diff . args)
 160   (let* ((p (getopt-long (cons 'api-diff args)
 161                          '((details (single-char #\d)
 162                                     (value #t))
 163                            ;; Add options here.
 164                            )))
 165          (rest (option-ref p '() '("/dev/null" "/dev/null")))
 166          (i-old (read-api-alist-file (car rest)))
 167          (i-new (read-api-alist-file (cadr rest)))
 168          (options '()))
 169     (cond ((option-ref p 'details #f)
 170            => (lambda (groups)
 171                 (set! options (cons (cons 'details
 172                                           (map string->symbol
 173                                                (string-tokenize
 174                                                 groups
 175                                                 #\,)))
 176                                     options)))))
 177     (apply group-diff i-old i-new options)))
 178
 179 (define main api-diff)
 180
 181 ;;; api-diff ends here