26 |
|
|
27 |
;;; Commentary: |
;;; Commentary: |
28 |
|
|
29 |
;; Usage: api-diff alist-file-A alist-file-B |
;; 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 |
;; Read in the alists from files ALIST-FILE-A and ALIST-FILE-B |
32 |
;; and display four lists: old scheme, new scheme, old C, new C. |
;; 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, the (scripts api-diff) module exports |
;; For scheme programming, this module exports the proc: |
|
;; two procedures: |
|
|
;; (diff-alists A-alist B-alist report) |
|
38 |
;; (api-diff A-file B-file) |
;; (api-diff A-file B-file) |
|
;; The latter implements the shell interface using the former. |
|
|
;; REPORT is a proc that takes the above four lists. Its return |
|
|
;; value is returned by `diff-alists'. |
|
39 |
;; |
;; |
40 |
;; Note that the convention is that the "older" alist/file is |
;; Note that the convention is that the "older" alist/file is |
41 |
;; specified first. |
;; specified first. |
42 |
;; |
;; |
43 |
;; TODO: When the annotations support it, also detect/report |
;; TODO: Develop scheme interface. |
|
;; procedure signature, or other simple type, changes. |
|
44 |
|
|
45 |
;;; Code: |
;;; Code: |
46 |
|
|
47 |
(define-module (scripts api-diff) |
(define-module (scripts api-diff) |
48 |
:use-module (ice-9 common-list) |
:use-module (ice-9 common-list) |
49 |
:export (diff-alists api-diff)) |
: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) |
(define (read-alist-file file) |
55 |
(with-input-from-file file |
(with-input-from-file file |
56 |
(lambda () (read)))) |
(lambda () (read)))) |
57 |
|
|
58 |
(define (diff x y) (set-difference (map car x) (map car y))) |
(define put set-object-property!) |
59 |
|
(define get object-property) |
60 |
|
|
61 |
(define (diff-alists A B report) |
(define (read-api-alist-file file) |
62 |
(let* ((A-scheme (assq-ref A 'scheme)) |
(let* ((alist (read-alist-file file)) |
63 |
(A-C (assq-ref A 'C)) |
(meta (assq-ref alist 'meta)) |
64 |
(B-scheme (assq-ref B 'scheme)) |
(interface (assq-ref alist 'interface))) |
65 |
(B-C (assq-ref B 'C)) |
(put interface 'meta meta) |
66 |
(OLD-scheme (diff A-scheme B-scheme)) |
(put interface 'groups (let ((ht (make-hash-table 31))) |
67 |
(NEW-scheme (diff B-scheme A-scheme)) |
(for-each (lambda (group) |
68 |
(OLD-C (diff A-C B-C)) |
(hashq-set! ht group '())) |
69 |
(NEW-C (diff B-C A-C))) |
(assq-ref meta 'groups)) |
70 |
(report OLD-scheme NEW-scheme OLD-C NEW-C))) |
ht)) |
71 |
|
interface)) |
72 |
(define (display-list head ls) |
|
73 |
(format #t ":: ~A -- ~A\n" head (length ls)) |
(define (hang-by-the-roots interface) |
74 |
(for-each (lambda (x) (format #t "~A\n" x)) ls) |
(let ((ht (get interface 'groups))) |
75 |
(newline)) |
(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) |
(define (api-diff . args) |
160 |
(diff-alists (read-alist-file (list-ref args 0)) |
(let* ((p (getopt-long (cons 'api-diff args) |
161 |
(read-alist-file (list-ref args 1)) |
'((details (single-char #\d) |
162 |
(lambda (OLD-scheme NEW-scheme OLD-C NEW-C) |
(value #t)) |
163 |
(display-list "OLD (deleted) scheme" OLD-scheme) |
;; Add options here. |
164 |
(display-list "NEW scheme" NEW-scheme) |
))) |
165 |
(display-list "OLD (deleted) C" OLD-C) |
(rest (option-ref p '() '("/dev/null" "/dev/null"))) |
166 |
(display-list "NEW C" NEW-C)))) |
(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) |
(define main api-diff) |
180 |
|
|