Add tests for TR's tooltip computation

original commit: f9e2231ce9f5df9013865f9311aaa27f4e3a343d

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")
+(define version "1.1")

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")

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))))))