diff --git a/drracket-core-lib/drracket/private/debug.rkt b/drracket-core-lib/drracket/private/debug.rkt index 6fbb2846d..34b27fee5 100644 --- a/drracket-core-lib/drracket/private/debug.rkt +++ b/drracket-core-lib/drracket/private/debug.rkt @@ -483,7 +483,7 @@ [(null? (cdr planet-version)) (format "~s" `(,(car planet-version) ?))] [else - (format "~s" `(,(car planet-version) ,(cadr planet-version)))])) + (format "~s" (list (car planet-version) (cadr planet-version)))])) (cons 'description (exn->trace exn)))] [else #f])) diff --git a/drracket-test/tests/drracket/example-tool.rkt b/drracket-test/tests/drracket/example-tool.rkt index a2ba53506..316c2874b 100644 --- a/drracket-test/tests/drracket/example-tool.rkt +++ b/drracket-test/tests/drracket/example-tool.rkt @@ -8,8 +8,7 @@ (define new-collection-root #; (string->path "C:\\tmp") - (make-temporary-file "drracket-test-example-tool~a" - 'directory)) + (make-temporary-directory "drracket-test-example-tool~a")) (define coll (build-path new-collection-root "coll")) (unless (directory-exists? coll) (make-directory coll)) diff --git a/drracket-test/tests/drracket/language-test.rkt b/drracket-test/tests/drracket/language-test.rkt index 4c2942a09..f0616a808 100644 --- a/drracket-test/tests/drracket/language-test.rkt +++ b/drracket-test/tests/drracket/language-test.rkt @@ -1812,8 +1812,7 @@ the settings above should match r5rs (loop child))] [(is-a? gui-thing radio-box%) (k gui-thing)])))])) - (error 'find-output-radio-box "could not find `~a' radio box" - label))) + (raise-arguments-error 'find-output-radio-box "could not find `' radio box" "label" label))) (define re:out-of-sync (regexp @@ -1933,16 +1932,22 @@ the settings above should match r5rs (define (test-undefined-var id #:icon+in? [icon+in? #f]) (test-expression id - (string-append (if icon+in? "{stop-22x22.png} " "") - (format "~a: this variable is not defined" id) - (if icon+in? (format " in: ~a " id) "")))) + (format "~a~a: this variable is not defined~a" + (if icon+in? "{stop-22x22.png} " "") + id + (if icon+in? + (format " in: ~a " id) + "")))) (define (test-undefined-fn exp id #:icon+in? [icon+in? #f]) (test-expression exp - (string-append (if icon+in? "{stop-22x22.png} " "") - (format "~a: this function is not defined" id) - (if icon+in? (format " in: ~a " id) "")))) + (format "~a~a: this function is not defined~a" + (if icon+in? "{stop-22x22.png} " "") + id + (if icon+in? + (format " in: ~a " id) + "")))) (define-syntax (go stx) (syntax-case stx () diff --git a/drracket-test/tests/drracket/no-write-and-frame-leak.rkt b/drracket-test/tests/drracket/no-write-and-frame-leak.rkt index 167235d81..192e23b60 100644 --- a/drracket-test/tests/drracket/no-write-and-frame-leak.rkt +++ b/drracket-test/tests/drracket/no-write-and-frame-leak.rkt @@ -139,13 +139,11 @@ This test checks: (process-container item))))) (define (record-shortcut item) - (when (is-a? item selectable-menu-item<%>) - (when (send item get-shortcut) - (define k (append (sort (send item get-shortcut-prefix) - string<=? - #:key symbol->string) - (list (send item get-shortcut)))) - (hash-update! shortcuts k (λ (v) (cons (send item get-label) v)) '())))) + (when (and (is-a? item selectable-menu-item<%>) (send item get-shortcut)) + (define k + (append (sort (send item get-shortcut-prefix) string<=? #:key symbol->string) + (list (send item get-shortcut)))) + (hash-update! shortcuts k (λ (v) (cons (send item get-label) v)) '()))) (define (get-lab item) (cond diff --git a/drracket-test/tests/drracket/syncheck-test.rkt b/drracket-test/tests/drracket/syncheck-test.rkt index 884a25a79..5569a00a8 100644 --- a/drracket-test/tests/drracket/syncheck-test.rkt +++ b/drracket-test/tests/drracket/syncheck-test.rkt @@ -1772,12 +1772,11 @@ (λ () (define drs (wait-for-drracket-frame)) ;(set-language-level! (list "Pretty Big")) - (begin - (set-language-level! (list "Pretty Big") #f) - (test:set-radio-box-item! "No debugging or profiling") - (let ([f (test:get-active-top-level-window)]) - (test:button-push "OK") - (wait-for-new-frame f))) + (set-language-level! (list "Pretty Big") #f) + (test:set-radio-box-item! "No debugging or profiling") + (let ([f (test:get-active-top-level-window)]) + (test:button-push "OK") + (wait-for-new-frame f)) (do-execute drs) (define defs (queue-callback/res (λ () (send drs get-definitions-text)))) (define filename (make-temporary-file "syncheck-test~a" #f temp-dir)) @@ -1809,177 +1808,161 @@ (define ((run-one-test save-dir) test) (set! total-tests-run (+ total-tests-run 1)) - (let* ([drs (wait-for-drracket-frame)] - [defs (queue-callback/res (λ () (send drs get-definitions-text)))]) - (clear-definitions drs) - (cond - [(test? test) - (let ([pre-input (test-input test)] - [expected (test-expected test)] - [arrows (test-arrows test)] - [tooltips (test-tooltips test)] - [relative "list.rkt"] - [setup (test-setup test)] - [teardown (test-teardown test)] - [extra-files (test-extra-files test)] - [extra-info? (test-extra-info? test)]) - (define extra-file-paths - (for/list ([(name contents) (in-hash extra-files)]) - (define path (build-path save-dir name)) - (display-to-file contents path #:mode 'text) - path)) - - (define setup-result (setup)) - (define input (if (procedure? pre-input) - (pre-input setup-result) - pre-input)) + (define drs (wait-for-drracket-frame)) + (define defs (queue-callback/res (λ () (send drs get-definitions-text)))) + (clear-definitions drs) + (cond + [(test? test) + (define pre-input (test-input test)) + (define expected (test-expected test)) + (define arrows (test-arrows test)) + (define tooltips (test-tooltips test)) + (define relative "list.rkt") + (define setup (test-setup test)) + (define teardown (test-teardown test)) + (define extra-files (test-extra-files test)) + (define extra-info? (test-extra-info? test)) + (define extra-file-paths + (for/list ([(name contents) (in-hash extra-files)]) + (define path (build-path save-dir name)) + (display-to-file contents path #:mode 'text) + path)) + + (define setup-result (setup)) + (define input + (if (procedure? pre-input) + (pre-input setup-result) + pre-input)) + (cond + [(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 extra-info?) + + ;; need to check for syntax error here + (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) + + (printf "'drracket:syncheck:show-arrows? ~s\n" + (preferences:get 'drracket:syncheck:show-arrows?))) + (compare-output (cond + [(dir-test? test) + (for/list ([x (in-list expected)]) + (list (if (eq? (car x) 'relative-path) + (path->require-string relative) + (car x)) + (cadr x)))] + [else expected]) + got + arrows + got-arrows + input + (test-line test))) + (when tooltips + (compare-tooltips (queue-callback/res (λ () (send defs syncheck:get-bindings-table #t))) + tooltips + (test-line test))) + + (teardown setup-result) + (for-each delete-directory/files extra-file-paths)] + [(rename-test? test) + (insert-in-definitions drs (rename-test-input test)) + (click-check-syntax-and-check-errors drs test #f) + (define menu-item + (queue-callback/res + (λ () + (define defs (send drs get-definitions-text)) + (define menu (make-object popup-menu%)) + (send defs syncheck:build-popup-menu menu (rename-test-pos test) defs) + (define item-name (format "Rename ~a" (rename-test-old-name test))) + (define menu-item + (for/or ([x (in-list (send menu get-items))]) + (and (is-a? x labelled-menu-item<%>) (equal? (send x get-label) item-name) x))) + (cond + [menu-item menu-item] + [else + (eprintf "syncheck-test.rkt: rename test ~s didn't find menu item named ~s in ~s\n" + test + item-name + (map (λ (x) (and (is-a? x labelled-menu-item<%>) (send x get-label))) + (send menu get-items))) + #f])))) + (when (and menu-item (rename-test-new-name test) (rename-test-output test)) + (queue-callback (λ () (send menu-item command (make-object control-event% 'menu)))) + (wait-for-new-frame drs) + (for ([x (in-string (rename-test-new-name test))]) + (test:keystroke x)) + (test:button-push "OK") + (define result + (queue-callback/res (λ () + (define defs (send drs get-definitions-text)) + (send defs get-text 0 (send defs last-position))))) + (unless (equal? result (rename-test-output test)) + (eprintf "syncheck-test.rkt FAILED\n test ~s\n got ~s\n" test result)))] + [(prefix-test? test) + (insert-in-definitions drs (prefix-test-input test)) + (click-check-syntax-and-check-errors drs test #f) + (define menu-item + (queue-callback/res + (λ () + (define defs (send drs get-definitions-text)) + (define menu (make-object popup-menu%)) + (send defs syncheck:build-popup-menu menu (prefix-test-pos test) defs) + (define item-name "Add Require Prefix") + (define menu-item + (for/or ([x (in-list (send menu get-items))]) + (and (is-a? x labelled-menu-item<%>) (equal? (send x get-label) item-name) x))) + (cond + [menu-item menu-item] + [else + (eprintf "syncheck-test.rkt: prefix test ~s didn't find menu item named ~s in ~s\n" + test + item-name + (map (λ (x) (and (is-a? x labelled-menu-item<%>) (send x get-label))) + (send menu get-items))) + #f])))) + (when menu-item + (queue-callback (λ () (send menu-item command (make-object control-event% 'menu)))) + (wait-for-new-frame drs) + (for ([x (in-string (prefix-test-prefix test))]) + (test:keystroke x)) + (test:button-push "OK") + (define result + (queue-callback/res (λ () + (define defs (send drs get-definitions-text)) + (send defs get-text 0 (send defs last-position))))) + (unless (equal? result (prefix-test-output test)) + (eprintf "syncheck-test.rkt FAILED\n test ~s\n got ~s\n" test result)))] + [(err-test? test) + (let/ec done + (insert-in-definitions drs (err-test-input test)) + (define err (click-check-syntax-and-check-errors drs test #f #:err-ok? #t)) + (unless err + (eprintf "syncheck-test.rkt FAILED\n test ~s\n didn't get an error\n" test) + (done)) + (define expected (err-test-expected test)) + (define message-good? (cond - [(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 extra-info?) - - ;; need to check for syntax error here - (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) - - (printf "'drracket:syncheck:show-arrows? ~s\n" - (preferences:get 'drracket:syncheck:show-arrows?))) - (compare-output (cond - [(dir-test? test) - (map (lambda (x) - (list (if (eq? (car x) 'relative-path) - (path->require-string relative) - (car x)) - (cadr x))) - expected)] - [else - expected]) - got - arrows - got-arrows - input - (test-line test))) - (when tooltips - (compare-tooltips (queue-callback/res (λ () (send defs syncheck:get-bindings-table #t))) - tooltips - (test-line test))) - - (teardown setup-result) - (for-each delete-directory/files extra-file-paths))] - [(rename-test? test) - (insert-in-definitions drs (rename-test-input test)) - (click-check-syntax-and-check-errors drs test #f) - (define menu-item - (queue-callback/res - (λ () - (define defs (send drs get-definitions-text)) - (define menu (make-object popup-menu%)) - (send defs syncheck:build-popup-menu menu (rename-test-pos test) defs) - (define item-name (format "Rename ~a" (rename-test-old-name test))) - (define menu-item - (for/or ([x (in-list (send menu get-items))]) - (and (is-a? x labelled-menu-item<%>) - (equal? (send x get-label) item-name) - x))) - (cond - [menu-item - menu-item] - [else - (eprintf "syncheck-test.rkt: rename test ~s didn't find menu item named ~s in ~s\n" - test - item-name - (map (λ (x) (and (is-a? x labelled-menu-item<%>) (send x get-label))) - (send menu get-items))) - #f])))) - (when (and menu-item (rename-test-new-name test) (rename-test-output test)) - (queue-callback (λ () (send menu-item command (make-object control-event% 'menu)))) - (wait-for-new-frame drs) - (for ([x (in-string (rename-test-new-name test))]) - (test:keystroke x)) - (test:button-push "OK") - (define result - (queue-callback/res (λ () - (define defs (send drs get-definitions-text)) - (send defs get-text 0 (send defs last-position))))) - (unless (equal? result (rename-test-output test)) - (eprintf "syncheck-test.rkt FAILED\n test ~s\n got ~s\n" - test - result)))] - [(prefix-test? test) - (insert-in-definitions drs (prefix-test-input test)) - (click-check-syntax-and-check-errors drs test #f) - (define menu-item - (queue-callback/res - (λ () - (define defs (send drs get-definitions-text)) - (define menu (make-object popup-menu%)) - (send defs syncheck:build-popup-menu menu (prefix-test-pos test) defs) - (define item-name "Add Require Prefix") - (define menu-item - (for/or ([x (in-list (send menu get-items))]) - (and (is-a? x labelled-menu-item<%>) - (equal? (send x get-label) item-name) - x))) - (cond - [menu-item - menu-item] - [else - (eprintf "syncheck-test.rkt: prefix test ~s didn't find menu item named ~s in ~s\n" - test - item-name - (map (λ (x) (and (is-a? x labelled-menu-item<%>) (send x get-label))) - (send menu get-items))) - #f])))) - (when menu-item - (queue-callback (λ () (send menu-item command (make-object control-event% 'menu)))) - (wait-for-new-frame drs) - (for ([x (in-string (prefix-test-prefix test))]) - (test:keystroke x)) - (test:button-push "OK") - (define result - (queue-callback/res (λ () - (define defs (send drs get-definitions-text)) - (send defs get-text 0 (send defs last-position))))) - (unless (equal? result (prefix-test-output test)) - (eprintf "syncheck-test.rkt FAILED\n test ~s\n got ~s\n" - test - result)))] - [(err-test? test) - (let/ec done - (insert-in-definitions drs (err-test-input test)) - (define err (click-check-syntax-and-check-errors drs test #f #:err-ok? #t)) - (unless err - (eprintf "syncheck-test.rkt FAILED\n test ~s\n didn't get an error\n" - test) - (done)) - (define expected (err-test-expected test)) - (define message-good? - (cond - [(string? expected) - (equal? expected err)] - [else - (regexp-match? expected err)])) - (unless message-good? - (eprintf "syncheck-test.rkt FAILED error doesn't match\n test ~s\n ~s\n" - test - err) - (done)) - (define srclocs (queue-callback/res (λ () (send (send drs get-interactions-text) get-error-ranges)))) - (define actual - (for/set ([srcloc (in-list srclocs)]) - (list (srcloc-position srcloc) - (srcloc-span srcloc)))) - (unless (equal? actual (err-test-locations test)) - (eprintf "syncheck-test.rkt FAILED srclocs don't match\n test ~s\n actual ~s\n got ~s\n" - test - actual - (err-test-locations test))) - (void))]))) + [(string? expected) (equal? expected err)] + [else (regexp-match? expected err)])) + (unless message-good? + (eprintf "syncheck-test.rkt FAILED error doesn't match\n test ~s\n ~s\n" test err) + (done)) + (define srclocs + (queue-callback/res (λ () (send (send drs get-interactions-text) get-error-ranges)))) + (define actual + (for/set ([srcloc (in-list srclocs)]) + (list (srcloc-position srcloc) (srcloc-span srcloc)))) + (unless (equal? actual (err-test-locations test)) + (eprintf + "syncheck-test.rkt FAILED srclocs don't match\n test ~s\n actual ~s\n got ~s\n" + test + actual + (err-test-locations test))) + (void))])) (define (path->require-string relative) (define (p->string p) @@ -1998,24 +1981,23 @@ (define (collapse-and-rename expected) (define renamed - (map (lambda (ent) - (let* ([str (car ent)] - [id (cadr ent)] - [matches (assoc id remappings)]) - (if matches - (list str (cadr matches)) - ent))) - expected)) + (for/list ([ent (in-list expected)]) + (define str (car ent)) + (define id (cadr ent)) + (define matches (assoc id remappings)) + (if matches + (list str (cadr matches)) + ent))) (let loop ([ids renamed]) (cond [(null? ids) null] [(null? (cdr ids)) ids] [else - (let ([fst (car ids)] - [snd (cadr ids)]) - (if (eq? (cadr fst) (cadr snd)) - (loop (cons (list (string-append (car fst) (car snd)) (cadr fst)) (cddr ids))) - (cons fst (loop (cdr ids)))))]))) + (define fst (car ids)) + (define snd (cadr ids)) + (if (eq? (cadr fst) (cadr snd)) + (loop (cons (list (string-append (car fst) (car snd)) (cadr fst)) (cddr ids))) + (cons fst (loop (cdr ids))))]))) ;; compare-arrows : expression ;; (or/c #f (listof (cons (list number-or-proc number-or-proc) @@ -2069,15 +2051,18 @@ (for-each (test-binding #f actual-ht) (hash-map expected-ht cons)))) (define (compare-output raw-expected got arrows arrows-got input line) - (let ([expected (collapse-and-rename raw-expected)]) - (cond - [(not-matching-colors got expected) - => - (λ (msg) - (eprintf "FAILED line ~a: ~s\n expected: ~s\n got: ~s\n ~a\n" - line input expected got msg))] - [else - (compare-arrows input arrows arrows-got line)]))) + (define expected (collapse-and-rename raw-expected)) + (cond + [(not-matching-colors got expected) + => + (λ (msg) + (eprintf "FAILED line ~a: ~s\n expected: ~s\n got: ~s\n ~a\n" + line + input + expected + got + msg))] + [else (compare-arrows input arrows arrows-got line)])) (define (not-matching-colors got expected) (let loop ([got got] diff --git a/drracket-test/tests/drracket/test-engine-test.rkt b/drracket-test/tests/drracket/test-engine-test.rkt index 79753ef97..f3d55e4ff 100644 --- a/drracket-test/tests/drracket/test-engine-test.rkt +++ b/drracket-test/tests/drracket/test-engine-test.rkt @@ -243,11 +243,11 @@ (common-signatures-sdp))) (define (prepare-for-test-expression) - (let ([drs (wait-for-drracket-frame)]) - (clear-definitions drs) - (set-language #t) - (sleep 1) ;; this shouldn't be neccessary.... - (do-execute drs))) + (define drs (wait-for-drracket-frame)) + (clear-definitions drs) + (set-language #t) + (sleep 1) ;; this shouldn't be neccessary.... + (do-execute drs)) ;; test-setting : (-> void) string string string -> void ;; opens the language dialog, runs `set-setting' @@ -262,15 +262,19 @@ (let ([f (test:get-active-top-level-window)]) (fw:test:button-push "OK") (wait-for-new-frame f)) - (let* ([drs (test:get-active-top-level-window)] - [interactions (send drs get-interactions-text)]) - (clear-definitions drs) - (insert-in-definitions drs expression) - (do-execute drs) - (let ([got (fetch-output/should-be-tested drs)]) - (unless (string=? result got) - (eprintf "FAILED: ~s ~s ~s test\n expected: ~s\n got: ~s\n" - (language) setting-name expression result got))))) + (define drs (test:get-active-top-level-window)) + (send drs get-interactions-text) + (clear-definitions drs) + (insert-in-definitions drs expression) + (do-execute drs) + (define got (fetch-output/should-be-tested drs)) + (unless (string=? result got) + (eprintf "FAILED: ~s ~s ~s test\n expected: ~s\n got: ~s\n" + (language) + setting-name + expression + result + got))) (define (fetch-output/should-be-tested . args) (regexp-replace (regexp @@ -297,11 +301,11 @@ ((regexp-match #rx"^Ran ([NoOneTwo0-9]+) tests?.\n([NoOneTwo0-9]+) tests? passed.\n(([NoOneTwo0-9]+) signature violations?.)?" txt) => (lambda (match) - (let-values (((_ test-count-text test-passed-count-text __ signature-violations-count-text) - (apply values match))) - (values (parse-number test-count-text) - (parse-number test-passed-count-text) - (parse-number signature-violations-count-text))))) + (define-values (_ test-count-text test-passed-count-text __ signature-violations-count-text) + (apply values match)) + (values (parse-number test-count-text) + (parse-number test-passed-count-text) + (parse-number signature-violations-count-text)))) ((regexp-match #rx"^This program must be tested!\n(([NoOneTwo0-9]+) signature violations?.)?" txt) => (lambda (match) (values 0 0 (parse-number (caddr match))))) @@ -309,23 +313,25 @@ (error 'parse-test-failure-header "bad test failure header" txt)))) (define (parse-test-failures txt) - (let-values (((test-count test-passed-count signature-violations-count) - (parse-test-failure-header txt))) - (let ((check-failures - (cond - ((regexp-match #rx"Check failures:\n(.*)" txt) - => (lambda (res) - (parse-check-failures (cadr res)))) - (else '()))) - (signature-violations - (cond - ((regexp-match #rx"Signature violations:\n(.*)" txt) - => (lambda (res) - (parse-signature-violations (cadr res)))) - (else '())))) - (values test-count test-passed-count signature-violations-count - check-failures - signature-violations)))) + (define-values (test-count test-passed-count signature-violations-count) + (parse-test-failure-header txt)) + (define check-failures + (cond + [(regexp-match #rx"Check failures:\n(.*)" txt) + => + (lambda (res) (parse-check-failures (cadr res)))] + [else '()])) + (define signature-violations + (cond + [(regexp-match #rx"Signature violations:\n(.*)" txt) + => + (lambda (res) (parse-signature-violations (cadr res)))] + [else '()])) + (values test-count + test-passed-count + signature-violations-count + check-failures + signature-violations)) (define-struct check-expect-failure (actual expected line column) @@ -431,34 +437,48 @@ (expected got)]))] [check-failures (lambda (where signature-violations-expected check-failures-expected) - (let ((text - (cond - ((send (send definitions-text get-tab) get-test-editor) - => (lambda (test-editor) - (let ((text (send test-editor get-text 0 'eof #t))) - (if (string=? text "") - #f - text)))) - (else #f)))) - - (cond - ((and (null? signature-violations-expected) - (null? check-failures-expected)) - (when text - (eprintf "FAILED: ~s ~s expected ~s to produce no check failures or signature violations:\ngot:\n~a\ninstead\n" - where (language) expression text))) - (text - (let-values (((test-count test-passed-count signature-violation-count check-failures signature-violations) - (parse-test-failures text))) - (when (not (equal? check-failures check-failures-expected)) - (eprintf "FAILED: ~s ~s expected ~s to produce check failures:\n~s\ngot:\n~s\ninstead\n" - where (language) expression check-failures-expected check-failures)) - (when (not (equal? signature-violations signature-violations-expected)) - (eprintf "FAILED: ~s ~s expected ~s to produce signature violations:\n~s\ngot:\n~s\ninstead\n" - where (language) expression signature-violations-expected signature-violations)))) - (else - (eprintf "expected ~a check failures and ~a signature violations but got none" - (length check-failures-expected) (length signature-violations-expected))))))] + (define text + (cond + [(send (send definitions-text get-tab) get-test-editor) + => + (lambda (test-editor) + (let ([text (send test-editor get-text 0 'eof #t)]) (if (string=? text "") #f text)))] + [else #f])) + + (cond + [(and (null? signature-violations-expected) (null? check-failures-expected)) + (when text + (eprintf + "FAILED: ~s ~s expected ~s to produce no check failures or signature violations:\ngot:\n~a\ninstead\n" + where + (language) + expression + text))] + [text + (let-values ([(test-count test-passed-count + signature-violation-count + check-failures + signature-violations) + (parse-test-failures text)]) + (when (not (equal? check-failures check-failures-expected)) + (eprintf "FAILED: ~s ~s expected ~s to produce check failures:\n~s\ngot:\n~s\ninstead\n" + where + (language) + expression + check-failures-expected + check-failures)) + (when (not (equal? signature-violations signature-violations-expected)) + (eprintf + "FAILED: ~s ~s expected ~s to produce signature violations:\n~s\ngot:\n~s\ninstead\n" + where + (language) + expression + signature-violations-expected + signature-violations)))] + [else + (eprintf "expected ~a check failures and ~a signature violations but got none" + (length check-failures-expected) + (length signature-violations-expected))]))] [make-err-msg (lambda (expected) diff --git a/drracket-tool-text-lib/drracket/find-module-path-completions.rkt b/drracket-tool-text-lib/drracket/find-module-path-completions.rkt index c715ac956..2c4741a0d 100644 --- a/drracket-tool-text-lib/drracket/find-module-path-completions.rkt +++ b/drracket-tool-text-lib/drracket/find-module-path-completions.rkt @@ -183,20 +183,20 @@ (and (regexp? (list-ref link-ent 2)) (regexp-match (list-ref link-ent 2) (version))) #t)) - `(,(list-ref link-ent 0) - ,(simplify-path - (let* ([encoded-path (list-ref link-ent 1)] - [path (cond - [(string? encoded-path) encoded-path] - [(bytes? encoded-path) (bytes->path encoded-path)] - [else (apply build-path - (for/list ([elem (in-list encoded-path)]) - (if (bytes? elem) - (bytes->path-element elem) - elem)))])]) - (if (relative-path? path) - (build-path base path) - path)))))] + (list (list-ref link-ent 0) + (simplify-path (let* ([encoded-path (list-ref link-ent 1)] + [path (cond + [(string? encoded-path) encoded-path] + [(bytes? encoded-path) (bytes->path encoded-path)] + [else + (apply build-path + (for/list ([elem (in-list encoded-path)]) + (if (bytes? elem) + (bytes->path-element elem) + elem)))])]) + (if (relative-path? path) + (build-path base path) + path)))))] [else '()])] [else (for/list ([clp (in-list library-collection-paths)])