suzanne.soy/typed-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add TR tooltips for type errors as well.

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

original commit: 693355710fae559c09f6c3f6850fe1268d048eb4
This commit is contained in:
Asumu Takikawa 2014-10-06 18:55:48 -04:00
parent 41e63fad3c
commit cb341fdd46
2 changed files with 53 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/type-table.rkt
View File

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

48
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt
View File

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