diff options
| -rwxr-xr-x | bin/run64 | 102 |
1 files changed, 94 insertions, 8 deletions
diff --git a/bin/run64 b/bin/run64 index ae80e13..9077e84 100755 --- a/bin/run64 +++ b/bin/run64 @@ -20,6 +20,7 @@ (import (rnrs exceptions) (rnrs programs) + (rnrs records syntactic) (srfi srfi-1) (srfi srfi-64) ;; We prefix (chibi match) imports with chibi: so as to not @@ -28,6 +29,11 @@ ;; possible. (prefix (chibi match) chibi:)) +(define-record-type (<highlit> highlit highlit?) + (fields (immutable contents highlit-contents))) + +(define-record-type (<nothing> nothing nothing?)) + (define (assq-ref alist key) (chibi:match (assq key alist) ((_ . value) value) @@ -57,6 +63,19 @@ (define (magenta str) (color 35 str)) +(define (set-color! code) + (display #\esc) + (display #\[) + (display code) + (display #\m)) + +(define (reset-color!) + (display #\esc) + (display "[0m")) + +(define (set-red!) + (set-color! 31)) + (define (make-runner) (let ((runner (test-runner-null))) (test-runner-on-group-begin! runner @@ -122,20 +141,42 @@ given string in an ANSI escape code." ;; Close the list. (display ")"))))) + (define (print-nothing-list-with-opener lst column opener) + ;; <nothing> elements only occur at the end of a list, and must not be + ;; printed. + (print-list-with-opener (take-while (lambda (element) + (test (lambda (element) + (not (nothing? element))) + element)) + lst) + column + opener)) + + (define (test pred obj) + (pred (if (highlit? obj) + (highlit-contents obj) + obj))) + (define (print obj column) (cond + ;; Highlit element + ((highlit? obj) + (set-red!) + (print (highlit-contents obj) + column) + (reset-color!)) ;; Lists ((list? obj) - (print-list-with-opener obj column "(")) + (print-nothing-list-with-opener obj column "(")) ;; Vectors ((vector? obj) - (print-list-with-opener (vector->list obj) column "#(")) + (print-nothing-list-with-opener (vector->list obj) column "#(")) ;; Pairs that are not lists ((pair? obj) - (if (or (vector? (car obj)) - (vector? (cdr obj)) - (list? (car obj)) - (list? (cdr obj))) + (if (or (test vector? (car obj)) + (test vector? (cdr obj)) + (test list? (car obj)) + (test list? (cdr obj))) ;; Print pairs with lists or vectors on several lines. (let ((child-column (+ (string-length "(") column))) @@ -162,6 +203,49 @@ given string in an ANSI escape code." (print obj column) (newline)) +(define (map-longest proc . lists) + "Like @code{map}, but does not stop when the end of the shortest list is reached. +@var{proc} calls beyond the end of shorter lists are passed a @code{<nothing>} +object instead of the list element." + (let ((heads (map (chibi:match-lambda + ((head _ ...) head) + (() (nothing))) + lists)) + (tails (map (chibi:match-lambda + ((_ tail ...) tail) + (() '())) + lists))) + (if (any (lambda (element) + (not (nothing? element))) + heads) + (cons (apply proc heads) + (apply map-longest proc tails)) + (list)))) + +(define (diff obj1 obj2) + "Diff OBJ1 and OBJ2 recursively. Return OBJ1 with differing parts wrapped in a +<highlit> record." + (cond + ;; Lists + ((and (list? obj1) + (list? obj2)) + (map-longest diff obj1 obj2)) + ;; Vectors + ((and (vector? obj1) + (vector? obj2)) + (list->vector (diff (vector->list obj1) + (vector->list obj2)))) + ;; Pairs that are not lists + ((and (pair? obj1) + (pair? obj2)) + (cons (diff (car obj1) (car obj2)) + (diff (cdr obj1) (cdr obj2)))) + ;; Atoms + (else + (if (equal? obj1 obj2) + obj1 + (highlit obj1))))) + (define (main args) (let ((runner (make-runner))) (headline "test session starts" bold) @@ -221,11 +305,13 @@ given string in an ANSI escape code." (else (newline) (display (red "Actual: ")) - (pretty-print (assq-ref failure 'actual-value) + (pretty-print (diff (assq-ref failure 'actual-value) + (assq-ref failure 'expected-value)) (string-length "Actual: ")) (newline) (display (red "Expected: ")) - (pretty-print (assq-ref failure 'expected-value) + (pretty-print (diff (assq-ref failure 'expected-value) + (assq-ref failure 'actual-value)) (string-length "Expected: ")) (newline))))))) (test-runner-aux-value runner)) |