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

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

@ -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))
(module+ test
(require rackunit)
(test-begin (SECTION 'stepper-lifting))
; TEST OF FIND-HIGHLIGHT
(test-begin
; 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)))
(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))))))))
(match-define (vector context-records highlight)
(find-highlight test-datum))
(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)))
(check-equal? (map datum-ize-context-record context-records)
expected))
(match-let* ([(vector context-records highlight) (find-highlight test-datum)])
(test expected map datum-ize-context-record context-records))
(let ()
(define test-stx (stepper-syntax-property
#'foo
'stepper-highlight
#t))
(match-define (vector context-records dc) (find-highlight test-stx))
(test null (lambda ()
(match-let* ([(vector context-records dc)
(find-highlight (car (build-stx-with-highlight `((hilite foo)))))])
context-records))))
(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
(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
((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))))
(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))
(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-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)))))
(define actual-sexps (map syntax->hilite-datum actual-stxs))
(test expected-sexps (lambda () actual-sexps))
;(printf "shared: ~v\n" (sexp-shared actual expected))
)
(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)
)
(report-errs)
)

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

@ -1,14 +1,5 @@
(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
]))
(test-begin (section 'sexp-diff))
(require rackunit)
; 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
@ -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)
(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))
(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)
(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))
(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? (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)))