diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/info.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/info.rkt index 961a9e0bc0..1b09e7b9ad 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/info.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/info.rkt @@ -15,6 +15,7 @@ "sandbox-lib" "pconvert-lib" "unstable-flonum-lib" + "unstable-list-lib" "unstable")) (define update-implies '("typed-racket")) @@ -22,4 +23,4 @@ (define pkg-authors '(samth stamourv)) -(define version "1.1") \ No newline at end of file +(define version "1.1") diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt index 61e6f16296..c6abd6326c 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt @@ -42,4 +42,5 @@ "metafunction-tests.rkt" "generalize-tests.rkt" "rep-tests.rkt" - "prims-tests.rkt") + "prims-tests.rkt" + "tooltip-tests.rkt") diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/tooltip-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/tooltip-tests.rkt new file mode 100644 index 0000000000..cdb24e5634 --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/tooltip-tests.rkt @@ -0,0 +1,98 @@ +#lang racket/base + +;; Tests for Typed Racket tooltips that are normally displayed in DrRacket. +;; These tests capture those results by listening to a logger and checks that +;; certain types are recorded at the right locations. + +(require "test-utils.rkt" + racket/match + rackunit + unstable/list + (for-syntax racket/base)) + +(provide tests) +(gen-test-main) + +(define-for-syntax debug? #f) +(define-syntax (debug stx) + (syntax-case stx () + [(_ e) debug? #'e] + [_ #'(void)])) + +(define-logger online-check-syntax) +(define receiver + (make-log-receiver online-check-syntax-logger 'info 'online-check-syntax)) + +;; This checks the given predicate on the tooltip vectors and will also +;; check that there's only one tooltip provided per location +(define-syntax-rule (check-tooltip exp pred) + (check-true (run-tooltip-test (quote exp) pred))) + +(define (run-tooltip-test sexp pred) + (define namespace (make-base-namespace)) + (define-values (in out) (make-pipe)) + (port-count-lines! in) + (port-count-lines! out) + (write `(module a typed/racket ,sexp) out) + (parameterize ([current-logger online-check-syntax-logger] + [current-namespace namespace]) + (eval-syntax (namespace-syntax-introduce (read-syntax 'tester in)))) + + (log-message online-check-syntax-logger 'info 'online-check-syntax "done" 'done) + + (define result (process-tooltips pred)) + (clear) + result) + +(define (process-tooltips pred) + (let loop () + (define result (sync receiver)) + (cond [(eq? 'done (vector-ref result 2)) 'no-tooltips] + [else + (define stxs (vector-ref result 2)) + (define tooltips + (syntax-property (car stxs) 'mouse-over-tooltips)) + (if tooltips + (and (pred tooltips) + (unique-locations? tooltips)) + (loop))]))) + +(define (clear) + (let loop () + (when (sync/timeout 0 receiver) + (loop)))) + +;; has-type-at? : (Listof (List String Int Int)) -> (Listof Vector) -> Boolean +(define ((has-types-at? lst) tooltips) + ;; turn debug? on to print the tooltip types and locations + (debug + (for ([tooltip (in-list tooltips)]) + (match-define (vector stx start* end* type*) tooltip) + (printf "~a ~a ~a~n" start* end* (if (procedure? type*) (type*) type*)))) + (for/and ([entry (in-list lst)]) + (match-define (list type start end) entry) + (for/or ([tooltip (in-list tooltips)]) + (match-define (vector stx start* end* type*) tooltip) + (and (= start start*) + (= end end*) + (equal? type (if (procedure? type*) (type*) type*)))))) + +;; ensures there are no duplicate type tooltips for a single syntax location +(define (unique-locations? tooltips) + (define locations + (for/list ([tooltip (in-list tooltips)]) + (match-define (vector _ start end _) tooltip) + (list start end))) + (if (check-duplicate locations) + 'duplicate-tooltips + #t)) + +(define tests + (test-suite "Tooltip tests" + (check-tooltip (string-append "foo" "bar") + (has-types-at? (list (list "String" 38 43)))) + (check-tooltip (for/list : (Listof Integer) ([i (list 1 2 3)]) i) + (has-types-at? (list (list "(Listof Integer)" 23 24) + (list "(Listof Integer)" 72 73)))) + (check-tooltip (class object% (super-new) (field [x : Integer 0]) x (set! x 3)) + (has-types-at? (list (list "Integer" 74 75))))))