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

Add type tooltip information in TR modules

Browse Source 
This lets DrRacket show types for expressions that
are typechecked.

original commit: e301519a7e9bfb71c66e20788d45cbcc0353dfd8
This commit is contained in:
Asumu Takikawa 2014-10-05 23:27:33 -04:00
parent 1aacf57a9a
commit 5c3700d983
3 changed files with 73 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt
View File

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

7
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt
View File

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

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

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