diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt index 4b71f62968..bb819b209a 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt @@ -6,7 +6,7 @@ (private with-types type-contract) (except-in syntax/parse id) racket/match racket/syntax - (types utils abbrev generalize) + (types utils abbrev generalize type-table) (typecheck provide-handling tc-toplevel tc-app-helper) (rep type-rep) (for-template (base-env top-interaction)) @@ -39,9 +39,11 @@ ;; add in syntax property on useless expression to draw check-syntax arrows [check-syntax-help (syntax-property (syntax-property - #'(void) - 'disappeared-binding (disappeared-bindings-todo)) - 'disappeared-use (disappeared-use-todo))]) + (syntax-property + #'(void) + 'disappeared-binding (disappeared-bindings-todo)) + 'disappeared-use (disappeared-use-todo)) + 'mouse-over-tooltips (type-table->tooltips))]) ;; reconstruct the module with the extra code ;; use the regular %#module-begin from `racket/base' for top-level printing (arm #`(#%module-begin #,before-code optimized-body ... #,after-code check-syntax-help)))))))])) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt index 431ed3c0e6..4301ff2b22 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt @@ -25,6 +25,8 @@ [tc-module (syntax? . c:-> . (values syntax? syntax?))] [tc-toplevel-form (syntax? . c:-> . c:any/c)]) +(define-logger online-check-syntax) + (define unann-defs (make-free-id-table)) (define (parse-typed-struct form) @@ -342,6 +344,11 @@ (do-time "Finished pass2") ;; check that declarations correspond to definitions (check-all-registered-types) + ;; log messages to check-syntax to show extra types / arrows before failures + (log-message online-check-syntax-logger + 'info + "TR's tooltip syntaxes; this message is ignored" + (list (syntax-property #'(void) 'mouse-over-tooltips (type-table->tooltips)))) ;; report delayed errors (report-all-errors) (define provide-tbl 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 77e37320ad..87bc235100 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 @@ -9,13 +9,17 @@ syntax/parse "../utils/utils.rkt" (contract-req) - (types utils union) - (utils tc-utils)) + (rep type-rep) + (types utils union printer) + (typecheck tc-app-helper) + (utils tc-utils) + (for-template racket/base)) (provide/cond-contract [add-typeof-expr (syntax? tc-results/c . -> . any/c)] [type-of (syntax? . -> . tc-results/c)] [reset-type-table (-> any/c)] + [type-table->tooltips (-> (listof (vector/c any/c integer? integer? string?)))] [test-position-add-true (syntax? . -> . any)] [test-position-add-false (syntax? . -> . any)] [test-position-takes-true-branch (syntax? . -> . boolean?)] @@ -62,6 +66,60 @@ (syntax-line e) (syntax-column e)))))) +;; Convert the contents of the type table to a format that check-syntax +;; can understand in order to draw type tooltips +(define (type-table->tooltips) + (for/fold ([tooltips '()]) + ([(stx results) (in-hash table)] + #:when (and (syntax-source stx) + (syntax-position stx) + (syntax-span 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 + (match results + [(tc-result1: type) + (and (not (or (Error? type) (Bottom? type))) + ;; cleanup-type is essential here so that this doesn't slow + ;; down compilation excessively (e.g., serializing the 4k type + ;; of the + function) + (pretty-format-type (cleanup-type type)))] + [(or (tc-results: types) + (tc-results: types _ _ _ _)) ; FIXME, account for dty/dbound + (apply string-append + (for/list ([(type index) (in-indexed (in-list types))]) + (format "Value ~a:~n ~a~n" + (add1 index) + (pretty-format-type (cleanup-type type) + #:indent 2))))] + [(tc-any-results: _) "AnyValues"])) + (cond [(not printed-types) tooltips] + ;; Put the tooltip only on the parens for compound expressions + ;; but put them on the whole expression for literals. This avoids + ;; overlapping tooltips. + [(or (not (pair? (syntax-e stx))) + ;; 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)) + (cons (vector (syntax-source stx) + (sub1 (syntax-position stx)) + (+ (sub1 (syntax-position stx)) (syntax-span stx)) + printed-types) + tooltips)] + [else + (list* (vector (syntax-source stx) + (sub1 (syntax-position stx)) + (syntax-position stx) + printed-types) + (vector (syntax-source stx) + (sub1 (+ (sub1 (syntax-position stx)) + (syntax-span stx))) + (+ (sub1 (syntax-position stx)) + (syntax-span stx)) + printed-types) + tooltips)]))) + ;; For expressions in test position keep track of if it evaluates to true/false (define test-position-table/true (make-hasheq)) (define test-position-table/false (make-hasheq))