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

automate some overlapping identifier tests

Browse Source
This commit is contained in:
Robby Findler 2013-05-20 09:46:16 -05:00
parent 3faf75bd72
commit 0ca35b1f6a
1 changed files with 245 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

293
collects/tests/drracket/syncheck-test.rkt
View File

@ -9,7 +9,8 @@
racket/list racket/list
racket/file racket/file
racket/set racket/set
mred racket/pretty
racket/gui/base
framework framework
mrlib/text-string-style-desc mrlib/text-string-style-desc
(for-syntax racket/base)) (for-syntax racket/base))
@ -18,17 +19,21 @@
;; type str/ann = (list (union symbol string) symbol) ;; type str/ann = (list (union symbol string) symbol)
;; type test = (make-test string ;; type test = (make-test string
;; (listof str/ann) ;; (or/c (-> any (listof str/ann)) -- if proc, then pass in result of setup thunk
;; (listof str/ann))
;; (listof (cons (list number number) (listof (list number number))))) ;; (listof (cons (list number number) (listof (list number number)))))
;; (listof (list number number) (listof string))) ;; (listof (list number number) (listof string)))
(define-struct test (line input expected arrows tooltips) #:transparent) ;; (-> any)
;; (any -> void?) -- argument is the result of the setup thunk
(define-struct test (line input expected arrows tooltips setup teardown) #:transparent)
(define-struct (dir-test test) () #:transparent) (define-struct (dir-test test) () #:transparent)
(define-struct rename-test (line input pos old-name new-name output) #:transparent) (define-struct rename-test (line input pos old-name new-name output) #:transparent)
(define build-test/proc (define build-test/proc
(λ (line input expected [arrow-table '()] #:tooltips [tooltips #f]) (λ (line input expected [arrow-table '()] #:tooltips [tooltips #f]
(make-test line input expected arrow-table tooltips))) #:setup [setup void] #:teardown [teardown void])
(make-test line input expected arrow-table tooltips setup teardown)))
(define-syntax (build-test stx) (define-syntax (build-test stx)
(syntax-case stx () (syntax-case stx ()
@ -47,11 +52,12 @@
[(_ args ...) [(_ args ...)
(with-syntax ([line (syntax-line stx)]) (with-syntax ([line (syntax-line stx)])
;; #f is for the tooltip portion of the test, just skip 'em ;; #f is for the tooltip portion of the test, just skip 'em
#'(make-dir-test line args ... #f))])) #'(make-dir-test line args ... #f void void))]))
;; tests : (listof test) ;; tests : (listof test)
(define tests (define tests
(list (list
(build-test "12345" (build-test "12345"
'(("12345" constant))) '(("12345" constant)))
(build-test "'abcdef" (build-test "'abcdef"
@ -1041,6 +1047,152 @@
(list '((6 12) (14 31) (38 54) (56 63)) (list '((6 12) (14 31) (38 54) (56 63))
'((32 33) (69 70)))) '((32 33) (69 70))))
(build-test
(λ (fn)
(string-append
"#lang racket/base\n"
;; 'values' is here so we get to the require
;; before attempting to expand 'm'
"(values\n"
" (m a-x\n"
" a a a\n"
" a-x a-x))\n"
;; this is last because its length might change
(format "~s\n" `(require (file ,(path->string fn))))))
'(("#lang racket/base\n(" default-color)
("values" imported)
("\n (" default-color)
("m" imported)
(" " default-color)
("a-x" lexically-bound)
("\n " default-color)
("a" lexically-bound)
(" " default-color)
("a" lexically-bound)
(" " default-color)
("a" lexically-bound)
("\n " default-color)
("a-x" lexically-bound)
(" " default-color)
("a-x" lexically-bound)
("))\n(" default-color)
("require" imported)
(#rx" [(]file \"[^\"]*\"[)][)]\n" default-color))
'(((6 17) (19 25) (59 66))
((30 33) (48 51) (52 55))
((30 31) (38 39) (40 41) (42 43))
((67 166) (28 29)))
#:setup
(λ ()
(define fn (make-temporary-file "syncheck-test-~a.rkt"))
(call-with-output-file fn
(λ (port)
(fprintf port "#lang racket/base\n")
(pretty-write '(require (for-syntax racket/base)) port)
(pretty-write '(provide m) port)
(pretty-write
'(define-syntax (m stx)
(syntax-case stx ()
[(_ a . rst)
(let ()
(define str (regexp-replace #rx"-.*$" (symbol->string (syntax-e #'a)) ""))
(with-syntax ([a2 (datum->syntax #'a
(string->symbol str)
(vector (syntax-source #'a)
(syntax-line #'a)
(syntax-column #'a)
(syntax-position #'a)
(string-length str))
#'a)])
#'(begin
(let ([a 1][a2 1]) . rst))))]))
port))
#:exists 'truncate)
fn)
#:teardown (λ (fn) (delete-file fn)))
(build-test
(λ (fn)
(string-append
"#lang racket/base\n"
;; 'values' is here so we get to the require
;; before attempting to expand 'n'
"(values\n"
" (n e\n"
" e_11111111111111\n"
" e e e\n"
" e_11111111111111 e_11111111111111))\n"
;; this is last because its length might change
(format "~s\n" `(require (file ,(path->string fn))))))
'(("#lang racket/base\n(" default-color)
("values" imported)
("\n (" default-color)
("n" imported)
(" " default-color)
("e" lexically-bound)
("\n " default-color)
("e_11111111111111" lexically-bound)
("\n " default-color)
("e" lexically-bound)
(" " default-color)
("e" lexically-bound)
(" " default-color)
("e" lexically-bound)
("\n " default-color)
("e_11111111111111" lexically-bound)
(" " default-color)
("e_11111111111111" lexically-bound)
("))\n(" default-color)
("require" imported)
(#rx" [(]file \"[^\"]*\"[)][)]\n" default-color))
'(((6 17) (19 25) (104 111))
((36 52) (67 83) (84 100))
((30 31) (36 37) (57 58) (59 60) (61 62) (67 68) (84 85))
((112 211) (28 29)))
#:setup
(λ ()
(define fn (make-temporary-file "syncheck-test-~a.rkt"))
(call-with-output-file fn
(λ (port)
(fprintf port "#lang racket/base\n")
(pretty-write '(require (for-syntax racket/base)) port)
(pretty-write '(provide n) port)
(pretty-write
'(define-syntax (n stx)
(syntax-case stx ()
[(_ b1 b2 . rst)
(let ()
(define str (regexp-replace #rx"-.*$" (symbol->string (syntax-e #'a)) ""))
#`(let ([b1 1]
[b2 1])
#,(datum->syntax #'b1
(syntax-e #'b1)
(vector (syntax-source #'b2)
(syntax-line #'b2)
(syntax-column #'b2)
(syntax-position #'b2)
(string-length (symbol->string (syntax-e #'b1))))
#'b1)
(let-syntax ([b2 (λ (x)
(unless (identifier? x)
(raise-syntax-error 'b2 "only ids"))
(datum->syntax x
'b1
(vector (syntax-source x)
(syntax-line x)
(syntax-column x)
(syntax-position x)
(string-length (symbol->string 'b1)))
x))])
.
rst)))]))
port))
#:exists 'truncate)
fn)
#:teardown (λ (fn) (delete-file fn)))
(build-rename-test "(lambda (x) x)" (build-rename-test "(lambda (x) x)"
9 9
"x" "x"
@ -1244,11 +1396,17 @@
(clear-definitions drs) (clear-definitions drs)
(cond (cond
[(test? test) [(test? test)
(let ([input (test-input test)] (let ([pre-input (test-input test)]
[expected (test-expected test)] [expected (test-expected test)]
[arrows (test-arrows test)] [arrows (test-arrows test)]
[tooltips (test-tooltips test)] [tooltips (test-tooltips test)]
[relative (find-relative-path save-dir (collection-path "mzlib"))]) [relative (find-relative-path save-dir (collection-path "mzlib"))]
[setup (test-setup test)]
[teardown (test-teardown test)])
(define setup-result (setup))
(define input (if (procedure? pre-input)
(pre-input setup-result)
pre-input))
(cond (cond
[(dir-test? test) [(dir-test? test)
(insert-in-definitions drs (format input (path->require-string relative)))] (insert-in-definitions drs (format input (path->require-string relative)))]
@ -1270,11 +1428,14 @@
got got
arrows arrows
(queue-callback/res (λ () (send defs syncheck:get-bindings-table))) (queue-callback/res (λ () (send defs syncheck:get-bindings-table)))
input)) input
(test-line test)))
(when tooltips (when tooltips
(compare-tooltips (queue-callback/res (λ () (send defs syncheck:get-bindings-table #t))) (compare-tooltips (queue-callback/res (λ () (send defs syncheck:get-bindings-table #t)))
tooltips tooltips
(test-line test))))] (test-line test)))
(teardown setup-result))]
[(rename-test? test) [(rename-test? test)
(insert-in-definitions drs (rename-test-input test)) (insert-in-definitions drs (rename-test-input test))
(click-check-syntax-and-check-errors drs test) (click-check-syntax-and-check-errors drs test)
@ -1355,53 +1516,85 @@
;; (listof (cons (list number number) (listof (list number number)))) ;; (listof (cons (list number number) (listof (list number number))))
;; hash-table[(list text number number) -o> (listof (list text number number))] ;; hash-table[(list text number number) -o> (listof (list text number number))]
;; -> void ;; -> void
(define (compare-arrows test-exp expected raw-actual) (define (compare-arrows test-exp expected raw-actual line)
(when expected (when expected
(let () (define already-checked (make-hash))
(define already-checked (make-hash))
(define actual-ht (make-hash)) (define actual-ht (make-hash))
(define stupid-internal-define-syntax1 (define stupid-internal-define-syntax1
(hash-for-each raw-actual (hash-for-each raw-actual
(lambda (k v) (lambda (k v)
(hash-set! actual-ht (cdr k) (hash-set! actual-ht (cdr k)
(sort (map cdr (set->list v)) (sort (map cdr (set->list v))
(lambda (x y) (< (car x) (car y)))))))) (lambda (x y) (< (car x) (car y))))))))
(define expected-ht (make-hash)) (define expected-ht (make-hash))
(define stupid-internal-define-syntax2 (for ([binding (in-list expected)])
(for-each (lambda (binding) (hash-set! expected-ht (car binding) (cdr binding))) (hash-set! expected-ht (car binding) (cdr binding)))
expected)) ;; binding-in-ht? : hash-table (list number number) (listof (list number number)) -> boolean
;; binding-in-ht? : hash-table (list number number) (listof (list number number)) -> boolean (define (test-binding expected? ht)
(define (test-binding expected? ht) (lambda (pr)
(lambda (pr) (let ([frm (car pr)]
(let ([frm (car pr)] [to (cdr pr)])
[to (cdr pr)]) (hash-ref
(hash-ref already-checked
already-checked frm
frm (lambda ()
(lambda () (hash-set! already-checked frm #t)
(hash-set! already-checked frm #t) (let ([ht-ent (hash-ref ht frm (lambda () 'nothing-there))])
(let ([ht-ent (hash-ref ht frm (lambda () 'nothing-there))]) (unless (equal? ht-ent to)
(unless (equal? ht-ent to) (eprintf (if expected?
(eprintf (if expected? "FAILED arrow test line ~a ~s from ~s\n expected ~s\n actual ~s\n"
"FAILED arrow test ~s from ~s\n expected ~s\n actual ~s\n" "FAILED arrow test line ~a ~s from ~s\n actual ~s\n expected ~s\n")
"FAILED arrow test ~s from ~s\n actual ~s\n expected ~s\n") line
test-exp test-exp
frm frm
ht-ent ht-ent
to)))))))) to))))))))
(for-each (test-binding #t expected-ht) (hash-map actual-ht cons)) (for-each (test-binding #t expected-ht) (hash-map actual-ht cons))
(for-each (test-binding #f actual-ht) (hash-map expected-ht cons))))) (for-each (test-binding #f actual-ht) (hash-map expected-ht cons))))
(define (compare-output raw-expected got arrows arrows-got input) (define (compare-output raw-expected got arrows arrows-got input line)
(let ([expected (collapse-and-rename raw-expected)]) (let ([expected (collapse-and-rename raw-expected)])
(cond (cond
[(equal? got expected) [(not-matching-colors got expected)
(compare-arrows input arrows arrows-got)] =>
(λ (msg)
(eprintf "FAILED line ~a: ~s\n expected: ~s\n got: ~s\n ~a\n"
line input expected got msg))]
[else [else
(eprintf "FAILED: ~s\n expected: ~s\n got: ~s\n" (compare-arrows input arrows arrows-got line)])))
input expected got)])))
(define (not-matching-colors got expected)
(let loop ([got got]
[expected expected]
[i 0])
(cond
[(and (pair? got) (pair? expected))
(or (not-matching-single-color i (car got) (car expected))
(loop (cdr got) (cdr expected) (+ i 1)))]
[(and (null? got) (null? expected))
#f]
[else
(format "lengths different by ~a" (abs (- (length got) (length expected))))])))
(define (not-matching-single-color i got expected)
(define got-str (list-ref got 0))
(define got-color (list-ref got 1))
(define exp-str (list-ref expected 0))
(define exp-color (list-ref expected 1))
(or (cond
[(string? exp-str)
(if (equal? got-str exp-str)
#f
(format "strings at position ~a do not match; got ~s" i got-str))]
[(regexp? exp-str)
(if (regexp-match? exp-str got-str)
#f
(format "regexp at position ~a does not match actual string: ~s" i got-str))])
(if (equal? got-color exp-color)
#f
(format "colors at position ~a do not match; got ~s" i got-color))))
(define (compare-tooltips got expected line) (define (compare-tooltips got expected line)
(unless (equal? got expected) (unless (equal? got expected)