add some debugging output to try to figure out what's different about drdr
when running the check syntax tests
This commit is contained in:
Robby Findler
parent
cad8331141
commit
bc5ab79910
|
|
@ -2,6 +2,7 @@
|
|||
|
||||
(require "private/drracket-test-util.rkt"
|
||||
drracket/private/syncheck/local-member-names
|
||||
drracket/syncheck-drracket-button
|
||||
string-constants/string-constant
|
||||
"private/gui.rkt"
|
||||
racket/path
|
||||
|
|
@ -26,15 +27,15 @@
|
|||
;; (listof (list number number) (listof string)))
|
||||
;; (-> any)
|
||||
;; (any -> void?) -- argument is the result of the setup thunk
|
||||
(define-struct test (line input expected arrows tooltips setup teardown) #:transparent)
|
||||
(define-struct test (line input expected arrows tooltips setup teardown extra-info?) #:transparent)
|
||||
(define-struct (dir-test test) () #:transparent)
|
||||
|
||||
(define-struct rename-test (line input pos old-name new-name output) #:transparent)
|
||||
|
||||
(define build-test/proc
|
||||
(λ (line input expected [arrow-table '()] #:tooltips [tooltips #f]
|
||||
#:setup [setup void] #:teardown [teardown void])
|
||||
(make-test line input expected arrow-table tooltips setup teardown)))
|
||||
#:setup [setup void] #:teardown [teardown void] #:extra-info? [extra-info? #f])
|
||||
(make-test line input expected arrow-table tooltips setup teardown extra-info?)))
|
||||
|
||||
(define-syntax (build-test stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -53,7 +54,7 @@
|
|||
[(_ args ...)
|
||||
(with-syntax ([line (syntax-line stx)])
|
||||
;; #f is for the tooltip portion of the test, just skip 'em
|
||||
#'(make-dir-test line args ... #f void void))]))
|
||||
#'(make-dir-test line args ... #f void void #f))]))
|
||||
|
||||
;; tests : (listof test)
|
||||
(define tests
|
||||
|
|
@ -1056,7 +1057,8 @@
|
|||
("red" imported)
|
||||
(")" default-color))
|
||||
'(((26 29) (47 50))
|
||||
((6 17) (19 25))))
|
||||
((6 17) (19 25)))
|
||||
#:extra-info? #t)
|
||||
|
||||
(build-test "#lang racket/base\n(require '#%kernel)\npair?"
|
||||
'(("#lang racket/base\n(" default-color)
|
||||
|
|
@ -1427,7 +1429,7 @@
|
|||
(define (close-the-error-window-test drs)
|
||||
(clear-definitions drs)
|
||||
(insert-in-definitions drs "(")
|
||||
(click-check-syntax-button drs)
|
||||
(click-check-syntax-button drs #f)
|
||||
(wait-for-computation drs)
|
||||
(unless (queue-callback/res (λ () (send drs syncheck:error-report-visible?)))
|
||||
(error 'close-the-error-window-test "error report window never appeared"))
|
||||
|
|
@ -1450,7 +1452,8 @@
|
|||
[tooltips (test-tooltips test)]
|
||||
[relative (find-relative-path save-dir (collection-file-path "list.rkt" "racket"))]
|
||||
[setup (test-setup test)]
|
||||
[teardown (test-teardown test)])
|
||||
[teardown (test-teardown test)]
|
||||
[extra-info? (test-extra-info? test)])
|
||||
(define setup-result (setup))
|
||||
(define input (if (procedure? pre-input)
|
||||
(pre-input setup-result)
|
||||
|
|
@ -1459,10 +1462,15 @@
|
|||
[(dir-test? test)
|
||||
(insert-in-definitions drs (format input (path->require-string relative)))]
|
||||
[else (insert-in-definitions drs input)])
|
||||
(click-check-syntax-and-check-errors drs test)
|
||||
(click-check-syntax-and-check-errors drs test extra-info?)
|
||||
|
||||
;; need to check for syntax error here
|
||||
(let ([got (get-annotated-output drs)])
|
||||
(let ([got (get-annotated-output drs)]
|
||||
[got-arrows (queue-callback/res (λ () (send defs syncheck:get-bindings-table)))])
|
||||
(when extra-info?
|
||||
(printf "got-arrows\n")
|
||||
(pretty-print got-arrows)
|
||||
(newline))
|
||||
(compare-output (cond
|
||||
[(dir-test? test)
|
||||
(map (lambda (x)
|
||||
|
|
@ -1475,7 +1483,7 @@
|
|||
expected])
|
||||
got
|
||||
arrows
|
||||
(queue-callback/res (λ () (send defs syncheck:get-bindings-table)))
|
||||
got-arrows
|
||||
input
|
||||
(test-line test)))
|
||||
(when tooltips
|
||||
|
|
@ -1486,7 +1494,7 @@
|
|||
(teardown setup-result))]
|
||||
[(rename-test? 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 #f)
|
||||
(define menu-item
|
||||
(queue-callback/res
|
||||
(λ ()
|
||||
|
|
@ -1663,8 +1671,8 @@
|
|||
(define (get-annotated-output drs)
|
||||
(queue-callback/res (λ () (get-string/style-desc (send drs get-definitions-text)))))
|
||||
|
||||
(define (click-check-syntax-and-check-errors drs test)
|
||||
(click-check-syntax-button drs)
|
||||
(define (click-check-syntax-and-check-errors drs test extra-info?)
|
||||
(click-check-syntax-button drs extra-info?)
|
||||
(wait-for-computation drs)
|
||||
(when (queue-callback/res (λ () (send (send drs get-definitions-text) in-edit-sequence?)))
|
||||
(error 'syncheck-test.rkt "still in edit sequence for ~s" test))
|
||||
|
|
@ -1675,8 +1683,8 @@
|
|||
test
|
||||
err))))
|
||||
|
||||
(define (click-check-syntax-button drs)
|
||||
(test:run-one (lambda () (send (send drs syncheck:get-button) command))))
|
||||
(define (click-check-syntax-button drs extra-info?)
|
||||
(test:run-one (lambda () (send drs syncheck:button-callback #:print-extra-info? extra-info?))))
|
||||
|
||||
(main)
|
||||
|
||||
|
|
|
|||
|
|
@ -1725,7 +1725,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
(define-values (pos text) (send editor get-pos/text event))
|
||||
(when (and pos (is-a? text text%))
|
||||
(send editor syncheck:build-popup-menu menu pos text #f))))))
|
||||
|
||||
|
||||
(define syncheck-frame<%>
|
||||
(interface ()
|
||||
syncheck:button-callback
|
||||
|
|
@ -2060,7 +2060,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
(inherit open-status-line close-status-line update-status-line ensure-rep-hidden)
|
||||
;; syncheck:button-callback : (case-> (-> void) ((union #f syntax) -> void)
|
||||
;; this is the only function that has any code running on the user's thread
|
||||
(define/public (syncheck:button-callback)
|
||||
(define/public (syncheck:button-callback #:print-extra-info? [print-extra-info? #f])
|
||||
(when (send check-syntax-button is-enabled?)
|
||||
(open-status-line 'drracket:check-syntax:status)
|
||||
(update-status-line 'drracket:check-syntax:status status-init)
|
||||
|
|
@ -2163,7 +2163,8 @@ If the namespace does not, they are colored the unbound color.
|
|||
(update-status-line 'drracket:check-syntax:status status-expanding-expression)
|
||||
(set!-values (expanded-expression expansion-completed)
|
||||
(make-traversal (current-namespace)
|
||||
(current-directory))) ;; set by set-directory above
|
||||
(current-directory)
|
||||
print-extra-info?)) ;; set by set-directory above
|
||||
(set! user-custodian (current-custodian))))
|
||||
|
||||
(set-syncheck-running-mode 'button)
|
||||
|
|
|
|||
|
|
@ -13,6 +13,7 @@
|
|||
racket/class
|
||||
racket/list
|
||||
racket/contract
|
||||
racket/pretty
|
||||
syntax/boundmap
|
||||
scribble/manual-struct)
|
||||
|
||||
|
|
@ -30,7 +31,7 @@
|
|||
;; represents the top-level of a single program. The first value
|
||||
;; is called once for each top-level expression and the second
|
||||
;; value is called once, after all expansion is complete.
|
||||
(define (make-traversal user-namespace user-directory)
|
||||
(define (make-traversal user-namespace user-directory [print-extra-info? #f])
|
||||
(let* ([tl-phase-to-binders (make-hash)]
|
||||
[tl-phase-to-varrefs (make-hash)]
|
||||
[tl-phase-to-varsets (make-hash)]
|
||||
|
|
@ -85,7 +86,22 @@
|
|||
sub-identifier-binding-directives)
|
||||
(annotate-contracts sexp
|
||||
(hash-ref phase-to-binders 0 (λ () (make-id-set)))
|
||||
binding-inits))]
|
||||
binding-inits)
|
||||
(when print-extra-info?
|
||||
(print-extra-info (list (list 'phase-to-binders phase-to-binders)
|
||||
(list 'phase-to-varrefs phase-to-varrefs)
|
||||
(list 'phase-to-varsets phase-to-varsets)
|
||||
(list 'phase-to-tops phase-to-tops)
|
||||
(list 'phase-to-requires phase-to-requires)
|
||||
(list 'binding-inits binding-inits)
|
||||
(list 'templrefs templrefs)
|
||||
(list 'module-lang-requires module-lang-requires)
|
||||
(list 'requires requires)
|
||||
(list 'require-for-syntaxes require-for-syntaxes)
|
||||
(list 'require-for-templates require-for-templates)
|
||||
(list 'require-for-labels require-for-templates)
|
||||
(list 'sub-identifier-binding-directives
|
||||
sub-identifier-binding-directives)))))]
|
||||
[else
|
||||
(annotate-basic sexp
|
||||
user-namespace user-directory
|
||||
|
|
@ -102,6 +118,16 @@
|
|||
(λ ()
|
||||
(parameterize ([current-directory (or user-directory (current-directory))]
|
||||
[current-load-relative-directory user-directory])
|
||||
(when print-extra-info?
|
||||
(print-extra-info (list (list 'tl-phase-to-binders tl-phase-to-binders)
|
||||
(list 'tl-phase-to-varrefs tl-phase-to-varrefs)
|
||||
(list 'tl-phase-to-varsets tl-phase-to-varsets)
|
||||
(list 'tl-phase-to-tops tl-phase-to-tops)
|
||||
(list 'tl-templrefs tl-templrefs)
|
||||
(list 'tl-module-lang-requires tl-module-lang-requires)
|
||||
(list 'tl-phase-to-requires tl-module-lang-requires)
|
||||
(list 'tl-sub-identifier-binding-directives
|
||||
tl-sub-identifier-binding-directives))))
|
||||
(annotate-variables user-namespace
|
||||
user-directory
|
||||
tl-phase-to-binders
|
||||
|
|
@ -115,6 +141,23 @@
|
|||
(values expanded-expression expansion-completed)))
|
||||
|
||||
|
||||
(define (print-extra-info stuff)
|
||||
(for ([info (in-list stuff)])
|
||||
(printf "~s\n" (car info))
|
||||
(pretty-print
|
||||
(let loop ([info (cadr info)])
|
||||
(cond
|
||||
[(hash? info)
|
||||
(for/hash ([(k v) (in-hash info)])
|
||||
(values (loop k) (loop v)))]
|
||||
[(free-identifier-mapping? info)
|
||||
(free-identifier-mapping-map
|
||||
info
|
||||
(λ (k v) (list (loop k) '=> (loop v))))]
|
||||
[(pair? info) (cons (loop (car info)) (loop (cdr info)))]
|
||||
[else info])))
|
||||
(newline)))
|
||||
|
||||
;; type req/tag = (make-req/tag syntax sexp boolean)
|
||||
(define-struct req/tag (req-stx req-sexp used?))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user