From cb341fdd469334258ff292cfe6d594c275a34476 Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Mon, 6 Oct 2014 18:55:48 -0400
Subject: [PATCH] Add TR tooltips for type errors as well.

Adjust type tooltips to only show if there isn't a type
error on that syntax location.

original commit: 693355710fae559c09f6c3f6850fe1268d048eb4
---
 .../typed-racket/types/type-table.rkt         |  7 ++-
 .../typed-racket/utils/tc-utils.rkt           | 48 +++++++++++++++++++
 2 files changed, 53 insertions(+), 2 deletions(-)

diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/type-table.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/type-table.rkt
index 87bc2351..02e8e8fd 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/type-table.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/type-table.rkt
@@ -73,7 +73,8 @@
             ([(stx results) (in-hash table)]
              #:when (and (syntax-source stx)
                          (syntax-position stx)
-                         (syntax-span stx)))
+                         (syntax-span stx))
+             #:unless (error-at-stx-loc? stx))
     ;; `printed-types` is #f if we should skip the type because it's
     ;; something not worth printing like Bottom or Error.
     (define printed-types
@@ -101,7 +102,9 @@
                ;; special-case quote because there's no worry of overlap
                ;; in a (quote ...) and because literals expand out to a
                ;; use of quote.
-               (free-identifier=? (car (syntax-e stx)) #'quote))
+               (let ([fst (car (syntax-e stx))])
+                 (and (identifier? fst)
+                      (free-identifier=? fst #'quote))))
            (cons (vector (syntax-source stx)
                          (sub1 (syntax-position stx))
                          (+ (sub1 (syntax-position stx)) (syntax-span stx))
diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt
index e0a59922..d2c899b4 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt
@@ -26,6 +26,7 @@ don't depend on any other portion of the system
          reset-errors!
          report-first-error
          report-all-errors
+         error-at-stx-loc?
          tc-error/fields
          tc-error/delayed
          tc-error
@@ -117,12 +118,14 @@ don't depend on any other portion of the system
     ;; if there's only one, we don't need multiple-error handling
     [(list (struct err (msg stx)))
      (reset-errors!)
+     (log-type-error msg stx)
      (raise-typecheck-error msg stx)]
     [l
      (let ([stxs
             (for/list ([e (in-list l)])
               (with-handlers ([exn:fail:syntax?
                                (λ (e) ((error-display-handler) (exn-message e) e))])
+                (log-type-error (err-msg e) (err-stx e))
                 (raise-typecheck-error (err-msg e) (err-stx e)))
               (err-stx e))])
        (reset-errors!)
@@ -131,6 +134,51 @@ don't depend on any other portion of the system
                                         (length stxs))
                                 (apply append stxs))))]))
 
+;; Returns #t if there's a type error recorded at the same position as
+;; the given syntax object. Does not return a useful result if the
+;; source, position, or span are #f.
+(define (error-at-stx-loc? stx)
+  (for/or ([an-err (in-list delayed-errors)])
+    (match-define (struct err (_ stxes)) an-err)
+    (define stx* (and (not (null? stxes)) (car stxes)))
+    (and stx*
+         (equal? (syntax-source stx*) (syntax-source stx))
+         (= (syntax-position stx*) (syntax-position stx))
+         (= (syntax-span stx*) (syntax-span stx)))))
+
+;; send type errors to DrRacket's tooltip system
+(define-logger online-check-syntax)
+(define (log-type-error msg stxes)
+  (define stx (and (not (null? stxes)) (car stxes)))
+  (when (and stx
+             (syntax-source stx)
+             (syntax-position stx)
+             (syntax-span stx))
+    (define tooltip-info
+      ;; see type-table.rkt for why we do this
+      (if (or (not (pair? (syntax-e stx)))
+              (let ([fst (car (syntax-e stx))])
+                (and (identifier? fst)
+                     (free-identifier=? fst #'quote))))
+          (list (vector (syntax-source stx)
+                        (sub1 (syntax-position stx))
+                        (+ (sub1 (syntax-position stx)) (syntax-span stx))
+                        msg))
+          (list (vector (syntax-source stx)
+                        (sub1 (syntax-position stx))
+                        (syntax-position stx)
+                        msg)
+                (vector (syntax-source stx)
+                        (sub1 (+ (sub1 (syntax-position stx))
+                                 (syntax-span stx)))
+                        (+ (sub1 (syntax-position stx))
+                           (syntax-span stx))
+                        msg))))
+    (log-message online-check-syntax-logger
+                 'info
+                 "TR's type error tooltip syntaxes; this message is ignored"
+                 (list (syntax-property #'(void) 'mouse-over-tooltips tooltip-info)))))
+
 (define delay-errors? (make-parameter #f))
 
 (define (tc-error/delayed msg #:stx [stx* (current-orig-stx)] . rest)