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