diff options
Diffstat (limited to 'csc/compare.csc')
| -rw-r--r-- | csc/compare.csc | 243 |
1 files changed, 134 insertions, 109 deletions
diff --git a/csc/compare.csc b/csc/compare.csc index fad9e4b..e8e68d3 100644 --- a/csc/compare.csc +++ b/csc/compare.csc @@ -1,25 +1,34 @@ (define-library (csc compare) - (export diff) + (export diff apply-transformer) (import (scheme base) - (only (csc format) fprintf) - (only (csc loop) - loop - return) + (only (scheme write) + display + write) (only (csc strings) - contains - split) - (only (csc vec) - vec - vec-append)) + contains? + split)) (begin ; compare is inspired by Go's cmp.Diff. + (define (print w . xs) + (unless (null? xs) + (let ((x (car xs))) + (if (or (string? x) + (symbol? x)) + (display x w) + (write x w))) + (apply print w (cdr xs)))) + + (define (apply-transformer t x) (if (list? t) - (loop for transformer in t - do (set! x (apply-transformer transformer x)) - finally (return x)) + (let loop ((transformers t) + (x x)) + (if (null? transformers) + x + (loop (cdr transformers) + (apply-transformer (car transformers) x)))) (if ((car t) x) ((cdr t) x) x))) @@ -27,11 +36,13 @@ (define (alist? l) (and (list? l) - (loop for x in l - unless (and (pair? x) - (symbol? (car x))) - return #f - finally (return #t)))) + (let loop ((l l)) + (cond + ((null? l) #t) + ((not (and (pair? (car l)) + (symbol? (caar l)))) + #f) + (else (loop (cdr l))))))) (define (transform x transformers) @@ -57,13 +68,16 @@ (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 ((i 1)) + (when (<= i (vector-length x-vals)) + (let loop-j ((j 1)) + (when (<= j (vector-length y-vals)) + (if (cmp (vector-ref x-vals (- i 1)) (vector-ref y-vals (- j 1))) + (vector-set! table (index i j) (+ 1 (vector-ref table (index (- i 1) (- j 1))))) + (vector-set! table (index i j) (max (vector-ref table (index (- i 1) j)) + (vector-ref table (index i (- j 1)))))) + (loop-j (+ 1 j)))) + (loop-i (+ 1 i)))) (let loop ((i (vector-length x-vals)) (j (vector-length y-vals)) (lcs '())) @@ -79,17 +93,18 @@ (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)) + (print w indent " (\n") + (let ((new-indent (string-append indent " "))) + (for-each (lambda (v) + (pretty w v new-indent)) + x)) + (print w indent " )\n")) ((and (pair? x) (symbol? (car x))) - (fprintf w "{} ({} .\n" indent (car x)) + (print w indent " (" (car x) " .\n") (pretty w (cdr x) (string-append indent " ")) - (fprintf w "{} )\n" indent)) - (else (fprintf w "{} {}\n" indent x)))) + (print w indent " )\n")) + (else (print w indent " " x "\n")))) (define (diff* w x y indent) @@ -101,89 +116,94 @@ (and (string? x) (string? y))) (if (equal? x y) (begin - (fprintf w "{} {}\n" indent x) + (print w indent " " x "\n") #t) (begin - (fprintf w "{}- {}\n{}+ {}\n" indent x indent y) + (print w indent "- " x "\n" indent "+ " y "\n") #f))) ((and (alist? x) (alist? y)) - (fprintf w "{} (\n" indent) + (print w indent " (\n") (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) + (let loop () + (unless (and (null? key-lcs) + (null? x) + (null? y)) + (cond + ((and (null? key-lcs) + (null? x)) + (pretty w (car y) (string-append indent* "+")) + (set! y (cdr y)) + (set! equal #f)) + ((null? key-lcs) + (pretty w (car x) (string-append indent* "-")) + (set! x (cdr x)) + (set! equal #f)) + ((symbol=? (caar x) (caar y) (car key-lcs)) + (print w indent* " (" (car key-lcs) " .\n") + (set! equal (and (diff* w (cdar x) (cdar y) (string-append indent* " ")) + equal)) + (print w indent* " )\n") + (set! x (cdr x)) + (set! y (cdr y)) + (set! key-lcs (cdr key-lcs))) + ((symbol=? (caar x) (car key-lcs)) + (pretty w (car y) (string-append indent* "+")) + (set! y (cdr y)) + (set! equal #f)) + (else + (pretty w (car x) (string-append indent* "-")) + (set! x (cdr x)) + (set! equal #f))) + (loop))) + (print w indent " )\n") equal)) ((and (list? x) (list? y)) - (fprintf w "{} (\n" indent) + (print w indent " (\n") (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) + (let loop () + (unless (and (null? common) + (null? x) + (null? y)) + (cond + ((and (null? common) + (null? x)) + (pretty w (car y) (string-append indent* "+")) + (set! y (cdr y)) + (set! equal #f)) + ((and (null? common) + (null? y)) + (pretty w (car x) (string-append indent* "-")) + (set! x (cdr x)) + (set! equal #f)) + ((null? common) + (diff* w (car x) (car y) indent*) + (set! x (cdr x)) + (set! y (cdr y)) + (set! equal #f)) + ((equal? (car x) (car y)) + (pretty w (car x) (string-append indent* " ")) + (set! x (cdr x)) + (set! y (cdr y)) + (set! common (cdr common))) + ((equal? (car x) (car common)) + (pretty w (car y) (string-append indent* "+")) + (set! y (cdr y)) + (set! equal #f)) + ((equal? (car y) (car common)) + (pretty w (car x) (string-append indent* "-")) + (set! x (cdr x)) + (set! equal #f)) + (else + (diff* w (car x) (car y) indent*) + (set! x (cdr x)) + (set! y (cdr y)) + (set! equal #f))) + (loop))) + (print w indent " )\n") equal)) (else (pretty w x (string-append indent "-")) @@ -195,7 +215,7 @@ (list (cons (lambda (s) (and (string? s) - (contains s "\n"))) + (contains? s "\n"))) (lambda (s) (list (cons '!type 'string) (cons 'value (split s "\n"))))) @@ -204,10 +224,15 @@ (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) - 16))))))))) + (cons 'value (let loop ((i 0) + (acc '())) + (when (< i (bytevector-length b)) + (loop (+ 1 i) + (cons (string-append "0x" (number->string + (bytevector-u8-ref b i) + 16)) + acc))) + (reverse acc)))))))) ; Returns a string diff between x and y. Diff knows how to compare lists, |