diff options
Diffstat (limited to 'csc/compare.csc')
| -rw-r--r-- | csc/compare.csc | 219 |
1 files changed, 219 insertions, 0 deletions
diff --git a/csc/compare.csc b/csc/compare.csc new file mode 100644 index 0000000..c9716bf --- /dev/null +++ b/csc/compare.csc @@ -0,0 +1,219 @@ +(define-library (csc compare) + (export diff) + (import (scheme base) + (only (csc format) fprintf) + (only (csc loop) + loop + return) + (only (csc match) match) + (only (csc sort) sort) + (only (csc strings) + contains + split) + (only (csc vec) + vec + vec-append)) + (begin + ; compare is inspired by Go's cmp.Diff. + + + (define (apply-transformer t x) + (if (list? t) + (loop for transformer in t + do (set! x (apply-transformer transformer x)) + finally (return x)) + (if ((car t) x) + ((cdr t) x) + x))) + + + (define (alist? l) + (match l + (((key . _) . _) + (symbol? key)) + (_ #f))) + + + (define (transform x transformers) + (define x* (apply-transformer transformers x)) + (cond + ((alist? x*) + (sort (lambda (a b) (string<? (symbol->string (car a)) (symbol->string (car b)))) + (map (lambda (elem) + (cons (car elem) (transform (cdr elem) transformers))) + x*))) + ((list? x*) + (map (lambda (elem) (transform elem transformers)) + x*)) + (else x*))) + + + ; As always, I copied the algorithm from Wikipedia + (define (lcs x y cmp) + (define x-vals (list->vector x)) + (define y-vals (list->vector y)) + (define table (make-vector (* (+ 1 (vector-length x-vals)) (+ 1 (vector-length y-vals))) 0)) + (define (index i j) + (+ j (* i (+ 1 (vector-length y-vals))))) + (loop for i from 1 to (vector-length x-vals) + do (loop for j from 1 to (vector-length y-vals) + if (cmp (vector-ref x-vals (- i 1)) (vector-ref y-vals (- j 1))) + do (vector-set! table (index i j) (+ 1 (vector-ref table (index (- i 1) (- j 1))))) + else + do (vector-set! table (index i j) (max (vector-ref table (index (- i 1) j)) + (vector-ref table (index i (- j 1))))))) + (let loop ((i (vector-length x-vals)) + (j (vector-length y-vals)) + (lcs '())) + (cond + ((or (= 0 i) (= 0 j)) lcs) + ((cmp (vector-ref x-vals (- i 1)) (vector-ref y-vals (- j 1))) + (loop (- i 1) (- j 1) (cons (vector-ref x-vals (- i 1)) lcs))) + ((> (vector-ref table (index i (- j 1))) (vector-ref table (index (- i 1) j))) + (loop i (- j 1) lcs)) + (else (loop (- i 1) j lcs))))) + + + (define (pretty w x indent) + (cond + ((list? x) + (fprintf w "{}(\n" indent) + (loop with new-indent = (string-append indent " ") + for v in x + do (pretty w v new-indent)) + (fprintf w "{})\n" indent)) + ((and (pair? x) + (symbol? (car x))) + (fprintf w "{}({} .\n" indent (car x)) + (pretty w (cdr x) (string-append indent " ")) + (fprintf w "{})\n" indent)) + (else (fprintf w "{}{}\n" indent x)))) + + + (define (diff* w x y indent) + (cond + ((or (and (boolean? x) (boolean? y)) + (and (char? x) (char? y)) + (and (symbol? x) (symbol? y)) + (and (number? x) (number? y)) + (and (string? x) (string? y))) + (if (equal? x y) + (begin + (fprintf w "{} {}\n" indent x) + #t) + (begin + (fprintf w "{}-{}\n{}+{}\n" indent x indent y) + #f))) + ((and (alist? x) (alist? y)) + (fprintf w "{} (\n" indent) + (let ((key-lcs (lcs (map car x) (map car y) symbol=?)) + (indent* (string-append indent " ")) + (equal #t)) + (loop if (null? key-lcs) + if (null? x) + if (null? y) + do (return) + else + do (pretty w (car y) (string-append indent* "+")) + (set! y (cdr y)) + (set! equal #f) + else + do (pretty w (car x) (string-append indent* "-")) + (set! x (cdr x)) + (set! equal #f) + else + if (symbol=? (caar x) (caar y) (car key-lcs)) + do (fprintf w "{} ({} .\n" indent* (car key-lcs)) + (set! equal (and (diff* w (cdar x) (cdar y) (string-append indent* " ")) + equal)) + (fprintf w "{} )\n" indent*) + (set! x (cdr x)) + (set! y (cdr y)) + (set! key-lcs (cdr key-lcs)) + else if (symbol=? (caar x) (car key-lcs)) + do (pretty w (car y) (string-append indent* "+")) + (set! y (cdr y)) + (set! equal #f) + else + do (pretty w (car x) (string-append indent* "-")) + (set! x (cdr x)) + (set! equal #f)) + (fprintf w "{} )\n" indent) + equal)) + ((and (list? x) (list? y)) + (fprintf w "{} (\n" indent) + (let* ((common (lcs x y equal?)) + (indent* (string-append indent " ")) + (equal #t)) + (loop if (null? common) + if (null? x) + if (null? y) + do (return) + else + do (pretty w (car y) (string-append indent* "+")) + (set! y (cdr y)) + (set! equal #f) + else if (null? y) + do (pretty w (car x) (string-append indent* "-")) + (set! x (cdr x)) + (set! equal #f) + else + do (diff* w (car x) (car y) indent*) + (set! x (cdr x)) + (set! y (cdr y)) + (set! equal #f) + else + if (equal? (car x) (car y)) + do (pretty w (car x) (string-append indent* " ")) + (set! x (cdr x)) + (set! y (cdr y)) + (set! common (cdr common)) + else if (equal? (car x) (car common)) + do (pretty w (car y) (string-append indent* "+")) + (set! y (cdr y)) + (set! equal #f) + else if (equal? (car y) (car common)) + do (pretty w (car x) (string-append indent* "-")) + (set! x (cdr x)) + (set! equal #f) + else + do (diff* w (car x) (car y) indent*) + (set! x (cdr x)) + (set! y (cdr y)) + (set! equal #f)) + (fprintf w "{} )\n" indent) + equal)))) + + + (define default-transformers + (list + (cons (lambda (s) + (and (string? s) + (contains s "\n"))) + (lambda (s) + (list (cons 'type 'string) + (cons 'value (split s "\n"))))) + (cons vector? (lambda (v) + (list (cons 'type 'vector) + (cons 'value (vector->list v))))) + (cons bytevector? (lambda (b) + (list (cons 'type 'bytevector) + (cons 'value (loop for i below (bytevector-length b) + collect (string-append "0x" (number->string (bytevector-u8-ref b i)))))))))) + + + ; Returns a string diff between x and y. Diff knows how to compare lists, + ; alists and other primitive types. Any user-defined type needs a + ; transformer. Each transformer is a pair of type predicate that the + ; transformer matches on, and a function that transforms a value of that + ; type into an alist. + ; + ; Potential future enhancements: + ; - support vector and bytevector + ; - split strings into lines + (define (diff x y . transformers) + (define d (open-output-string)) + (define t* (cons default-transformers transformers)) + (if (diff* d (transform x t*) (transform y t*) "") + "" + (get-output-string d))))) |