PageRenderTime 66ms CodeModel.GetById 28ms app.highlight 31ms RepoModel.GetById 1ms app.codeStats 0ms

/diff.ss

http://github.com/yinwang0/ydiff
Scheme | 827 lines | 565 code | 186 blank | 76 comment | 0 complexity | 09d399bf598d0a8aeb18ca3dcf6523a9 MD5 | raw file
  1;; ydiff - a language-aware tool for comparing programs
  2;; Copyright (C) 2011 Yin Wang (yinwang0@gmail.com)
  3
  4
  5;; This program is free software: you can redistribute it and/or modify
  6;; it under the terms of the GNU General Public License as published by
  7;; the Free Software Foundation, either version 3 of the License, or
  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
 13;; GNU General Public License for more details.
 14
 15;; You should have received a copy of the GNU General Public License
 16;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 17
 18
 19
 20(load "utils.ss")
 21
 22
 23
 24;-------------------------------------------------------------
 25;                      parameters
 26;-------------------------------------------------------------
 27
 28;; The ratio of cost/size that we consider two nodes to be
 29;; "similar", so as to perform a heuristic move (that will
 30;; cut running time by a lot.) But this number should be
 31;; small enough otherwise everything will be considered to
 32;; be moves! Set to a small number for accuracy.
 33(define *move-ratio* 0)
 34
 35
 36;; The minimum size of a node to be considered for moves.
 37;; Shouldn't be too small, otherwise small deletec names
 38;; will appear in a very distant place!
 39(define *move-size* 5)
 40
 41
 42;; How long must a string be in order for us to use string-dist
 43;; function, which is costly when used on long strings but the most
 44;; accurate method to use. Currently this parameter is set to 0,
 45;; effective disables all LCS string comparison. This improves
 46;; performance while not sacrificing accuracy because the algorithm is
 47;; AST based.
 48(define *max-string-len* 0)
 49
 50
 51;; Only memoize the diff of nodes of size larger than this number.
 52;; This effectively reduces memory usage.
 53(define *memo-node-size* 2)
 54
 55
 56
 57
 58
 59;-------------------------------------------------------------
 60;                      data types
 61;-------------------------------------------------------------
 62
 63(struct Change (orig cur cost type) #:transparent)
 64(struct Tag (tag idx start) #:transparent)
 65
 66(define ins?
 67  (lambda (c)
 68    (eq? 'ins (Change-type c))))
 69
 70(define del?
 71  (lambda (c)
 72    (eq? 'del (Change-type c))))
 73
 74(define mod?
 75  (lambda (c)
 76    (eq? 'mod (Change-type c))))
 77
 78
 79
 80;----------------- utils for creating changes ----------------
 81(define ins
 82  (lambda (node)
 83    (let ([size (node-size node)])
 84      (list (Change #f node size 'ins)))))
 85
 86
 87(define del
 88  (lambda (node)
 89    (let ([size (node-size node)])
 90      (list (Change node #f size 'del)))))
 91
 92
 93(define mod
 94  (lambda (node1 node2 cost)
 95    (list (Change node1 node2 cost 'mod))))
 96
 97
 98(define mov
 99  (lambda (node1 node2 cost)
100    (list (Change node1 node2 cost 'mov))))
101
102
103;; create a "total change". (delete node1 and insert node2)
104(define total
105  (lambda (node1 node2)
106    (let ([size1 (node-size node1)]
107          [size2 (node-size node2)])
108      (values (append (del node1) (ins node2))
109              (+ size1 size2)))))
110
111
112(define mod->mov
113  (lambda (c)
114    (match c
115     [(Change node1 node2 cost 'mod)
116      (Change node1 node2 cost 'mov)]
117     [other other])))
118
119
120
121;;------------------ frames utils --------------------
122(define deframe
123  (lambda (node)
124    (match node
125      [(Expr _ _ 'frame elts)
126       (apply append (map deframe elts))]
127     [else (list node)])))
128
129
130(define deframe-change
131  (lambda (change)
132    (cond
133     [(ins? change)
134      (apply append
135             (map ins (deframe (Change-cur change))))]
136     [(del? change)
137      (apply append
138             (map del (deframe (Change-orig change))))]
139     [else (list change)])))
140
141
142(define extract-frame
143  (lambda (node1 node2 type)
144    (match node1
145      [(Expr start1 end1 type1 elts1)
146       (let ([frame-elts (filter (lambda (x)
147                                   (not (eq? x node2)))
148                                 elts1)])
149         (type (Expr start1 start1 'frame frame-elts)))]
150      [_ fatal 'extract-frame "I only accept Expr"])))
151
152
153;; (define n1 (Token "ok" 0 1))
154;; (define n2 (Expr 'ok 0 2 (list n1 (Token "bar" 1 2))))
155;; (map deframe-change (extract-frame n2 n1 ins))
156
157
158
159
160
161
162;------------------ operations on nodes ---------------------
163
164;; "virtual function" - get definition name
165;; can be overridden by individual languages
166(define get-name (lambda (node) #f))
167
168
169;; "virtual function" - get node type
170;; can be overridden by individual languages
171(define get-type
172  (lambda (node)
173    (cond
174     [(Expr? node) (Expr-type node)]
175     [(Token? node) 'token]
176     [(Comment? node) 'comment]
177     [(Str? node) 'str]
178     [(Char? node) 'char])))
179
180
181;; same-def? and different-def? only depend on get-name, so they need
182;; not be overridden by individual languages.
183(define same-def?
184  (lambda (e1 e2)
185    (cond
186     [(not (eq? (get-type e1) (get-type e2)))
187      #f]
188     [else
189      (let ([name1 (get-name e1)]
190            [name2 (get-name e2)])
191        (and name1 name2 (equal? name1 name2)))])))
192
193
194(define different-def?
195  (lambda (e1 e2)
196    (cond
197     [(not (eq? (get-type e1) (get-type e2)))
198      #f]
199     [else
200      (let ([name1 (get-name e1)]
201            [name2 (get-name e2)])
202        (and name1 name2 (not (equal? name1 name2))))])))
203
204
205
206
207;; whether two nodes are similar given the cost
208(define similar?
209  (lambda (node1 node2 c)
210    (<= c (* *move-ratio* (+ (node-size node1)
211                             (node-size node2))))))
212
213
214
215;----------- node size function ------------
216(define *node-size-hash* (make-hasheq))
217
218(define node-size
219  (lambda (node)
220    (define memo
221      (lambda (v)
222        (if (> v 1)
223            (hash-set! *node-size-hash* node v)
224            (void))
225        v))
226    (cond
227     [(pair? node)
228      (apply + (map node-size node))]
229     [(or (Token? node) (Str? node) (Char? node)) 1]
230     [(Expr? node)
231      (cond
232       [(hash-has-key? *node-size-hash* node)
233        (hash-ref *node-size-hash* node)]
234       [else
235        (memo (node-size (Expr-elts node)))])]
236     [else 0])))
237
238
239(define node-depth
240  (lambda (node)
241    (cond
242     [(null? node) 0]
243     [(pair? node)
244      (apply max (map node-depth node))]
245     [(Expr? node)
246      (add1 (node-depth (Expr-elts node)))]
247     [else 0])))
248
249
250; (node-depth (parse-scheme "(lambda (x (x (y)) (y)) x)"))
251
252
253(define uid
254  (let ([count 1]
255        [table (box '())])
256    (lambda (node)
257      (let ([p (assq node (unbox table))])
258        (cond
259         [(not p)
260          (let ([id count])
261            (set! count (add1 count))
262            (set-box! table (cons `(,node . ,id) (unbox table)))
263            id)]
264         [else
265          (cdr p)])))))
266
267
268
269;; similarity string from a change
270(define similarity
271  (lambda (change)
272    (let ([total (+ (node-size (Change-orig change))
273                    (node-size (Change-cur change)))])
274      (cond
275       [(or (= 0 total) (= 0 (Change-cost change)))
276        "100%"]
277       [else
278        (string-append
279         (real->decimal-string
280          (* 100 (- 1.0 (/ (Change-cost change) total))) 1)
281         "%")]))))
282
283
284
285;-------------------------------------------------------------
286;                       diff proper
287;-------------------------------------------------------------
288
289; 2-D memoization table
290(define make-table
291  (lambda (dim1 dim2)
292    (let ([vec (make-vector (add1 dim1))])
293      (let loop ([n 0])
294        (cond
295         [(= n (vector-length vec)) vec]
296         [else
297          (vector-set! vec n (make-vector (add1 dim2) #f))
298          (loop (add1 n))])))))
299
300
301(define table-ref
302  (lambda (t x y)
303    (let ([row (vector-ref t x)])
304      (vector-ref row y))))
305
306
307(define table-set!
308  (lambda (t x y v)
309    (let ([row (vector-ref t x)])
310      (vector-set! row y v))))
311
312
313
314;---------------- string distance function -----------------
315
316;; string distance is no longer used because string=? saffice to
317;; compare strings in ASTs. Retain it here for possible later uses.
318(define string-dist
319  (lambda (s1 s2)
320    (let* ([len1 (string-length s1)]
321           [len2 (string-length s2)]
322           [t (make-table len1 len2)]
323           [char-dist (dist1 t s1 0 s2 0)])
324      (cond
325       [(= 0 (+ len1 len2)) 0]
326       [else
327        (/ (* 2.0 char-dist) (+ len1 len2))]))))
328
329
330(define dist1
331  (lambda (table s1 start1 s2 start2)
332    (define memo
333      (lambda (value)
334        (table-set! table start1 start2 value)
335        value))
336    (cond
337     [(table-ref table start1 start2)
338      => (lambda (cached) cached)]
339     [(= start1 (string-length s1))
340      (memo (- (string-length s2) start2))]
341     [(= start2 (string-length s2))
342      (memo (- (string-length s1) start1))]
343     [else
344      (let* ([c1 (string-ref s1 start1)]
345             [c2 (string-ref s2 start2)]
346             [d0 (cond
347                  [(char=? c1 c2) 0]
348                  [(char=? (char-downcase c1)
349                           (char-downcase c2)) 1]
350                  [else 2])]
351             [d1 (+ d0 (dist1 table s1 (add1 start1) s2 (add1 start2)))]
352             [d2 (+ 1 (dist1 table s1 (add1 start1) s2 start2))]
353             [d3 (+ 1 (dist1 table s1 start1 s2 (add1 start2)))])
354        (memo (min d1 d2 d3)))])))
355
356
357
358
359
360;--------------------- the primary diff function -------------------
361(define diff-node
362  (lambda (node1 node2 move?)
363
364    (define memo
365      (lambda (v1 v2)
366        (and (> (node-size node1) *memo-node-size*)
367             (> (node-size node2) *memo-node-size*)
368             (hash-put! *diff-hash* node1 node2 (cons v1 v2)))
369        (values v1 v2)))
370
371    (define try-extract
372      (lambda (changes cost)
373        (cond
374         [(or (not move?)
375              (similar? node1 node2 cost))
376          (memo changes cost)]
377         [else
378          (letv ([(m c) (diff-extract node1 node2 move?)])
379            (cond
380             [(not m)
381              (memo changes cost)]
382             [else
383              (memo m c)]))])))
384
385
386    (diff-progress 1) ;; progress bar
387
388    (cond
389     [(hash-get *diff-hash* node1 node2)
390      => (lambda (cached)
391           (values (car cached) (cdr cached)))]
392     [(and (Char? node1) (Char? node2))
393      (diff-string (char->string (Char-text node1))
394                   (char->string (Char-text node2))
395                   node1 node2)]
396     [(and (Str? node1) (Str? node2))
397      (diff-string (Str-text node1) (Str-text node2) node1 node2)]
398     [(and (Comment? node1) (Comment? node2))
399      (diff-string (Comment-text node1) (Comment-text node2) node1 node2)]
400     [(and (Token? node1) (Token? node2))
401      (diff-string (Token-text node1) (Token-text node2) node1 node2)]
402     [(and (Expr? node1) (Expr? node2)
403           (eq? (get-type node1) (get-type node2)))
404      (letv ([(m c) (diff-list (Expr-elts node1) (Expr-elts node2) move?)])
405        (try-extract m c))]
406     [(and (pair? node1) (not (pair? node2)))
407      (diff-list node1 (list node2) move?)]
408     [(and (not (pair? node1)) (pair? node2))
409      (diff-list (list node1) node2 move?)]
410     [(and (pair? node1) (pair? node2))
411      (diff-list node1 node2 move?)]
412     [else
413      (letv ([(m c) (total node1 node2)])
414        (try-extract m c))])))
415
416
417
418
419;; helper for nodes with string contents (Str, Comment, Token etc.)
420(define diff-string
421  (lambda (string1 string2 node1 node2)
422    (cond
423     [(or (> (string-length string1) *max-string-len*)
424          (> (string-length string2) *max-string-len*))
425      (cond
426       [(string=? string1 string2)
427        (values (mod node1 node2 0) 0)]
428       [else
429        (total node1 node2)])]
430     [else
431      (let ([cost (string-dist string1 string2)])
432        (values (mod node1 node2 cost) cost))])))
433
434
435
436
437
438;; global 2D hash for storing known diffs
439(define *diff-hash* (make-hasheq))
440
441(define diff-list
442  (lambda (ls1 ls2 move?)
443    (let ([ls1 (sort ls1 node-sort-fn)]
444          [ls2 (sort ls2 node-sort-fn)])
445      (diff-list1 (make-hasheq) ls1 ls2 move?))))
446
447
448(define diff-list1
449  (lambda (table ls1 ls2 move?)
450
451    (define memo
452      (lambda (v1 v2)
453        (hash-put! table ls1 ls2 (cons v1 v2))
454        (values v1 v2)))
455
456    (define guess
457      (lambda (ls1  ls2)
458        (letv ([(m0 c0) (diff-node (car ls1) (car ls2) move?)]
459               [(m1 c1) (diff-list1 table (cdr ls1) (cdr ls2) move?)]
460               [cost1 (+ c0 c1)])
461          (cond
462           [(or (same-def? (car ls1) (car ls2))
463                (and (not (different-def? (car ls1) (car ls2)))
464                     (similar? (car ls1) (car ls2) c0)))
465            (memo (append m0 m1) cost1)]
466           [else
467            (letv ([(m2 c2) (diff-list1 table (cdr ls1) ls2  move?)]
468                   [(m3 c3) (diff-list1 table ls1 (cdr ls2) move?)]
469                   [cost2 (+ c2 (node-size (car ls1)))]
470                   [cost3 (+ c3 (node-size (car ls2)))])
471              (cond
472               [(<= cost2 cost3)
473                (memo (append (del (car ls1)) m2) cost2)]
474               [else
475                (memo (append (ins (car ls2)) m3) cost3)]))]))))
476
477    (cond
478     [(hash-get table ls1 ls2)
479      => (lambda (cached)
480           (values (car cached) (cdr cached)))]
481     [(and (null? ls1) (null? ls2))
482      (values '() 0)]
483     [(null? ls1)
484      (let ([changes (apply append (map ins ls2))])
485        (values changes (node-size ls2)))]
486     [(null? ls2)
487      (let ([changes (apply append (map del ls1))])
488        (values changes (node-size ls1)))]
489     [else
490      (guess ls1 ls2)])))
491
492
493
494
495;; structure extraction
496(define diff-extract
497  (lambda (node1 node2 move?)
498    (cond
499     [(or (< (node-size node1) *move-size*)
500          (< (node-size node2) *move-size*))
501      (values #f #f)]
502     [(and (Expr? node1) (Expr? node2))
503      (cond
504       [(<= (node-size node1) (node-size node2))
505        (let loop ([elts2 (Expr-elts node2)])
506          (cond
507           [(null? elts2) (values #f #f)]
508           [else
509            (letv ([(m0 c0) (diff-node node1 (car elts2)  move?)])
510              (cond
511               [(or (same-def? node1 (car elts2))
512                    (similar? node1 (car elts2) c0))
513                (let ([frame (extract-frame node2 (car elts2) ins)])
514                  (values (append m0 frame) c0))]
515               [else
516                (loop (cdr elts2))]))]))]
517       [else
518        (let loop ([elts1 (Expr-elts node1)])
519          (cond
520           [(null? elts1) (values #f #f)]
521           [else
522            (letv ([(m0 c0) (diff-node (car elts1) node2 move?)])
523              (cond
524               [(or (same-def? (car elts1) node2)
525                    (similar? (car elts1) node2 c0))
526                (let ([frame (extract-frame node1 (car elts1) del)])
527                  (values (append m0 frame) c0))]
528               [else
529                (loop (cdr elts1))]))]))])]
530     [else (values #f #f)])))
531
532
533
534
535
536;-------------------------------------------------------------
537;                    finding moves
538;-------------------------------------------------------------
539
540(define big-node?
541  (lambda (node)
542    (>= (node-size node) *move-size*)))
543
544
545(define big-change?
546  (lambda (c)
547    (cond
548     [(ins? c)
549      (big-node? (Change-cur c))]
550     [(del? c)
551      (big-node? (Change-orig c))]
552     [(mod? c)
553      (or (big-node? (Change-orig c))
554          (big-node? (Change-cur c)))])))
555
556
557(define node-sort-fn
558  (lambda (x y)
559    (let ([name1 (get-name x)]
560          [name2 (get-name y)])
561      (cond
562       [(and name1 name2)
563        (string<? (symbol->string name1)
564                  (symbol->string name2))]
565       [(and name1 (not name2)) #t]
566       [(and (not name1) name2) #f]
567       [else
568        (< (get-start x) (get-start y))]))))
569
570
571
572;; iterate diff-list on the list of changes
573(define closure
574  (lambda (changes)
575    (set! *diff-hash* (make-hasheq))
576    (let loop ([changes changes] [closed '()] [count 1])
577      (printf "~n[closure loop #~a] " count)
578      (letv ([dels (filter (predand del? big-change?) changes)]
579             [adds (filter (predand ins? big-change?) changes)]
580             [rest (set- changes (append dels adds))]
581             [ls1 (sort (map Change-orig dels) node-sort-fn)]
582             [ls2 (sort (map Change-cur adds) node-sort-fn)]
583             [(m c) (diff-list ls1 ls2 #t)]
584             [new-moves (map mod->mov (filter mod? m))])
585        (printf "~n~a new moves found" (length new-moves))
586        (cond
587         [(null? new-moves)
588          (let ([all-changes (append m rest closed)])
589            (apply append (map deframe-change all-changes)))]
590         [else
591          (let ([new-changes (filter (negate mod?) m)])
592            (loop new-changes
593                  (append new-moves rest closed)
594                  (add1 count)))])))))
595
596
597
598
599
600;-------------------------------------------------------------
601;                      HTML generation
602;-------------------------------------------------------------
603
604;----------------- utils ----------------
605(define qs
606  (lambda (x)
607    (let ([x (cond
608              [(symbol? x) (symbol->string x)]
609              [(number? x) (number->string x)]
610              [(string? x) x])])
611      (string-append "'" x "'"))))
612
613
614(define line
615  (lambda (port . s)
616    (display (string-append (apply string-append s) "\n") port)))
617
618
619
620(define change-tags
621  (lambda (changes side)
622    (let loop ([cs changes] [tags '()])
623      (cond
624       [(null? cs) tags]
625       [else
626        (let ([key (if (eq? side 'left)
627                       (Change-orig (car cs))
628                       (Change-cur (car cs)))])
629          (cond
630           [(or (not key)
631                (= (get-start key) (get-end key)))
632            (loop (cdr cs) tags)]
633           [(and (Change-orig (car cs)) (Change-cur (car cs)))
634            (let ([startTag (Tag (link-start (car cs) side)
635                                 (get-start key) -1)]
636                  [endTag (Tag "</a>" (get-end key) (get-start key))])
637              (loop (cdr cs) (cons endTag (cons startTag tags))))]
638           [else
639            (let ([startTag (Tag (span-start (car cs) side)
640                                 (get-start key) -1)]
641                  [endTag (Tag "</span>" (get-end key) (get-start key))])
642              (loop (cdr cs) (cons endTag (cons startTag tags))))]))]))))
643
644
645(define apply-tags
646  (lambda (s tags)
647    (let ([tags (sort tags tag-sort-fn)])
648      (let loop ([tags tags] [curr 0] [out '()])
649        (cond
650         [(null? tags)
651          (cond
652           [(< curr (string-length s))
653            (loop tags (add1 curr) (cons (escape (string-ref s curr)) out))]
654           [else
655            (apply string-append (reverse out))])]
656         [else
657          (cond
658           [(< curr (Tag-idx (car tags)))
659            (loop tags (add1 curr) (cons (escape (string-ref s curr)) out))]
660           [else
661            (loop (cdr tags) curr (cons (Tag-tag (car tags)) out))])])))))
662
663
664
665;; get the CSS class for the change
666(define change-class
667  (lambda (change)
668    (cond
669     [(and (eq? (Change-type change) 'mov)
670           (> (Change-cost change) 0))
671      "mc"]                                     ; move-change
672     [(eq? (Change-type change) 'mov) "m"]      ; move
673     [(> (Change-cost change) 0) "c"]           ; change
674     [else "u"])))                              ; unchanged
675
676
677
678(define link-start
679  (lambda (change side)
680    (let ([cls (change-class change)]
681          [me (if (eq? side 'left)
682                  (Change-orig change)
683                  (Change-cur change))]
684          [other (if (eq? side 'left)
685                     (Change-cur change)
686                     (Change-orig change))])
687      (string-append
688       "<a id="  (qs (uid me))
689       " tid="   (qs (uid other))
690       " class=" (qs cls)
691       ">"))))
692
693
694
695(define span-start
696  (lambda (change side)
697    (let ([cls (if (eq? 'del (Change-type change)) "d" "i")]) ; del or ins
698      (string-append "<span class=" (qs cls) ">"))))
699
700
701
702(define tag-sort-fn
703  (lambda (t1 t2)
704    (cond
705     [(= (Tag-idx t1) (Tag-idx t2))
706      (> (Tag-start t1) (Tag-start t2))]
707     [else
708      (< (Tag-idx t1) (Tag-idx t2))])))
709
710
711(define *escape-table*
712  '((#\"  .   "&quot;")
713    (#\'  .    "&#39;")
714    (#\<  .    "&lt;")
715    (#\>  .    "&gt;")))
716
717
718(define escape
719  (lambda (c)
720    (cond
721     [(assq c *escape-table*) => cdr]
722     [else (char->string c)])))
723
724
725
726; getting the base name of a path/file name
727; (base-name "mk/mk-c.scm") => mk-c
728(define base-name
729  (lambda (fn)
730    (let loop ([i (- (string-length fn) 1)]
731               [start -1]
732               [end (- (string-length fn) 1)])
733      (cond
734       [(= i 0)
735        (substring fn i end)]
736       [(eq? (string-ref fn i) #\.)
737        (loop (sub1 i) start i)]
738       [(eq? (string-ref fn i) #\/)
739        (substring fn (add1 i) end)]
740       [else
741        (loop (sub1 i) start end)]))))
742
743
744
745(define html-header
746  (lambda (port)
747      (line port "<html>")
748      (line port "<head>")
749      (line port "<META http-equiv=\"Content-Type\""
750                      " content=\"text/html; charset=utf-8\">")
751      (line port "<LINK href=\"diff-s.css\""
752                      " rel=\"stylesheet\" type=\"text/css\">")
753      (line port "<script type=\"text/javascript\""
754                        " src=\"nav-div.js\"></script>")
755      (line port "</head>")
756      (line port "<body>")))
757
758
759
760(define html-footer
761  (lambda (port)
762    (line port "</body>")
763    (line port "</html>")))
764
765
766
767(define write-html
768  (lambda (port text side)
769    (line port (string-append "<div id=\"" side "\" class=\"src\">"))
770    (line port "<pre>")
771    (if (string=? side "left")
772        (line port "<a id='leftstart' tid='rightstart'></a>")
773        (line port "<a id='rightstart' tid='leftstart'></a>"))
774    (line port text)
775    (line port "</pre>")
776    (line port "</div>")))
777
778
779
780;; poor man's progress bar
781(define diff-progress
782  (new-progress 10000))
783
784
785
786(define cleanup
787  (lambda ()
788    (set! *node-size-hash* (make-hasheq))
789    (set! *diff-hash* (make-hasheq))))
790
791
792
793;; main command
794;; takes two file names and a parser
795(define diff
796  (lambda (file1 file2 parse)
797    (cleanup)
798    (letv ([start (current-seconds)]
799           [s1 (read-file file1)]
800           [s2 (read-file file2)]
801           [node1 (parse s1)]
802           [node2 (parse s2)]
803           [_ (diff-progress "\nDone parsing")]
804           [(changes cost) (diff-node node1 node2 #f)]
805           [_ (diff-progress "\nDone diffing")]
806           [changes (closure changes)]
807           [_ (diff-progress "\nDone moving")]
808           [_ (set! *diff-hash* (make-hasheq))]
809           [ctags1 (change-tags changes 'left)]
810           [ctags2 (change-tags changes 'right)]
811           [tagged1 (apply-tags s1 ctags1)]
812           [tagged2 (apply-tags s2 ctags2)]
813           [frame-file (string-append (base-name file1) "-"
814                                      (base-name file2) ".html")]
815           [port (open-output-file frame-file
816                                   #:mode 'text
817                                   #:exists 'replace)]
818           [end (current-seconds)])
819      (printf "finished in ~a seconds~n" (- end start))
820
821      (html-header port)
822      (write-html port tagged1 "left")
823      (write-html port tagged2 "right")
824      (html-footer port)
825      (close-output-port port)
826      (cleanup))))
827