From bc5ab799107b5b69eac2439511dd4600b441fb49 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 2 Aug 2014 02:31:28 -0500 Subject: [PATCH] add some debugging output to try to figure out what's different about drdr when running the check syntax tests --- .../tests/drracket/syncheck-test.rkt | 38 +++++++++------ .../drracket/private/syncheck/gui.rkt | 7 +-- .../drracket/private/syncheck/traversals.rkt | 47 ++++++++++++++++++- 3 files changed, 72 insertions(+), 20 deletions(-) diff --git a/pkgs/drracket-pkgs/drracket-test/tests/drracket/syncheck-test.rkt b/pkgs/drracket-pkgs/drracket-test/tests/drracket/syncheck-test.rkt index 2ffc11fa72..a9527d6745 100644 --- a/pkgs/drracket-pkgs/drracket-test/tests/drracket/syncheck-test.rkt +++ b/pkgs/drracket-pkgs/drracket-test/tests/drracket/syncheck-test.rkt @@ -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) diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/syncheck/gui.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/syncheck/gui.rkt index faee468cec..fd61ba0822 100644 --- a/pkgs/drracket-pkgs/drracket/drracket/private/syncheck/gui.rkt +++ b/pkgs/drracket-pkgs/drracket/drracket/private/syncheck/gui.rkt @@ -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) diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/syncheck/traversals.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/syncheck/traversals.rkt index 3d46cf1f6f..72040e4139 100644 --- a/pkgs/drracket-pkgs/drracket/drracket/private/syncheck/traversals.rkt +++ b/pkgs/drracket-pkgs/drracket/drracket/private/syncheck/traversals.rkt @@ -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?))