suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

remove dependencies on mz-testing.rkt

Browse Source
This commit is contained in:
John Clements 2012-08-27 13:35:24 -07:00
parent 514c1c5921
commit 614ff235fc
2 changed files with 91 additions and 99 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

89
collects/stepper/private/lifting.rkt
View File

@ -159,46 +159,50 @@
; TESTING: ; TESTING:
(define-syntax (test-begin stx)
(syntax-case stx ()
[(_ expr ...)
;#'(begin expr ...) ; testing version
#'(void) ; non-testing version
]))
(define (datum-ize-context-record cr) (define (datum-ize-context-record cr)
(list (syntax->datum (context-record-stx cr)) (list (syntax->datum (context-record-stx cr))
(context-record-index cr) (context-record-index cr)
(context-record-kind cr))) (context-record-kind cr)))
(test-begin (require tests/utils/mz-testing)) (module+ test
(require rackunit)
(test-begin (SECTION 'stepper-lifting))
(test-begin
; TEST OF FIND-HIGHLIGHT ; 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 test-datum (expand (car (build-stx-with-highlight (define expected
`((define (f x) (letrec ([a (lambda (x) (b (- x 1)))] (list (list `(#%app a x) '(1) 'expr)
[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 `(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 `(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 (#%top . -) x (quote 1))))] [(b) (lambda (x) (#%app a x))]) (#%app a x))) '(2) '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 (#%top . -) x (quote 1))))] [(b) (lambda (x) (#%app a x))]) (#%app a x)))) '(2) (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))) 'general-top-level)))
(match-let* ([(vector context-records highlight) (find-highlight test-datum)]) (match-define (vector context-records highlight)
(test expected map datum-ize-context-record context-records)) (find-highlight test-datum))
(check-equal? (map datum-ize-context-record context-records)
expected))
(test null (lambda () (let ()
(match-let* ([(vector context-records dc) (define test-stx (stepper-syntax-property
(find-highlight (car (build-stx-with-highlight `((hilite foo)))))]) #'foo
context-records)))) '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 ; 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 ; (represented by a list of numbers) and a syntax-expression to insert. If the path is null, the
@ -229,12 +233,12 @@
arg arg
(fn (n-times (- n 1) fn arg)))) (fn (n-times (- n 1) fn arg))))
(test-begin (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)))
(local (check-equal? actual expected)))
((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))))
; lift-local-defs takes a list of contexts and an instruction and works its way out, reconstructing the expression. ; lift-local-defs takes a list of contexts and an instruction and works its way out, reconstructing the expression.
@ -291,9 +295,8 @@
(lift)] (lift)]
[else (values so-far-defs stx)]))) [else (values so-far-defs stx)])))
(test-begin (module+ test
(local (define actual-stxs
((define actual-stxs
(lift-local-defs (lift-local-defs
(list (make-context-record #'(dc 14) '(0) 'expr) (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 #'(letrec-values ([(a) 3] [(b) dc] [(c) 5]) (+ 3 4)) '(1 1 1) 'expr)
@ -301,21 +304,19 @@
#'(let-values ([(a) 4] [(b) 9] [(c) 12]) (p q)) #'(let-values ([(a) 4] [(b) 9] [(c) 12]) (p q))
#t)) #t))
(define actual-sexps (map syntax-object->hilite-datum actual-stxs))
(define actual-sexps (map syntax->hilite-datum actual-stxs))
(define expected-sexps (define expected-sexps
(list '(define-values (a) 3) (list '(define-values (a) 3)
`(hilite (define-values (a) 4)) '(hilite (define-values (a) 4))
`(hilite (define-values (b) 9)) '(hilite (define-values (b) 9))
`(hilite (define-values (c) 12)) '(hilite (define-values (c) 12))
`(define-values (b) ((hilite (p q)) 14)) '(define-values (b) ((hilite (p q)) 14))
'(define-values (c) 5) '(define-values (c) 5)
'(f (+ 3 4))))) '(f (+ 3 4))))
(test expected-sexps (lambda () actual-sexps)) (check-equal? actual-sexps expected-sexps)
;(printf "shared: ~v\n" (sexp-shared actual expected))
) )
(report-errs)
)

45
collects/tests/utils/sexp-diff.rkt
View File

@ -1,14 +1,5 @@
(module sexp-diff mzscheme (module sexp-diff mzscheme
(require tests/utils/mz-testing) (require rackunit)
(define-syntax (test-begin stx)
(syntax-case stx ()
[(_ expr ...)
;#'(begin expr ...) ; testing version
#'(void) ; non-testing version
]))
(test-begin (section 'sexp-diff))
; sexp-diff and sexp-diff/expound show the difference between two specified s-expressions. ; 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 ; in each case, the part of the s-expression that is the same is preserved in the result. When
@ -17,6 +8,8 @@
; in the sexp-diff/expound function. ; in the sexp-diff/expound function.
(provide sexp-diff sexp-diff/expound) (provide sexp-diff sexp-diff/expound)
(provide list-diff list-diff/expound)
(define (sexp-diff/core expound? collect?) (define (sexp-diff/core expound? collect?)
(letrec ([construct-diff-result (if expound? (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 ; cdr's of two pair elements is different, the results are recombined to make the whole pair labeled
; different. ; different.
(provide list-diff list-diff/expound)
(define list-diff (sexp-diff/core #f #t)) (define list-diff (sexp-diff/core #f #t))
(define list-diff/expound (sexp-diff/core #t #t)) (define list-diff/expound (sexp-diff/core #t #t))
(test-begin (check-equal? (sexp-diff null null) null)
(test null sexp-diff null null)
(define a `(1 2 (3 4 (5 6) (6 7) () 8) 9)) (define a `(1 2 (3 4 (5 6) (6 7) () 8) 9))
(test a sexp-diff a a) (check-equal? (sexp-diff a a) a)
(define b `(1 0 (3 0 (5 7) 0 0 8 3 4) 9)) (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) (check-equal? (sexp-diff a b)
`(1 ,diff-id (3 ,diff-id (5 ,diff-id) ,diff-id ,diff-id 8 . ,diff-id) 9))
(test null sexp-diff/expound null null) (check-equal? (sexp-diff/expound null null) null)
(test a sexp-diff/expound a a) (check-equal? (sexp-diff/expound a 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) (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))
(test null list-diff null null) (check-equal? (list-diff null null) null)
(test null list-diff/expound null null) (check-equal? (list-diff/expound null null) null)
(test a list-diff a a) (check-equal? (list-diff a a) a)
(test a list-diff/expound a a) (check-equal? (list-diff/expound a a) a)
(test `(1 ,diff-id ,diff-id 9) list-diff a b) (check-equal? (list-diff a b) `(1 ,diff-id ,diff-id 9))
(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) (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)))
(report-errs)))