From 614ff235fcd846786aa95ed7bbafc24e60c10d1e Mon Sep 17 00:00:00 2001 From: John Clements Date: Mon, 27 Aug 2012 13:35:24 -0700 Subject: [PATCH] remove dependencies on mz-testing.rkt --- collects/stepper/private/lifting.rkt | 137 ++++++++++++++------------- collects/tests/utils/sexp-diff.rkt | 53 +++++------ 2 files changed, 91 insertions(+), 99 deletions(-) diff --git a/collects/stepper/private/lifting.rkt b/collects/stepper/private/lifting.rkt index 913e119171..466df5d1d5 100644 --- a/collects/stepper/private/lifting.rkt +++ b/collects/stepper/private/lifting.rkt @@ -159,46 +159,50 @@ ; TESTING: - (define-syntax (test-begin stx) - (syntax-case stx () - [(_ expr ...) - ;#'(begin expr ...) ; testing version - #'(void) ; non-testing version - ])) - (define (datum-ize-context-record cr) (list (syntax->datum (context-record-stx cr)) (context-record-index cr) (context-record-kind cr))) - (test-begin (require tests/utils/mz-testing)) - - (test-begin (SECTION 'stepper-lifting)) - - (test-begin - ; TEST OF FIND-HIGHLIGHT - - - (define test-datum (expand (car (build-stx-with-highlight - `((define (f x) (letrec ([a (lambda (x) (b (- x 1)))] - [b (lambda (x) ((hilite a) x))]) - (a x)))))))) - - (define expected (list (list `(#%app a x) '(1) 'expr) - (list `(lambda (x) (#%app a x)) '(2) 'expr) - (list `(letrec-values ([(a) (lambda (x) (#%app b (#%app (#%top . -) x (quote 1))))] [(b) (lambda (x) (#%app a x))]) (#%app a x)) '(1 1 1) 'expr) - (list `(lambda (x) (letrec-values ([(a) (lambda (x) (#%app b (#%app (#%top . -) x (quote 1))))] [(b) (lambda (x) (#%app a x))]) (#%app a x))) '(2) 'expr) - (list `(define-values (f) (lambda (x) (letrec-values ([(a) (lambda (x) (#%app b (#%app (#%top . -) x (quote 1))))] [(b) (lambda (x) (#%app a x))]) (#%app a x)))) '(2) - 'general-top-level))) - - (match-let* ([(vector context-records highlight) (find-highlight test-datum)]) - (test expected map datum-ize-context-record context-records)) - - - (test null (lambda () - (match-let* ([(vector context-records dc) - (find-highlight (car (build-stx-with-highlight `((hilite foo)))))]) - context-records)))) + (module+ test + (require rackunit) + + ; TEST OF FIND-HIGHLIGHT + + (let () + (define test-datum + (with-syntax ([hilite-a + (stepper-syntax-property + #'a + 'stepper-highlight + #t)]) + (expand #`(define (f x) (letrec ([a (lambda (x) (b (- x 1)))] + [b (lambda (x) (hilite-a x))]) + (a x)))))) + + (define expected + (list (list `(#%app a x) '(1) 'expr) + (list `(lambda (x) (#%app a x)) '(2) 'expr) + (list `(letrec-values ([(a) (lambda (x) (#%app b (#%app - x (quote 1))))] [(b) (lambda (x) (#%app a x))]) (#%app a x)) '(1 1 1) 'expr) + (list `(lambda (x) (letrec-values ([(a) (lambda (x) (#%app b (#%app - x (quote 1))))] [(b) (lambda (x) (#%app a x))]) (#%app a x))) '(2) 'expr) + (list `(define-values (f) (lambda (x) (letrec-values ([(a) (lambda (x) (#%app b (#%app - x (quote 1))))] [(b) (lambda (x) (#%app a x))]) (#%app a x)))) '(2) + 'general-top-level))) + + (match-define (vector context-records highlight) + (find-highlight test-datum)) + + (check-equal? (map datum-ize-context-record context-records) + expected)) + + (let () + (define test-stx (stepper-syntax-property + #'foo + 'stepper-highlight + #t)) + + (match-define (vector context-records dc) (find-highlight test-stx)) + + (check-equal? context-records null))) ; substitute-in-syntax takes a syntax expression (which must be a proper syntax list) and a path ; (represented by a list of numbers) and a syntax-expression to insert. If the path is null, the @@ -229,12 +233,12 @@ arg (fn (n-times (- n 1) fn arg)))) - (test-begin - - (local - ((define expected '(let-values ([(a) (lambda (x) 'bar)]) (a))) - (define actual (syntax->datum (substitute-in-syntax #'(let-values ([(a) (lambda (x) 'foo)]) (a)) '(1 0 1 2 1) #'bar)))) - (printf "equal? ~v\n" (equal? expected actual)))) + (module+ test + (let () + (define expected '(let-values ([(a) (lambda (x) 'bar)]) (a))) + (define actual (syntax->datum (substitute-in-syntax #'(let-values ([(a) (lambda (x) 'foo)]) (a)) '(1 0 1 2 1) #'bar))) + + (check-equal? actual expected))) ; lift-local-defs takes a list of contexts and an instruction and works its way out, reconstructing the expression. @@ -291,31 +295,28 @@ (lift)] [else (values so-far-defs stx)]))) - (test-begin - (local - ((define actual-stxs - (lift-local-defs - (list (make-context-record #'(dc 14) '(0) 'expr) - (make-context-record #'(letrec-values ([(a) 3] [(b) dc] [(c) 5]) (+ 3 4)) '(1 1 1) 'expr) - (make-context-record #'(f dc) '(1) 'expr)) - #'(let-values ([(a) 4] [(b) 9] [(c) 12]) (p q)) - #t)) - - (define actual-sexps (map syntax-object->hilite-datum actual-stxs)) - - (define expected-sexps - (list '(define-values (a) 3) - `(hilite (define-values (a) 4)) - `(hilite (define-values (b) 9)) - `(hilite (define-values (c) 12)) - `(define-values (b) ((hilite (p q)) 14)) - '(define-values (c) 5) - '(f (+ 3 4))))) - - (test expected-sexps (lambda () actual-sexps)) - ;(printf "shared: ~v\n" (sexp-shared actual expected)) - ) - - (report-errs) - ) + (module+ test + (define actual-stxs + (lift-local-defs + (list (make-context-record #'(dc 14) '(0) 'expr) + (make-context-record #'(letrec-values ([(a) 3] [(b) dc] [(c) 5]) (+ 3 4)) '(1 1 1) 'expr) + (make-context-record #'(f dc) '(1) 'expr)) + #'(let-values ([(a) 4] [(b) 9] [(c) 12]) (p q)) + #t)) + + + (define actual-sexps (map syntax->hilite-datum actual-stxs)) + + (define expected-sexps + (list '(define-values (a) 3) + '(hilite (define-values (a) 4)) + '(hilite (define-values (b) 9)) + '(hilite (define-values (c) 12)) + '(define-values (b) ((hilite (p q)) 14)) + '(define-values (c) 5) + '(f (+ 3 4)))) + + (check-equal? actual-sexps expected-sexps) + ) + diff --git a/collects/tests/utils/sexp-diff.rkt b/collects/tests/utils/sexp-diff.rkt index e37d2fc909..58e7e35919 100644 --- a/collects/tests/utils/sexp-diff.rkt +++ b/collects/tests/utils/sexp-diff.rkt @@ -1,15 +1,6 @@ (module sexp-diff mzscheme - (require tests/utils/mz-testing) - - (define-syntax (test-begin stx) - (syntax-case stx () - [(_ expr ...) - ;#'(begin expr ...) ; testing version - #'(void) ; non-testing version - ])) + (require rackunit) - (test-begin (section 'sexp-diff)) - ; sexp-diff and sexp-diff/expound show the difference between two specified s-expressions. ; in each case, the part of the s-expression that is the same is preserved in the result. When ; traversal reveals a difference, the point that is different is replaced with either the symbol @@ -17,6 +8,8 @@ ; in the sexp-diff/expound function. (provide sexp-diff sexp-diff/expound) + (provide list-diff list-diff/expound) + (define (sexp-diff/core expound? collect?) (letrec ([construct-diff-result (if expound? @@ -74,28 +67,26 @@ ; cdr's of two pair elements is different, the results are recombined to make the whole pair labeled ; different. - (provide list-diff list-diff/expound) - (define list-diff (sexp-diff/core #f #t)) (define list-diff/expound (sexp-diff/core #t #t)) - (test-begin - (test null sexp-diff null null) - (define a `(1 2 (3 4 (5 6) (6 7) () 8) 9)) - (test a sexp-diff a a) - (define b `(1 0 (3 0 (5 7) 0 0 8 3 4) 9)) - (test `(1 ,diff-id (3 ,diff-id (5 ,diff-id) ,diff-id ,diff-id 8 . ,diff-id) 9) sexp-diff a b) - - (test null sexp-diff/expound null null) - (test a sexp-diff/expound a a) - (test `(1 (,diff-id 2 0) (3 (,diff-id 4 0) (5 (,diff-id 6 7)) (,diff-id (6 7) 0) (,diff-id () 0) 8 . (,diff-id () (3 4))) 9) sexp-diff/expound a b) - - (test null list-diff null null) - (test null list-diff/expound null null) - (test a list-diff a a) - (test a list-diff/expound a a) - (test `(1 ,diff-id ,diff-id 9) list-diff a b) - (test `(1 (,diff-id 2 0) (,diff-id (3 4 (5 6) (6 7) () 8) (3 0 (5 7) 0 0 8 3 4)) 9) list-diff/expound a b) - - (report-errs))) + (check-equal? (sexp-diff null null) null) + (define a `(1 2 (3 4 (5 6) (6 7) () 8) 9)) + (check-equal? (sexp-diff a a) a) + (define b `(1 0 (3 0 (5 7) 0 0 8 3 4) 9)) + (check-equal? (sexp-diff a b) + `(1 ,diff-id (3 ,diff-id (5 ,diff-id) ,diff-id ,diff-id 8 . ,diff-id) 9)) + + (check-equal? (sexp-diff/expound null null) null) + (check-equal? (sexp-diff/expound a a) a) + (check-equal? (sexp-diff/expound a b) + `(1 (,diff-id 2 0) (3 (,diff-id 4 0) (5 (,diff-id 6 7)) (,diff-id (6 7) 0) (,diff-id () 0) 8 . (,diff-id () (3 4))) 9)) + + (check-equal? (list-diff null null) null) + (check-equal? (list-diff/expound null null) null) + (check-equal? (list-diff a a) a) + (check-equal? (list-diff/expound a a) a) + (check-equal? (list-diff a b) `(1 ,diff-id ,diff-id 9)) + (check-equal? (list-diff/expound a b) + `(1 (,diff-id 2 0) (,diff-id (3 4 (5 6) (6 7) () 8) (3 0 (5 7) 0 0 8 3 4)) 9)))