source: project/release/4/format-textdiff/trunk/format-textdiff.scm @ 14389

Last change on this file since 14389 was 14389, checked in by Ivan Raikov, 11 years ago

format-textdiff ported to Chicken 4

File size: 16.0 KB
Line 
1;;
2;;
3;; Output text diff scripts in different formats.
4;;
5;; Copyright 2007-2009 Ivan Raikov.
6;;
7;;
8;; This program is free software: you can redistribute it and/or modify
9;; it under the terms of the GNU General Public License as published by
10;; the Free Software Foundation, either version 3 of the License, or (at
11;; your option) any later version.
12;;
13;; This program is distributed in the hope that it will be useful, but
14;; WITHOUT ANY WARRANTY; without even the implied warranty of
15;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
16;; General Public License for more details.
17;;
18;; A full copy of the GPL license can be found at
19;; <http://www.gnu.org/licenses/>."))))
20;;
21
22(module format-textdiff
23
24 (export textdiff textdiff->sexp make-format-textdiff)
25                   
26 (import scheme chicken data-structures  )
27
28 (require-extension srfi-1 srfi-4 srfi-13 matchable vector-lib dyn-vector npdiff)
29
30;; pair split
31(define (psplit2 lst) (values (car lst) (cdr lst)))
32
33(define  (textdiff text1 text2 . rest)
34  (let-optionals  rest ((context-len 0))
35    (let ((A   (list->vector text1))
36          (B   (list->vector text2)))
37      ((make-npdiff  string=? vector-ref vector-length 
38                     (make-hunks vector-ref vector-length 
39                                 (compose vector->list vector-copy)))
40       A B context-len))))
41
42
43(define (make-format-textdiff type)
44  (case type
45    ((ed)      edformat)
46    ((normal)  normalformat)
47    ((rcs)     rcsformat)
48    ((context) contextformat)
49    (else (error 'make-format-textdiff "unknown format type " type))))
50
51;;
52;; Generate s-expressions for the patch egg:
53;;
54;; ([c|a|d] start-line finish-line new-start-line new-finish-line (lines to be deleted) (lines to be inserted))
55;;
56;;
57(define (textdiff->sexp hunks)
58
59  (define (format h)
60    (match h
61           (($ diffop 'Insert target source seq)
62            (let-values (((l r)  (psplit2 source)))
63                        `(a ,target ,target ,l ,r ,(list) ,seq)))
64           
65           (($ diffop 'Remove target seq)
66            (let-values (((l r)  (psplit2 target)))
67                        `(d ,(fx+ 1 l) ,r #f #f ,seq ,(list))))
68
69           (($ diffop 'Change target source seqin seqout)
70            (let-values (((l r)  (psplit2 source))
71                         ((l1 r1)  (psplit2 target)))
72                        `(c ,(fx+ 1 l1) ,r1 ,(fx+ 1 l) ,r ,seqout ,seqin)))))
73
74  (map format hunks))
75
76
77
78;; ed script
79(define (edformat out hunks)
80
81  (define (pair->string p)
82    (let-values (((a b) (psplit2 p)))
83      (let ((a (fx+ 1 a)))
84        (if (fx= a b)
85            (number->string a)
86            (conc a "," b)))))
87
88  (define (format-lines lines out)
89    (let ((escape #f))
90      (for-each
91       (lambda (l) 
92         (if (string=? l ".")
93             (begin (set! escape #t)
94                    (display "..\n.\ns/.//\n" out))
95             (display (string-concatenate
96                       (list (if escape
97                                 (begin
98                                   (set! escape #f)
99                                   "a\n") 
100                                 "")
101                             l "\n")) 
102                      out)))
103                lines)))
104                             
105
106  (define (format hs out)
107    (if (not (null? hs))
108        (let ((h  (car hs)))
109          (match h
110                 (($ diffop 'Insert target source seq)
111                  (begin
112                    (display (conc target "a\n") out)
113                    (format-lines seq out)
114                    (display ".\n" out)))
115                 (($ diffop 'Remove target seq)
116                  (begin
117                    (display (pair->string target) out)
118                    (display "d\n" out)))
119                 (($ diffop 'Change target source seqin seqout)
120                  (begin
121                    (display (pair->string target) out)
122                    (display "c\n" out)
123                    (format-lines seqin out)
124                    (display ".\n" out))))
125          (format (cdr hs) out))))
126
127  (format (reverse hunks) out))
128
129;; normal diff format
130(define (normalformat out hunks)
131  (define (pair->string p)
132    (let-values (((a b) (psplit2 p)))
133      (let ((a (fx+ 1 a)))
134        (if (fx= a b)
135            (number->string a)
136            (conc a "," b)))))
137
138  (define (format-lines prefix lines out)
139    (for-each (lambda (l) 
140                (display prefix out)
141                (display l out)
142                (display "\n" out)) lines))
143                             
144  (define (format h n out)
145    (match h
146           (($ diffop 'Insert target source seq)
147            (let-values (((l r)  (psplit2 source)))
148                        (display target out)
149                        (display (string-concatenate 
150                                  (list "a" (pair->string source) "\n")) out)
151                        (format-lines "> " seq out)
152                        (fx+ n (fx- r l))))
153           
154           (($ diffop 'Remove target seq)
155            (let-values (((l r)  (psplit2 target)))
156                        (display (pair->string target) out)
157                        (display "d" out)
158                        (display (fx+ l n) out)
159                        (display "\n" out)
160                        (format-lines "< " seq out)
161                        (fx- n (fx- r l))))
162           
163           (($ diffop 'Change target source seqin seqout)
164            (let-values (((l r)  (psplit2 source))
165                         ((l1 r1)  (psplit2 target)))
166                        (display (string-concatenate 
167                                  (list (pair->string target)  "c" 
168                                        (pair->string source) "\n")) out)
169                        (format-lines "< " seqout out)
170                        (display "---\n" out)
171                        (format-lines "> " seqin out)
172                        (fx- n (fx- (fx- r1 l1) (fx- r l)))))))
173
174  (fold (lambda (h n) (format h n out)) 0 hunks))
175
176
177;; RCS format
178(define (rcsformat out hunks)
179
180  (define (pair->string p)
181    (let-values (((a b) (psplit2 p)))
182      (let ((a (fx+ 1 a)))
183        (if (fx= a b)
184            (number->string a)
185            (conc a "," b)))))
186
187
188  (define (format-lines lines out)
189    (for-each (lambda (l) 
190                (display l out)
191                (display "\n" out)) lines))
192                             
193  (define (format h out)
194    (match h
195           (($ diffop 'Insert target source seq)
196            (let-values (((l r)  (psplit2 source)))
197                        (display (string-concatenate 
198                                  (list "a" (number->string target) " ")) out)
199                        (display (fx- r l) out)
200                        (display "\n" out)
201                        (format-lines seq out)))
202
203           (($ diffop 'Remove target seq)
204            (let-values (((l r)  (psplit2 target)))
205                        (display "d" out)
206                        (display (fx+ 1 l) out)
207                        (display " " out)
208                        (display (fx- r l) out)
209                        (display "\n" out)))
210           
211           (($ diffop 'Change target source seqin seqout)
212            (let-values (((l r)  (psplit2 target))
213                         ((l1 r1)  (psplit2 source)))
214                        (display "d" out)
215                        (display (fx+ 1 l) out)
216                        (display " " out)
217                        (display (fx- r l) out)
218                        (display "\n" out)
219                        (display "a" out)
220                        (display (fx+ l (fx- r l)) out)
221                        (display " " out)
222                        (display (fx- r1 l1) out)
223                        (display "\n" out)
224                        (format-lines seqin out)))))
225
226  (for-each (lambda (h) (format h out)) hunks))
227
228
229;; Context format (patch)
230(define (contextformat out hunks fname1 tstamp1 fname2 tstamp2)
231
232  (define hunkhead  "***************\n")
233  (define fromhead "*** ")
234  (define fromtail " ****\n")
235  (define tohead   "--- ")
236  (define totail   " ----\n")
237
238  (define (pair->string p)
239    (let-values (((a b) (psplit2 p)))
240      (let ((a (fx+ 1 a)))
241        (conc a "," b))))
242 
243  ;; compute the line ranges of context hunks
244  (define (get-target-range h)
245    (match h 
246           (($ diffop 'Insert target source data (before . after))
247            (cons (if before (fx- target (length before)) target) 
248                  (if after (fx+ target (length after)) target)))
249           (($ diffop 'Remove (x . y) data (before . after))
250            (cons (if before (fx- x (length before)) x)
251                  (if after (fx+ y (length after)) y)))
252           (($ diffop 'Change (x . y) source datain dataout contextin (before . after))
253            (cons (if before (fx- x (length before)) x)
254                  (if after (fx+ y (length after)) y)))))
255
256  (define (get-source-range h)
257    (match h 
258           (($ diffop 'Insert target (x . y) data (before . after))
259            (cons (if before (fx- x (length before)) x)
260                  (if after (fx+ y (length after)) y)))
261           (($ diffop 'Remove (x . y) data (before . after))
262            #f)
263           (($ diffop 'Change target (x . y) datain dataout (before . after) contextout)
264            (cons (if before (fx- x (length before)) x)
265                  (if after (fx+ y (length after)) y)))))
266
267
268  ;; converts a hunk to a vector of lines where each line can be
269  ;; prefixed by - + ! or nothing
270  (define (hunk->vector h . rest)
271    (let-optionals rest ((target-vect #f)  (source-vect #f)
272                         (target-range (get-target-range h)) (source-range (get-source-range h))
273                         (target-start #f) (source-start #f))
274      (match h 
275           (($ diffop 'Insert target source data (before . after))
276            (let ((source-vect     (or source-vect (make-dynvector (fx- (cdr source-range) (car source-range)) #f)))
277                  (target-vect     (or target-vect (make-dynvector (fx- after before) #f)))
278                  (source-start    (or source-start 0))
279                  (target-start    (or target-start 0)))
280              (fold (lambda (s i) 
281                      (match (dynvector-ref source-vect i)
282                             ((or #f (#f . _))
283                              (dynvector-set! source-vect i (cons #f s)))
284                             (else (void)))
285                      (fx+ 1 i))
286                    source-start before)
287              (fold (lambda (s i) 
288                      (dynvector-set! source-vect i (cons '+ s)) 
289                      (fx+ 1 i))
290                    (fx+ source-start (length before)) data)
291              (fold (lambda (s i) 
292                      (match (dynvector-ref source-vect i)
293                             ((or #f (#f . _))
294                              (dynvector-set! source-vect i (cons #f s)))
295                             (else (void)))
296                      (fx+ 1 i))
297                    (fx+ source-start (fx+ (length before) (length data))) after)
298
299              (fold (lambda (s i) 
300                      (match (dynvector-ref target-vect i)
301                             ((or #f (#f . _))
302                              (dynvector-set! target-vect i (cons #f s)))
303                             (else (void)))
304                      (fx+ 1 i))
305                    target-start before)
306              (fold (lambda (s i) 
307                      (match (dynvector-ref target-vect i)
308                             ((or #f (#f . _))
309                              (dynvector-set! target-vect i (cons #f s)))
310                             (else (void)))
311                      (fx+ 1 i))
312                    (fx+ target-start (length before)) after)
313             
314              (values source-vect target-vect source-range target-range)))
315               
316           (($ diffop 'Remove (x . y) data (before . after))
317            (let ((vect   (or target-vect (make-dynvector (fx- (cdr target-range) (car target-range)) #f)))
318                  (start  (or target-start 0)))
319              (fold (lambda (s i)
320                      (match (dynvector-ref vect i)
321                             ((or #f (#f . _))
322                              (dynvector-set! vect i (cons #f s)))
323                             (else (void)))
324                      (fx+ 1 i))
325                    start before)
326              (fold (lambda (s i) 
327                      (dynvector-set! vect i (cons '- s))
328                      (fx+ 1 i))
329                    (fx+ start (length before)) data)
330              (fold (lambda (s i) 
331                      (match (dynvector-ref vect i)
332                             ((or #f (#f . _))
333                              (dynvector-set! vect i (cons #f s)))
334                             (else (void)))
335                      (fx+ 1 i))
336                    (fx+ start (fx+ (length data) (length before))) after)
337              (values source-vect vect source-range target-range)))
338           
339           (($ diffop 'Change (x . y) (w . z) datain dataout 
340               (beforein . afterin) (beforeout . afterout))
341            (let ((outvect  (or target-vect (make-dynvector (fx- (cdr target-range) (car target-range)) #f)))
342                  (invect   (or source-vect (make-dynvector (fx- (cdr source-range) (car source-range)) #f)))
343                  (outstart (or target-start 0))
344                  (instart  (or source-start 0)))
345             
346              (fold (lambda (s i) 
347                      (match (dynvector-ref outvect i)
348                             ((or #f (#f . _))
349                              (dynvector-set! outvect i (cons #f s)))
350                             (else (void)))
351                      (fx+ 1 i))
352                    outstart beforeout)
353              (fold (lambda (s i) 
354                      (dynvector-set! outvect i (cons '! s)) 
355                      (fx+ 1 i))
356                    (fx+ outstart (length beforeout)) dataout)
357              (fold (lambda (s i) 
358                      (match (dynvector-ref outvect i)
359                             ((or #f (#f . _))
360                              (dynvector-set! outvect i (cons #f s)))
361                             (else (void)))
362                      (fx+ 1 i))
363                    (fx+ outstart (fx+ (length dataout) (length beforeout))) afterout)
364             
365              (fold (lambda (s i) 
366                      (match (dynvector-ref invect i)
367                             ((or #f (#f . _))
368                              (dynvector-set! invect i (cons #f s)))
369                             (else (void)))
370                      (fx+ 1 i))
371                    instart beforein)
372              (fold (lambda (s i) 
373                      (dynvector-set! invect i (cons '! s)) 
374                          (fx+ 1 i))
375                    (fx+ instart (length beforein)) datain)
376              (fold (lambda (s i) 
377                      (match (dynvector-ref invect i)
378                             ((or #f (#f . _))
379                              (dynvector-set! invect i (cons #f s)))
380                             (else (void)))
381                      (fx+ 1 i))
382                    (fx+ instart (fx+ (length datain) (length beforein))) afterin)
383              (values invect outvect source-range target-range))))))
384
385  ;; checks if hunk ranges overlap or are adjacent
386  (define (adjacent? range1 range2)
387    (and (and range1 range2)
388         (fx>= 0 (fx- (car range2) (cdr range1)))))
389
390  ;; incorporates hunk h into the given source/target vectors
391  (define (merge h target-vect source-vect target-range source-range)
392    (let ((h-target-range (get-target-range h))
393          (h-source-range (get-source-range h)))
394      (hunk->vector h target-vect source-vect 
395                    ;; merge the ranges
396                    (cond ((and target-range h-target-range) 
397                           (cons (car target-range) (max (cdr target-range) (cdr h-target-range))))
398                          (target-range target-range)
399                          (h-target-range h-target-range)
400                          (else (error "context diff merge: invalid target range")))
401                    (cond ((and source-range h-source-range)
402                           (cons (car source-range) (max (cdr source-range) (cdr h-source-range))))
403                          (source-range source-range)
404                          (h-source-range h-source-range)
405                          (else (error "context diff merge: invalid source range")))
406                    ;; determine start index
407                    (and h-target-range target-range
408                         (let ((hx  (car h-target-range))
409                               (x   (car target-range)))
410                           (and (fx> hx x) (fx- hx x))))
411                    (and h-source-range source-range 
412                         (let ((hx  (car h-source-range))
413                               (x   (car source-range)))
414                           (and (fx> hx x) (fx- hx x)))))))
415
416  (define (format source-vect target-vect source-range target-range out)
417    (let ((target-vect-change? 
418           (and target-vect (dynvector-any (lambda (x) (car x)) target-vect)))
419          (source-vect-change? 
420           (and source-vect (dynvector-any (lambda (x) (car x)) source-vect))))
421      (cond ((and source-vect-change? target-vect-change?)
422             ;; change hunk
423             (display hunkhead out)
424             (display fromhead out)
425             (display (pair->string target-range) out)
426             (display fromtail out)
427             (dynvector-for-each (lambda (i l) 
428                                   (if l
429                                       (let ((p (car l)))
430                                         (display (conc (or p " ") " ") out)
431                                         (display (cdr l) out)
432                                         (display "\n" out))
433                                       (display (conc l "\n") out)))
434                                 target-vect)
435             (display tohead out)
436             (display (pair->string source-range) out)
437             (display totail out)
438             (dynvector-for-each (lambda (i l) 
439                                   (if l 
440                                       (let ((p (car l)))
441                                         (display (conc (or p " ") " ") out)
442                                         (display (cdr l) out)
443                                         (display "\n" out))
444                                       (display (conc l "\n") out)))
445                                 source-vect))
446           
447            (target-vect-change?
448             ;; remove hunk
449             (display hunkhead out)
450             (display fromhead out)
451             (display (pair->string target-range) out)
452             (display fromtail out)
453             (dynvector-for-each (lambda (i l) 
454                                   (let ((p (car l)))
455                                     (display (conc (or p " ") " ") out)
456                                     (display (cdr l) out)
457                                     (display "\n" out)))
458                                 target-vect)
459             (display tohead out)
460             (display (and source-range (pair->string source-range)) out)
461             (display totail out))
462
463            (source-vect-change?
464             ;; insert hunk
465             (display hunkhead out)
466             (display fromhead out)
467             (display (pair->string target-range) out)
468             (display fromtail out)
469             (display tohead out)
470             (display (pair->string source-range) out)
471             (display totail out)
472             (dynvector-for-each (lambda (i l) 
473                                   (let ((p (car l)))
474                                     (display (conc (or p " ") " ") out)
475                                     (display (cdr l) out)
476                                     (display "\n" out)))
477                                 source-vect))
478           
479            (else (void)))))
480
481  (display (string-concatenate (list fromhead fname1 " " tstamp1 "\n")) out)
482  (display (string-concatenate (list tohead fname2 " " tstamp2 "\n")) out)
483  (if (not (null? hunks))
484      (let-values (((source-vect target-vect source-range target-range)
485                    (hunk->vector (car hunks))))
486       (let loop ((hunks         (cdr hunks))
487                  (source-vect   source-vect)
488                  (target-vect   target-vect)
489                  (source-range  source-range)
490                  (target-range  target-range))
491        (if (null? hunks)
492            (format source-vect target-vect source-range target-range out)
493            (let* ((h (car hunks))
494                   (h-target-range (get-target-range h)))
495              (if (adjacent? target-range h-target-range)
496                  ;; merge contiguous hunks and recurse
497                  (let-values (((source-vect1 target-vect1 source-range1 target-range1)
498                                (merge h target-vect source-vect target-range source-range)))
499                    (loop (cdr hunks)
500                          source-vect1 target-vect1
501                          source-range1 target-range1))
502                  ;; print current hunk and recurse
503                  (let-values (((source-vect1 target-vect1 source-range1 target-range1)
504                                (hunk->vector h)))
505                      (format source-vect target-vect source-range target-range out)
506                      (loop (cdr hunks) source-vect1 target-vect1 source-range1 target-range1)))))))))
507)
Note: See TracBrowser for help on using the repository browser.