From cb341fdd469334258ff292cfe6d594c275a34476 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa 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)